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;
}
