static PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl)
{
PerlInterpreter *interp;
UV clone_flags = 0;
PERL_SET_CONTEXT(perl);
pthread_once(&rlm_perl_once, rlm_perl_make_key);
interp = pthread_getspecific(rlm_perl_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);
pthread_setspecific(rlm_perl_key, interp);
fprintf(stderr, "GOT CLONE %d %p\n", pthread_self(), interp);
return interp;
}
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 PerlInterpreter *rlm_perl_clone(PerlInterpreter *perl, pthread_key_t *key)
{
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);
pthread_setspecific(*key, interp);
return interp;
}
/* lazily maintain 1:1 mapping between tcl and perl interpreters */
perl_context *nsperl2_get_assoc_perl_context (Tcl_Interp *interp)
{
extern perl_master_context *nsperl2_master_context;
assert (nsperl2_master_context);
perl_context *context = Tcl_GetAssocData (interp, "nsperl2:perl_context", NULL);
PerlInterpreter *perl_interp;
if(context)
return context;
Ns_Log (Notice, "cloning perl interpreter for tcl interp");
PERL_SET_CONTEXT (nsperl2_master_context->perl_master_interp);
if ((perl_interp = perl_clone (nsperl2_master_context->perl_master_interp, CLONEf_KEEP_PTR_TABLE)) == NULL) {
Ns_Log (Error, "Couldn't clone perl interp");
return NULL;
}
/* save the perl interp */
context = ns_malloc (sizeof(perl_context));
context->perl_interp = perl_interp;
Tcl_SetAssocData(interp, "nsperl2:perl_context", nsperl2_delete_assoc_perl, context);
return context;
}
static PerlInterpreter *
clone_perl_interpreter (void *parent_intrp, char *err, int max_len)
{
PerlInterpreter *intrp = (PerlInterpreter *) parent_intrp;
UV clone_flags = CLONEf_KEEP_PTR_TABLE;
#if defined(WIN32) && defined(CLONEf_CLONE_HOST)
clone_flags |= CLONEf_CLONE_HOST;
#endif
log_debug ("clone_perl_interpreter");
PERL_SET_CONTEXT(intrp);
return perl_clone (intrp, clone_flags);
}
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;
}
EXTERN_C DllExport int
RunPerl(int argc, char **argv, char **env)
{
int exitstatus;
PerlInterpreter *my_perl, *new_perl = NULL;
#ifndef __BORLANDC__
/* XXX this _may_ be a problem on some compilers (e.g. Borland) that
* want to free() argv after main() returns. As luck would have it,
* Borland's CRT does the right thing to argv[0] already. */
char szModuleName[MAX_PATH];
GetModuleFileName(NULL, szModuleName, sizeof(szModuleName));
(void)win32_longpath(szModuleName);
argv[0] = szModuleName;
#endif
#ifdef PERL_GLOBAL_STRUCT
#define PERLVAR(var,type) /**/
#define PERLVARA(var,type) /**/
#define PERLVARI(var,type,init) PL_Vars.var = init;
#define PERLVARIC(var,type,init) PL_Vars.var = init;
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
#endif
PERL_SYS_INIT(&argc,&argv);
if (!(my_perl = perl_alloc()))
return (1);
perl_construct(my_perl);
PL_perl_destruct_level = 0;
exitstatus = perl_parse(my_perl, xs_init, argc, argv, env);
if (!exitstatus) {
#if defined(TOP_CLONE) && defined(USE_ITHREADS) /* XXXXXX testing */
new_perl = perl_clone(my_perl, 1);
exitstatus = perl_run(new_perl);
PERL_SET_THX(my_perl);
#else
exitstatus = perl_run(my_perl);
#endif
}
perl_destruct(my_perl);
perl_free(my_perl);
#ifdef USE_ITHREADS
if (new_perl) {
PERL_SET_THX(new_perl);
perl_destruct(new_perl);
perl_free(new_perl);
}
#endif
PERL_SYS_TERM();
return (exitstatus);
}
EXTERN_C
int RunPerl(int argc, char **argv, char **env)
{
int exitstatus = 0;
ClsPerlHost nlm;
PerlInterpreter *my_perl = NULL; // defined in Perl.h
PerlInterpreter *new_perl = NULL; // defined in Perl.h
//__asm{int 3};
#ifdef PERL_GLOBAL_STRUCT
#define PERLVAR(prefix,var,type)
#define PERLVARA(prefix,var,type)
#define PERLVARI(prefix,var,type,init) PL_Vars.prefix##var = init;
#define PERLVARIC(prefix,var,type,init) PL_Vars.prefix##var = init;
#include "perlvars.h"
#undef PERLVAR
#undef PERLVARA
#undef PERLVARI
#undef PERLVARIC
#endif
PERL_SYS_INIT(&argc, &argv);
if (!(my_perl = perl_alloc())) // Allocate memory for Perl.
return (1);
if(nlm.PerlCreate(my_perl))
{
PL_perl_destruct_level = 0;
if(!nlm.PerlParse(my_perl, argc, argv, env))
{
#if defined(TOP_CLONE) && defined(USE_ITHREADS) // XXXXXX testing
# ifdef PERL_OBJECT
CPerlHost *h = new CPerlHost();
new_perl = perl_clone_using(my_perl, 1,
h->m_pHostperlMem,
h->m_pHostperlMemShared,
h->m_pHostperlMemParse,
h->m_pHostperlEnv,
h->m_pHostperlStdIO,
h->m_pHostperlLIO,
h->m_pHostperlDir,
h->m_pHostperlSock,
h->m_pHostperlProc
);
CPerlObj *pPerl = (CPerlObj*)new_perl;
# else
new_perl = perl_clone(my_perl, 1);
# endif
(void) perl_run(new_perl); // Run Perl.
PERL_SET_THX(my_perl);
#else
(void) nlm.PerlRun(my_perl);
#endif
}
exitstatus = nlm.PerlDestroy(my_perl);
}
if(my_perl)
nlm.PerlFree(my_perl);
#ifdef USE_ITHREADS
if (new_perl)
{
PERL_SET_THX(new_perl);
exitstatus = nlm.PerlDestroy(new_perl);
nlm.PerlFree(my_perl);
}
#endif
PERL_SYS_TERM();
return exitstatus;
}
static PerlInterpreter *clone_perl(void)
{
PerlInterpreter *my_perl = perl_clone(globals.my_perl, CLONEf_COPY_STACKS | CLONEf_KEEP_PTR_TABLE);
PERL_SET_CONTEXT(my_perl);
return my_perl;
}