void Perl_set_version(pTHX_ const char *name, STRLEN nlen, const char *strval, STRLEN plen, NV nvval) { SV* ver = GvSV(gv_add_by_type(gv_fetchpvn(name, nlen, GV_ADD, SVt_PVNV), SVt_PVNV)); PERL_ARGS_ASSERT_SET_VERSION; SvREADONLY_off(ver); SvUPGRADE(ver, SVt_PVNV); SvPVX(ver) = SvGROW(ver, plen+1); Move(strval, SvPVX(ver), plen, char); SvCUR_set(ver, plen); SvNVX(ver) = nvval; /* not the PROTECT bit */ SvFLAGS(ver) |= (SVf_NOK|SVp_NOK|SVf_POK|SVp_POK|SVf_READONLY); }
/* * 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; }
/* helper for the default modify handler for builtin attributes */ static int modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs) { SV *attr; int nret; for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) { STRLEN len; const char *name = SvPV_const(attr, len); const bool negated = (*name == '-'); HV *typestash; if (negated) { name++; len--; } switch (SvTYPE(sv)) { case SVt_PVCV: switch ((int)len) { case 4: if (memEQ(name, "pure", 4)) { if (negated) Perl_croak(aTHX_ "Illegal :-pure attribute"); CvPURE_on(sv); goto next_attr; } break; case 5: if (memEQ(name, "const", 5)) { if (negated) CvCONST_off(sv); else { #ifndef USE_CPERL const bool warn = (!CvANON(sv) || CvCLONED(sv)) && !CvCONST(sv); CvCONST_on(sv); if (warn) break; #else CvCONST_on(sv); #endif } goto next_attr; } break; case 6: switch (name[3]) { case 'l': if (memEQ(name, "lvalue", 6)) { bool warn = !CvISXSUB(MUTABLE_CV(sv)) && CvROOT(MUTABLE_CV(sv)) && !CvLVALUE(MUTABLE_CV(sv)) != negated; if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE; else CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE; if (warn) break; goto next_attr; } break; case 'h': if (memEQ(name, "method", 6)) { if (negated) CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD; else CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD; goto next_attr; } break; } break; default: if (len > 10 && memEQ(name, "prototype(", 10)) { SV * proto = newSVpvn(name+10,len-11); HEK *const hek = CvNAME_HEK((CV *)sv); SV *subname; if (name[len-1] != ')') Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list"); if (hek) subname = sv_2mortal(newSVhek(hek)); else subname=(SV *)CvGV((const CV *)sv); if (ckWARN(WARN_ILLEGALPROTO)) Perl_validate_proto(aTHX_ subname, proto, TRUE); Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv, (const GV *)subname, name+10, len-11, SvUTF8(attr)); sv_setpvn(MUTABLE_SV(sv), name+10, len-11); if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv)); goto next_attr; } break; } if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) { CvTYPED_on(sv); CvTYPE_set((CV*)sv, typestash); continue; } break; case SVt_IV: case SVt_PVIV: case SVt_PVMG: if (memEQ(name, "unsigned", 8) && (SvIOK(sv) || SvUOK(sv))) { if (negated) /* :-unsigned alias for :signed */ SvIsUV_off(sv); else SvIsUV_on(sv); continue; } /* fallthru - all other data types */ default: if (memEQ(name, "const", 5) && !(SvFLAGS(sv) & SVf_PROTECT)) { if (negated) SvREADONLY_off(sv); else SvREADONLY_on(sv); continue; } if (memEQs(name, len, "shared")) { if (negated) Perl_croak(aTHX_ "A variable may not be unshared"); SvSHARE(sv); continue; } break; } /* anything recognized had a 'continue' above */ *retlist++ = attr; nret++; next_attr: ; } return nret; }