/*
* 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;
}
/*
* 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_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;
}
/*
* 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;
}