extern char **environ;
#endif
-#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 *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.
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 = NULL;
-
-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, "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 */
-};
-
-
#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 *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;
rlm_perl_close_handles(handles);
}
-static void delete_pool_handle(POOL_HANDLE *handle, PERL_INST *inst)
-{
- POOL_HANDLE *prev;
- POOL_HANDLE *next;
+static pthread_key_t rlm_perl_key;
+static pthread_once_t rlm_perl_once = PTHREAD_ONCE_INIT;
- 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)
+/* Create Key */
+static void rlm_perl_make_key(void)
{
- 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;
+ pthread_key_create(&rlm_perl_key, rlm_destroy_perl);
}
-
-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)
+static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl)
{
- 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;
- }
+ PerlInterpreter *interp;
+ UV clone_flags = 0;
- MUTEX_UNLOCK(&handle->lock);
- handle->status = idle;
- inst->perl_pool->active_clones--;
+ PERL_SET_CONTEXT(perl);
- spare = inst->perl_pool->current_clones - inst->perl_pool->active_clones;
+ pthread_once(&rlm_perl_once, rlm_perl_make_key);
- radlog(L_DBG,"perl_pool total/active/spare [%d/%d/%d]"
- , inst->perl_pool->current_clones, inst->perl_pool->active_clones, spare);
+ interp = pthread_getspecific(rlm_perl_key);
+ if (interp) return interp;
- if (spare < inst->perl_pool->min_spare_clones) {
- t = inst->perl_pool->min_spare_clones - spare;
- for (i=0;i<t; i++) {
- if ((tmp = pool_grow(inst)) == NULL) {
- MUTEX_UNLOCK(&inst->perl_pool->mutex);
- return -1;
- }
- }
- MUTEX_UNLOCK(&inst->perl_pool->mutex);
- return 0;
- }
- now = time(NULL);
- if ((now - inst->perl_pool->time_when_last_added) < inst->perl_pool->cleanup_delay) {
- MUTEX_UNLOCK(&inst->perl_pool->mutex);
- return 0;
- }
- if (spare > inst->perl_pool->max_spare_clones) {
- spare -= inst->perl_pool->max_spare_clones;
- for (tmp = inst->perl_pool->head; (tmp !=NULL ) && (spare > 0) ; tmp = tmp2) {
- tmp2 = tmp->next;
-
- if(tmp->status == idle) {
- rlm_destroy_perl(tmp->clone);
- delete_pool_handle(tmp,inst);
- spare--;
- break;
- }
- }
- }
- /*
- * If 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);
- }
+ interp = perl_clone(perl, clone_flags);
+ {
+ dTHXa(interp);
}
- /*
- * 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
- *
- */
+#if PERL_REVISION >= 5 && PERL_VERSION <8
+ call_pv("CLONE",0);
+#endif
+ ptr_table_free(PL_ptr_table);
+ PL_ptr_table = NULL;
- cf_section_parse(conf,pool,pool_conf);
- inst->perl_pool = pool;
- inst->perl_pool->detach = no;
+ PERL_SET_CONTEXT(aTHX);
+ rlm_perl_clear_handles(aTHX);
- for(t = 0;t < inst->perl_pool->start_clones ;t++){
- if ((handle = pool_grow(inst)) == NULL) {
- return -1;
- }
+ pthread_setspecific(rlm_perl_key, interp);
- }
+ fprintf(stderr, "GOT CLONE %d %p\n", pthread_self(), interp);
- return 1;
+ return interp;
}
#endif
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);
+#ifndef WITH_ITHREADS
+ perl = inst->perl;
+#else
+ perl = rlm_perl_clone(inst->perl);
{
- dTHXa(perl);
+ dTHXa(perl);
}
#endif
PERL_SET_CONTEXT(perl);
LEAVE ;
}
-#ifdef USE_ITHREADS
- pool_release(handle, instance);
-#endif
return ret;
}
/*
}
#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);
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;
HV *rad_request_proxy_reply_hv;
#ifdef USE_ITHREADS
- POOL_HANDLE *handle;
+ PerlInterpreter *interp;
- if ((handle = pool_pop(instance)) == NULL) {
- return RLM_MODULE_FAIL;
- }
-
- radlog(L_DBG,"found interpetator at address 0x%lx",(unsigned long) handle->clone);
+ interp = rlm_perl_clone(inst->perl);
{
- 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;
}
}
-#ifdef USE_ITHREADS
- pool_release(handle,instance);
- radlog(L_DBG,"Unreserve perl at address 0x%lx", (unsigned long) handle->clone);
-#endif
-
return exitstatus;
}
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
- */
+#if 0
+ /*
+ * FIXME: Call this in the destruct function?
+ */
{
dTHXa(handle->clone);
PERL_SET_CONTEXT(handle->clone);
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
{
dTHXa(inst->perl);
-#endif /* USE_ITHREADS */
PERL_SET_CONTEXT(inst->perl);
{
dSP; ENTER; SAVETMPS;
FREETMPS;
LEAVE;
}
-#ifdef USE_ITHREADS
}
-#endif
xlat_unregister(inst->xlat_name, perl_xlat);
free(inst->xlat_name);
-
#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);
free(inst);
return exitstatus;
}
+
+
/*
* The module name should be the only globally exported symbol.
* That is, everything else should be 'static'.