/* xs_init is the second argument perl_parse. As the name hints, it initializes XS subroutines (see the perlembed manpage) */ static void xs_init (pTHX) { HV *stash; SV *version; /* This one allows dynamic loading of perl modules in perl scripts by the 'use perlmod;' construction */ newXS ("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__); /* load up all the custom IRC perl functions */ newXS ("Xchat::Internal::register", XS_Xchat_register, __FILE__); newXS ("Xchat::Internal::hook_server", XS_Xchat_hook_server, __FILE__); newXS ("Xchat::Internal::hook_command", XS_Xchat_hook_command, __FILE__); newXS ("Xchat::Internal::hook_print", XS_Xchat_hook_print, __FILE__); newXS ("Xchat::Internal::hook_timer", XS_Xchat_hook_timer, __FILE__); newXS ("Xchat::Internal::hook_fd", XS_Xchat_hook_fd, __FILE__); newXS ("Xchat::Internal::unhook", XS_Xchat_unhook, __FILE__); newXS ("Xchat::Internal::print", XS_Xchat_print, __FILE__); newXS ("Xchat::Internal::command", XS_Xchat_command, __FILE__); newXS ("Xchat::Internal::set_context", XS_Xchat_set_context, __FILE__); newXS ("Xchat::Internal::get_info", XS_Xchat_get_info, __FILE__); newXS ("Xchat::Internal::context_info", XS_Xchat_context_info, __FILE__); newXS ("Xchat::Internal::get_list", XS_Xchat_get_list, __FILE__); newXS ("Xchat::find_context", XS_Xchat_find_context, __FILE__); newXS ("Xchat::get_context", XS_Xchat_get_context, __FILE__); newXS ("Xchat::get_prefs", XS_Xchat_get_prefs, __FILE__); newXS ("Xchat::emit_print", XS_Xchat_emit_print, __FILE__); newXS ("Xchat::send_modes", XS_Xchat_send_modes, __FILE__); newXS ("Xchat::nickcmp", XS_Xchat_nickcmp, __FILE__); newXS ("Xchat::Embed::plugingui_remove", XS_Xchat_Embed_plugingui_remove, __FILE__); stash = get_hv ("Xchat::", TRUE); if (stash == NULL) { exit (1); } newCONSTSUB (stash, "PRI_HIGHEST", newSViv (XCHAT_PRI_HIGHEST)); newCONSTSUB (stash, "PRI_HIGH", newSViv (XCHAT_PRI_HIGH)); newCONSTSUB (stash, "PRI_NORM", newSViv (XCHAT_PRI_NORM)); newCONSTSUB (stash, "PRI_LOW", newSViv (XCHAT_PRI_LOW)); newCONSTSUB (stash, "PRI_LOWEST", newSViv (XCHAT_PRI_LOWEST)); newCONSTSUB (stash, "EAT_NONE", newSViv (XCHAT_EAT_NONE)); newCONSTSUB (stash, "EAT_XCHAT", newSViv (XCHAT_EAT_XCHAT)); newCONSTSUB (stash, "EAT_PLUGIN", newSViv (XCHAT_EAT_PLUGIN)); newCONSTSUB (stash, "EAT_ALL", newSViv (XCHAT_EAT_ALL)); newCONSTSUB (stash, "FD_READ", newSViv (XCHAT_FD_READ)); newCONSTSUB (stash, "FD_WRITE", newSViv (XCHAT_FD_WRITE)); newCONSTSUB (stash, "FD_EXCEPTION", newSViv (XCHAT_FD_EXCEPTION)); newCONSTSUB (stash, "FD_NOTSOCKET", newSViv (XCHAT_FD_NOTSOCKET)); newCONSTSUB (stash, "KEEP", newSViv (1)); newCONSTSUB (stash, "REMOVE", newSViv (0)); version = get_sv( "Xchat::VERSION", 1 ); sv_setpv( version, PACKAGE_VERSION ); }
static void print_var(char *var_name, char *var) { HV *h_var; h_var = get_hv(var_name, 0); if(!h_var) error_tmpl("Vars hash not exist"); SV **sr_var = hv_fetch(h_var, var, (int)strlen(var), 0); if(!sr_var){ error_tmpl("Var not exist");}; if(SvTYPE(*sr_var) == SVt_IV || SvTYPE(*sr_var) == SVt_PVIV){ printf( "%li", SvIV(*sr_var)); } else if(SvTYPE(*sr_var) == SVt_NV || SvTYPE(*sr_var) == SVt_PVNV){ printf("%f", SvNV(*sr_var)); } else if(SvTYPE(*sr_var) == SVt_PV){ printf("%s", SvPV_nolen(*sr_var)); } else { error_tmpl("Incompatible type of var"); } }
USER_OBJECT_ RS_PerlNames(USER_OBJECT_ obj) { HV* hv; SV *el; int n, i; USER_OBJECT_ names; char *key; I32 len; dTHX; if(IS_CHARACTER(obj)) { hv = get_hv(CHAR_DEREF(STRING_ELT(obj,0)), FALSE); } else hv = (HV *) RS_PerlGetSV(obj); if(hv == NULL) { PROBLEM "identifier does not refer to a Perl hashtable object" ERROR; } if(SvTYPE(hv) != SVt_PVHV) { if(SvROK(hv) && SvTYPE(SvRV(hv)) == SVt_PVHV) { hv = (HV *) SvRV(hv); } else { PROBLEM "identifier is not a Perl hashtable object, but some other type %s", getPerlType((SV*)hv) ERROR; } } n = hv_iterinit(hv); if(n == 0) return(NULL_USER_OBJECT); PROTECT(names = NEW_CHARACTER(n)); i = 0; while(i < n) { el = hv_iternextsv(hv, &key, &len); if(key == NULL) break; SET_STRING_ELT(names, i, COPY_TO_USER_STRING(key)); i++; } UNPROTECT(1); return(names); }
SV *p5_get_global(PerlInterpreter *my_perl, const char* name) { PERL_SET_CONTEXT(my_perl); if (strlen(name) < 2) return NULL; if (name[0] == '$') return get_sv(&name[1], 0); if (name[0] == '@') return sv_2mortal(newRV_inc((SV *)get_av(&name[1], 0))); if (name[0] == '%') return sv_2mortal(newRV_inc((SV *)get_hv(&name[1], 0))); return NULL; }
void purple_perl_plugin_action_cb(PurplePluginAction *action) { SV **callback; HV *hv = NULL; gchar *hvname; PurplePlugin *plugin; PurplePerlScript *gps; dSP; plugin = action->plugin; gps = (PurplePerlScript *)plugin->info->extra_info; hvname = g_strdup_printf("%s::plugin_actions", gps->package); hv = get_hv(hvname, FALSE); g_free(hvname); if (hv == NULL) croak("No plugin_actions hash found in \"%s\" plugin.", purple_plugin_get_name(plugin)); ENTER; SAVETMPS; callback = hv_fetch(hv, action->label, strlen(action->label), 0); if (callback == NULL || *callback == NULL) croak("No plugin_action function named \"%s\" in \"%s\" plugin.", action->label, purple_plugin_get_name(plugin)); PUSHMARK(sp); XPUSHs(purple_perl_bless_object(gps->plugin, "Purple::Plugin")); PUTBACK; call_sv(*callback, G_EVAL | G_VOID | G_DISCARD); SPAGAIN; if (SvTRUE(ERRSV)) { purple_debug_error("perl", "Perl plugin action function exited abnormally: %s\n", SvPVutf8_nolen(ERRSV)); } PUTBACK; FREETMPS; LEAVE; }
void math_int64_boot(pTHX_ int version) { dSP; SV **svp; eval_pv("require Math::Int64", TRUE); if (SvTRUE(ERRSV)) Perl_croak(aTHX_ "Unable to load Math::Int64: %s", SvPV_nolen(ERRSV)); math_int64_capi_hash = get_hv("Math::Int64::C_API", 0); if (!math_int64_capi_hash) Perl_croak(aTHX_ "Unable to load Math::Int64 C API"); math_int64_capi_version = SvIV(*hv_fetchs(math_int64_capi_hash, "version", 1)); if (math_int64_capi_version < version) Perl_croak(aTHX_ "Math::Int64 C API version mismatch, expected %d, found %d", version, math_int64_capi_version); fetch_ptr(math_int64_capi_newSVi64, "newSVi64"); fetch_ptr(math_int64_capi_newSVu64, "newSVu64"); fetch_ptr(math_int64_capi_SvI64, "SvI64"); fetch_ptr(math_int64_capi_SvU64, "SvU64"); fetch_ptr(math_int64_capi_SvI64OK, "SvI64OK"); fetch_ptr(math_int64_capi_SvU64OK, "SvU64OK"); }
USER_OBJECT_ RS_getHV(USER_OBJECT_ name, USER_OBJECT_ convert, USER_OBJECT_ interpreter) { USER_OBJECT_ ans = NULL_USER_OBJECT; HV *table; dTHX; if(!IS_CHARACTER(name)) { SV *tmp = getForeignPerlReference(name); if(tmp == NULL || SvTYPE(tmp) != SVt_PVHV) { PROBLEM "non-array reference passed to RS_getHV" ERROR; } table = (HV*) tmp; } else { table = get_hv(CHAR_DEREF(STRING_ELT(name,0)), FALSE); } if(table != NULL) { if(TYPEOF(convert) == LGLSXP || TYPEOF(convert) == INTSXP) { unsigned int depth; depth = (TYPEOF(convert) == LGLSXP ? LOGICAL(convert)[0] : INTEGER(convert)[0]); if(depth) { ans = fromPerlHV(table, depth); } else { /* ans = fromPerl((SV*) table); */ ans = makeForeignPerlReference((SV*) table, makeRSPerlClassVector("PerlHashReference"), &exportReferenceTable); } } else { ans = directConvertFromPerl((SV*) table, convert); } } return(ans); }
/* Wrap a JS value to export into perl * Returns a new SV, REFCNT_dec is caller's responsability */ JSBool PJS_ReflectJS2Perl( pTHX_ JSContext *cx, jsval value, SV** sv, int full ) { if(JSVAL_IS_PRIMITIVE(value)) { *sv = PrimJSVALToSV(aTHX_ cx, value); if(*sv) return JS_TRUE; } else if(JSVAL_IS_OBJECT(value)) { PJS_Context *pcx = PJS_GET_CONTEXT(cx); JSObject *object = JSVAL_TO_OBJECT(value); JSClass *clasp = PJS_GET_CLASS(cx, object); const char *classname = clasp->name; JSObject *passport; SV *wrapper; SV *box; char hkey[32]; jsval temp = JSVAL_VOID; snprintf(hkey, 32, "%p", (void *)object); PJS_DEBUG2("Wrapping a %s(%s)\n", classname, hkey); if(PJS_getFlag(pcx, "ConvertRegExp") && strEQ(classname, "RegExp")) { jsval src; char *str; if(JS_CallFunctionName(cx, object, "toSource", 0, NULL, &src) && (str = JS_GetStringBytes(JS_ValueToString(cx, src))) ) { dSP; SV *tmp = newSVpvf("qr%s", str); eval_sv(tmp, G_SCALAR); sv_free(tmp); // Don't leak SPAGAIN; tmp = POPs; PUTBACK; if(!SvTRUE(ERRSV)) { *sv = SvREFCNT_inc_simple_NN(tmp); return JS_TRUE; } } return JS_FALSE; } if(IS_PERL_CLASS(clasp)) { /* IS_PERL_CLASS means actual perl object is there */ SV *priv = (SV *)JS_GetPrivate(cx, object); if(priv && SvOK(priv) && SvROK(priv)) { *sv = SvREFCNT_inc_simple_NN(priv); return JS_TRUE; } croak("A private %s?!\n", classname); return JS_FALSE; } /* Common JSObject case */ /* Check registered perl visitors */ JS_LookupProperty(cx, pcx->pvisitors, hkey, &temp); if(temp != JSVAL_VOID) { /* Already registered, so exits a reference in perl space * _must_ hold a PASSPORT */ assert(JSVAL_TO_OBJECT(temp) == object); box = PJS_GetPassport(aTHX_ cx, object); SvREFCNT_inc_void_NN(box); /* In perl should be one more */ PJS_DEBUG1("Cached!: %s\n", hkey); } else { /* Check if with a PASSPORT */ JS_LookupPropertyWithFlags(cx, object, PJS_PASSPORT_PROP, 0, &temp); if(JSVAL_IS_OBJECT(temp) && (passport = JSVAL_TO_OBJECT(temp)) && PJS_GET_CLASS(cx, passport) == &passport_class && JS_GetReservedSlot(cx, passport, 0, &temp) && object == (JSObject *)JSVAL_TO_PRIVATE(temp) ) { /* Yes, reentering perl */ box = (SV *)JS_GetPrivate(cx, passport); /* Here we don't increment refcount, the ownership in passport is * transferred to perl land. */ PJS_DEBUG1("Reenter: %s\n", hkey); } else { /* No, first time, must wrap the object */ SV *boxref; const char *package; SV *robj = newSV(0); SV *rjsv = newSV(0); if (JS_ObjectIsFunction(cx, object)) package = PJS_FUNCTION_PACKAGE; else if(JS_IsArrayObject(cx, object)) package = PJS_ARRAY_PACKAGE; else if(strEQ(classname, PJS_PACKAGE_CLASS_NAME)) package = PJS_STASH_PACKAGE; #if JS_HAS_XML_SUPPORT else if(strEQ(classname, "XML")) package = PJS_XMLOBJ_PACKAGE; #endif else if(strEQ(classname, "Error")) package = PJS_ERROR_PACKAGE; else { SV **sv = hv_fetch(get_hv(NAMESPACE"ClassMap", 1), classname, strlen(classname), 0); if(sv) package = SvPV_nolen(*sv); else package = PJS_OBJECT_PACKAGE; } sv_setref_pv(robj, PJS_RAW_OBJECT, (void*)object); sv_setref_iv(rjsv, PJS_RAW_JSVAL, (IV)value); boxref = PJS_CallPerlMethod(aTHX_ cx, "__new", sv_2mortal(newSVpv(package, 0)), // package sv_2mortal(robj), // content sv_2mortal(rjsv), // jsval NULL ); if(!boxref) return JS_FALSE; if(!SvOK(boxref) || !sv_derived_from(boxref, PJS_BOXED_PACKAGE)) croak("PJS_Assert: Contructor must return a "NAMESPACE"Boxed"); /* Create a new PASSPORT */ passport = JS_NewObject(cx, &passport_class, NULL, object); if(!passport || !JS_DefineProperty(cx, object, PJS_PASSPORT_PROP, OBJECT_TO_JSVAL(passport), NULL, NULL, JSPROP_READONLY | JSPROP_PERMANENT)) return JS_FALSE; box = SvRV(boxref); /* boxref is mortal, so we need to increment its rc, at end of * scope, PASSPORT owns created box */ JS_SetPrivate(cx, passport, (void *)SvREFCNT_inc_simple_NN(box)); JS_SetReservedSlot(cx, passport, 0, PRIVATE_TO_JSVAL(object)); PJS_DEBUG2("New boxed: %s brc: %d\n", hkey, SvREFCNT(box)); } /* Root object adding it to pvisitors list, will be unrooted by * jsc_free_root at Boxed DESTROY time */ JS_DefineProperty(cx, pcx->pvisitors, hkey, value, NULL, NULL, 0); } /* Here the RC of box in PASSPORT reflects wrapper's ownership */ if(full && PJS_getFlag(pcx, "AutoTie") && (strEQ(classname, "Object") || strEQ(classname, "Array")) ) { /* Return tied */ AV *avbox = (AV *)SvRV(box); SV **last; SV *tied; SV *tier; if(strEQ(classname, "Array")) { last = av_fetch(avbox, 6, 1); if(last && SvOK(*last) && SvROK(*last)) { // Cached *sv = newSVsv(*last); sv_free(box); /* Hard copy 'sv' owns the reference */ return JS_TRUE; } tied = (SV *)newAV(); } else { // Object last = av_fetch(avbox, 5, 1); if(last && SvOK(*last) && SvROK(*last)) { // Cached *sv = newSVsv(*last); sv_free(box); /* Hard copy 'sv' owns the reference */ return JS_TRUE; } tied = (SV *)newHV(); } /* hv_magic below own a reference to box, we use an explicit path, * to make clear that to perl land only one reference is given */ tier = newRV_inc(box); hv_magic((HV *)tied, (GV *)tier, PERL_MAGIC_tied); sv_free(tier); wrapper = newRV_noinc(tied); /* Don't leak the hidden tied variable */ /* Save in cache a weaken copy, the cache itself dosn't hold a reference */ sv_setsv(*last, wrapper); sv_rvweaken(*last); PJS_DEBUG1("Return tied for %s\n", SvPV_nolen(tier)); } else { wrapper = newRV_noinc(box); /* Transfer ownership to wrapper */ #if PERL_VERSION < 9 sv_bless(wrapper, SvSTASH(box)); #endif } *sv = wrapper; return JS_TRUE; } return JS_FALSE; }
Hash::Temp Interpreter::hash(const char* name) const { HV* const ret = get_hv(name, true); SvGETMAGIC(reinterpret_cast<SV*>(ret)); return Hash::Temp(raw_interp.get(), ret, false); }
Hash::Temp Package::hash(const char* name) const { HV* const ret = get_hv((package_name + "::" + name).c_str(), true); return Hash::Temp(interp, ret, false); }
/* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ static int mod_instantiate(CONF_SECTION *conf, void *instance) { rlm_perl_t *inst = instance; AV *end_AV; char const **embed_c; /* Stupid Perl and lack of const consistency */ char **embed; char **envp = NULL; char const *xlat_name; int exitstatus = 0, argc=0; MEM(embed_c = talloc_zero_array(inst, char const *, 4)); memcpy(&embed, &embed_c, sizeof(embed)); /* * Create pthread key. This key will be stored in instance */ #ifdef USE_ITHREADS pthread_mutex_init(&inst->clone_mutex, NULL); inst->thread_key = rad_malloc(sizeof(*inst->thread_key)); memset(inst->thread_key,0,sizeof(*inst->thread_key)); rlm_perl_make_key(inst->thread_key); #endif char arg[] = "0"; embed_c[0] = NULL; if (inst->perl_flags) { embed_c[1] = inst->perl_flags; embed_c[2] = inst->module; embed_c[3] = arg; argc = 4; } else { embed_c[1] = inst->module; embed_c[2] = arg; argc = 3; } PERL_SYS_INIT3(&argc, &embed, &envp); if ((inst->perl = perl_alloc()) == NULL) { ERROR("rlm_perl: No memory for allocating new perl !"); return (-1); } perl_construct(inst->perl); #ifdef USE_ITHREADS PL_perl_destruct_level = 2; { dTHXa(inst->perl); } PERL_SET_CONTEXT(inst->perl); #endif #if PERL_REVISION >= 5 && PERL_VERSION >=8 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL); end_AV = PL_endav; PL_endav = Nullav; if(!exitstatus) { perl_run(inst->perl); } else { ERROR("rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module); return (-1); } PL_endav = end_AV; xlat_name = cf_section_name2(conf); if (!xlat_name) xlat_name = cf_section_name1(conf); if (xlat_name) { xlat_register(xlat_name, perl_xlat, NULL, inst); } /* parse perl configuration sub-section */ CONF_SECTION *cs; cs = cf_section_sub_find(conf, "config"); if (cs) { DEBUG("rlm_perl (%s): parsing 'config' section...", xlat_name); inst->rad_perlconf_hv = get_hv("RAD_PERLCONF",1); perl_parse_config(cs, 0, inst->rad_perlconf_hv); DEBUG("rlm_perl (%s): done parsing 'config'.", xlat_name); } return 0; }
/* * 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; }
/* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Boyan: * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ static int perl_instantiate(CONF_SECTION *conf, void **instance) { PERL_INST *inst = (PERL_INST *) instance; HV *rad_reply_hv; HV *rad_check_hv; HV *rad_request_hv; HV *rad_request_proxy_hv; HV *rad_request_proxy_reply_hv; AV *end_AV; char *embed[4], *xlat_name; int exitstatus = 0, argc=0; /* * Set up a storage area for instance data */ inst = rad_malloc(sizeof(PERL_INST)); memset(inst, 0, sizeof(PERL_INST)); /* * If the configuration parameters can't be parsed, then * fail. */ if (cf_section_parse(conf, inst, module_config) < 0) { free(inst); return -1; } embed[0] = NULL; if (inst->perl_flags) { embed[1] = inst->perl_flags; embed[2] = inst->module; embed[3] = "0"; argc = 4; } else { embed[1] = inst->module; embed[2] = "0"; argc = 3; } #ifdef USE_ITHREADS inst->perl = interp; if ((inst->perl = perl_alloc()) == NULL) { radlog(L_DBG, "rlm_perl: No memory for allocating new perl !"); return (-1); } perl_construct(inst->perl); PL_perl_destruct_level = 2; { dTHXa(inst->perl); } PERL_SET_CONTEXT(inst->perl); #else if ((inst->perl = perl_alloc()) == NULL) { radlog(L_ERR, "rlm_perl: No memory for allocating new perl !"); return -1; } perl_construct(inst->perl); #endif #if PERL_REVISION >= 5 && PERL_VERSION >=8 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL); end_AV = PL_endav; PL_endav = Nullav; if(!exitstatus) { exitstatus = perl_run(inst->perl); } else { radlog(L_ERR,"rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module); return (-1); } PL_endav = end_AV; newXS("radiusd::radlog",XS_radiusd_radlog, "rlm_perl.c"); rad_reply_hv = newHV(); rad_check_hv = newHV(); rad_request_hv = newHV(); rad_request_proxy_hv = newHV(); rad_request_proxy_reply_hv = newHV(); 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); xlat_name = cf_section_name2(conf); if (xlat_name == NULL) xlat_name = cf_section_name1(conf); if (xlat_name){ inst->xlat_name = strdup(xlat_name); xlat_register(xlat_name, perl_xlat, inst); } #ifdef USE_ITHREADS if ((init_pool(conf, inst)) == -1) { radlog(L_ERR,"Couldn't init a pool of perl clones. Exiting"); return -1; } #endif *instance = inst; return 0; }
/* * Implementation functions: load or unload a perl script. */ static module_t *do_script_load(const char *filename) { /* Remember, this must now be re-entrant. The use of the static * perl_error buffer is still OK, as it's only used immediately after * setting, without control passing from this function. */ perl_script_module_t *m = mowgli_heap_alloc(perl_script_module_heap); mowgli_strlcpy(m->filename, filename, sizeof(m->filename)); snprintf(perl_error, sizeof(perl_error), "Unknown error attempting to load perl script %s", filename); dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(newRV_noinc((SV*)get_cv("Atheme::Init::load_script", 0))); XPUSHs(sv_2mortal(newSVpv(filename, 0))); PUTBACK; int perl_return_count = call_pv("Atheme::Init::call_wrapper", G_EVAL | G_SCALAR); SPAGAIN; if (SvTRUE(ERRSV)) { mowgli_strlcpy(perl_error, SvPV_nolen(ERRSV), sizeof(perl_error)); goto fail; } if (1 != perl_return_count) { snprintf(perl_error, sizeof(perl_error), "Script load didn't return a package name"); goto fail; } /* load_script should have returned the package name that was just * loaded... */ const char *packagename = POPp; char info_varname[BUFSIZE]; snprintf(info_varname, BUFSIZE, "%s::Info", packagename); /* ... so use that name to grab the script information hash... */ HV *info_hash = get_hv(info_varname, 0); if (!info_hash) { snprintf(perl_error, sizeof(perl_error), "Couldn't get package info hash %s", info_varname); goto fail; } /* ..., extract the canonical name... */ SV **name_var = hv_fetch(info_hash, "name", 4, 0); if (!name_var) { snprintf(perl_error, sizeof(perl_error), "Couldn't find canonical name in package info hash"); goto fail; } mowgli_strlcpy(m->mod.name, SvPV_nolen(*name_var), sizeof(m->mod.name)); /* ... and dependency list. */ SV **deplist_var = hv_fetch(info_hash, "depends", 7, 0); /* Not declaring this is legal... */ if (deplist_var) { /* ... but having it as anything but an arrayref isn't. */ if (!SvROK(*deplist_var) || SvTYPE(SvRV(*deplist_var)) != SVt_PVAV) { snprintf(perl_error, sizeof(perl_error), "$Info::depends must be an array reference"); goto fail; } AV *deplist = (AV*)SvRV(*deplist_var); I32 len = av_len(deplist); /* av_len returns max index, not number of items */ for (I32 i = 0; i <= len; ++i) { SV **item = av_fetch(deplist, i, 0); if (!item) continue; const char *dep_name = SvPV_nolen(*item); if (!module_request(dep_name)) { snprintf(perl_error, sizeof(perl_error), "Dependent module %s failed to load", dep_name); goto fail; } module_t *dep_mod = module_find_published(dep_name); mowgli_node_add(dep_mod, mowgli_node_create(), &m->mod.deplist); mowgli_node_add(m, mowgli_node_create(), &dep_mod->dephost); } } FREETMPS; LEAVE; invalidate_object_references(); /* Now that everything's loaded, do the module housekeeping stuff. */ m->mod.unload_handler = perl_script_module_unload_handler; /* Can't do much better than the address of the module_t here */ m->mod.address = m; m->mod.can_unload = MODULE_UNLOAD_CAPABILITY_OK; return (module_t*)m; fail: slog(LG_ERROR, "Failed to load Perl script %s: %s", filename, perl_error); if (info_hash) SvREFCNT_dec((SV*)info_hash); do_script_unload(filename); mowgli_heap_free(perl_script_module_heap, m); POPs; FREETMPS; LEAVE; invalidate_object_references(); return NULL; }
/* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Boyan: * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ static int perl_instantiate(CONF_SECTION *conf, void **instance) { PERL_INST *inst = (PERL_INST *) instance; 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 AV *end_AV; char **embed; char **envp = NULL; const char *xlat_name; int exitstatus = 0, argc=0; embed = rad_malloc(4 * sizeof(char *)); memset(embed, 0, 4 *sizeof(char *)); /* * Set up a storage area for instance data */ inst = rad_malloc(sizeof(PERL_INST)); memset(inst, 0, sizeof(PERL_INST)); /* * If the configuration parameters can't be parsed, then * fail. */ if (cf_section_parse(conf, inst, module_config) < 0) { free(embed); free(inst); return -1; } /* * Create pthread key. This key will be stored in instance */ #ifdef USE_ITHREADS pthread_mutex_init(&inst->clone_mutex, NULL); inst->thread_key = rad_malloc(sizeof(*inst->thread_key)); memset(inst->thread_key,0,sizeof(*inst->thread_key)); rlm_perl_make_key(inst->thread_key); #endif char arg[] = "0"; embed[0] = NULL; if (inst->perl_flags) { embed[1] = inst->perl_flags; embed[2] = inst->module; embed[3] = arg; argc = 4; } else { embed[1] = inst->module; embed[2] = arg; argc = 3; } PERL_SYS_INIT3(&argc, &embed, &envp); #ifdef USE_ITHREADS if ((inst->perl = perl_alloc()) == NULL) { radlog(L_DBG, "rlm_perl: No memory for allocating new perl !"); free(embed); free(inst); return (-1); } perl_construct(inst->perl); PL_perl_destruct_level = 2; { dTHXa(inst->perl); } PERL_SET_CONTEXT(inst->perl); #else if ((inst->perl = perl_alloc()) == NULL) { radlog(L_ERR, "rlm_perl: No memory for allocating new perl !"); free(embed); free(inst); return -1; } perl_construct(inst->perl); #endif #if PERL_REVISION >= 5 && PERL_VERSION >=8 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL); end_AV = PL_endav; PL_endav = Nullav; newXS("radiusd::radlog",XS_radiusd_radlog, "rlm_perl"); if(!exitstatus) { exitstatus = perl_run(inst->perl); } else { radlog(L_ERR,"rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module); free(embed); free(inst); return (-1); } PL_endav = end_AV; rad_reply_hv = newHV(); rad_check_hv = newHV(); rad_config_hv = newHV(); rad_request_hv = newHV(); #ifdef WITH_PROXY rad_request_proxy_hv = newHV(); rad_request_proxy_reply_hv = newHV(); #endif 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); #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); #endif xlat_name = cf_section_name2(conf); if (xlat_name == NULL) xlat_name = cf_section_name1(conf); if (xlat_name){ inst->xlat_name = strdup(xlat_name); xlat_register(xlat_name, perl_xlat, inst); } *instance = inst; return 0; }
int perl_math_int128_load(int required_version) { dTHX; SV **svp; eval_pv("require Math::Int128", TRUE); if (SvTRUE(ERRSV)) return 0; math_int128_c_api_hash = get_hv("Math::Int128::C_API", 0); if (!math_int128_c_api_hash) { sv_setpv_mg(ERRSV, "Unable to load Math::Int128 C API"); return 0; } math_int128_c_api_min_version = SvIV(*hv_fetch(math_int128_c_api_hash, "min_version", 11, 1)); math_int128_c_api_max_version = SvIV(*hv_fetch(math_int128_c_api_hash, "max_version", 11, 1)); if ((required_version < math_int128_c_api_min_version) || (required_version > math_int128_c_api_max_version)) { sv_setpvf_mg(ERRSV, "Math::Int128 C API version mismatch. " "The installed module supports versions %d to %d but %d is required", math_int128_c_api_min_version, math_int128_c_api_max_version, required_version); return 0; } svp = hv_fetch(math_int128_c_api_hash, "SvI128", 6, 0); if (!svp || !*svp) { sv_setpv_mg(ERRSV, "Unable to fetch pointer 'SvI128' C function from Math::Int128"); return 0; } math_int128_c_api_SvI128 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int128_c_api_hash, "SvI128OK", 8, 0); if (!svp || !*svp) { sv_setpv_mg(ERRSV, "Unable to fetch pointer 'SvI128OK' C function from Math::Int128"); return 0; } math_int128_c_api_SvI128OK = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int128_c_api_hash, "SvU128", 6, 0); if (!svp || !*svp) { sv_setpv_mg(ERRSV, "Unable to fetch pointer 'SvU128' C function from Math::Int128"); return 0; } math_int128_c_api_SvU128 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int128_c_api_hash, "SvU128OK", 8, 0); if (!svp || !*svp) { sv_setpv_mg(ERRSV, "Unable to fetch pointer 'SvU128OK' C function from Math::Int128"); return 0; } math_int128_c_api_SvU128OK = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int128_c_api_hash, "newSVi128", 9, 0); if (!svp || !*svp) { sv_setpv_mg(ERRSV, "Unable to fetch pointer 'newSVi128' C function from Math::Int128"); return 0; } math_int128_c_api_newSVi128 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int128_c_api_hash, "newSVu128", 9, 0); if (!svp || !*svp) { sv_setpv_mg(ERRSV, "Unable to fetch pointer 'newSVu128' C function from Math::Int128"); return 0; } math_int128_c_api_newSVu128 = INT2PTR(void *, SvIV(*svp)); return 1; }
regexp* hook_regcompp (pTHX_ char* exp, char* xend, PMOP* pm) { SV* handler = NULL; /* fprintf(stderr,"hook_regcompp in %lx\n",(unsigned long)exp); */ /* Check $^H for lexical selection of semantics and implementation */ if(handler == NULL) { const char hint_key[] = "regcompp"; SV** phandler; HV* hints; hints = get_hv("\b",0); if(hints != NULL) { phandler = hv_fetch(hints, hint_key, strlen(hint_key), 0); if(phandler != NULL) { handler = *phandler; /* fprintf(stderr,"hook_regcompp lexical...%lx\n",(unsigned long)handler); */ /* call_sv(handler,G_DISCARD|G_EVAL); fprintf(stderr,"can survive %lx %lx\n",(unsigned long)exp,(unsigned long)handler); */ } } } /* Check $re::override::regcompp for a dynamic selection of implementation */ if(handler == NULL) { SV* sv; sv = get_sv("$re::override::regcompp",0); if(sv != NULL && sv != &PL_sv_undef) { /* fprintf(stderr,"hook_regcompp dynamic...\n"); */ handler = sv; } } /* If no handlers, then hand off */ if(handler == NULL) { /* fprintf(stderr,"hook_regcompp punt.\n"); */ return previous_comp_hook(aTHX_ exp,xend,pm); } { dSP; char *nulpat; regexp* r; I32 ret; I32 api; nulpat = savepv(""); /*XXX - can be constant? */ r = Perl_pregcomp(aTHX_ nulpat,nulpat,pm); /*XXX - can free nulpat now? */ /* fprintf(stderr,"exp =%lu\nxend=%lu\n",(unsigned long)exp,(unsigned long)xend);*/ PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpvn(exp,xend-exp))); mXPUSHu((unsigned long)r); PUTBACK; HANDLER_CALL: /* fprintf(stderr,"calling out...\n");*/ ret = call_sv(handler, G_ARRAY); /* fprintf(stderr,"...back.\n");*/ SPAGAIN; api = POPi; if(api == 13) { SV* pat; long nparens; SV* exec_callback_sub; /* fprintf(stderr,"api 13\n");*/ if(ret != 4) { fprintf(stderr,"api 13 violation\n"); exit(0); } pat = POPs; nparens = POPl; exec_callback_sub = POPs; PUTBACK; regexp_setup(aTHX_ r,pat,nparens,exec_callback_sub); } else if(api == 14) { SV* expr_code; SV* expr_result; /* fprintf(stderr,"api 14\n");*/ if(ret != 3) { fprintf(stderr,"api 14 violation\n"); exit(0); } handler = SvREFCNT_inc(POPs); /*XXX needed? */ expr_code = POPs; PUTBACK; expr_result = eval_pv(SvPV_nolen(expr_code),0); SPAGAIN; XPUSHs(expr_result); PUTBACK; goto HANDLER_CALL; } else { fprintf(stderr,"api UNKNOWN violation\n"); exit(0); } /* fprintf(stderr,"hook_regcompp done.\n"); */ return r; } }
/* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ static int mod_instantiate(void *instance, CONF_SECTION *conf) { rlm_perl_t *inst = instance; AV *end_AV; char const **embed_c; /* Stupid Perl and lack of const consistency */ char **embed; char **envp = NULL; int exitstatus = 0, argc=0; char arg[] = "0"; CONF_SECTION *cs; #ifdef USE_ITHREADS /* * Create pthread key. This key will be stored in instance */ pthread_mutex_init(&inst->clone_mutex, NULL); MEM(inst->thread_key = talloc_zero(inst, pthread_key_t)); rlm_perl_make_key(inst->thread_key); #endif /* * Setup the argument array we pass to the perl interpreter */ MEM(embed_c = talloc_zero_array(inst, char const *, 4)); memcpy(&embed, &embed_c, sizeof(embed)); embed_c[0] = NULL; if (inst->perl_flags) { embed_c[1] = inst->perl_flags; embed_c[2] = inst->module; embed_c[3] = arg; argc = 4; } else { embed_c[1] = inst->module; embed_c[2] = arg; argc = 3; } /* * Create tweak the server's environment to support * perl. Docs say only call this once... Oops. */ if (!perl_sys_init3_called) { PERL_SYS_INIT3(&argc, &embed, &envp); perl_sys_init3_called = 1; } /* * Allocate a new perl interpreter to do the parsing */ if ((inst->perl = perl_alloc()) == NULL) { ERROR("No memory for allocating new perl interpretor!"); return -1; } perl_construct(inst->perl); /* ...and initialise it */ #ifdef USE_ITHREADS PL_perl_destruct_level = 2; { dTHXa(inst->perl); } PERL_SET_CONTEXT(inst->perl); #endif #if PERL_REVISION >= 5 && PERL_VERSION >=8 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL); end_AV = PL_endav; PL_endav = (AV *)NULL; if (exitstatus) { ERROR("Perl_parse failed: %s not found or has syntax errors", inst->module); return -1; } /* parse perl configuration sub-section */ cs = cf_section_find(conf, "config", NULL); if (cs) { inst->rad_perlconf_hv = get_hv("RAD_PERLCONF", 1); perl_parse_config(cs, 0, inst->rad_perlconf_hv); } inst->perl_parsed = true; perl_run(inst->perl); PL_endav = end_AV; return 0; }
// hv getters void *swiftperl_get_hv(const char *name, int add) { return (void *)get_hv(name, add ? GV_ADD : 0); }
/* * 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; }
/* * 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; }
/* * 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; }
int perl_math_int64_load(int required_version) { dTHX; SV **svp; eval_pv("require Math::Int64", TRUE); if (SvTRUE(ERRSV)) return 0; math_int64_c_api_hash = get_hv("Math::Int64::C_API", 0); if (!math_int64_c_api_hash) { sv_setpv(ERRSV, "Unable to load Math::Int64 C API"); SvSETMAGIC(ERRSV); return 0; } svp = hv_fetch(math_int64_c_api_hash, "min_version", 11, 0); if (!svp) svp = hv_fetch(math_int64_c_api_hash, "version", 7, 1); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to retrieve C API version for Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_min_version = SvIV(*svp); svp = hv_fetch(math_int64_c_api_hash, "max_version", 11, 0); if (!svp) svp = hv_fetch(math_int64_c_api_hash, "version", 7, 1); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to retrieve C API version for Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_max_version = SvIV(*svp); if ((required_version < math_int64_c_api_min_version) || (required_version > math_int64_c_api_max_version)) { sv_setpvf(ERRSV, "Math::Int64 C API version mismatch. " "The installed module supports versions %d to %d but %d is required", math_int64_c_api_min_version, math_int64_c_api_max_version, required_version); SvSETMAGIC(ERRSV); return 0; } svp = hv_fetch(math_int64_c_api_hash, "SvI64", 5, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'SvI64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_SvI64 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "SvI64OK", 7, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'SvI64OK' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_SvI64OK = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "SvU64", 5, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'SvU64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_SvU64 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "SvU64OK", 7, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'SvU64OK' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_SvU64OK = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "newSVi64", 8, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'newSVi64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_newSVi64 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "newSVu64", 8, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'newSVu64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_newSVu64 = INT2PTR(void *, SvIV(*svp)); svp = hv_fetch(math_int64_c_api_hash, "randU64", 7, 0); if (!svp || !*svp) { sv_setpv(ERRSV, "Unable to fetch pointer 'randU64' C function from Math::Int64"); SvSETMAGIC(ERRSV); return 0; } math_int64_c_api_randU64 = INT2PTR(void *, SvIV(*svp)); return 1; }