/* Free memory occupied by PJS_Context structure */ void PJS_DestroyContext(PJS_Context *pcx) { if (pcx == NULL) { return; } if (pcx->function_by_name) { hv_undef(pcx->function_by_name); pcx->function_by_name = NULL; } if (pcx->class_by_name) { hv_undef(pcx->class_by_name); pcx->class_by_name = NULL; } if (pcx->class_by_package) { hv_undef(pcx->class_by_package); pcx->class_by_package = NULL; } /* Destory context */ if (pcx->cx) { JS_DestroyContext(pcx->cx); pcx->cx = NULL; } Safefree(pcx); }
void run_filter_perlplugin(char *dst, size_t dst_size, struct fileFilterFormat *filter, struct hashtable **metahash) { char perlpath[PATH_MAX]; snprintf(perlpath, sizeof perlpath, "%smain.pm", filter->path); HV *perl_metahash = newHV(); SV *perl_dst = newSVpv("", strlen("")); //AV *perl_extracted_files = newAV(); HV *params = newHV(); hv_store(params, "file", strlen("file"), sv_2mortal(newSVpv(filter->command, 0)), 0); hv_store(params, "metadata", strlen("metadata"), sv_2mortal(newRV((SV *) perl_metahash)), 0); hv_store(params, "data", strlen("data"), sv_2mortal(newRV((SV *) perl_dst)), 0); //hv_store(params, "extracted_files", strlen("extracted_files"), sv_2mortal(newRV((SV *) perl_extracted_files)), 0); #ifdef DEBUG printf("perl run: %s:dump(file=%s, metadata=%p)\n",perlpath,filter->command,perl_metahash); #endif if(!perl_embed_run(perlpath, "dump", params, NULL, NULL, NULL, 0)) errx(1, "Perlplugin error on '%s'", filter->command); STRLEN data_size; char *data = SvPV(perl_dst, data_size); // asuming data is a '\0'-terminated string strlcpy(dst, data, dst_size); if (metahash) { *metahash = create_hashtable(3, ht_stringhash, ht_stringcmp); perl_ht_to_ht(perl_metahash, *metahash); } // clean up hv_undef(perl_metahash); hv_undef(params); free(data); }
/* * get the vps and put them in perl hash * If one VP have multiple values it is added as array_ref * Example for this is Cisco-AVPair that holds multiple values. * Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'} */ static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv) { VALUE_PAIR *nvp, *vpa, *vpn; AV *av; char namebuf[256], *name; char buffer[1024]; int attr, vendor, len; hv_undef(rad_hv); nvp = paircopy(vp); while (nvp != NULL) { name = nvp->name; attr = nvp->attribute; vendor = nvp->vendor; vpa = paircopy2(nvp, attr, vendor); if (vpa->next) { av = newAV(); vpn = vpa; while (vpn) { len = vp_prints_value(buffer, sizeof(buffer), vpn, FALSE); av_push(av, newSVpv(buffer, len)); vpn = vpn->next; } hv_store(rad_hv, nvp->name, strlen(nvp->name), newRV_noinc((SV *) av), 0); } else { if ((vpa->flags.has_tag) && (vpa->flags.tag != 0)) { snprintf(namebuf, sizeof(namebuf), "%s:%d", nvp->name, nvp->flags.tag); name = namebuf; } len = vp_prints_value(buffer, sizeof(buffer), vpa, FALSE); hv_store(rad_hv, name, strlen(name), newSVpv(buffer, len), 0); } pairfree(&vpa); vpa = nvp; while ((vpa != NULL) && (vpa->attribute == attr) && (vpa->vendor == vendor)) vpa = vpa->next; pairdelete(&nvp, attr, vendor); nvp = vpa; } }
void ntop_perl_loadHost() { char buf[64]; /* traceEvent(CONST_TRACE_INFO, "[perl] loadHost(%p)", ntop_host); */ if(perl_host) { hv_undef(perl_host); perl_host = NULL; } if(ntop_host) { perl_host = perl_get_hv ("main::host", TRUE); ntop_perl_loadHost_values(perl_host, ntop_host); } }
static int mod_detach(void *instance) { rlm_perl_t *inst = (rlm_perl_t *) instance; int exitstatus = 0, count = 0; if (inst->perl_parsed) { dTHXa(inst->perl); PERL_SET_CONTEXT(inst->perl); if (inst->rad_perlconf_hv != NULL) hv_undef(inst->rad_perlconf_hv); if (inst->func_detach) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); count = call_pv(inst->func_detach, G_SCALAR | G_EVAL ); SPAGAIN; if (count == 1) { exitstatus = POPi; if (exitstatus >= 100 || exitstatus < 0) { exitstatus = RLM_MODULE_FAIL; } } PUTBACK; FREETMPS; LEAVE; } } #ifdef USE_ITHREADS rlm_perl_destruct(inst->perl); pthread_mutex_destroy(&inst->clone_mutex); #else perl_destruct(inst->perl); perl_free(inst->perl); #endif /* * Hope this is not really needed. * Is only allowed to be called once just before exit(). * PERL_SYS_TERM(); */ return exitstatus; }
/* * get the vps and put them in perl hash * If one VP have multiple values it is added as array_ref * Example for this is Cisco-AVPair that holds multiple values. * Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'} */ static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv) { VALUE_PAIR *nvp, *vpa, *vpn; AV *av; char buffer[1024]; int attr, len; hv_undef(rad_hv); nvp = paircopy(vp); while (nvp != NULL) { attr = nvp->attribute; vpa = paircopy2(nvp,attr); if (vpa->next) { av = newAV(); vpn = vpa; while (vpn) { len = vp_prints_value(buffer, sizeof(buffer), vpn, FALSE); av_push(av, newSVpv(buffer, len)); vpn = vpn->next; } hv_store(rad_hv, nvp->name, strlen(nvp->name), newRV_noinc((SV *) av), 0); } else { len = vp_prints_value(buffer, sizeof(buffer), vpa, FALSE); hv_store(rad_hv, vpa->name, strlen(vpa->name), newSVpv(buffer, len), 0); } pairfree(&vpa); vpa = nvp; while ((vpa != NULL) && (vpa->attribute == attr)) vpa = vpa->next; pairdelete(&nvp, attr); nvp = vpa; } }
/* * Call the function_name inside the module * Store all vps in hashes %RAD_CONFIG %RAD_REPLY %RAD_REQUEST * */ static int do_perl(void *instance, REQUEST *request, char const *function_name) { rlm_perl_t *inst = instance; VALUE_PAIR *vp; int exitstatus=0, count; STRLEN n_a; HV *rad_reply_hv; HV *rad_config_hv; HV *rad_request_hv; HV *rad_state_hv; #ifdef WITH_PROXY HV *rad_request_proxy_hv; HV *rad_request_proxy_reply_hv; #endif /* * Radius has told us to call this function, but none * is defined. */ if (!function_name) return RLM_MODULE_FAIL; #ifdef USE_ITHREADS pthread_mutex_lock(&inst->clone_mutex); PerlInterpreter *interp; interp = rlm_perl_clone(inst->perl,inst->thread_key); { dTHXa(interp); PERL_SET_CONTEXT(interp); } pthread_mutex_unlock(&inst->clone_mutex); #else PERL_SET_CONTEXT(inst->perl); #endif { dSP; ENTER; SAVETMPS; rad_reply_hv = get_hv("RAD_REPLY", 1); rad_config_hv = get_hv("RAD_CONFIG", 1); rad_request_hv = get_hv("RAD_REQUEST", 1); rad_state_hv = get_hv("RAD_STATE", 1); perl_store_vps(request->packet, request, &request->packet->vps, rad_request_hv, "RAD_REQUEST", "request"); perl_store_vps(request->reply, request, &request->reply->vps, rad_reply_hv, "RAD_REPLY", "reply"); perl_store_vps(request, request, &request->control, rad_config_hv, "RAD_CONFIG", "control"); perl_store_vps(request->state_ctx, request, &request->state, rad_state_hv, "RAD_STATE", "session-state"); #ifdef WITH_PROXY rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1); rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1); if (request->proxy) { perl_store_vps(request->proxy->packet, request, &request->proxy->packet->vps, rad_request_proxy_hv, "RAD_REQUEST_PROXY", "proxy-request"); } else { hv_undef(rad_request_proxy_hv); } if (request->proxy && request->proxy->reply != NULL) { perl_store_vps(request->proxy->reply, request, &request->proxy->reply->vps, rad_request_proxy_reply_hv, "RAD_REQUEST_PROXY_REPLY", "proxy-reply"); } else { hv_undef(rad_request_proxy_reply_hv); } #endif /* * Store pointer to request structure globally so radiusd::xlat works */ rlm_perl_request = request; PUSHMARK(SP); /* * This way %RAD_xx can be pushed onto stack as sub parameters. * XPUSHs( newRV_noinc((SV *)rad_request_hv) ); * XPUSHs( newRV_noinc((SV *)rad_reply_hv) ); * XPUSHs( newRV_noinc((SV *)rad_config_hv) ); * PUTBACK; */ count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS); SPAGAIN; if (SvTRUE(ERRSV)) { REDEBUG("perl_embed:: module = %s , func = %s exit status= %s\n", inst->module, function_name, SvPV(ERRSV,n_a)); (void)POPs; exitstatus = RLM_MODULE_FAIL; } else if (count == 1) { exitstatus = POPi; if (exitstatus >= 100 || exitstatus < 0) { exitstatus = RLM_MODULE_FAIL; } } PUTBACK; FREETMPS; LEAVE; vp = NULL; if ((get_hv_content(request->packet, request, rad_request_hv, &vp, "RAD_REQUEST", "request")) == 0) { fr_pair_list_free(&request->packet->vps); request->packet->vps = vp; vp = NULL; /* * Update cached copies */ request->username = fr_pair_find_by_da(request->packet->vps, attr_user_name, TAG_ANY); request->password = fr_pair_find_by_da(request->packet->vps, attr_user_password, TAG_ANY); if (!request->password) request->password = fr_pair_find_by_da(request->packet->vps, attr_chap_password, TAG_ANY); } if ((get_hv_content(request->reply, request, rad_reply_hv, &vp, "RAD_REPLY", "reply")) == 0) { fr_pair_list_free(&request->reply->vps); request->reply->vps = vp; vp = NULL; } if ((get_hv_content(request, request, rad_config_hv, &vp, "RAD_CONFIG", "control")) == 0) { fr_pair_list_free(&request->control); request->control = vp; vp = NULL; } if ((get_hv_content(request->state_ctx, request, rad_state_hv, &vp, "RAD_STATE", "session-state")) == 0) { fr_pair_list_free(&request->state); request->state = vp; vp = NULL; } #ifdef WITH_PROXY if (request->proxy && (get_hv_content(request->proxy->packet, request, rad_request_proxy_hv, &vp, "RAD_REQUEST_PROXY", "proxy-request") == 0)) { fr_pair_list_free(&request->proxy->packet->vps); request->proxy->packet->vps = vp; vp = NULL; } if (request->proxy && request->proxy->reply && (get_hv_content(request->proxy->reply, request, rad_request_proxy_reply_hv, &vp, "RAD_REQUEST_PROXY_REPLY", "proxy-reply") == 0)) { fr_pair_list_free(&request->proxy->reply->vps); request->proxy->reply->vps = vp; vp = NULL; } #endif } return exitstatus; }
/* * get the vps and put them in perl hash * If one VP have multiple values it is added as array_ref * Example for this is Cisco-AVPair that holds multiple values. * Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'} */ static void perl_store_vps(UNUSED TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR **vps, HV *rad_hv, const char *hash_name, const char *list_name) { VALUE_PAIR *vp; hv_undef(rad_hv); fr_cursor_t cursor; RINDENT(); fr_pair_list_sort(vps, fr_pair_cmp_by_da_tag); for (vp = fr_cursor_init(&cursor, vps); vp; vp = fr_cursor_next(&cursor)) { VALUE_PAIR *next; char const *name; char namebuf[256]; /* * Tagged attributes are added to the hash with name * <attribute>:<tag>, others just use the normal attribute * name as the key. */ if (vp->da->flags.has_tag && (vp->tag != TAG_ANY)) { snprintf(namebuf, sizeof(namebuf), "%s:%d", vp->da->name, vp->tag); name = namebuf; } else { name = vp->da->name; } /* * We've sorted by type, then tag, so attributes of the * same type/tag should follow on from each other. */ if ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next)) { int i = 0; AV *av; av = newAV(); perl_vp_to_svpvn_element(request, av, vp, &i, hash_name, list_name); do { perl_vp_to_svpvn_element(request, av, next, &i, hash_name, list_name); fr_cursor_next(&cursor); } while ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next)); (void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0); continue; } /* * It's a normal single valued attribute */ switch (vp->vp_type) { case FR_TYPE_STRING: RDEBUG2("$%s{'%s'} = &%s:%s -> '%pV'", hash_name, vp->da->name, list_name, vp->da->name, &vp->data); (void)hv_store(rad_hv, name, strlen(name), newSVpvn(vp->vp_strvalue, vp->vp_length), 0); break; case FR_TYPE_OCTETS: RDEBUG2("$%s{'%s'} = &%s:%s -> %pV", hash_name, vp->da->name, list_name, vp->da->name, &vp->data); (void)hv_store(rad_hv, name, strlen(name), newSVpvn((char const *)vp->vp_octets, vp->vp_length), 0); break; default: { char buffer[1024]; size_t len; len = fr_pair_value_snprint(buffer, sizeof(buffer), vp, '\0'); RDEBUG2("$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->da->name, list_name, vp->da->name, buffer); (void)hv_store(rad_hv, name, strlen(name), newSVpvn(buffer, truncate_len(len, sizeof(buffer))), 0); } break; } } REXDENT(); }
/* * Call the function_name inside the module * Store all vps in hashes %RAD_CHECK %RAD_REPLY %RAD_REQUEST * */ static int do_perl(void *instance, REQUEST *request, char *function_name) { rlm_perl_t *inst = instance; VALUE_PAIR *vp; int exitstatus=0, count; STRLEN n_a; HV *rad_reply_hv; HV *rad_check_hv; HV *rad_config_hv; HV *rad_request_hv; #ifdef WITH_PROXY HV *rad_request_proxy_hv; HV *rad_request_proxy_reply_hv; #endif /* * Radius has told us to call this function, but none * is defined. */ if (!function_name) return RLM_MODULE_FAIL; #ifdef USE_ITHREADS pthread_mutex_lock(&inst->clone_mutex); PerlInterpreter *interp; interp = rlm_perl_clone(inst->perl,inst->thread_key); { dTHXa(interp); PERL_SET_CONTEXT(interp); } pthread_mutex_unlock(&inst->clone_mutex); #else PERL_SET_CONTEXT(inst->perl); #endif { dSP; ENTER; SAVETMPS; rad_reply_hv = get_hv("RAD_REPLY",1); rad_check_hv = get_hv("RAD_CHECK",1); rad_config_hv = get_hv("RAD_CONFIG",1); rad_request_hv = get_hv("RAD_REQUEST",1); perl_store_vps(request->reply, request->reply->vps, rad_reply_hv); perl_store_vps(request, request->config_items, rad_check_hv); perl_store_vps(request->packet, request->packet->vps, rad_request_hv); perl_store_vps(request, request->config_items, rad_config_hv); #ifdef WITH_PROXY rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1); rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1); if (request->proxy != NULL) { perl_store_vps(request->proxy, request->proxy->vps, rad_request_proxy_hv); } else { hv_undef(rad_request_proxy_hv); } if (request->proxy_reply !=NULL) { perl_store_vps(request->proxy_reply, request->proxy_reply->vps, rad_request_proxy_reply_hv); } else { hv_undef(rad_request_proxy_reply_hv); } #endif PUSHMARK(SP); /* * This way %RAD_xx can be pushed onto stack as sub parameters. * XPUSHs( newRV_noinc((SV *)rad_request_hv) ); * XPUSHs( newRV_noinc((SV *)rad_reply_hv) ); * XPUSHs( newRV_noinc((SV *)rad_check_hv) ); * PUTBACK; */ count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS); SPAGAIN; if (SvTRUE(ERRSV)) { ERROR("rlm_perl: perl_embed:: module = %s , func = %s exit status= %s\n", inst->module, function_name, SvPV(ERRSV,n_a)); (void)POPs; } if (count == 1) { exitstatus = POPi; if (exitstatus >= 100 || exitstatus < 0) { exitstatus = RLM_MODULE_FAIL; } } PUTBACK; FREETMPS; LEAVE; vp = NULL; if ((get_hv_content(request->packet, rad_request_hv, &vp)) > 0 ) { pairfree(&request->packet->vps); request->packet->vps = vp; vp = NULL; /* * Update cached copies */ request->username = pairfind(request->packet->vps, PW_USER_NAME, 0, TAG_ANY); request->password = pairfind(request->packet->vps, PW_USER_PASSWORD, 0, TAG_ANY); if (!request->password) request->password = pairfind(request->packet->vps, PW_CHAP_PASSWORD, 0, TAG_ANY); } if ((get_hv_content(request->reply, rad_reply_hv, &vp)) > 0 ) { pairfree(&request->reply->vps); request->reply->vps = vp; vp = NULL; } if ((get_hv_content(request, rad_check_hv, &vp)) > 0 ) { pairfree(&request->config_items); request->config_items = vp; vp = NULL; } #ifdef WITH_PROXY if (request->proxy && (get_hv_content(request->proxy, rad_request_proxy_hv, &vp) > 0)) { pairfree(&request->proxy->vps); request->proxy->vps = vp; vp = NULL; } if (request->proxy_reply && (get_hv_content(request->proxy_reply, rad_request_proxy_reply_hv, &vp) > 0)) { pairfree(&request->proxy_reply->vps); request->proxy_reply->vps = vp; vp = NULL; } #endif } return exitstatus; }
/* * get the vps and put them in perl hash * If one VP have multiple values it is added as array_ref * Example for this is Cisco-AVPair that holds multiple values. * Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'} */ static void perl_store_vps(TALLOC_CTX *ctx, VALUE_PAIR *vps, HV *rad_hv) { VALUE_PAIR *head, *sublist; AV *av; char const *name; char namebuf[256]; char buffer[1024]; int len; hv_undef(rad_hv); /* * Copy the valuepair list so we can remove attributes * we've already processed. This is a horrible hack to * get around various other stupidity. */ head = paircopy(ctx, vps); while (head) { vp_cursor_t cursor; /* * Tagged attributes are added to the hash with name * <attribute>:<tag>, others just use the normal attribute * name as the key. */ if (head->da->flags.has_tag && (head->tag != 0)) { snprintf(namebuf, sizeof(namebuf), "%s:%d", head->da->name, head->tag); name = namebuf; } else { name = head->da->name; } /* * Create a new list with all the attributes like this one * which are in the same tag group. */ sublist = NULL; pairfilter(ctx, &sublist, &head, head->da->attr, head->da->vendor, head->tag); fr_cursor_init(&cursor, &sublist); /* * Attribute has multiple values */ if (fr_cursor_next(&cursor)) { VALUE_PAIR *vp; av = newAV(); for (vp = fr_cursor_first(&cursor); vp; vp = fr_cursor_next(&cursor)) { len = vp_prints_value(buffer, sizeof(buffer), vp, 0); av_push(av, newSVpv(buffer, len)); } (void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0); /* * Attribute has a single value, so its value just gets * added to the hash. */ } else { len = vp_prints_value(buffer, sizeof(buffer), sublist, 0); (void)hv_store(rad_hv, name, strlen(name), newSVpv(buffer, len), 0); } pairfree(&sublist); } rad_assert(!head); }
static int mod_detach(void *instance) { rlm_perl_t *inst = (rlm_perl_t *) instance; int exitstatus = 0, count = 0; if (inst->rad_perlconf_hv != NULL) { hv_undef(inst->rad_perlconf_hv); } #if 0 /* * FIXME: Call this in the destruct function? */ { dTHXa(handle->clone); PERL_SET_CONTEXT(handle->clone); { dSP; ENTER; SAVETMPS; PUSHMARK(SP); count = call_pv(inst->func_detach, G_SCALAR | G_EVAL ); SPAGAIN; if (count == 1) { exitstatus = POPi; /* * FIXME: bug in perl * */ if (exitstatus >= 100 || exitstatus < 0) { exitstatus = RLM_MODULE_FAIL; } } PUTBACK; FREETMPS; LEAVE; } } #endif if (inst->func_detach) { dTHXa(inst->perl); PERL_SET_CONTEXT(inst->perl); { dSP; ENTER; SAVETMPS; PUSHMARK(SP); count = call_pv(inst->func_detach, G_SCALAR | G_EVAL ); SPAGAIN; if (count == 1) { exitstatus = POPi; if (exitstatus >= 100 || exitstatus < 0) { exitstatus = RLM_MODULE_FAIL; } } PUTBACK; FREETMPS; LEAVE; } } #ifdef USE_ITHREADS rlm_perl_destruct(inst->perl); pthread_mutex_destroy(&inst->clone_mutex); #else perl_destruct(inst->perl); perl_free(inst->perl); #endif PERL_SYS_TERM(); return exitstatus; }
/* * get the vps and put them in perl hash * If one VP have multiple values it is added as array_ref * Example for this is Cisco-AVPair that holds multiple values. * Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'} */ static void perl_store_vps(UNUSED TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR *vps, HV *rad_hv, const char *hashname, const char *list_name) { VALUE_PAIR *vp; hv_undef(rad_hv); vp_cursor_t cursor; RINDENT(); pairsort(&vps, attrtagcmp); for (vp = fr_cursor_init(&cursor, &vps); vp; vp = fr_cursor_next(&cursor)) { VALUE_PAIR *next; char const *name; char namebuf[256]; char buffer[1024]; size_t len; /* * Tagged attributes are added to the hash with name * <attribute>:<tag>, others just use the normal attribute * name as the key. */ if (vp->da->flags.has_tag && (vp->tag != TAG_ANY)) { snprintf(namebuf, sizeof(namebuf), "%s:%d", vp->da->name, vp->tag); name = namebuf; } else { name = vp->da->name; } /* * We've sorted by type, then tag, so attributes of the * same type/tag should follow on from each other. */ if ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next)) { int i; AV *av; av = newAV(); for (next = fr_cursor_next_by_da(&cursor, vp->da, vp->tag), i = 0; next; next = fr_cursor_next_by_da(&cursor, vp->da, vp->tag), i++) { switch (vp->da->type) { case PW_TYPE_STRING: RDEBUG("$%s{'%s'}[%i] = &%s:%s -> '%s'", hashname, next->da->name, i, list_name, next->da->name, next->vp_strvalue); av_push(av, newSVpvn(next->vp_strvalue, next->length)); break; case PW_TYPE_OCTETS: if (RDEBUG_ENABLED) { char *hex; hex = fr_abin2hex(request, next->vp_octets, next->length); RDEBUG("$%s{'%s'}[%i] = &%s:%s -> 0x%s", hashname, next->da->name, i, list_name, next->da->name, hex); talloc_free(hex); } av_push(av, newSVpvn((char const *)next->vp_octets, next->length)); break; default: len = vp_prints_value(buffer, sizeof(buffer), next, 0); RDEBUG("$%s{'%s'}[%i] = &%s:%s -> '%s'", hashname, next->da->name, i, list_name, next->da->name, buffer); av_push(av, newSVpvn(buffer, truncate_len(len, sizeof(buffer)))); break; } } (void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0); continue; } /* * It's a normal single valued attribute */ switch (vp->da->type) { case PW_TYPE_STRING: RDEBUG("$%s{'%s'} = &%s:%s -> '%s'", hashname, vp->da->name, list_name, vp->da->name, vp->vp_strvalue); (void)hv_store(rad_hv, name, strlen(name), newSVpvn(vp->vp_strvalue, vp->length), 0); break; case PW_TYPE_OCTETS: if (RDEBUG_ENABLED) { char *hex; hex = fr_abin2hex(request, vp->vp_octets, vp->length); RDEBUG("$%s{'%s'} = &%s:%s -> 0x%s", hashname, vp->da->name, list_name, vp->da->name, hex); talloc_free(hex); } (void)hv_store(rad_hv, name, strlen(name), newSVpvn((char const *)vp->vp_octets, vp->length), 0); break; default: len = vp_prints_value(buffer, sizeof(buffer), vp, 0); RDEBUG("$%s{'%s'} = &%s:%s -> '%s'", hashname, vp->da->name, list_name, vp->da->name, buffer); (void)hv_store(rad_hv, name, strlen(name), newSVpvn(buffer, truncate_len(len, sizeof(buffer))), 0); break; } } REXDENT(); }
/* * get the vps and put them in perl hash * If one VP have multiple values it is added as array_ref * Example for this is Cisco-AVPair that holds multiple values. * Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'} */ static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv) { VALUE_PAIR *nvp, *vpa, *vpn; AV *av; const char *name; char namebuf[256]; char buffer[1024]; int len; hv_undef(rad_hv); /* * Copy the valuepair list so we can remove attributes we've * already processed. */ nvp = paircopy(vp); while (nvp != NULL) { /* * Tagged attributes are added to the hash with name * <attribute>:<tag>, others just use the normal attribute * name as the key. */ if (nvp->flags.has_tag && (nvp->flags.tag != 0)) { snprintf(namebuf, sizeof(namebuf), "%s:%d", nvp->name, nvp->flags.tag); name = namebuf; } else { name = nvp->name; } /* * Create a new list with all the attributes like this one * which are in the same tag group. */ vpa = paircopy2(nvp, nvp->attribute, nvp->vendor, nvp->flags.tag); /* * Attribute has multiple values */ if (vpa->next) { av = newAV(); for (vpn = vpa; vpn; vpn = vpn->next) { len = vp_prints_value(buffer, sizeof(buffer), vpn, FALSE); av_push(av, newSVpv(buffer, len)); } (void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0); /* * Attribute has a single value, so its value just gets * added to the hash. */ } else { len = vp_prints_value(buffer, sizeof(buffer), vpa, FALSE); (void)hv_store(rad_hv, name, strlen(name), newSVpv(buffer, len), 0); } pairfree(&vpa); /* * Find the next attribute which we won't have processed, * we need to do this so we know it won't be freed on * pairdelete. */ vpa = nvp->next; while ((vpa != NULL) && (vpa->attribute == nvp->attribute) && (vpa->vendor == nvp->vendor) && (vpa->flags.tag == nvp->flags.tag)) { vpa = vpa->next; } /* * Finally remove all the VPs we processed from our copy * of the list. */ pairdelete(&nvp, nvp->attribute, nvp->vendor, nvp->flags.tag); nvp = vpa; } }
/* * Call the function_name inside the module * Store all vps in hashes %RAD_CHECK %RAD_REPLY %RAD_REQUEST * */ static int do_perl(void *instance, REQUEST *request, char const *function_name) { rlm_perl_t *inst = instance; VALUE_PAIR *vp; int exitstatus=0, count; STRLEN n_a; HV *rad_reply_hv; HV *rad_check_hv; HV *rad_config_hv; HV *rad_request_hv; HV *rad_state_hv; #ifdef WITH_PROXY HV *rad_request_proxy_hv; HV *rad_request_proxy_reply_hv; #endif SV *rad_requestp_sv; /* * Radius has told us to call this function, but none * is defined. */ if (!function_name) return RLM_MODULE_FAIL; #ifdef USE_ITHREADS pthread_mutex_lock(&inst->clone_mutex); PerlInterpreter *interp; interp = rlm_perl_clone(inst->perl,inst->thread_key); { dTHXa(interp); PERL_SET_CONTEXT(interp); } pthread_mutex_unlock(&inst->clone_mutex); #else PERL_SET_CONTEXT(inst->perl); #endif { dSP; ENTER; SAVETMPS; rad_reply_hv = get_hv("RAD_REPLY", 1); rad_check_hv = get_hv("RAD_CHECK", 1); rad_config_hv = get_hv("RAD_CONFIG", 1); rad_request_hv = get_hv("RAD_REQUEST", 1); rad_state_hv = get_hv("RAD_STATE", 1); rad_requestp_sv = get_sv("RAD___REQUESTP", 1); perl_store_vps(request->packet, request, &request->packet->vps, rad_request_hv, "RAD_REQUEST", "request"); perl_store_vps(request->reply, request, &request->reply->vps, rad_reply_hv, "RAD_REPLY", "reply"); perl_store_vps(request, request, &request->config, rad_check_hv, "RAD_CHECK", "control"); perl_store_vps(request, request, &request->config, rad_config_hv, "RAD_CONFIG", "control"); perl_store_vps(request->state_ctx, request, &request->state, rad_state_hv, "RAD_STATE", "session-state"); #ifdef WITH_PROXY rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1); rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1); if (request->proxy != NULL) { perl_store_vps(request->proxy, request, &request->proxy->vps, rad_request_proxy_hv, "RAD_REQUEST_PROXY", "proxy-request"); } else { hv_undef(rad_request_proxy_hv); } if (request->proxy_reply != NULL) { perl_store_vps(request->proxy_reply, request, &request->proxy_reply->vps, rad_request_proxy_reply_hv, "RAD_REQUEST_PROXY_REPLY", "proxy-reply"); } else { hv_undef(rad_request_proxy_reply_hv); } #endif /* * Store pointer to request structure globally so xlat works * We mark it read-only for interpreter so end users will not be * in posession to change it and crash radiusd with bogus pointer */ SvREADONLY_off(rad_requestp_sv); sv_setiv(rad_requestp_sv, PTR2IV(request)); SvREADONLY_on(rad_requestp_sv); PUSHMARK(SP); /* * This way %RAD_xx can be pushed onto stack as sub parameters. * XPUSHs( newRV_noinc((SV *)rad_request_hv) ); * XPUSHs( newRV_noinc((SV *)rad_reply_hv) ); * XPUSHs( newRV_noinc((SV *)rad_check_hv) ); * PUTBACK; */ count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS); SPAGAIN; if (SvTRUE(ERRSV)) { RDEBUG("perl_embed:: module = %s , func = %s exit status= %s\n", inst->module, function_name, SvPV(ERRSV,n_a)); (void)POPs; count = 0; exitstatus = RLM_MODULE_FAIL; } if (count == 1) { exitstatus = POPi; if (exitstatus >= 100 || exitstatus < 0) { exitstatus = RLM_MODULE_FAIL; } } PUTBACK; FREETMPS; LEAVE; vp = NULL; get_hv_content(request->packet, request, rad_request_hv, &vp, "RAD_REQUEST", "request"); if (vp) { fr_pair_list_free(&request->packet->vps); request->packet->vps = vp; vp = NULL; /* * Update cached copies */ request->username = fr_pair_find_by_num(request->packet->vps, PW_USER_NAME, 0, TAG_ANY); request->password = fr_pair_find_by_num(request->packet->vps, PW_USER_PASSWORD, 0, TAG_ANY); if (!request->password) request->password = fr_pair_find_by_num(request->packet->vps, PW_CHAP_PASSWORD, 0, TAG_ANY); } get_hv_content(request->reply, request, rad_reply_hv, &vp, "RAD_REPLY", "reply"); if (vp) { fr_pair_list_free(&request->reply->vps); request->reply->vps = vp; vp = NULL; } get_hv_content(request, request, rad_check_hv, &vp, "RAD_CHECK", "control"); if (vp) { fr_pair_list_free(&request->config); request->config = vp; vp = NULL; } get_hv_content(request->state_ctx, request, rad_state_hv, &vp, "RAD_STATE", "session-state"); if (vp) { fr_pair_list_free(&request->state); request->state = vp; vp = NULL; } #ifdef WITH_PROXY if (request->proxy) { get_hv_content(request->proxy, request, rad_request_proxy_hv, &vp, "RAD_REQUEST_PROXY", "proxy-request"); if (vp) { fr_pair_list_free(&request->proxy->vps); request->proxy->vps = vp; vp = NULL; } } if (request->proxy_reply) { get_hv_content(request->proxy_reply, request, rad_request_proxy_reply_hv, &vp, "RAD_REQUEST_PROXY_REPLY", "proxy-reply"); if (vp) { fr_pair_list_free(&request->proxy_reply->vps); request->proxy_reply->vps = vp; vp = NULL; } } #endif } return exitstatus; }
/* * get the vps and put them in perl hash * If one VP have multiple values it is added as array_ref * Example for this is Cisco-AVPair that holds multiple values. * Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'} */ static void perl_store_vps(UNUSED TALLOC_CTX *ctx, REQUEST *request, VALUE_PAIR **vps, HV *rad_hv, const char *hash_name, const char *list_name) { VALUE_PAIR *vp; char *tbuff; size_t tbufflen = 1024; hv_undef(rad_hv); vp_cursor_t cursor; /* * Find out how much room to allocate. */ for (vp = fr_cursor_init(&cursor, vps); vp; vp = fr_cursor_next(&cursor)) { if (((vp->length * 2) + 3) > tbufflen) { tbufflen = (vp->vp_length * 2) + 3; } } tbuff = talloc_array(request, char, tbufflen); RINDENT(); fr_pair_list_sort(vps, fr_pair_cmp_by_da_tag); for (vp = fr_cursor_init(&cursor, vps); vp; vp = fr_cursor_next(&cursor)) { VALUE_PAIR *next; char const *name; size_t len; char namebuf[256]; /* * Tagged attributes are added to the hash with name * <attribute>:<tag>, others just use the normal attribute * name as the key. */ if (vp->da->flags.has_tag && (vp->tag != TAG_ANY)) { snprintf(namebuf, sizeof(namebuf), "%s:%d", vp->da->name, vp->tag); name = namebuf; } else { name = vp->da->name; } /* * We've sorted by type, then tag, so attributes of the * same type/tag should follow on from each other. */ if ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next)) { int i = 0; AV *av; av = newAV(); perl_vp_to_svpvn_element(request, av, vp, &i, hash_name, list_name); do { perl_vp_to_svpvn_element(request, av, next, &i, hash_name, list_name); fr_cursor_next(&cursor); } while ((next = fr_cursor_next_peek(&cursor)) && ATTRIBUTE_EQ(vp, next)); (void)hv_store(rad_hv, name, strlen(name), newRV_noinc((SV *)av), 0); continue; } /* * It's a normal single valued attribute */ switch (vp->da->type) { case PW_TYPE_STRING: RDEBUG("$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->da->name, list_name, vp->da->name, vp->vp_strvalue); (void)hv_store(rad_hv, name, strlen(name), newSVpvn(vp->vp_strvalue, vp->vp_length), 0); break; default: len = vp_prints_value(tbuff, tbufflen, vp, 0); RDEBUG("$%s{'%s'} = &%s:%s -> '%s'", hash_name, vp->da->name, list_name, vp->da->name, tbuff); (void)hv_store(rad_hv, name, strlen(name), newSVpvn(tbuff, truncate_len(len, tbufflen)), 0); break; } } REXDENT(); talloc_free(tbuff); }
/* * Call the function_name inside the module * Store all vps in hashes %RAD_CHECK %RAD_REPLY %RAD_REQUEST * */ static int rlmperl_call(void *instance, REQUEST *request, char *function_name) { PERL_INST *inst = instance; VALUE_PAIR *vp; int exitstatus=0, count; STRLEN n_a; HV *rad_reply_hv; HV *rad_check_hv; HV *rad_request_hv; HV *rad_request_proxy_hv; HV *rad_request_proxy_reply_hv; #ifdef USE_ITHREADS POOL_HANDLE *handle; if ((handle = pool_pop(instance)) == NULL) { return RLM_MODULE_FAIL; } radlog(L_DBG,"found interpetator at address 0x%lx",(unsigned long) handle->clone); { dTHXa(handle->clone); PERL_SET_CONTEXT(handle->clone); } #else PERL_SET_CONTEXT(inst->perl); radlog(L_DBG,"Using perl at 0x%lx",(unsigned long) inst->perl); #endif { dSP; ENTER; SAVETMPS; /* * Radius has told us to call this function, but none * is defined. */ if (!function_name) { return RLM_MODULE_FAIL; } rad_reply_hv = get_hv("RAD_REPLY",1); rad_check_hv = get_hv("RAD_CHECK",1); rad_request_hv = get_hv("RAD_REQUEST",1); rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1); rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1); perl_store_vps(request->reply->vps, rad_reply_hv); perl_store_vps(request->config_items, rad_check_hv); perl_store_vps(request->packet->vps, rad_request_hv); if (request->proxy != NULL) { perl_store_vps(request->proxy->vps, rad_request_proxy_hv); } else { hv_undef(rad_request_proxy_hv); } if (request->proxy_reply !=NULL) { perl_store_vps(request->proxy_reply->vps, rad_request_proxy_reply_hv); } else { hv_undef(rad_request_proxy_reply_hv); } vp = NULL; PUSHMARK(SP); /* * This way %RAD_xx can be pushed onto stack as sub parameters. * XPUSHs( newRV_noinc((SV *)rad_request_hv) ); * XPUSHs( newRV_noinc((SV *)rad_reply_hv) ); * XPUSHs( newRV_noinc((SV *)rad_check_hv) ); * PUTBACK; */ count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS); SPAGAIN; if (SvTRUE(ERRSV)) { radlog(L_ERR, "rlm_perl: perl_embed:: module = %s , func = %s exit status= %s\n", inst->module, function_name, SvPV(ERRSV,n_a)); POPs; } if (count == 1) { exitstatus = POPi; if (exitstatus >= 100 || exitstatus < 0) { exitstatus = RLM_MODULE_FAIL; } } PUTBACK; FREETMPS; LEAVE; if ((get_hv_content(rad_reply_hv, &vp)) > 0 ) { pairmove(&request->reply->vps, &vp); pairfree(&vp); } if ((get_hv_content(rad_check_hv, &vp)) > 0 ) { pairmove(&request->config_items, &vp); pairfree(&vp); } if ((get_hv_content(rad_request_proxy_reply_hv, &vp)) > 0 && request->proxy_reply != NULL) { pairfree(&request->proxy_reply->vps); pairmove(&request->proxy_reply->vps, &vp); pairfree(&vp); } } #ifdef USE_ITHREADS pool_release(handle,instance); radlog(L_DBG,"Unreserve perl at address 0x%lx", (unsigned long) handle->clone); #endif return exitstatus; }