*
* 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 Boian Jordanov <bjordanov@orbitel.bg>
*/
-#include "autoconf.h"
-#include "libradius.h"
+#include <freeradius-devel/autoconf.h>
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
-#include "radiusd.h"
-#include "modules.h"
-#include "conffile.h"
+#include <freeradius-devel/radiusd.h>
+#include <freeradius-devel/modules.h>
+#include <freeradius-devel/conffile.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>
+#ifdef __APPLE__
+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.
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.
* 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"},
+ { "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,
*/
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) ;)
- *
+ * 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
*/
-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 PerlInterpreter *interp = NULL;
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"},
+ { "max_clones", PW_TYPE_INTEGER, offsetof(PERL_POOL, max_clones), NULL, "32"},
+ { "start_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL, start_clones), NULL, "32"},
+ { "min_spare_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL, min_spare_clones),NULL, "0"},
+ { "max_spare_clones",PW_TYPE_INTEGER, offsetof(PERL_POOL,max_spare_clones),NULL, "32"},
+ { "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 */
};
free(handles);
}
-static PerlInterpreter *rlm_perl_clone()
+static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl)
{
PerlInterpreter *clone;
- UV clone_flags = CLONEf_KEEP_PTR_TABLE;
+ UV clone_flags = 0;
- PERL_SET_CONTEXT(interp);
+ PERL_SET_CONTEXT(perl);
- clone = perl_clone(interp, clone_flags);
+ 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;
rlm_perl_close_handles(handles);
}
-static void delete_pool_handle(POOL_HANDLE *handle)
+static void delete_pool_handle(POOL_HANDLE *handle, PERL_INST *inst)
{
POOL_HANDLE *prev;
POOL_HANDLE *next;
next = handle->next;
if (prev == NULL) {
- perl_pool.head = next;
+ inst->perl_pool->head = next;
} else {
prev->next = next;
}
if (next == NULL) {
- perl_pool.tail = prev;
+ inst->perl_pool->tail = prev;
} else {
next->prev = prev;
}
- perl_pool.current_clones--;
+ inst->perl_pool->current_clones--;
+ MUTEX_DESTROY(&handle->lock);
+ free(handle);
}
-static void move2tail(POOL_HANDLE *handle)
+static void move2tail(POOL_HANDLE *handle, PERL_INST *inst)
{
POOL_HANDLE *prev;
POOL_HANDLE *next;
- if (perl_pool.head == NULL) {
+ if (inst->perl_pool->head == NULL) {
handle->prev = NULL;
handle->next = NULL;
- perl_pool.head = handle;
- perl_pool.tail = handle;
+ inst->perl_pool->head = handle;
+ inst->perl_pool->tail = handle;
return;
}
- if (perl_pool.tail == handle) {
+ if (inst->perl_pool->tail == handle) {
return;
}
}
if (prev == NULL) {
- perl_pool.head = next;
+ inst->perl_pool->head = next;
next->prev = NULL;
} else {
}
handle->next = NULL;
- prev = perl_pool.tail;
+ prev = inst->perl_pool->tail;
- perl_pool.tail = handle;
+ inst->perl_pool->tail = handle;
handle->prev = prev;
prev->next = handle;
}
-static POOL_HANDLE *pool_grow () {
+static POOL_HANDLE *pool_grow (PERL_INST *inst) {
POOL_HANDLE *handle;
time_t now;
- if (perl_pool.max_clones == perl_pool.current_clones) {
+ if (inst->perl_pool->max_clones == inst->perl_pool->current_clones) {
+ return NULL;
+ }
+ if (inst->perl_pool->detach == yes ) {
return NULL;
}
handle->prev = NULL;
handle->next = NULL;
handle->status = idle;
- handle->clone = rlm_perl_clone();
+ handle->clone = rlm_perl_clone(inst->perl);
handle->request_count = 0;
- perl_pool.current_clones++;
- move2tail(handle);
+ MUTEX_INIT(&handle->lock);
+ inst->perl_pool->current_clones++;
+ move2tail(handle, inst);
now = time(NULL);
- perl_pool.time_when_last_added = now;
+ inst->perl_pool->time_when_last_added = now;
return handle;
}
-static POOL_HANDLE *pool_pop()
+static POOL_HANDLE *pool_pop(PERL_INST *inst)
{
POOL_HANDLE *handle;
POOL_HANDLE *found;
* Lock the pool and be fast other thread maybe
* waiting for us to finish
*/
- MUTEX_LOCK(&perl_pool.mutex);
+ MUTEX_LOCK(&inst->perl_pool->mutex);
found = NULL;
- for (handle = perl_pool.head; handle ; handle = tmp) {
+ for (handle = inst->perl_pool->head; handle ; handle = tmp) {
tmp = handle->next;
if (handle->status == idle){
}
if (found == NULL) {
- if (perl_pool.current_clones < perl_pool.max_clones ) {
+ if (inst->perl_pool->current_clones < inst->perl_pool->max_clones ) {
- found = pool_grow();
- perl_pool.current_clones++;
+ found = pool_grow(inst);
if (found == NULL) {
radlog(L_ERR,"Cannot grow pool returning");
- MUTEX_UNLOCK(&perl_pool.mutex);
+ MUTEX_UNLOCK(&inst->perl_pool->mutex);
return NULL;
}
} else {
- radlog(L_ERR,"reached maximum clones %d cannot grow",
- perl_pool.current_clones);
- MUTEX_UNLOCK(&perl_pool.mutex);
+ 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);
+ move2tail(found, inst);
found->status = busy;
- perl_pool.active_clones++;
+ MUTEX_LOCK(&found->lock);
+ inst->perl_pool->active_clones++;
found->request_count++;
/*
* Hurry Up
*/
- MUTEX_UNLOCK(&perl_pool.mutex);
+ 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) {
+static int pool_release(POOL_HANDLE *handle, PERL_INST *inst) {
POOL_HANDLE *tmp, *tmp2;
int spare, i, t;
/*
* Lock it
*/
- MUTEX_LOCK(&perl_pool.mutex);
+ MUTEX_LOCK(&inst->perl_pool->mutex);
+
+ /*
+ * If detach is set then just release the mutex
+ */
+ if (inst->perl_pool->detach == yes ) {
handle->status = idle;
- perl_pool.active_clones--;
+ MUTEX_UNLOCK(&handle->lock);
+ MUTEX_UNLOCK(&inst->perl_pool->mutex);
+ return 0;
+ }
- spare = perl_pool.current_clones - perl_pool.active_clones;
+ 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]"
- , perl_pool.current_clones, perl_pool.active_clones, spare);
+ , inst->perl_pool->current_clones, inst->perl_pool->active_clones, spare);
- if (spare < perl_pool.min_spare_clones) {
- t = perl_pool.min_spare_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()) == NULL) {
- MUTEX_UNLOCK(&perl_pool.mutex);
+ if ((tmp = pool_grow(inst)) == NULL) {
+ MUTEX_UNLOCK(&inst->perl_pool->mutex);
return -1;
}
}
- MUTEX_UNLOCK(&perl_pool.mutex);
+ MUTEX_UNLOCK(&inst->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);
+ if ((now - inst->perl_pool->time_when_last_added) < inst->perl_pool->cleanup_delay) {
+ MUTEX_UNLOCK(&inst->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) {
+ 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);
- perl_pool.current_clones--;
+ 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(&perl_pool.mutex);
+ MUTEX_UNLOCK(&inst->perl_pool->mutex);
return 0;
}
-static int init_pool (CONF_SECTION *conf) {
+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(&perl_pool.mutex);
+ MUTEX_INIT(&pool->mutex);
/*
* Read The Config
*
*/
- cf_section_parse(conf,NULL,pool_conf);
+ cf_section_parse(conf,pool,pool_conf);
+ inst->perl_pool = pool;
+ inst->perl_pool->detach = no;
- for(t = 0;t < perl_pool.start_clones ;t++){
- if ((handle = pool_grow()) == NULL) {
+ 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.
- */
-static int perl_init(void)
-{
- if ((interp = perl_alloc()) == NULL) {
- radlog(L_INFO, "rlm_perl: No memory for allocating new perl !");
- return -1;
- }
-
- perl_construct(interp);
- PL_perl_destruct_level = 2;
-
- return 0;
-
-}
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)
+ 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, ret=0;
STRLEN n_a;
-
- perl = interp;
-
+#ifndef USE_ITHREADS
+ perl = inst->perl;
+#endif
#ifdef USE_ITHREADS
POOL_HANDLE *handle;
- if ((handle = pool_pop()) == NULL) {
+ if ((handle = pool_pop(instance)) == NULL) {
return 0;
}
dTHXa(perl);
}
#endif
+ PERL_SET_CONTEXT(perl);
{
dSP;
ENTER;SAVETMPS;
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;
FREETMPS ;
LEAVE ;
- if (ret <= freespace)
- return ret;
}
}
#ifdef USE_ITHREADS
- pool_release(handle);
+ pool_release(handle, instance);
#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_request_hv;
+ HV *rad_request_proxy_hv;
+ HV *rad_request_proxy_reply_hv;
+ AV *end_AV;
- char *embed[4], *xlat_name;
+ char *embed[4];
+ const char *xlat_name;
int exitstatus = 0, argc=0;
/*
argc = 3;
}
- exitstatus = perl_parse(interp, xs_init, argc, embed, NULL);
+#ifdef USE_ITHREADS
+ if (!interp) {
+ 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;
+ }
+
+ inst->perl = interp;
+ {
+ 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_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)
}
#ifdef USE_ITHREADS
-
- if ((init_pool(conf)) == -1) {
+ if ((init_pool(conf, inst)) == -1) {
radlog(L_ERR,"Couldn't init a pool of perl clones. Exiting");
return -1;
}
char buffer[1024];
int attr, len;
- hv_clear(rad_hv);
+ hv_undef(rad_hv);
nvp = paircopy(vp);
while (nvp != NULL) {
vpn = vpn->next;
}
hv_store(rad_hv, nvp->name, strlen(nvp->name),
- newRV((SV *) av), 0);
+ newRV_noinc((SV *) av), 0);
} else {
len = vp_prints_value(buffer, sizeof(buffer),
vpa, FALSE);
*/
static int pairadd_sv(VALUE_PAIR **vp, char *key, SV *sv) {
char *val;
- int val_len;
VALUE_PAIR *vpp;
- if ((sv != NULL) && (SvPOK(sv))) {
- val = SvPV(sv, val_len);
+ if (SvOK(sv)) {
+ val = SvPV_nolen(sv);
vpp = pairmake(key, val, T_OP_EQ);
if (vpp != NULL) {
pairadd(vp, vpp);
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()) == NULL) {
+ if ((handle = pool_pop(instance)) == NULL) {
return RLM_MODULE_FAIL;
}
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;
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;
pairmove(&request->config_items, &vp);
pairfree(&vp);
}
-
-#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;
+
+ 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);
}
-#endif
-
}
#ifdef USE_ITHREADS
- pool_release(handle);
+ pool_release(handle,instance);
radlog(L_DBG,"Unreserve perl at address 0x%lx", (unsigned long) handle->clone);
#endif
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;
/*
* 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;
+ int exitstatus = 0, count = 0;
#ifdef USE_ITHREADS
- POOL_HANDLE *handle;
+ POOL_HANDLE *handle, *tmp, *tmp2;
+
+ MUTEX_LOCK(&inst->perl_pool->mutex);
+ inst->perl_pool->detach = yes;
+ MUTEX_UNLOCK(&inst->perl_pool->mutex);
- for (handle = perl_pool.head; handle; handle = handle->next) {
+ for (handle = inst->perl_pool->head; handle != NULL; handle = handle->next) {
- radlog(L_INFO,"Detach perl 0x%lx", (unsigned long) handle->clone);
+ radlog(L_DBG,"Detach perl 0x%lx", (unsigned long) handle->clone);
/*
* Wait until clone becomes idle
- *
*/
- while (handle->status == busy) {
- }
+ MUTEX_LOCK(&handle->lock);
/*
* Give a clones chance to run detach 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",
+ FREETMPS;
+ LEAVE;
+ radlog(L_DBG,"detach at 0x%lx returned status %d",
(unsigned long) handle->clone, exitstatus);
}
}
-
+ MUTEX_UNLOCK(&handle->lock);
}
/*
- *
- * FIXME: For more efficienty we don't
- * free entire pool. We only reread config flags thus way
- * we can extend pool_size.
- *
+ * 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(interp);
- PERL_SET_CONTEXT(interp);
+ dTHXa(inst->perl);
#endif /* USE_ITHREADS */
+ PERL_SET_CONTEXT(inst->perl);
{
- dSP;
+ dSP; ENTER; SAVETMPS;
PUSHMARK(SP);
+
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
}
}
PUTBACK;
+ FREETMPS;
+ LEAVE;
}
#ifdef USE_ITHREADS
}
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'.
* 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 */
+ perl_pre_proxy, /* pre-proxy */
+ perl_post_proxy, /* post-proxy */
+ perl_post_auth /* post-auth */
},
- perl_detach, /* detach */
- NULL, /* destroy */
};
projects / freeradius.git / blobdiff