#include "autoconf.h"
#include "libradius.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include "radiusd.h"
#include "modules.h"
#include "conffile.h"
#ifdef DEBUG
#undef DEBUG
#endif
#ifdef INADDR_ANY
#undef INADDR_ANY
#endif
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include <dlfcn.h>
#include <semaphore.h>
#ifdef __APPLE__
extern char **environ;
#endif
static const char rcsid[] = "$Id: rlm_perl.c,v 1.13.4.8 2007/01/26 09:38:38 aland Exp $";
#ifdef USE_ITHREADS
typedef struct pool_handle {
struct pool_handle *next;
struct pool_handle *prev;
enum {busy, idle} status;
unsigned int request_count;
PerlInterpreter *clone;
perl_mutex lock;
} POOL_HANDLE;
typedef struct PERL_POOL {
POOL_HANDLE *head;
POOL_HANDLE *tail;
int current_clones;
int active_clones;
int max_clones;
int start_clones;
int min_spare_clones;
int max_spare_clones;
int max_request_per_clone;
int cleanup_delay;
enum {yes,no} detach;
perl_mutex mutex;
time_t time_when_last_added;
} PERL_POOL;
#endif
typedef struct perl_inst {
char *module;
char *func_authorize;
char *func_authenticate;
char *func_accounting;
char *func_start_accounting;
char *func_stop_accounting;
char *func_preacct;
char *func_checksimul;
char *func_detach;
char *func_xlat;
char *func_pre_proxy;
char *func_post_proxy;
char *func_post_auth;
char *xlat_name;
char *perl_flags;
PerlInterpreter *perl;
#ifdef USE_ITHREADS
PERL_POOL *perl_pool;
#endif
} PERL_INST;
static const CONF_PARSER module_config[] = {
{ "module", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,module), NULL, "module"},
{ "func_authorize", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_authorize), NULL, "authorize"},
{ "func_authenticate", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_authenticate), NULL, "authenticate"},
{ "func_accounting", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_accounting), NULL, "accounting"},
{ "func_preacct", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_preacct), NULL, "preacct"},
{ "func_checksimul", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_checksimul), NULL, "checksimul"},
{ "func_detach", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_detach), NULL, "detach"},
{ "func_xlat", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_xlat), NULL, "xlat"},
{ "func_pre_proxy", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_pre_proxy), NULL, "pre_proxy"},
{ "func_post_proxy", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_post_proxy), NULL, "post_proxy"},
{ "func_post_auth", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_post_auth), NULL, "post_auth"},
{ "perl_flags", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,perl_flags), NULL, NULL},
{ "func_start_accounting", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_start_accounting), NULL, NULL},
{ "func_stop_accounting", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_stop_accounting), NULL, NULL},
{ NULL, -1, 0, NULL, NULL }
};
EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
#ifdef USE_ITHREADS
static PerlInterpreter *interp;
static const CONF_PARSER pool_conf[] = {
{ "max_clones", PW_TYPE_INTEGER, offsetof(PERL_POOL, max_clones), NULL, "32"},
{ "start_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL, start_clones), NULL, "5"},
{ "min_spare_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL, min_spare_clones),NULL, "3"},
{ "max_spare_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL,max_spare_clones),NULL, "3"},
{ "cleanup_delay",PW_TYPE_INTEGER, offsetof(PERL_POOL,cleanup_delay),NULL, "5"},
{ "max_request_per_clone",PW_TYPE_INTEGER, offsetof(PERL_POOL,max_request_per_clone),NULL, "0"},
{ NULL, -1, 0, NULL, NULL }
};
#define dl_librefs "DynaLoader::dl_librefs"
#define dl_modules "DynaLoader::dl_modules"
static void rlm_perl_clear_handles(pTHX)
{
AV *librefs = get_av(dl_librefs, FALSE);
if (librefs) {
av_clear(librefs);
}
}
static void **rlm_perl_get_handles(pTHX)
{
I32 i;
AV *librefs = get_av(dl_librefs, FALSE);
AV *modules = get_av(dl_modules, FALSE);
void **handles;
if (!librefs) {
radlog(L_ERR,
"Could not get @%s for unloading.\n",
dl_librefs);
return NULL;
}
if (!(AvFILL(librefs) >= 0)) {
return NULL;
}
handles = (void **)rad_malloc(sizeof(void *) * (AvFILL(librefs)+2));
for (i=0; i<=AvFILL(librefs); i++) {
void *handle;
SV *handle_sv = *av_fetch(librefs, i, FALSE);
if(!handle_sv) {
radlog(L_ERR,
"Could not fetch $%s[%d]!\n",
dl_librefs, (int)i);
continue;
}
handle = (void *)SvIV(handle_sv);
if (handle) {
handles[i] = handle;
}
}
av_clear(modules);
av_clear(librefs);
handles[i] = (void *)0;
return handles;
}
static void rlm_perl_close_handles(void **handles)
{
int i;
if (!handles) {
return;
}
for (i=0; handles[i]; i++) {
radlog(L_DBG, "close 0x%lx\n", (unsigned long)handles[i]);
dlclose(handles[i]);
}
free(handles);
}
static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl)
{
PerlInterpreter *clone;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
clone = perl_clone(perl, clone_flags);
{
dTHXa(clone);
}
#if PERL_REVISION >= 5 && PERL_VERSION <8
call_pv("CLONE",0);
#endif
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
return clone;
}
static void rlm_perl_destruct(PerlInterpreter *perl)
{
char **orig_environ = NULL;
dTHXa(perl);
PERL_SET_CONTEXT(perl);
PL_perl_destruct_level = 2;
PL_origenviron = environ;
{
dTHXa(perl);
}
while (PL_scopestack_ix > 1 ){
LEAVE;
}
perl_destruct(perl);
perl_free(perl);
if (orig_environ) {
environ = orig_environ;
}
}
static void rlm_destroy_perl(PerlInterpreter *perl)
{
void **handles;
dTHXa(perl);
PERL_SET_CONTEXT(perl);
handles = rlm_perl_get_handles(aTHX);
rlm_perl_destruct(perl);
rlm_perl_close_handles(handles);
}
static void delete_pool_handle(POOL_HANDLE *handle, PERL_INST *inst)
{
POOL_HANDLE *prev;
POOL_HANDLE *next;
prev = handle->prev;
next = handle->next;
if (prev == NULL) {
inst->perl_pool->head = next;
} else {
prev->next = next;
}
if (next == NULL) {
inst->perl_pool->tail = prev;
} else {
next->prev = prev;
}
inst->perl_pool->current_clones--;
MUTEX_DESTROY(&handle->lock);
free(handle);
}
static void move2tail(POOL_HANDLE *handle, PERL_INST *inst)
{
POOL_HANDLE *prev;
POOL_HANDLE *next;
if (inst->perl_pool->head == NULL) {
handle->prev = NULL;
handle->next = NULL;
inst->perl_pool->head = handle;
inst->perl_pool->tail = handle;
return;
}
if (inst->perl_pool->tail == handle) {
return;
}
prev = handle->prev;
next = handle->next;
if ((next != NULL) ||
(prev != NULL)) {
if (next == NULL) {
return;
}
if (prev == NULL) {
inst->perl_pool->head = next;
next->prev = NULL;
} else {
prev->next = next;
next->prev = prev;
}
}
handle->next = NULL;
prev = inst->perl_pool->tail;
inst->perl_pool->tail = handle;
handle->prev = prev;
prev->next = handle;
}
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;
}
static POOL_HANDLE *pool_pop(PERL_INST *inst)
{
POOL_HANDLE *handle;
POOL_HANDLE *found;
POOL_HANDLE *tmp;
MUTEX_LOCK(&inst->perl_pool->mutex);
found = NULL;
for (handle = inst->perl_pool->head; handle ; handle = tmp) {
tmp = handle->next;
if (handle->status == idle){
found = handle;
break;
}
}
if (found == NULL) {
if (inst->perl_pool->current_clones < inst->perl_pool->max_clones ) {
found = pool_grow(inst);
if (found == NULL) {
radlog(L_ERR,"Cannot grow pool returning");
MUTEX_UNLOCK(&inst->perl_pool->mutex);
return NULL;
}
} else {
radlog(L_ERR,"rlm_perl:: reached maximum clones %d cannot grow",
inst->perl_pool->current_clones);
MUTEX_UNLOCK(&inst->perl_pool->mutex);
return NULL;
}
}
move2tail(found, inst);
found->status = busy;
MUTEX_LOCK(&found->lock);
inst->perl_pool->active_clones++;
found->request_count++;
MUTEX_UNLOCK(&inst->perl_pool->mutex);
radlog(L_DBG,"perl_pool: item 0x%lx asigned new request. Handled so far: %d",
(unsigned long) found->clone, found->request_count);
return found;
}
static int pool_release(POOL_HANDLE *handle, PERL_INST *inst) {
POOL_HANDLE *tmp, *tmp2;
int spare, i, t;
time_t now;
MUTEX_LOCK(&inst->perl_pool->mutex);
if (inst->perl_pool->detach == yes ) {
handle->status = idle;
MUTEX_UNLOCK(&handle->lock);
MUTEX_UNLOCK(&inst->perl_pool->mutex);
return 0;
}
MUTEX_UNLOCK(&handle->lock);
handle->status = idle;
inst->perl_pool->active_clones--;
spare = inst->perl_pool->current_clones - inst->perl_pool->active_clones;
radlog(L_DBG,"perl_pool total/active/spare [%d/%d/%d]"
, inst->perl_pool->current_clones, inst->perl_pool->active_clones, spare);
if (spare < inst->perl_pool->min_spare_clones) {
t = inst->perl_pool->min_spare_clones - spare;
for (i=0;i<t; i++) {
if ((tmp = pool_grow(inst)) == NULL) {
MUTEX_UNLOCK(&inst->perl_pool->mutex);
return -1;
}
}
MUTEX_UNLOCK(&inst->perl_pool->mutex);
return 0;
}
now = time(NULL);
if ((now - inst->perl_pool->time_when_last_added) < inst->perl_pool->cleanup_delay) {
MUTEX_UNLOCK(&inst->perl_pool->mutex);
return 0;
}
if (spare > inst->perl_pool->max_spare_clones) {
spare -= inst->perl_pool->max_spare_clones;
for (tmp = inst->perl_pool->head; (tmp !=NULL ) && (spare > 0) ; tmp = tmp2) {
tmp2 = tmp->next;
if(tmp->status == idle) {
rlm_destroy_perl(tmp->clone);
delete_pool_handle(tmp,inst);
spare--;
break;
}
}
}
if (inst->perl_pool->max_request_per_clone > 0 ) {
if (handle->request_count > inst->perl_pool->max_request_per_clone) {
rlm_destroy_perl(handle->clone);
delete_pool_handle(handle,inst);
}
}
MUTEX_UNLOCK(&inst->perl_pool->mutex);
return 0;
}
static int init_pool (CONF_SECTION *conf, PERL_INST *inst) {
POOL_HANDLE *handle;
int t;
PERL_POOL *pool;
pool = rad_malloc(sizeof(PERL_POOL));
memset(pool,0,sizeof(PERL_POOL));
inst->perl_pool = pool;
MUTEX_INIT(&pool->mutex);
cf_section_parse(conf,pool,pool_conf);
inst->perl_pool = pool;
inst->perl_pool->detach = no;
for(t = 0;t < inst->perl_pool->start_clones ;t++){
if ((handle = pool_grow(inst)) == NULL) {
return -1;
}
}
return 1;
}
#endif
static int perl_init(void)
{
return 0;
}
static void xs_init(pTHX)
{
char *file = __FILE__;
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
}
static XS(XS_radiusd_radlog)
{
dXSARGS;
if (items !=2)
croak("Usage: radiusd::radlog(level, message)");
{
int level;
char *msg;
level = (int) SvIV(ST(0));
msg = (char *) SvPV(ST(1), PL_na);
radlog(level, "rlm_perl: %s", msg);
}
XSRETURN_NO;
}
static int perl_xlat(void *instance, REQUEST *request, char *fmt, char * out,
size_t freespace, RADIUS_ESCAPE_STRING func)
{
PERL_INST *inst= (PERL_INST *) instance;
PerlInterpreter *perl;
char params[1024], *ptr, *tmp;
int count, ret=0;
STRLEN n_a;
if (!radius_xlat(params, sizeof(params), fmt, request, func)) {
radlog(L_ERR, "rlm_perl: xlat failed.");
return 0;
}
#ifndef USE_ITHREADS
perl = inst->perl;
#endif
#ifdef USE_ITHREADS
POOL_HANDLE *handle;
if ((handle = pool_pop(instance)) == NULL) {
return 0;
}
perl = handle->clone;
radlog(L_DBG,"Found a interpetator 0x%lx",(unsigned long) perl);
{
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));
POPs ;
} else if (count > 0) {
tmp = POPp;
strNcpy(out,tmp,freespace);
ret = strlen(out);
radlog(L_DBG,"rlm_perl: Len is %d , out is %s freespace is %d",
ret, out,freespace);
}
PUTBACK ;
FREETMPS ;
LEAVE ;
}
#ifdef USE_ITHREADS
pool_release(handle, instance);
#endif
return ret;
}
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;
inst = rad_malloc(sizeof(PERL_INST));
memset(inst, 0, sizeof(PERL_INST));
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;
}
static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv)
{
VALUE_PAIR *nvp, *vpa, *vpn;
AV *av;
char buffer[1024];
int attr, len;
hv_undef(rad_hv);
nvp = paircopy(vp);
while (nvp != NULL) {
attr = nvp->attribute;
vpa = paircopy2(nvp,attr);
if (vpa->next) {
av = newAV();
vpn = vpa;
while (vpn) {
len = vp_prints_value(buffer, sizeof(buffer),
vpn, FALSE);
av_push(av, newSVpv(buffer, len));
vpn = vpn->next;
}
hv_store(rad_hv, nvp->name, strlen(nvp->name),
newRV_noinc((SV *) av), 0);
} else {
len = vp_prints_value(buffer, sizeof(buffer),
vpa, FALSE);
hv_store(rad_hv, vpa->name, strlen(vpa->name),
newSVpv(buffer, len), 0);
}
pairfree(&vpa);
vpa = nvp; while ((vpa != NULL) && (vpa->attribute == attr))
vpa = vpa->next;
pairdelete(&nvp, attr);
nvp = vpa;
}
}
static int pairadd_sv(VALUE_PAIR **vp, char *key, SV *sv, int operator) {
char *val;
VALUE_PAIR *vpp;
if (SvOK(sv)) {
val = SvPV_nolen(sv);
vpp = pairmake(key, val, operator);
if (vpp != NULL) {
pairadd(vp, vpp);
radlog(L_DBG,
"rlm_perl: Added pair %s = %s", key, val);
return 1;
} else {
radlog(L_DBG,
"rlm_perl: ERROR: Failed to create pair %s = %s",
key, val);
}
}
return 0;
}
static int get_hv_content(HV *my_hv, VALUE_PAIR **vp)
{
SV *res_sv, **av_sv;
AV *av;
char *key;
I32 key_len, len, i, j;
int ret=0;
for (i = hv_iterinit(my_hv); i > 0; i--) {
res_sv = hv_iternextsv(my_hv,&key,&key_len);
if (SvROK(res_sv) && (SvTYPE(SvRV(res_sv)) == SVt_PVAV)) {
av = (AV*)SvRV(res_sv);
len = av_len(av);
for (j = 0; j <= len; j++) {
av_sv = av_fetch(av, j, 0);
ret = pairadd_sv(vp, key, *av_sv, T_OP_ADD) + ret;
}
} else ret = pairadd_sv(vp, key, res_sv, T_OP_EQ) + ret;
}
return ret;
}
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;
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);
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;
}
static int perl_authorize(void *instance, REQUEST *request)
{
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_authorize);
}
static int perl_authenticate(void *instance, REQUEST *request)
{
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_authenticate);
}
static int perl_preacct(void *instance, REQUEST *request)
{
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_preacct);
}
static int perl_accounting(void *instance, REQUEST *request)
{
VALUE_PAIR *pair;
int acctstatustype=0;
if ((pair = pairfind(request->packet->vps, PW_ACCT_STATUS_TYPE)) != NULL) {
acctstatustype = pair->lvalue;
} else {
radlog(L_ERR, "Invalid Accounting Packet");
return RLM_MODULE_INVALID;
}
switch (acctstatustype) {
case PW_STATUS_START:
if (((PERL_INST *)instance)->func_start_accounting) {
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_start_accounting);
} else {
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_accounting);
}
break;
case PW_STATUS_STOP:
if (((PERL_INST *)instance)->func_stop_accounting) {
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_stop_accounting);
} else {
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_accounting);
}
break;
default:
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_accounting);
}
}
static int perl_checksimul(void *instance, REQUEST *request)
{
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_checksimul);
}
static int perl_pre_proxy(void *instance, REQUEST *request)
{
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_pre_proxy);
}
static int perl_post_proxy(void *instance, REQUEST *request)
{
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_post_proxy);
}
static int perl_post_auth(void *instance, REQUEST *request)
{
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_post_auth);
}
static int perl_detach(void *instance)
{
PERL_INST *inst = (PERL_INST *) instance;
int exitstatus=0,count=0;
#ifdef USE_ITHREADS
POOL_HANDLE *handle, *tmp, *tmp2;
MUTEX_LOCK(&inst->perl_pool->mutex);
inst->perl_pool->detach = yes;
MUTEX_UNLOCK(&inst->perl_pool->mutex);
for (handle = inst->perl_pool->head; handle != NULL; handle = handle->next) {
radlog(L_DBG,"Detach perl 0x%lx", (unsigned long) handle->clone);
MUTEX_LOCK(&handle->lock);
{
dTHXa(handle->clone);
PERL_SET_CONTEXT(handle->clone);
{
dSP; ENTER; SAVETMPS; PUSHMARK(SP);
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
radlog(L_DBG,"detach at 0x%lx returned status %d",
(unsigned long) handle->clone, exitstatus);
}
}
MUTEX_UNLOCK(&handle->lock);
}
for (tmp = inst->perl_pool->head; tmp !=NULL ; tmp = tmp2) {
tmp2 = tmp->next;
radlog(L_DBG,"rlm_perl:: Destroy perl");
rlm_perl_destruct(tmp->clone);
delete_pool_handle(tmp,inst);
}
{
dTHXa(inst->perl);
#endif
PERL_SET_CONTEXT(inst->perl);
{
dSP; ENTER; SAVETMPS;
PUSHMARK(SP);
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
}
#ifdef USE_ITHREADS
}
#endif
xlat_unregister(inst->xlat_name, perl_xlat);
free(inst->xlat_name);
if (inst->func_authorize) free(inst->func_authorize);
if (inst->func_authenticate) free(inst->func_authenticate);
if (inst->func_accounting) free(inst->func_accounting);
if (inst->func_preacct) free(inst->func_preacct);
if (inst->func_checksimul) free(inst->func_checksimul);
if (inst->func_pre_proxy) free(inst->func_pre_proxy);
if (inst->func_post_proxy) free(inst->func_post_proxy);
if (inst->func_post_auth) free(inst->func_post_auth);
if (inst->func_detach) free(inst->func_detach);
#ifdef USE_ITHREADS
free(inst->perl_pool->head);
free(inst->perl_pool->tail);
MUTEX_DESTROY(&inst->perl_pool->mutex);
free(inst->perl_pool);
rlm_perl_destruct(inst->perl);
#else
perl_destruct(inst->perl);
perl_free(inst->perl);
#endif
free(inst);
return exitstatus;
}
module_t rlm_perl = {
"perl",
#ifdef USE_ITHREADS
RLM_TYPE_THREAD_SAFE,
#else
RLM_TYPE_THREAD_UNSAFE,
#endif
perl_init,
perl_instantiate,
{
perl_authenticate,
perl_authorize,
perl_preacct,
perl_accounting,
perl_checksimul,
perl_pre_proxy,
perl_post_proxy,
perl_post_auth
},
perl_detach,
NULL,
};