static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
{
int ret;
PerlInterpreter *interp;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
interp = pthread_getspecific(*key);
if (interp) return interp;
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;
PERL_SET_CONTEXT(aTHX);
rlm_perl_clear_handles(aTHX);
ret = pthread_setspecific(*key, interp);
if (ret != 0) {
DEBUG("Failed associating interpretor with thread %s", fr_syserror(ret));
rlm_perl_destruct(interp);
return NULL;
}
return interp;
}
static void rlm_destroy_perl(PerlInterpreter *perl)
{
void **handles;
dTHXa(perl);
PERL_SET_CONTEXT(perl);
handles = rlm_perl_get_handles(aTHX);
if (handles) rlm_perl_close_handles(handles);
rlm_perl_destruct(perl);
}
static int mod_detach(void *instance)
{
rlm_perl_t *inst = (rlm_perl_t *) instance;
int exitstatus = 0, count = 0;
if (inst->perl_parsed) {
dTHXa(inst->perl);
PERL_SET_CONTEXT(inst->perl);
if (inst->rad_perlconf_hv != NULL) hv_undef(inst->rad_perlconf_hv);
if (inst->func_detach) {
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
rlm_perl_destruct(inst->perl);
pthread_mutex_destroy(&inst->clone_mutex);
#else
perl_destruct(inst->perl);
perl_free(inst->perl);
#endif
/*
* Hope this is not really needed.
* Is only allowed to be called once just before exit().
*
PERL_SYS_TERM();
*/
return exitstatus;
}
static int mod_detach(void *instance)
{
rlm_perl_t *inst = (rlm_perl_t *) instance;
int exitstatus = 0, count = 0;
#if 0
/*
* FIXME: Call this in the destruct 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;
}
}
#endif
if (inst->func_detach) {
dTHXa(inst->perl);
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
rlm_perl_destruct(inst->perl);
pthread_mutex_destroy(&inst->clone_mutex);
#else
perl_destruct(inst->perl);
perl_free(inst->perl);
#endif
PERL_SYS_TERM();
return exitstatus;
}
/*
* 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;
}
/*
* 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;
#if 0
/*
* FIXME: Call this in the destruct 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;
}
}
#endif
{
dTHXa(inst->perl);
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;
}
}
xlat_unregister(inst->xlat_name, perl_xlat);
free(inst->xlat_name);
#ifdef USE_ITHREADS
rlm_perl_destruct(inst->perl);
#else
perl_destruct(inst->perl);
perl_free(inst->perl);
#endif
free(inst);
return exitstatus;
}
