-/*
+ /*
* rlm_perl.c
*
* Version: $Id$
*
* 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 <bjordanov@orbitel.bg>
*/
-#include "autoconf.h"
-#include "libradius.h"
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
+#include <freeradius-devel/ident.h>
+RCSID("$Id$")
-#include "radiusd.h"
-#include "modules.h"
-#include "conffile.h"
+#include <freeradius-devel/radiusd.h>
+#include <freeradius-devel/modules.h>
#ifdef DEBUG
#undef DEBUG
#undef INADDR_ANY
#endif
-#ifdef INADDR_NONE
-#undef INADDR_NONE
-#endif
-
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include <dlfcn.h>
#include <semaphore.h>
-static const char rcsid[] = "$Id$";
-
+#ifdef __APPLE__
+extern char **environ;
+#endif
/*
* Define a structure for our module configuration.
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;
+ pthread_key_t *thread_key;
} PERL_INST;
/*
* A mapping of configuration file names to internal variables.
* to the strdup'd string into 'config.string'. This gets around
* buffer over-flows.
*/
-static CONF_PARSER module_config[] = {
- { "module", PW_TYPE_STRING_PTR,
+static const CONF_PARSER module_config[] = {
+ { "module", PW_TYPE_FILENAME,
offsetof(PERL_INST,module), NULL, "module"},
{ "func_authorize", PW_TYPE_STRING_PTR,
offsetof(PERL_INST,func_authorize), NULL, "authorize"},
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,
*/
EXTERN_C void boot_DynaLoader(pTHX_ CV* cv);
-/*
- * We share one perl interpreter among all of the instances
- * of this module. And clone it for every thread if we have perl
- * with -Duseithreads compiled in
- */
-static PerlInterpreter *interp;
-
#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;
-} 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;
- perl_mutex mutex;
- time_t time_when_last_added;
-} PERL_POOL;
-
-static PERL_POOL perl_pool;
-
-static const CONF_PARSER pool_conf[] = {
- { "max_clones", PW_TYPE_INTEGER, 0, &perl_pool.max_clones, "32"},
- { "start_clones",PW_TYPE_INTEGER, 0, &perl_pool.start_clones, "5"},
- { "min_spare_clones",PW_TYPE_INTEGER, 0, &perl_pool.min_spare_clones, "3"},
- { "max_spare_clones",PW_TYPE_INTEGER, 0, &perl_pool.max_spare_clones, "3"},
- { "cleanup_delay",PW_TYPE_INTEGER, 0, &perl_pool.cleanup_delay, "5"},
- { "max_request_per_clone",PW_TYPE_INTEGER, 0, &perl_pool.max_request_per_clone, "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)
}
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 *clone;
- UV clone_flags = CLONEf_KEEP_PTR_TABLE;
-
- PERL_SET_CONTEXT(interp);
-
- clone = perl_clone(interp, clone_flags);
- {
- dTHXa(clone);
- }
-
- 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);
perl_destruct(perl);
perl_free(perl);
-
- if (orig_environ) {
- environ = orig_environ;
- }
}
static void rlm_destroy_perl(PerlInterpreter *perl)
rlm_perl_close_handles(handles);
}
-static void delete_pool_handle(POOL_HANDLE *handle)
+/* 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) {
- perl_pool.head = next;
- } else {
- prev->next = next;
- }
-
- if (next == NULL) {
- perl_pool.tail = prev;
- } else {
- next->prev = prev;
- }
- perl_pool.current_clones--;
-}
-
-static void move2tail(POOL_HANDLE *handle)
-{
- POOL_HANDLE *prev;
- POOL_HANDLE *next;
-
- if (perl_pool.head == NULL) {
-
- handle->prev = NULL;
- handle->next = NULL;
- perl_pool.head = handle;
- perl_pool.tail = handle;
- return;
- }
-
- if (perl_pool.tail == handle) {
- return;
- }
-
- prev = handle->prev;
- next = handle->next;
-
- if ((next != NULL) ||
- (prev != NULL)) {
- if (next == NULL) {
- return;
- }
-
- if (prev == NULL) {
- perl_pool.head = next;
- next->prev = NULL;
-
- } else {
-
- prev->next = next;
- next->prev = prev;
- }
- }
-
- handle->next = NULL;
- prev = perl_pool.tail;
-
- perl_pool.tail = handle;
- handle->prev = prev;
- prev->next = handle;
-}
-
-
-static POOL_HANDLE *pool_grow () {
- POOL_HANDLE *handle;
- time_t now;
-
- if (perl_pool.max_clones == perl_pool.current_clones) {
- 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();
- handle->request_count = 0;
- perl_pool.current_clones++;
- move2tail(handle);
-
- now = time(NULL);
- perl_pool.time_when_last_added = now;
-
- return handle;
+ pthread_key_create(key, rlm_destroy_perl);
}
-static POOL_HANDLE *pool_pop()
+static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
{
- 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(&perl_pool.mutex);
-
- found = NULL;
-
- for (handle = perl_pool.head; handle ; handle = tmp) {
- tmp = handle->next;
-
- if (handle->status == idle){
- found = handle;
- break;
- }
- }
-
- if (found == NULL) {
- if (perl_pool.current_clones < perl_pool.max_clones ) {
-
- found = pool_grow();
- perl_pool.current_clones++;
-
- if (found == NULL) {
- radlog(L_ERR,"Cannot grow pool returning");
- MUTEX_UNLOCK(&perl_pool.mutex);
- return NULL;
- }
- } else {
- radlog(L_ERR,"reached maximum clones %d cannot grow",
- perl_pool.current_clones);
- MUTEX_UNLOCK(&perl_pool.mutex);
- return NULL;
- }
- }
-
- move2tail(found);
- found->status = busy;
- perl_pool.active_clones++;
- found->request_count++;
- /*
- * Hurry Up
- */
- MUTEX_UNLOCK(&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) {
-
- POOL_HANDLE *tmp, *tmp2;
- int spare, i, t;
- time_t now;
- /*
- * Lock it
- */
- MUTEX_LOCK(&perl_pool.mutex);
- handle->status = idle;
- perl_pool.active_clones--;
-
- spare = perl_pool.current_clones - perl_pool.active_clones;
-
- radlog(L_DBG,"perl_pool total/active/spare [%d/%d/%d]"
- , perl_pool.current_clones, perl_pool.active_clones, spare);
-
- if (spare < perl_pool.min_spare_clones) {
- t = perl_pool.min_spare_clones - spare;
- for (i=0;i<t; i++) {
- if ((tmp = pool_grow()) == NULL) {
- MUTEX_UNLOCK(&perl_pool.mutex);
- return -1;
- }
- }
- MUTEX_UNLOCK(&perl_pool.mutex);
- return 0;
- }
- now = time(NULL);
- if ((now - perl_pool.time_when_last_added) < perl_pool.cleanup_delay) {
- MUTEX_UNLOCK(&perl_pool.mutex);
- return 0;
- }
- if (spare > perl_pool.max_spare_clones) {
- spare -= perl_pool.max_spare_clones;
- for (tmp = 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);
- perl_pool.current_clones--;
- spare--;
- break;
- }
- }
- }
- /*
- * Hurry Up :)
- */
- MUTEX_UNLOCK(&perl_pool.mutex);
- return 0;
-}
-static int init_pool (CONF_SECTION *conf) {
- POOL_HANDLE *handle;
- int t;
+ PerlInterpreter *interp;
+ UV clone_flags = 0;
- MUTEX_INIT(&perl_pool.mutex);
-
- /*
- * Read The Config
- *
- */
-
- cf_section_parse(conf,NULL,pool_conf);
+ PERL_SET_CONTEXT(perl);
- for(t = 0;t < perl_pool.start_clones ;t++){
- if ((handle = pool_grow()) == NULL) {
- return -1;
- }
+ interp = pthread_getspecific(*key);
+ if (interp) return interp;
+ interp = perl_clone(perl, clone_flags);
+ {
+ dTHXa(interp);
}
-
- return 1;
-}
+#if PERL_REVISION >= 5 && PERL_VERSION <8
+ call_pv("CLONE",0);
#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.
- */
-static int perl_init(void)
-{
- if ((interp = perl_alloc()) == NULL) {
- radlog(L_INFO, "rlm_perl: No memory for allocating new perl !");
- return -1;
- }
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
- perl_construct(interp);
- PL_perl_destruct_level = 2;
+ PERL_SET_CONTEXT(aTHX);
+ rlm_perl_clear_handles(aTHX);
- return 0;
+ pthread_setspecific(*key, interp);
+ return interp;
}
+#endif
static void xs_init(pTHX)
{
/*
* The xlat function
*/
-static int perl_xlat(void *instance, REQUEST *request, char *fmt, char * out,
- int 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], *tmp_ptr, *ptr, *tmp;
- int count, ret;
+ char params[1024], *ptr, *tmp;
+ int count;
+ size_t ret = 0;
STRLEN n_a;
- perl = interp;
-
-#ifdef USE_ITHREADS
- POOL_HANDLE *handle;
-
- if ((handle = pool_pop()) == 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);
{
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);
- XPUSHs(sv_2mortal(newSVpv(ptr,0)));
-
- while ((tmp_ptr = strtok(NULL, " ")) != NULL) {
- XPUSHs(sv_2mortal(newSVpv(tmp_ptr,0)));
+ while (ptr != NULL) {
+ XPUSHs(sv_2mortal(newSVpv(ptr,0)));
+ ptr = strtok(NULL, " ");
}
PUTBACK;
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 ;
- if (ret <= freespace)
- return ret;
}
- }
-#ifdef USE_ITHREADS
- pool_release(handle);
-#endif
- return 0;
+ return ret;
}
/*
* Do any per-module initialization that is separate to each
static int perl_instantiate(CONF_SECTION *conf, void **instance)
{
PERL_INST *inst = (PERL_INST *) instance;
- HV *rad_reply_hv = newHV();
- HV *rad_check_hv = newHV();
- HV *rad_request_hv = newHV();
+ 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
*/
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;
argc = 3;
}
- exitstatus = perl_parse(interp, xs_init, argc, embed, NULL);
+ PERL_SYS_INIT3(&argc, &embed, &envp);
+#ifdef USE_ITHREADS
+ 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(interp);
+ exitstatus = perl_run(inst->perl);
} else {
- radlog(L_INFO,"rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module);
+ 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_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)
xlat_register(xlat_name, perl_xlat, inst);
}
-#ifdef USE_ITHREADS
-
- if ((init_pool(conf)) == -1) {
- radlog(L_ERR,"Couldn't init a pool of perl clones. Exiting");
- return -1;
- }
-
-#endif
*instance = inst;
return 0;
{
VALUE_PAIR *nvp, *vpa, *vpn;
AV *av;
+ char namebuf[256], *name;
char buffer[1024];
- int attr, len;
+ int attr, vendor, len;
- hv_clear(rad_hv);
+ 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;
vpn = vpn->next;
}
hv_store(rad_hv, nvp->name, strlen(nvp->name),
- newRV((SV *) av), 0);
+ 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;
}
}
* 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;
- int val_len;
VALUE_PAIR *vpp;
- if ((sv != NULL) && (SvPOK(sv))) {
- val = SvPV(sv, val_len);
- vpp = pairmake(key, val, T_OP_EQ);
+ if (SvOK(sv)) {
+ val = SvPV_nolen(sv);
+ vpp = pairmake(key, val, operator);
if (vpp != NULL) {
pairadd(vp, vpp);
radlog(L_DBG,
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)) {
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;
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;
+ PerlInterpreter *interp;
- if ((handle = pool_pop()) == NULL) {
- return RLM_MODULE_FAIL;
- }
-
- 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);
#endif
{
dSP;
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);
- vp = NULL;
+ 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 {
+ 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);
+ }
+#endif
PUSHMARK(SP);
/*
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) {
}
}
+
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 0
- /*
- * Do we want to allow this?
- */
- if ((get_hv_content(rad_request_hv, &vp)) > 0 ) {
- pairfree(&request->packet->vps);
- request->packet->vps = 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;
}
-#endif
+ 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);
- radlog(L_DBG,"Unreserve perl at address 0x%lx", (unsigned long) handle->clone);
#endif
+ }
return exitstatus;
}
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;
+ 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;
/*
* Check for simultaneouse-use
*/
-
static int perl_checksimul(void *instance, REQUEST *request)
{
return rlmperl_call(instance, request,
((PERL_INST *)instance)->func_checksimul);
}
+#ifdef WITH_PROXY
+/*
+ * 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);
+}
+#endif
+
+/*
+ * Pre-Auth request
+ */
+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;
-
- for (handle = perl_pool.head; handle; handle = handle->next) {
-
- radlog(L_INFO,"Detach perl 0x%lx", (unsigned long) handle->clone);
- /*
- * Wait until clone becomes idle
- *
- */
- while (handle->status == busy) {
- }
+ int exitstatus = 0, count = 0;
- /*
- * 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);
{
- dSP; PUSHMARK(SP);
+ dSP; ENTER; SAVETMPS; PUSHMARK(SP);
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
}
}
PUTBACK;
- radlog(L_INFO,"detach at 0x%lx returned status %d",
- (unsigned long) handle->clone, exitstatus);
+ FREETMPS;
+ LEAVE;
}
}
+#endif
- }
- /*
- *
- * FIXME: For more efficienty we don't
- * free entire pool. We only reread config flags thus way
- * we can extend pool_size.
- *
- */
+ if (inst->func_detach) {
+ dTHXa(inst->perl);
+ PERL_SET_CONTEXT(inst->perl);
{
- dTHXa(interp);
- PERL_SET_CONTEXT(interp);
-#endif /* USE_ITHREADS */
- {
- dSP;
+ dSP; ENTER; SAVETMPS;
PUSHMARK(SP);
+
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
}
}
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_detach) free(inst->func_detach);
+#ifdef USE_ITHREADS
+ 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'.
* 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 */
- NULL, /* pre-proxy */
- NULL, /* post-proxy */
- NULL /* post-auth */
+#ifdef WITH_PROXY
+ perl_pre_proxy, /* pre-proxy */
+ perl_post_proxy, /* post-proxy */
+#else
+ NULL, NULL,
+#endif
+ perl_post_auth /* post-auth */
+#ifdef WITH_COA
+ , perl_recv_coa,
+ perl_send_coa
+#endif
},
- perl_detach, /* detach */
- NULL, /* destroy */
};