/*
* The xlat function
*/
static ssize_t perl_xlat(void *instance, REQUEST *request, char const *fmt, char *out, size_t freespace)
{
rlm_perl_t *inst= (rlm_perl_t *) instance;
char *tmp;
char const *p, *q;
int count;
size_t ret = 0;
STRLEN n_a;
#ifdef USE_ITHREADS
PerlInterpreter *interp;
pthread_mutex_lock(&inst->clone_mutex);
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;
PUSHMARK(SP);
p = fmt;
while ((q = strchr(p, ' '))) {
XPUSHs(sv_2mortal(newSVpv(p, p - q)));
p = q + 1;
}
PUTBACK;
count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
REDEBUG("Exit %s", SvPV(ERRSV,n_a));
(void)POPs;
} else if (count > 0) {
tmp = POPp;
strlcpy(out, tmp, freespace);
ret = strlen(out);
RDEBUG("Len is %zu , out is %s freespace is %zu", ret, out, freespace);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
}
return ret;
}
static POOL_HANDLE *pool_grow (PERL_INST *inst) {
POOL_HANDLE *handle;
time_t now;
if (inst->perl_pool->max_clones == inst->perl_pool->current_clones) {
return NULL;
}
if (inst->perl_pool->detach == yes ) {
return NULL;
}
handle = (POOL_HANDLE *)rad_malloc(sizeof(POOL_HANDLE));
if (!handle) {
radlog(L_ERR,"Could not find free memory for pool. Aborting");
return NULL;
}
handle->prev = NULL;
handle->next = NULL;
handle->status = idle;
handle->clone = rlm_perl_clone(inst->perl);
handle->request_count = 0;
MUTEX_INIT(&handle->lock);
inst->perl_pool->current_clones++;
move2tail(handle, inst);
now = time(NULL);
inst->perl_pool->time_when_last_added = now;
return handle;
}
/*
* 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;
}
/*
* The xlat function
*/
static ssize_t perl_xlat(UNUSED TALLOC_CTX *ctx, char **out, size_t outlen,
void const *mod_inst, UNUSED void const *xlat_inst,
REQUEST *request, char const *fmt)
{
rlm_perl_t *inst;
char *tmp;
char const *p, *q;
int count;
size_t ret = 0;
STRLEN n_a;
memcpy(&inst, &mod_inst, sizeof(inst));
#ifdef USE_ITHREADS
PerlInterpreter *interp;
pthread_mutex_lock(&inst->clone_mutex);
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;
PUSHMARK(SP);
p = q = fmt;
while (*p == ' ') {
p++;
q++;
}
while (*q) {
if (*q == ' ') {
XPUSHs(sv_2mortal(newSVpvn(p, q - p)));
p = q + 1;
/*
* Don't use an empty string
*/
while (*p == ' ') p++;
q = p;
}
q++;
}
/*
* And the last bit.
*/
if (*p) {
XPUSHs(sv_2mortal(newSVpvn(p, strlen(p))));
}
PUTBACK;
count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
REDEBUG("Exit %s", SvPV(ERRSV,n_a));
(void)POPs;
} else if (count > 0) {
tmp = POPp;
strlcpy(*out, tmp, outlen);
ret = strlen(*out);
RDEBUG2("Len is %zu , out is %s freespace is %zu", ret, *out, outlen);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
}
return ret;
}
/*
* 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;
}
/*
* The xlat function
*/
static size_t perl_xlat(void *instance, REQUEST *request, const char *fmt,
char *out, size_t freespace)
{
PERL_INST *inst= (PERL_INST *) instance;
PerlInterpreter *perl;
char params[1024], *ptr, *tmp;
int count;
size_t ret = 0;
STRLEN n_a;
/*
* Do an xlat on the provided string (nice recursive operation).
*/
if (!radius_xlat(params, sizeof(params), fmt, request, NULL, NULL)) {
radlog(L_ERR, "rlm_perl: xlat failed.");
return 0;
}
#ifndef WITH_ITHREADS
perl = inst->perl;
#else
perl = rlm_perl_clone(inst->perl,inst->thread_key);
{
dTHXa(perl);
}
#endif
PERL_SET_CONTEXT(perl);
{
dSP;
ENTER;SAVETMPS;
ptr = strtok(params, " ");
PUSHMARK(SP);
while (ptr != NULL) {
XPUSHs(sv_2mortal(newSVpv(ptr,0)));
ptr = strtok(NULL, " ");
}
PUTBACK;
count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
radlog(L_ERR, "rlm_perl: perl_xlat exit %s\n",
SvPV(ERRSV,n_a));
(void)POPs;
} else if (count > 0) {
tmp = POPp;
strlcpy(out, tmp, freespace);
ret = strlen(out);
radlog(L_DBG,"rlm_perl: Len is %zu , out is %s freespace is %zu",
ret, out, freespace);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
}
return ret;
}
/*
* 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;
}