/* * rlm_perl.c * * Version: $Id: rlm_perl.c,v 1.13.4.8 2007/01/26 09:38:38 aland Exp $ * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * Copyright 2002 The FreeRADIUS server project * Copyright 2002 Boian Jordanov */ #include "autoconf.h" #include "libradius.h" #include #include #include #include "radiusd.h" #include "modules.h" #include "conffile.h" #ifdef DEBUG #undef DEBUG #endif #ifdef INADDR_ANY #undef INADDR_ANY #endif #include #include #include #include #include #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 /* * Pool of Perl's clones (genetically cloned) ;) * */ 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 /* * Define a structure for our module configuration. * * These variables do not need to be in a structure, but it's * a lot cleaner to do so, and a pointer to the structure can * be used as the instance handle. */ typedef struct perl_inst { /* Name of the perl module */ char *module; /* Name of the functions for each module method */ 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; /* * A mapping of configuration file names to internal variables. * * Note that the string is dynamically allocated, so it MUST * be freed. When the configuration file parse re-reads the string, * it free's the old one, and strdup's the new one, placing the pointer * to the strdup'd string into 'config.string'. This gets around * buffer over-flows. */ 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 } /* end the list */ }; /* * man perlembed */ EXTERN_C void boot_DynaLoader(pTHX_ CV* cv); #ifdef USE_ITHREADS /* * We use one perl to clone from it i.e. main boss * We clone it for every instance if we have perl * with -Duseithreads compiled in */ 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 } /* end the list */ }; #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); } /* * FIXME: This shouldn't happen * */ 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; /* * Lock the pool and be fast other thread maybe * waiting for us to finish */ 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++; /* * Hurry Up */ 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; /* * Lock it */ MUTEX_LOCK(&inst->perl_pool->mutex); /* * If detach is set then just release the 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;iperl_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 the clone have reached max_request_per_clone clean it. */ 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); } } /* * Hurry Up :) */ 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); /* * Read The Config * */ 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 /* * Do any per-module initialization. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * Try to avoid putting too much stuff in here - it's better to * do it in instantiate() where it is not global. * I use one global interpetator to make things more fastest for * Threading env I clone new perl from this interp. */ static int perl_init(void) { return 0; } static void xs_init(pTHX) { char *file = __FILE__; /* DynaLoader is a special case */ newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file); } /* * * This is wrapper for radlog * Now users can call radiusd::radlog(level,msg) wich is the same * calling radlog from C code. * Boyan */ 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); /* * Because 'msg' is a 'char *', we don't want '%s', etc. * in it to give us printf-style vulnerabilities. */ radlog(level, "rlm_perl: %s", msg); } XSRETURN_NO; } /* * The xlat function */ 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; /* * Do an xlat on the provided string (nice recursive operation). */ 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; } /* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Boyan: * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ 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; /* * Set up a storage area for instance data */ inst = rad_malloc(sizeof(PERL_INST)); memset(inst, 0, sizeof(PERL_INST)); /* * If the configuration parameters can't be parsed, then * fail. */ 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; } /* * get the vps and put them in perl hash * If one VP have multiple values it is added as array_ref * Example for this is Cisco-AVPair that holds multiple values. * Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'} */ 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; } } /* * * Verify that a Perl SV is a string and save it in FreeRadius * Value Pair Format * */ 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; } /* * Boyan : * Gets the content from hashes */ 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; } /* * 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; } /* * Find the named user in this modules database. Create the set * of attribute-value pairs to check and reply with for this user * from the database. The authentication code only needs to check * the password, the rest is done here. */ static int perl_authorize(void *instance, REQUEST *request) { return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_authorize); } /* * Authenticate the user with the given password. */ static int perl_authenticate(void *instance, REQUEST *request) { return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_authenticate); } /* * Massage the request before recording it or proxying it */ static int perl_preacct(void *instance, REQUEST *request) { return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_preacct); } /* * Write accounting information to this modules database. */ 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); } } /* * Check for simultaneouse-use */ static int perl_checksimul(void *instance, REQUEST *request) { return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_checksimul); } /* * Pre-Proxy request */ static int perl_pre_proxy(void *instance, REQUEST *request) { return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_pre_proxy); } /* * Post-Proxy request */ static int perl_post_proxy(void *instance, REQUEST *request) { return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_post_proxy); } /* * Pre-Auth request */ static int perl_post_auth(void *instance, REQUEST *request) { return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_post_auth); } /* * Detach a instance give a chance to a module to make some internal setup ... */ 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); /* * Wait until clone becomes idle */ MUTEX_LOCK(&handle->lock); /* * Give a clones chance to run detach function */ { 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; /* * FIXME: bug in perl * */ 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); } /* * Free handles */ 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 /* USE_ITHREADS */ 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; } /* * The module name should be the only globally exported symbol. * That is, everything else should be 'static'. * * If the module needs to temporarily modify it's instantiation * data, the type should be changed to RLM_TYPE_THREAD_UNSAFE. * The server will then take care of ensuring that the module * is single-threaded. */ module_t rlm_perl = { "perl", /* Name */ #ifdef USE_ITHREADS RLM_TYPE_THREAD_SAFE, /* type */ #else RLM_TYPE_THREAD_UNSAFE, #endif perl_init, /* initialization */ perl_instantiate, /* instantiation */ { perl_authenticate, perl_authorize, perl_preacct, perl_accounting, perl_checksimul, /* check simul */ perl_pre_proxy, /* pre-proxy */ perl_post_proxy, /* post-proxy */ perl_post_auth /* post-auth */ }, perl_detach, /* detach */ NULL, /* destroy */ };