PerlInterpreter *p5_init_perl() {
char *embedding[] = { "", "-e", "0" };
int argc = 0;
char **argv;
if (!inited++)
PERL_SYS_INIT(&argc, &argv);
PerlInterpreter *my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
PL_perl_destruct_level = 1;
perl_construct( my_perl );
perl_parse(my_perl, xs_init, 3, embedding, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
return my_perl;
}
PerlInterpreter *p5_init_perl(
int argc,
char **argv,
SV *(*call_p6_method)(IV, char * , I32, SV *, SV **),
SV *(*call_p6_callable)(IV, SV *, SV **),
void (*free_p6_object)(IV),
SV *(*hash_at_key)(IV, char *),
SV *(*hash_assign_key)(IV, char *, SV *)
) {
if (inited) {
#ifndef MULTIPLICITY
return NULL;
#endif
}
else {
inited = 1;
PERL_SYS_INIT(&argc, &argv);
}
interpreters++;
PerlInterpreter *my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
PL_perl_destruct_level = 1;
perl_construct( my_perl );
perl_parse(my_perl, xs_init, argc, argv, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
p5_init_callbacks(
call_p6_method,
call_p6_callable,
free_p6_object,
hash_at_key,
hash_assign_key
);
return my_perl;
}
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);
}
int handlePerlHTTPRequest(char *url) {
int perl_argc = 2, idx, found = 0;
char perl_path[256];
char * perl_argv[] = { "", NULL };
struct stat statbuf;
char *question_mark = strchr(url, '?');
PerlInterpreter *my_perl; /*** The Perl interpreter ***/
traceEvent(CONST_TRACE_WARNING, "Calling perl... [%s]", url);
if(question_mark) question_mark[0] = '\0';
for(idx=0; (!found) && (myGlobals.dataFileDirs[idx] != NULL); idx++) {
safe_snprintf(__FILE__, __LINE__, perl_path, sizeof(perl_path),
"%s/perl/%s", myGlobals.dataFileDirs[idx], url);
revertSlashIfWIN32(perl_path, 0);
if(!stat(perl_path, &statbuf)) {
/* Found */
/* traceEvent(CONST_TRACE_INFO, "[perl] [%d] Found %s", idx, perl_path); */
found = 1;
break;
} else {
/* traceEvent(CONST_TRACE_INFO, "[perl] [%d] Not found %s", idx, perl_path); */
}
}
if(!found) {
returnHTTPpageNotFound(NULL);
return(1);
}
perl_argv[1] = perl_path;
PERL_SYS_INIT(&perl_argc, &perl_argv);
if((my_perl = perl_alloc()) == NULL) {
traceEvent(CONST_TRACE_WARNING, "[perl] Not enough memory");
return(0);
}
perl_construct(my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse(my_perl, xs_init, perl_argc, perl_argv, (char **)NULL);
SWIG_InitializeModule(0);
if(question_mark) {
PERL_STORE_STRING(perl_get_hv("main::ENV", TRUE), "QUERY_STRING_UNESCAPED", &question_mark[1]);
}
newXS("sendString", _wrap_ntop_perl_sendString, (char*)__FILE__);
newXS("sendFile", _wrap_ntop_perl_sendFile, (char*)__FILE__);
newXS("send_http_header", _wrap_ntop_perl_send_http_header, (char*)__FILE__);
newXS("send_html_footer", _wrap_ntop_perl_send_html_footer, (char*)__FILE__);
newXS("loadHost", _wrap_ntop_perl_loadHost, (char*)__FILE__);
newXS("getFirstHost", _wrap_ntop_perl_getFirstHost, (char*)__FILE__);
newXS("getNextHost", _wrap_ntop_perl_getNextHost, (char*)__FILE__);
perl_run(my_perl);
/* Unset variables */
perl_host = NULL;
// PL_perl_destruct_level = 1;
perl_destruct(my_perl);
perl_free(my_perl);
//PERL_SYS_TERM();
return(1);
}
static char *
ngx_http_perl_init_interpreter(ngx_conf_t *cf, ngx_http_perl_main_conf_t *pmcf)
{
#if (NGX_HAVE_PERL_MULTIPLICITY)
ngx_pool_cleanup_t *cln;
cln = ngx_pool_cleanup_add(cf->pool, 0);
if (cln == NULL) {
return NGX_CONF_ERROR;
}
#else
static PerlInterpreter *perl;
#endif
#ifdef NGX_PERL_MODULES
if (pmcf->modules.data == NULL) {
pmcf->modules.data = NGX_PERL_MODULES;
}
#endif
if (pmcf->modules.data) {
if (ngx_conf_full_name(cf->cycle, &pmcf->modules, 0) != NGX_OK) {
return NGX_CONF_ERROR;
}
}
#if !(NGX_HAVE_PERL_MULTIPLICITY)
if (perl) {
if (ngx_set_environment(cf->cycle, NULL) == NULL) {
return NGX_CONF_ERROR;
}
if (ngx_http_perl_run_requires(aTHX_ &pmcf->requires, cf->log)
!= NGX_OK)
{
return NGX_CONF_ERROR;
}
pmcf->perl = perl;
pmcf->nginx = nginx_stash;
return NGX_CONF_OK;
}
#endif
if (nginx_stash == NULL) {
PERL_SYS_INIT(&ngx_argc, &ngx_argv);
}
pmcf->perl = ngx_http_perl_create_interpreter(cf, pmcf);
if (pmcf->perl == NULL) {
return NGX_CONF_ERROR;
}
pmcf->nginx = nginx_stash;
#if (NGX_HAVE_PERL_MULTIPLICITY)
cln->handler = ngx_http_perl_cleanup_perl;
cln->data = pmcf->perl;
#else
perl = pmcf->perl;
#endif
return NGX_CONF_OK;
}
static char *
ngx_http_perl_init_interpreter(ngx_conf_t *cf, ngx_http_perl_main_conf_t *pmcf)
{
ngx_str_t *m;
ngx_uint_t i;
#if (NGX_HAVE_PERL_MULTIPLICITY)
ngx_pool_cleanup_t *cln;
cln = ngx_pool_cleanup_add(cf->pool, 0);
if (cln == NULL) {
return NGX_CONF_ERROR;
}
#endif
#ifdef NGX_PERL_MODULES
if (pmcf->modules == NGX_CONF_UNSET_PTR) {
pmcf->modules = ngx_array_create(cf->pool, 1, sizeof(ngx_str_t));
if (pmcf->modules == NULL) {
return NGX_CONF_ERROR;
}
m = ngx_array_push(pmcf->modules);
if (m == NULL) {
return NGX_CONF_ERROR;
}
ngx_str_set(m, NGX_PERL_MODULES);
}
#endif
if (pmcf->modules != NGX_CONF_UNSET_PTR) {
m = pmcf->modules->elts;
for (i = 0; i < pmcf->modules->nelts; i++) {
if (ngx_conf_full_name(cf->cycle, &m[i], 0) != NGX_OK) {
return NGX_CONF_ERROR;
}
}
}
#if !(NGX_HAVE_PERL_MULTIPLICITY)
if (perl) {
if (ngx_set_environment(cf->cycle, NULL) == NULL) {
return NGX_CONF_ERROR;
}
if (ngx_http_perl_run_requires(aTHX_ pmcf->requires, cf->log)
!= NGX_OK)
{
return NGX_CONF_ERROR;
}
pmcf->perl = perl;
pmcf->nginx = nginx_stash;
return NGX_CONF_OK;
}
#endif
if (nginx_stash == NULL) {
PERL_SYS_INIT(&ngx_argc, &ngx_argv);
}
pmcf->perl = ngx_http_perl_create_interpreter(cf, pmcf);
if (pmcf->perl == NULL) {
return NGX_CONF_ERROR;
}
pmcf->nginx = nginx_stash;
#if (NGX_HAVE_PERL_MULTIPLICITY)
cln->handler = ngx_http_perl_cleanup_perl;
cln->data = pmcf->perl;
#else
perl = pmcf->perl;
#endif
return NGX_CONF_OK;
}
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;
}
