X-Git-Url: http://www.project-moonshot.org/gitweb/?a=blobdiff_plain;f=src%2Fmodules%2Frlm_perl%2Frlm_perl.c;h=8acb1f09d3f1ea36a5a92a3e821b3d8ef3c26f7b;hb=9960563934a7da222528a1d82224aecc207c8aa8;hp=d75c0a80ceec655bf255dc0fa57767449ab8229e;hpb=0fe78ce2f659dd20e837ffb65d6b998edeac2019;p=freeradius.git diff --git a/src/modules/rlm_perl/rlm_perl.c b/src/modules/rlm_perl/rlm_perl.c index d75c0a8..8acb1f0 100644 --- a/src/modules/rlm_perl/rlm_perl.c +++ b/src/modules/rlm_perl/rlm_perl.c @@ -1,4 +1,4 @@ -/* + /* * rlm_perl.c * * Version: $Id$ @@ -15,22 +15,17 @@ * * 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 + * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA * - * Copyright 2002 The FreeRADIUS server project + * Copyright 2002,2006 The FreeRADIUS server project * Copyright 2002 Boian Jordanov */ -#include "autoconf.h" -#include "libradius.h" - -#include -#include -#include +#include +RCSID("$Id$") -#include "radiusd.h" -#include "modules.h" -#include "conffile.h" +#include +#include #ifdef DEBUG #undef DEBUG @@ -50,42 +45,6 @@ extern char **environ; #endif -static const char rcsid[] = "$Id$"; - -#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. * @@ -107,15 +66,19 @@ typedef struct perl_inst { char *func_checksimul; char *func_detach; char *func_xlat; +#ifdef WITH_PROXY char *func_pre_proxy; char *func_post_proxy; +#endif char *func_post_auth; +#ifdef WITH_COA + char *func_recv_coa; + char *func_send_coa; +#endif char *xlat_name; char *perl_flags; PerlInterpreter *perl; -#ifdef USE_ITHREADS - PERL_POOL *perl_pool; -#endif + pthread_key_t *thread_key; } PERL_INST; /* * A mapping of configuration file names to internal variables. @@ -127,7 +90,7 @@ typedef struct perl_inst { * buffer over-flows. */ static const CONF_PARSER module_config[] = { - { "module", PW_TYPE_STRING_PTR, + { "module", PW_TYPE_FILENAME, offsetof(PERL_INST,module), NULL, "module"}, { "func_authorize", PW_TYPE_STRING_PTR, offsetof(PERL_INST,func_authorize), NULL, "authorize"}, @@ -143,12 +106,20 @@ static const CONF_PARSER module_config[] = { offsetof(PERL_INST,func_detach), NULL, "detach"}, { "func_xlat", PW_TYPE_STRING_PTR, offsetof(PERL_INST,func_xlat), NULL, "xlat"}, +#ifdef WITH_PROXY { "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"}, +#endif { "func_post_auth", PW_TYPE_STRING_PTR, offsetof(PERL_INST,func_post_auth), NULL, "post_auth"}, +#ifdef WITH_COA + { "func_recv_coa", PW_TYPE_STRING_PTR, + offsetof(PERL_INST,func_recv_coa), NULL, "recv_coa"}, + { "func_send_coa", PW_TYPE_STRING_PTR, + offsetof(PERL_INST,func_send_coa), NULL, "send_coa"}, +#endif { "perl_flags", PW_TYPE_STRING_PTR, offsetof(PERL_INST,perl_flags), NULL, NULL}, { "func_start_accounting", PW_TYPE_STRING_PTR, @@ -165,24 +136,6 @@ static const CONF_PARSER module_config[] = { 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) @@ -247,39 +200,15 @@ static void rlm_perl_close_handles(void **handles) } for (i=0; handles[i]; i++) { - radlog(L_DBG, "close 0x%lx\n", (unsigned long)handles[i]); + radlog(L_DBG, "close %p\n", 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); @@ -301,10 +230,6 @@ static void rlm_perl_destruct(PerlInterpreter *perl) perl_destruct(perl); perl_free(perl); - - if (orig_environ) { - environ = orig_environ; - } } static void rlm_destroy_perl(PerlInterpreter *perl) @@ -319,291 +244,40 @@ static void rlm_destroy_perl(PerlInterpreter *perl) rlm_perl_close_handles(handles); } -static void delete_pool_handle(POOL_HANDLE *handle, PERL_INST *inst) +/* Create Key */ +static void rlm_perl_make_key(pthread_key_t *key) { - 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); + pthread_key_create(key, rlm_destroy_perl); } -static void move2tail(POOL_HANDLE *handle, PERL_INST *inst) +static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key) { - 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; - } + PerlInterpreter *interp; + UV clone_flags = 0; - 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) { + PERL_SET_CONTEXT(perl); - POOL_HANDLE *tmp, *tmp2; - int spare, i, t; - time_t now; - /* - * Lock it - */ - MUTEX_LOCK(&inst->perl_pool->mutex); + interp = pthread_getspecific(*key); + if (interp) return interp; - /* - * 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; + interp = perl_clone(perl, clone_flags); + { + dTHXa(interp); } +#if PERL_REVISION >= 5 && PERL_VERSION <8 + call_pv("CLONE",0); +#endif + ptr_table_free(PL_ptr_table); + PL_ptr_table = NULL; - MUTEX_UNLOCK(&handle->lock); - handle->status = idle; - inst->perl_pool->active_clones--; - - spare = inst->perl_pool->current_clones - inst->perl_pool->active_clones; + PERL_SET_CONTEXT(aTHX); + rlm_perl_clear_handles(aTHX); - radlog(L_DBG,"perl_pool total/active/spare [%d/%d/%d]" - , inst->perl_pool->current_clones, inst->perl_pool->active_clones, spare); + pthread_setspecific(*key, interp); - 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; + return interp; } #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) -{ -#ifdef USE_ITHREADS - if ((interp = perl_alloc()) == NULL) { - radlog(L_DBG, "rlm_perl: No memory for allocating new perl !"); - return -1; - } - - perl_construct(interp); - PL_perl_destruct_level = 2; -#endif - return 0; - -} static void xs_init(pTHX) { @@ -644,30 +318,31 @@ static XS(XS_radiusd_radlog) /* * The xlat function */ -static int perl_xlat(void *instance, REQUEST *request, char *fmt, char * out, - size_t freespace, RADIUS_ESCAPE_STRING func) +static size_t 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; + int count; + size_t ret = 0; STRLEN n_a; -#ifndef USE_ITHREADS - perl = inst->perl; -#endif -#ifdef USE_ITHREADS - POOL_HANDLE *handle; - if ((handle = pool_pop(instance)) == NULL) { + /* + * 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; } - perl = handle->clone; - - radlog(L_DBG,"Found a interpetator 0x%lx",(unsigned long) perl); +#ifndef WITH_ITHREADS + perl = inst->perl; +#else + perl = rlm_perl_clone(inst->perl,inst->thread_key); { - dTHXa(perl); + dTHXa(perl); } #endif PERL_SET_CONTEXT(perl); @@ -675,13 +350,6 @@ static int perl_xlat(void *instance, REQUEST *request, char *fmt, char * out, dSP; ENTER;SAVETMPS; - /* - * 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; - } ptr = strtok(params, " "); PUSHMARK(SP); @@ -699,26 +367,21 @@ static int perl_xlat(void *instance, REQUEST *request, char *fmt, char * out, if (SvTRUE(ERRSV)) { radlog(L_ERR, "rlm_perl: perl_xlat exit %s\n", SvPV(ERRSV,n_a)); - return 0; - } - - if (count > 0) { + POPs ; + } else if (count > 0) { tmp = POPp; - ret = strlen(tmp); - strncpy(out,tmp,ret); + strlcpy(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 ; + PUTBACK ; + FREETMPS ; + LEAVE ; } - } -#ifdef USE_ITHREADS - pool_release(handle, instance); -#endif return ret; } /* @@ -741,14 +404,21 @@ 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_config_hv; HV *rad_request_hv; +#ifdef WITH_PROXY HV *rad_request_proxy_hv; HV *rad_request_proxy_reply_hv; +#endif AV *end_AV; - char *embed[4], *xlat_name; + char **embed; + char **envp = NULL; + const char *xlat_name; int exitstatus = 0, argc=0; + embed = rad_malloc(4*(sizeof(char *))); + memset(embed, 0, sizeof(4*(sizeof(char *)))); /* * Set up a storage area for instance data */ @@ -763,8 +433,17 @@ static int perl_instantiate(CONF_SECTION *conf, void **instance) free(inst); return -1; } + + /* + * Create pthread key. This key will be stored in instance + */ - +#ifdef USE_ITHREADS + inst->thread_key = rad_malloc(sizeof(*inst->thread_key)); + memset(inst->thread_key,0,sizeof(*inst->thread_key)); + + rlm_perl_make_key(inst->thread_key); +#endif embed[0] = NULL; if (inst->perl_flags) { embed[1] = inst->perl_flags; @@ -777,8 +456,16 @@ static int perl_instantiate(CONF_SECTION *conf, void **instance) argc = 3; } + PERL_SYS_INIT3(&argc, &embed, &envp); #ifdef USE_ITHREADS - inst->perl = perl_clone(interp ,CLONEf_KEEP_PTR_TABLE); + 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); } @@ -814,15 +501,21 @@ static int perl_instantiate(CONF_SECTION *conf, void **instance) rad_reply_hv = newHV(); rad_check_hv = newHV(); + rad_config_hv = newHV(); rad_request_hv = newHV(); +#ifdef WITH_PROXY rad_request_proxy_hv = newHV(); rad_request_proxy_reply_hv = newHV(); +#endif 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); +#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); +#endif xlat_name = cf_section_name2(conf); if (xlat_name == NULL) @@ -832,13 +525,6 @@ static int perl_instantiate(CONF_SECTION *conf, void **instance) 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; @@ -854,15 +540,19 @@ static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv) { VALUE_PAIR *nvp, *vpa, *vpn; AV *av; + char namebuf[256], *name; char buffer[1024]; - int attr, len; + int attr, vendor, len; hv_undef(rad_hv); nvp = paircopy(vp); while (nvp != NULL) { + name = nvp->name; attr = nvp->attribute; - vpa = paircopy2(nvp,attr); + vendor = nvp->vendor; + vpa = paircopy2(nvp, attr, vendor); + if (vpa->next) { av = newAV(); vpn = vpa; @@ -875,16 +565,23 @@ static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv) hv_store(rad_hv, nvp->name, strlen(nvp->name), newRV_noinc((SV *) av), 0); } else { + if ((vpa->flags.has_tag) && + (vpa->flags.tag != 0)) { + snprintf(namebuf, sizeof(namebuf), "%s:%d", + nvp->name, nvp->flags.tag); + name = namebuf; + } + len = vp_prints_value(buffer, sizeof(buffer), - vpa, FALSE); - hv_store(rad_hv, vpa->name, strlen(vpa->name), - newSVpv(buffer, len), 0); + vpa, FALSE); + hv_store(rad_hv, name, strlen(name), + newSVpv(buffer, len), 0); } pairfree(&vpa); - vpa = nvp; while ((vpa != NULL) && (vpa->attribute == attr)) + vpa = nvp; while ((vpa != NULL) && (vpa->attribute == attr) && (vpa->vendor == vendor)) vpa = vpa->next; - pairdelete(&nvp, attr); + pairdelete(&nvp, attr, vendor); nvp = vpa; } } @@ -895,13 +592,13 @@ static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv) * Value Pair Format * */ -static int pairadd_sv(VALUE_PAIR **vp, char *key, SV *sv) { +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, T_OP_EQ); + vpp = pairmake(key, val, operator); if (vpp != NULL) { pairadd(vp, vpp); radlog(L_DBG, @@ -928,6 +625,7 @@ static int get_hv_content(HV *my_hv, VALUE_PAIR **vp) I32 key_len, len, i, j; int ret=0; + *vp = NULL; 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)) { @@ -935,9 +633,9 @@ static int get_hv_content(HV *my_hv, VALUE_PAIR **vp) len = av_len(av); for (j = 0; j <= len; j++) { av_sv = av_fetch(av, j, 0); - ret = pairadd_sv(vp, key, *av_sv) + ret; + ret = pairadd_sv(vp, key, *av_sv, T_OP_ADD) + ret; } - } else ret = pairadd_sv(vp, key, res_sv) + ret; + } else ret = pairadd_sv(vp, key, res_sv, T_OP_EQ) + ret; } return ret; @@ -958,25 +656,23 @@ static int rlmperl_call(void *instance, REQUEST *request, char *function_name) 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 #ifdef USE_ITHREADS - POOL_HANDLE *handle; - - if ((handle = pool_pop(instance)) == NULL) { - return RLM_MODULE_FAIL; - } + PerlInterpreter *interp; - radlog(L_DBG,"found interpetator at address 0x%lx",(unsigned long) handle->clone); + interp = rlm_perl_clone(inst->perl,inst->thread_key); { - dTHXa(handle->clone); - PERL_SET_CONTEXT(handle->clone); + dTHXa(interp); + PERL_SET_CONTEXT(interp); } #else PERL_SET_CONTEXT(inst->perl); - radlog(L_DBG,"Using perl at 0x%lx",(unsigned long) inst->perl); #endif { dSP; @@ -995,15 +691,19 @@ static int rlmperl_call(void *instance, REQUEST *request, char *function_name) 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); +#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); - +#endif 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); - + perl_store_vps(request->config_items, rad_config_hv); + +#ifdef WITH_PROXY if (request->proxy != NULL) { perl_store_vps(request->proxy->vps, rad_request_proxy_hv); } else { @@ -1014,10 +714,8 @@ static int rlmperl_call(void *instance, REQUEST *request, char *function_name) perl_store_vps(request->proxy_reply->vps, rad_request_proxy_reply_hv); } else { hv_undef(rad_request_proxy_reply_hv); - } - - vp = NULL; - + } +#endif PUSHMARK(SP); /* @@ -1032,6 +730,13 @@ static int rlmperl_call(void *instance, REQUEST *request, char *function_name) 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) { @@ -1039,37 +744,58 @@ static int rlmperl_call(void *instance, REQUEST *request, char *function_name) } } + PUTBACK; FREETMPS; LEAVE; - 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)); + vp = NULL; + if ((get_hv_content(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); + request->password = pairfind(request->packet->vps, + PW_USER_PASSWORD, 0); + if (!request->password) + request->password = pairfind(request->packet->vps, + PW_CHAP_PASSWORD, 0); } if ((get_hv_content(rad_reply_hv, &vp)) > 0 ) { - pairmove(&request->reply->vps, &vp); - pairfree(&vp); + pairfree(&request->reply->vps); + request->reply->vps = vp; + vp = NULL; } if ((get_hv_content(rad_check_hv, &vp)) > 0 ) { - pairmove(&request->config_items, &vp); - pairfree(&vp); + pairfree(&request->config_items); + request->config_items = vp; + vp = NULL; } - - 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 WITH_PROXY + if (request->proxy && + (get_hv_content(rad_request_proxy_hv, &vp) > 0)) { + pairfree(&request->proxy->vps); + request->proxy->vps = vp; + vp = NULL; } + + if (request->proxy_reply && + (get_hv_content(rad_request_proxy_reply_hv, &vp) > 0)) { + pairfree(&request->proxy_reply->vps); + request->proxy_reply->vps = vp; + vp = NULL; } -#ifdef USE_ITHREADS - pool_release(handle,instance); - radlog(L_DBG,"Unreserve perl at address 0x%lx", (unsigned long) handle->clone); #endif + } return exitstatus; } @@ -1109,8 +835,8 @@ 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; + if ((pair = pairfind(request->packet->vps, PW_ACCT_STATUS_TYPE, 0)) != NULL) { + acctstatustype = pair->vp_integer; } else { radlog(L_ERR, "Invalid Accounting Packet"); return RLM_MODULE_INVALID; @@ -1153,6 +879,8 @@ static int perl_checksimul(void *instance, REQUEST *request) return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_checksimul); } + +#ifdef WITH_PROXY /* * Pre-Proxy request */ @@ -1169,6 +897,8 @@ static int perl_post_proxy(void *instance, REQUEST *request) return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_post_proxy); } +#endif + /* * Pre-Auth request */ @@ -1177,32 +907,36 @@ static int perl_post_auth(void *instance, REQUEST *request) return rlmperl_call(instance, request, ((PERL_INST *)instance)->func_post_auth); } +#ifdef WITH_COA +/* + * Recv CoA request + */ +static int perl_recv_coa(void *instance, REQUEST *request) +{ + return rlmperl_call(instance, request, + ((PERL_INST *)instance)->func_recv_coa); +} +/* + * Send CoA request + */ +static int perl_send_coa(void *instance, REQUEST *request) +{ + return rlmperl_call(instance, request, + ((PERL_INST *)instance)->func_send_coa); +} +#endif /* * 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) { + int exitstatus = 0, count = 0; - 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 - */ +#if 0 + /* + * FIXME: Call this in the destruct function? + */ { dTHXa(handle->clone); PERL_SET_CONTEXT(handle->clone); @@ -1224,26 +958,12 @@ static int perl_detach(void *instance) 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); - } +#endif - { + if (inst->func_detach) { dTHXa(inst->perl); -#endif /* USE_ITHREADS */ PERL_SET_CONTEXT(inst->perl); { dSP; ENTER; SAVETMPS; @@ -1262,37 +982,24 @@ static int perl_detach(void *instance) 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 + PERL_SYS_TERM(); free(inst); return exitstatus; } + + /* * The module name should be the only globally exported symbol. * That is, everything else should be 'static'. @@ -1303,24 +1010,31 @@ static int perl_detach(void *instance) * is single-threaded. */ module_t rlm_perl = { + RLM_MODULE_INIT, "perl", /* Name */ #ifdef USE_ITHREADS RLM_TYPE_THREAD_SAFE, /* type */ #else RLM_TYPE_THREAD_UNSAFE, #endif - perl_init, /* initialization */ perl_instantiate, /* instantiation */ + perl_detach, /* detach */ { - perl_authenticate, - perl_authorize, - perl_preacct, - perl_accounting, + perl_authenticate, /* authenticate */ + perl_authorize, /* authorize */ + perl_preacct, /* preacct */ + perl_accounting, /* accounting */ perl_checksimul, /* check simul */ - perl_pre_proxy, /* pre-proxy */ +#ifdef WITH_PROXY + perl_pre_proxy, /* pre-proxy */ perl_post_proxy, /* post-proxy */ - perl_post_auth /* post-auth */ +#else + NULL, NULL, +#endif + perl_post_auth /* post-auth */ +#ifdef WITH_COA + , perl_recv_coa, + perl_send_coa +#endif }, - perl_detach, /* detach */ - NULL, /* destroy */ };