static void rlm_perl_destruct(PerlInterpreter *perl)
{
dTHXa(perl);
PERL_SET_CONTEXT(perl);
PL_perl_destruct_level = 2;
PL_origenviron = environ;
{
dTHXa(perl);
}
/*
* FIXME: This shouldn't happen
*
*/
while (PL_scopestack_ix > 1 ){
LEAVE;
}
perl_destruct(perl);
perl_free(perl);
}
zAPI::IModule::ChainStatus ModPerl::onPreSend(zAPI::IHttpRequest* request, zAPI::IHttpResponse* response)
{
if (request->getParam("modPerl_status") != NULL)
{
int* fds_input = new int[2];
int* fds_output = new int[2];
request->setParam("modPerl_fds_input", fds_input);
request->setParam("modPerl_fds_output", fds_output);
if (pipe(fds_input) < 0)
return zAPI::IModule::ERRORMODULE;
if (pipe(fds_output) < 0)
return zAPI::IModule::ERRORMODULE;
pid_t pid = fork();
if (pid == -1)
{
perror("fork");
return zAPI::IModule::ERRORMODULE;
}
else if (pid == 0)
{
dup2(fds_input[0], 0);
dup2(fds_output[1], 1);
close(fds_input[1]);
close(fds_output[0]);
char *perlOpts[] = {"", "-e", "0"};
struct stat sb;
int fd;
void* addr;
PerlInterpreter* _perl;
_perl = perl_alloc();
perl_construct(_perl);
perl_parse(_perl, NULL, 3, perlOpts, NULL);
perl_run(_perl);
fd = open((*(request->getConfig()->getParam("DocumentRoot")) + request->getUri()).c_str() ,O_RDONLY);
if (fd == -1)
exit(1);
if (fstat(fd, &sb) == -1)
{
close(fd);
exit(1);
}
addr = mmap(NULL, sb.st_size, PROT_READ, MAP_PRIVATE, fd, 0);
if (addr == MAP_FAILED)
{
close(fd);
exit(1);
}
perl_eval_pv((char*)addr,TRUE);
munmap(addr, sb.st_size);
close(fd);
perl_destruct(_perl);
perl_free(_perl);
exit(0);
}
else
{
request->setParam("modPerl_pid_t", reinterpret_cast<void*>(pid));
close(fds_output[1]);
close(fds_input[0]);
zAPI::IResponseStream* post = request->getBodyStream();
if (post)
{
char buff[1024];
size_t ret;
while (post->completed() == false)
{
ret = post->read(buff, 1024);
write(fds_input[1], buff, ret);
}
}
close(fds_input[1]);
}
}
return zAPI::IModule::CONTINUE;
}
static void perlfilter()
{
char *embedding[] = { "", WRAPPERPL };
char *args[] = { "", "0", NULL, NULL, NULL};
int exitstatus = 0;
int sock;
PerlInterpreter *my_perl;
if((my_perl = perl_alloc()) == NULL)
{
fprintf(stderr, "no memory!");
exit(1);
}
perl_construct(my_perl);
exitstatus = perl_parse(my_perl, xs_init, 2, embedding, NULL);
if (exitstatus || (exitstatus=perl_run(my_perl)) != 0)
{
fprintf(stderr, "Cannot parse " WRAPPERPL "\n");
exit(exitstatus);
}
while ((sock=lf_accept(listen_sock)) >= 0)
{
char sockbuf[100];
args[0]=filter;
sprintf(sockbuf, "%d", sock);
args[2]=sockbuf;
{
dSP ;
ENTER ;
SAVETMPS ;
perl_call_argv("Embed::Persistent::eval_file",
G_VOID | G_DISCARD | G_EVAL, args);
#ifdef ERRSV
if(SvTRUE(ERRSV))
#else
if(SvTRUE(GvSV(errgv)))
#endif
{
clog_open_syslog("perlfilter");
clog_msg_start_err();
clog_msg_str("eval error: ");
#ifdef ERRSV
clog_msg_str(SvPV(ERRSV,PL_na));
#else
clog_msg_str(SvPV(GvSV(errgv),na));
#endif
clog_msg_send();
}
FREETMPS ;
LEAVE ;
}
close(sock); /* Just in case */
}
#ifdef perl_destruct_level
perl_destruct_level=0;
#else
PL_perl_destruct_level=0;
#endif
perl_destruct(my_perl);
perl_free(my_perl);
exit(0);
}
void destructor(PerlInterpreter* interp) {
perl_destruct(interp);
perl_free(interp);
}
isc_result_t
dlz_create(const char *dlzname, unsigned int argc, char *argv[],
void **dbdata, ...)
{
config_data_t *cd;
char *init_args[] = { NULL, NULL };
char *perlrun[] = { "", NULL, "dlz perl", NULL };
char *perl_class_name;
int r;
va_list ap;
const char *helper_name;
const char *missing_method_name;
char *call_argv_args = NULL;
#ifdef MULTIPLICITY
PerlInterpreter *my_perl;
#endif
cd = malloc(sizeof(config_data_t));
if (cd == NULL)
return (ISC_R_NOMEMORY);
memset(cd, 0, sizeof(config_data_t));
/* fill in the helper functions */
va_start(ap, dbdata);
while ((helper_name = va_arg(ap, const char *)) != NULL) {
b9_add_helper(cd, helper_name, va_arg(ap, void*));
}
va_end(ap);
if (argc < 2) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Missing script argument.",
dlzname);
return (ISC_R_FAILURE);
}
if (argc < 3) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Missing class name argument.",
dlzname);
return (ISC_R_FAILURE);
}
perl_class_name = argv[2];
cd->log(ISC_LOG_INFO, "DLZ Perl '%s': Loading '%s' from location '%s'",
dlzname, perl_class_name, argv[1], argc);
#ifndef MULTIPLICITY
if (global_perl) {
/*
* PERL_SET_CONTEXT not needed here as we're guaranteed to
* have an implicit context thanks to an undefined
* MULTIPLICITY.
*/
PL_perl_destruct_level = 1;
perl_destruct(global_perl);
perl_free(global_perl);
global_perl = NULL;
global_perl_dont_free = 1;
}
#endif
cd->perl = perl_alloc();
if (cd->perl == NULL) {
free(cd);
return (ISC_R_FAILURE);
}
#ifdef MULTIPLICITY
my_perl = cd->perl;
#endif
PERL_SET_CONTEXT(cd->perl);
/*
* We will re-create the interpreter during an rndc reconfig, so we
* must set this variable per perlembed in order to insure we can
* clean up Perl at a later time.
*/
PL_perl_destruct_level = 1;
perl_construct(cd->perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
/* Prevent crashes from clients writing to $0 */
PL_origalen = 1;
cd->perl_source = strdup(argv[1]);
if (cd->perl_source == NULL) {
free(cd);
return (ISC_R_NOMEMORY);
}
perlrun[1] = cd->perl_source;
if (perl_parse(cd->perl, xs_init, 3, perlrun, (char **)NULL)) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Failed to parse Perl script, aborting",
dlzname);
goto CLEAN_UP_PERL_AND_FAIL;
}
/* Let Perl know about our callbacks. */
call_argv("DLZ_Perl::clientinfo::bootstrap",
G_DISCARD|G_NOARGS, &call_argv_args);
call_argv("DLZ_Perl::bootstrap",
G_DISCARD|G_NOARGS, &call_argv_args);
/*
* Run the script. We don't really need to do this since we have
* the init callback, but there's not really a downside either.
*/
if (perl_run(cd->perl)) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Script exited with an error, aborting",
dlzname);
goto CLEAN_UP_PERL_AND_FAIL;
}
#ifdef MULTIPLICITY
if (missing_method_name = missing_perl_method(perl_class_name, my_perl))
#else
if (missing_method_name = missing_perl_method(perl_class_name))
#endif
{
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': Missing required function '%s', "
"aborting", dlzname, missing_method_name);
goto CLEAN_UP_PERL_AND_FAIL;
}
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(perl_class_name, 0)));
/* Build flattened hash of config info. */
XPUSHs(sv_2mortal(newSVpv("log_context", 0)));
XPUSHs(sv_2mortal(newSViv((IV)cd->log)));
/* Argument to pass to new? */
if (argc == 4) {
XPUSHs(sv_2mortal(newSVpv("argv", 0)));
XPUSHs(sv_2mortal(newSVpv(argv[3], 0)));
}
PUTBACK;
r = call_method("new", G_EVAL|G_SCALAR);
SPAGAIN;
if (r) cd->perl_class = SvREFCNT_inc(POPs);
PUTBACK;
FREETMPS;
LEAVE;
if (SvTRUE(ERRSV)) {
POPs;
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': new died in eval: %s",
dlzname, SvPV_nolen(ERRSV));
goto CLEAN_UP_PERL_AND_FAIL;
}
if (!r || !sv_isobject(cd->perl_class)) {
cd->log(ISC_LOG_ERROR,
"DLZ Perl '%s': new failed to return a blessed object",
dlzname);
goto CLEAN_UP_PERL_AND_FAIL;
}
*dbdata = cd;
#ifndef MULTIPLICITY
global_perl = cd->perl;
#endif
return (ISC_R_SUCCESS);
CLEAN_UP_PERL_AND_FAIL:
PL_perl_destruct_level = 1;
perl_destruct(cd->perl);
perl_free(cd->perl);
free(cd->perl_source);
free(cd);
return (ISC_R_FAILURE);
}
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 main(int argc, char **argv, char **env)
{
FILE *rnull;
FILE *wnull;
char *perlerr;
int status = 0;
if (argc <= 1) {
fprintf(stderr, "Usage: %s --builtin|TEST.t|-le CODE\n", argv[0]);
return 1;
}
/* initialize a fake ncurses, detached from std{in,out} */
wnull = fopen("/dev/null", "w");
rnull = fopen("/dev/null", "r");
newterm("xterm", wnull, rnull);
/* initialize global structures */
owl_global_init(&g);
perlerr = owl_perlconfig_initperl(NULL, &argc, &argv, &env);
if (perlerr) {
endwin();
fprintf(stderr, "Internal perl error: %s\n", perlerr);
status = 1;
goto out;
}
owl_global_complete_setup(&g);
owl_global_setup_default_filters(&g);
owl_view_create(owl_global_get_current_view(&g), "main",
owl_global_get_filter(&g, "all"),
owl_global_get_style_by_name(&g, "default"));
owl_function_firstmsg();
ENTER;
SAVETMPS;
if (strcmp(argv[1], "--builtin") == 0) {
status = owl_regtest();
} else if (strcmp(argv[1], "-le") == 0 && argc > 2) {
/*
* 'prove' runs its harness perl with '-le CODE' to get some
* information out.
*/
moreswitches("l");
eval_pv(argv[2], true);
} else {
sv_setpv(get_sv("0", false), argv[1]);
sv_setpv(get_sv("main::test_prog", TRUE), argv[1]);
eval_pv("do $main::test_prog; die($@) if($@)", true);
}
status = 0;
FREETMPS;
LEAVE;
out:
perl_destruct(owl_global_get_perlinterp(&g));
perl_free(owl_global_get_perlinterp(&g));
/* probably not necessary, but tear down the screen */
endwin();
fclose(rnull);
fclose(wnull);
return status;
}
int
main(int argc, char **argv, char **env)
#endif
{
dVAR;
int exitstatus;
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *plvarsp = init_global_struct();
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
my_vars = my_plvarsp = plvarsp;
# endif
#endif /* PERL_GLOBAL_STRUCT */
(void)env;
#ifndef PERL_USE_SAFE_PUTENV
PL_use_safe_putenv = 0;
#endif /* PERL_USE_SAFE_PUTENV */
/* if user wants control of gprof profiling off by default */
/* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
PERL_GPROF_MONCONTROL(0);
#ifdef NO_ENV_ARRAY_IN_MAIN
PERL_SYS_INIT3(&argc,&argv,&environ);
#else
PERL_SYS_INIT3(&argc,&argv,&env);
#endif
#if defined(USE_ITHREADS)
/* XXX Ideally, this should really be happening in perl_alloc() or
* perl_construct() to keep libperl.a transparently fork()-safe.
* It is currently done here only because Apache/mod_perl have
* problems due to lack of a call to cancel pthread_atfork()
* handlers when shared objects that contain the handlers may
* be dlclose()d. This forces applications that embed perl to
* call PTHREAD_ATFORK() explicitly, but if and only if it hasn't
* been called at least once before in the current process.
* --GSAR 2001-07-20 */
PTHREAD_ATFORK(Perl_atfork_lock,
Perl_atfork_unlock,
Perl_atfork_unlock);
#endif
if (!PL_do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct(my_perl);
PL_perl_destruct_level = 0;
}
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
if (!exitstatus)
perl_run(my_perl);
exitstatus = perl_destruct(my_perl);
perl_free(my_perl);
#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL) && !defined(NO_ENV_ARRAY_IN_MAIN)
/*
* The old environment may have been freed by perl_free()
* when PERL_TRACK_MEMPOOL is defined, but without having
* been restored by perl_destruct() before (this is only
* done if destruct_level > 0).
*
* It is important to have a valid environment for atexit()
* routines that are eventually called.
*/
environ = env;
#endif
#ifdef PERL_GLOBAL_STRUCT
free_global_struct(plvarsp);
#endif /* PERL_GLOBAL_STRUCT */
PERL_SYS_TERM();
exit(exitstatus);
return exitstatus;
}
void p5_destruct_perl(PerlInterpreter *my_perl) {
PL_perl_destruct_level = 1;
perl_destruct(my_perl);
perl_free(my_perl);
}
int
main(int argc, char **argv, char **env)
{
int exitstatus;
int i;
char **fakeargv;
GV* tmpgv;
SV* tmpsv;
int options_count;
PERL_SYS_INIT3(&argc,&argv,&env);
if (!PL_do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct( my_perl );
PL_perl_destruct_level = 0;
}
#ifdef USE_ITHREADS
for( i = 0; i < 117; ++i ) {
av_push( PL_regex_padav, newSViv(0) );
}
PL_regex_pad = AvARRAY( PL_regex_padav );
#endif
#ifdef CSH
if (!PL_cshlen)
PL_cshlen = strlen(PL_cshname);
#endif
#ifdef ALLOW_PERL_OPTIONS
#define EXTRA_OPTIONS 3
#else
#define EXTRA_OPTIONS 4
#endif /* ALLOW_PERL_OPTIONS */
New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
fakeargv[0] = argv[0];
fakeargv[1] = "-e";
fakeargv[2] = "";
options_count = 3;
if( 0 ) {
fakeargv[options_count] = "-T";
++options_count;
}
#ifndef ALLOW_PERL_OPTIONS
fakeargv[options_count] = "--";
++options_count;
#endif /* ALLOW_PERL_OPTIONS */
for (i = 1; i < argc; i++)
fakeargv[i + options_count - 1] = argv[i];
fakeargv[argc + options_count - 1] = 0;
exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
fakeargv, NULL);
if (exitstatus)
exit( exitstatus );
TAINT;
if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* hello.p */
tmpsv = GvSV(tmpgv);
sv_setpv(tmpsv, argv[0]);
SvSETMAGIC(tmpsv);
}
if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
tmpsv = GvSV(tmpgv);
#ifdef WIN32
sv_setpv(tmpsv,"perl.exe");
#else
sv_setpv(tmpsv,"perl");
#endif
SvSETMAGIC(tmpsv);
}
TAINT_NOT;
/* PL_main_cv = PL_compcv; */
PL_compcv = 0;
exitstatus = perl_init();
if (exitstatus)
exit( exitstatus );
dl_init(aTHX);
exitstatus = perl_run( my_perl );
perl_destruct( my_perl );
perl_free( my_perl );
PERL_SYS_TERM();
exit( 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;
}
cPerlScript::~cPerlScript()
{
perl_destruct(mPerl);
perl_free(mPerl);
}
int
main(int argc, char **argv, char **env)
{
int exitstatus;
(void)env;
#ifndef PERL_USE_SAFE_PUTENV
PL_use_safe_putenv = 0;
#endif /* PERL_USE_SAFE_PUTENV */
#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
/* if user wants control of gprof profiling off by default */
/* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
PERL_GPROF_MONCONTROL(0);
PERL_SYS_INIT3(&argc,&argv,&env);
#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
/* XXX Ideally, this should really be happening in perl_alloc() or
* perl_construct() to keep libperl.a transparently fork()-safe.
* It is currently done here only because Apache/mod_perl have
* problems due to lack of a call to cancel pthread_atfork()
* handlers when shared objects that contain the handlers may
* be dlclose()d. This forces applications that embed perl to
* call PTHREAD_ATFORK() explicitly, but if and only if it hasn't
* been called at least once before in the current process.
* --GSAR 2001-07-20 */
PTHREAD_ATFORK(Perl_atfork_lock,
Perl_atfork_unlock,
Perl_atfork_unlock);
#endif
if (!PL_do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct(my_perl);
PL_perl_destruct_level = 0;
}
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
if (!exitstatus)
perl_run(my_perl);
exitstatus = perl_destruct(my_perl);
perl_free(my_perl);
PERL_SYS_TERM();
exit(exitstatus);
return exitstatus;
}
int main(int argc, char **argv, char **env) {
/*
#ifdef aTHX
dTHX;
#endif
*/
char *embedding[] = { "", "p1.pl" };
char *plugin_output ;
char fname[MAX_INPUT_CHARS];
char *args[] = {"", "0", "", "", NULL };
char command_line[MAX_INPUT_CHARS];
int exitstatus;
int pclose_result;
if((my_perl = perl_alloc()) == NULL) {
printf("%s\n", "Error: Could not allocate memory for embedded Perl interpreter!");
exit(1);
}
perl_construct(my_perl);
exitstatus = perl_parse(my_perl, xs_init, 2, embedding, NULL);
if(!exitstatus) {
exitstatus = perl_run(my_perl);
while(printf("Enter file name: ") && fgets(command_line, MAX_INPUT_CHARS - 1, stdin)) {
SV *plugin_hndlr_cr;
STRLEN n_a;
int count = 0 ;
dSP;
command_line[strlen(command_line) -1] = '\0';
strncpy(fname, command_line, strcspn(command_line, " "));
fname[strcspn(command_line, " ")] = '\x0';
args[0] = fname ;
args[3] = command_line + strlen(fname) + 1 ;
args[2] = "";
/* call our perl interpreter to compile and optionally cache the command */
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(args[0], 0)));
XPUSHs(sv_2mortal(newSVpv(args[1], 0)));
XPUSHs(sv_2mortal(newSVpv(args[2], 0)));
XPUSHs(sv_2mortal(newSVpv(args[3], 0)));
PUTBACK;
count = call_pv("Embed::Persistent::eval_file", G_SCALAR | G_EVAL);
SPAGAIN;
/* check return status */
if(SvTRUE(ERRSV)) {
(void) POPs;
pclose_result = -2;
printf("embedded perl ran %s with error %s\n", fname, SvPVX(ERRSV));
continue;
}
else {
plugin_hndlr_cr = newSVsv(POPs);
PUTBACK;
FREETMPS;
LEAVE;
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(args[0], 0)));
XPUSHs(sv_2mortal(newSVpv(args[1], 0)));
XPUSHs(plugin_hndlr_cr);
XPUSHs(sv_2mortal(newSVpv(args[3], 0)));
PUTBACK;
count = perl_call_pv("Embed::Persistent::run_package", G_EVAL | G_ARRAY);
SPAGAIN;
plugin_output = POPpx ;
pclose_result = POPi ;
printf("embedded perl plugin return code and output was: %d & '%s'\n", pclose_result, plugin_output);
PUTBACK;
FREETMPS;
LEAVE;
}
}
PL_perl_destruct_level = 0;
perl_destruct(my_perl);
perl_free(my_perl);
exit(exitstatus);
}
~interp() {
perl_destruct(my_perl);
perl_free(my_perl);
};
int init_psgi_app(struct wsgi_request *wsgi_req, char *app, uint16_t app_len, PerlInterpreter **interpreters) {
struct stat st;
int i;
SV **callables;
time_t now = uwsgi_now();
char *app_name = uwsgi_concat2n(app, app_len, "", 0);
// prepare for $0
uperl.embedding[1] = app_name;
int fd = open(app_name, O_RDONLY);
if (fd < 0) {
uwsgi_error_open(app_name);
goto clear2;
}
if (fstat(fd, &st)) {
uwsgi_error("fstat()");
close(fd);
goto clear2;
}
char *buf = uwsgi_calloc(st.st_size+1);
if (read(fd, buf, st.st_size) != st.st_size) {
uwsgi_error("read()");
close(fd);
free(buf);
goto clear2;
}
close(fd);
// the first (default) app, should always be loaded in the main interpreter
if (interpreters == NULL) {
if (uwsgi_apps_cnt) {
interpreters = uwsgi_calloc(sizeof(PerlInterpreter *) * uwsgi.threads);
interpreters[0] = uwsgi_perl_new_interpreter();
if (!interpreters[0]) {
uwsgi_log("unable to create new perl interpreter\n");
free(interpreters);
goto clear2;
}
}
else {
interpreters = uperl.main;
}
}
if (!interpreters) {
goto clear2;
}
callables = uwsgi_calloc(sizeof(SV *) * uwsgi.threads);
uperl.tmp_streaming_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads);
uperl.tmp_input_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads);
uperl.tmp_error_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads);
uperl.tmp_stream_responder = uwsgi_calloc(sizeof(CV *) * uwsgi.threads);
uperl.tmp_psgix_logger = uwsgi_calloc(sizeof(CV *) * uwsgi.threads);
for(i=0;i<uwsgi.threads;i++) {
if (i > 0 && interpreters != uperl.main) {
interpreters[i] = uwsgi_perl_new_interpreter();
if (!interpreters[i]) {
uwsgi_log("unable to create new perl interpreter\n");
// what to do here ? i hope no-one will use threads with dynamic apps...but clear the whole stuff...
free(callables);
uwsgi_perl_free_stashes();
while(i>=0) {
perl_destruct(interpreters[i]);
perl_free(interpreters[i]);
goto clear2;
}
}
}
PERL_SET_CONTEXT(interpreters[i]);
uperl.tmp_current_i = i;
if (uperl.locallib) {
uwsgi_log("using %s as local::lib directory\n", uperl.locallib);
uperl.embedding[1] = uwsgi_concat2("-Mlocal::lib=", uperl.locallib);
uperl.embedding[2] = app_name;
if (perl_parse(interpreters[i], xs_init, 3, uperl.embedding, NULL)) {
// what to do here ? i hope no-one will use threads with dynamic apps... but clear the whole stuff...
free(uperl.embedding[1]);
uperl.embedding[1] = app_name;
free(callables);
uwsgi_perl_free_stashes();
goto clear;
}
free(uperl.embedding[1]);
uperl.embedding[1] = app_name;
}
else {
if (perl_parse(interpreters[i], xs_init, 2, uperl.embedding, NULL)) {
// what to do here ? i hope no-one will use threads with dynamic apps... but clear the whole stuff...
free(callables);
uwsgi_perl_free_stashes();
goto clear;
}
}
perl_eval_pv("use IO::Handle;", 0);
perl_eval_pv("use IO::File;", 0);
perl_eval_pv("use Scalar::Util;", 0);
if (!uperl.no_die_catch) {
perl_eval_pv("use Devel::StackTrace;", 0);
if (!SvTRUE(ERRSV)) {
uperl.stacktrace_available = 1;
perl_eval_pv("$SIG{__DIE__} = \\&uwsgi::stacktrace;", 0);
}
}
SV *dollar_zero = get_sv("0", GV_ADD);
sv_setsv(dollar_zero, newSVpv(app, app_len));
callables[i] = perl_eval_pv(uwsgi_concat4("#line 1 ", app_name, "\n", buf), 0);
if (!callables[i]) {
uwsgi_log("unable to find PSGI function entry point.\n");
// what to do here ? i hope no-one will use threads with dynamic apps...
free(callables);
uwsgi_perl_free_stashes();
goto clear;
}
PERL_SET_CONTEXT(interpreters[0]);
}
free(buf);
if(SvTRUE(ERRSV)) {
uwsgi_log("%s\n", SvPV_nolen(ERRSV));
free(callables);
uwsgi_perl_free_stashes();
goto clear;
}
if (uwsgi_apps_cnt >= uwsgi.max_apps) {
uwsgi_log("ERROR: you cannot load more than %d apps in a worker\n", uwsgi.max_apps);
goto clear;
}
int id = uwsgi_apps_cnt;
struct uwsgi_app *wi = NULL;
if (wsgi_req) {
// we need a copy of app_id
wi = uwsgi_add_app(id, psgi_plugin.modifier1, uwsgi_concat2n(wsgi_req->appid, wsgi_req->appid_len, "", 0), wsgi_req->appid_len, interpreters, callables);
}
else {
wi = uwsgi_add_app(id, psgi_plugin.modifier1, "", 0, interpreters, callables);
}
wi->started_at = now;
wi->startup_time = uwsgi_now() - now;
uwsgi_log("PSGI app %d (%s) loaded in %d seconds at %p (interpreter %p)\n", id, app_name, (int) wi->startup_time, callables[0], interpreters[0]);
free(app_name);
// copy global data to app-specific areas
wi->stream = uperl.tmp_streaming_stash;
wi->input = uperl.tmp_input_stash;
wi->error = uperl.tmp_error_stash;
wi->responder0 = uperl.tmp_stream_responder;
wi->responder1 = uperl.tmp_psgix_logger;
uwsgi_emulate_cow_for_apps(id);
// restore context if required
if (interpreters != uperl.main) {
PERL_SET_CONTEXT(uperl.main[0]);
}
return id;
clear:
if (interpreters != uperl.main) {
for(i=0;i<uwsgi.threads;i++) {
perl_destruct(interpreters[i]);
perl_free(interpreters[i]);
}
free(interpreters);
}
PERL_SET_CONTEXT(uperl.main[0]);
clear2:
free(app_name);
return -1;
}
static PerlInterpreter *
ngx_http_perl_create_interpreter(ngx_conf_t *cf,
ngx_http_perl_main_conf_t *pmcf)
{
int n;
STRLEN len;
SV *sv;
char *ver, *embedding[6];
PerlInterpreter *perl;
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, cf->log, 0, "create perl interpreter");
if (ngx_set_environment(cf->cycle, NULL) == NULL) {
return NULL;
}
perl = perl_alloc();
if (perl == NULL) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0, "perl_alloc() failed");
return NULL;
}
{
dTHXa(perl);
PERL_SET_CONTEXT(perl);
perl_construct(perl);
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
embedding[0] = "";
if (pmcf->modules.data) {
embedding[1] = "-I";
embedding[2] = (char *) pmcf->modules.data;
n = 3;
} else {
n = 1;
}
embedding[n++] = "-Mnginx";
embedding[n++] = "-e";
embedding[n++] = "0";
n = perl_parse(perl, ngx_http_perl_xs_init, n, embedding, NULL);
if (n != 0) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0, "perl_parse() failed: %d", n);
goto fail;
}
sv = get_sv("nginx::VERSION", FALSE);
ver = SvPV(sv, len);
if (ngx_strcmp(ver, NGINX_VERSION) != 0) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0,
"version " NGINX_VERSION " of nginx.pm is required, "
"but %s was found", ver);
goto fail;
}
if (ngx_http_perl_run_requires(aTHX_ &pmcf->requires, cf->log) != NGX_OK) {
goto fail;
}
}
return perl;
fail:
(void) perl_destruct(perl);
perl_free(perl);
return NULL;
}
void perl_embed_clean() {
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SYS_TERM();
}
/*
* Clear up after thread is done with
*/
void
Perl_ithread_destruct (pTHX_ ithread* thread, const char *why)
{
PerlInterpreter *freeperl = NULL;
MUTEX_LOCK(&thread->mutex);
if (!thread->next) {
Perl_croak(aTHX_ "panic: destruct destroyed thread %p (%s)",thread, why);
}
if (thread->count != 0) {
MUTEX_UNLOCK(&thread->mutex);
return;
}
MUTEX_LOCK(&create_destruct_mutex);
/* Remove from circular list of threads */
if (thread->next == thread) {
/* last one should never get here ? */
threads = NULL;
}
else {
thread->next->prev = thread->prev;
thread->prev->next = thread->next;
if (threads == thread) {
threads = thread->next;
}
thread->next = NULL;
thread->prev = NULL;
}
known_threads--;
assert( known_threads >= 0 );
#if 0
Perl_warn(aTHX_ "destruct %d @ %p by %p now %d",
thread->tid,thread->interp,aTHX, known_threads);
#endif
MUTEX_UNLOCK(&create_destruct_mutex);
/* Thread is now disowned */
if(thread->interp) {
dTHXa(thread->interp);
ithread* current_thread;
#ifdef OEMVS
void *ptr;
#endif
PERL_SET_CONTEXT(thread->interp);
current_thread = Perl_ithread_get(aTHX);
Perl_ithread_set(aTHX_ thread);
SvREFCNT_dec(thread->params);
thread->params = Nullsv;
perl_destruct(thread->interp);
freeperl = thread->interp;
thread->interp = NULL;
}
MUTEX_UNLOCK(&thread->mutex);
MUTEX_DESTROY(&thread->mutex);
#ifdef WIN32
if (thread->handle)
CloseHandle(thread->handle);
thread->handle = 0;
#endif
PerlMemShared_free(thread);
if (freeperl)
perl_free(freeperl);
PERL_SET_CONTEXT(aTHX);
}
int Perl5_Run(int myargc, char **myargv, int mode, int fCheck, int keepcwd, char *source, char **env, char *perlscript, char *perlstderr, char *perlstdout)
{
DECL_EXRC;
FILE *er;
FILE *out;
char *cpBuf = NULL;
char sourcedir[2048];
char *cp;
static PerlInterpreter *my_perl = NULL;
struct stat st;
int size;
char cwd[MAXPATHLEN];
/* open a file for Perl's STDOUT channel
and redirect stdout to the new channel */
if ((out = fopen(perlstdout, "w")) == NULL) {
PrintError(mode, source, NULL, NULL, "Cannot open STDOUT file `%s' for writing", perlstdout);
CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
}
IO_redirect_stdout(out);
/* open a file for Perl's STDERR channel
and redirect stderr to the new channel */
if ((er = fopen(perlstderr, "w")) == NULL) {
PrintError(mode, source, NULL, NULL, "Cannot open STDERR file `%s' for writing", perlstderr);
CU(mode == MODE_FILTER ? EX_IOERR : EX_OK);
}
IO_redirect_stderr(er);
my_perl = perl_alloc();
perl_construct(my_perl);
perl_init_i18nl10n(1);
/* now parse the script!
NOTICE: At this point, the script gets
only _parsed_, not evaluated/executed! */
#ifdef HAVE_PERL_DYNALOADER
rc = perl_parse(my_perl, Perl5_XSInit, myargc, myargv, env);
#else
rc = perl_parse(my_perl, NULL, myargc, myargv, env);
#endif
if (rc != 0) {
if (fCheck && mode == MODE_FILTER) {
fclose(er); er = NULL;
IO_restore_stdout();
IO_restore_stderr();
if ((cpBuf = ePerl_ReadErrorFile(perlstderr, perlscript, source)) != NULL) {
fprintf(stderr, cpBuf);
}
CU(EX_FAIL);
}
else {
fclose(er); er = NULL;
PrintError(mode, source, perlscript, perlstderr, "Perl parsing error (interpreter rc=%d)", rc);
CU(mode == MODE_FILTER ? EX_FAIL : EX_OK);
}
}
/* Stop when we are just doing a syntax check */
if (fCheck && mode == MODE_FILTER) {
fclose(er); er = NULL;
IO_restore_stdout();
IO_restore_stderr();
fprintf(stderr, "%s syntax OK\n", source);
CU(-1);
}
/* change to directory of script:
this actually is not important to us, but really useful
for the ePerl source file programmer!! */
cwd[0] = NUL;
if (!keepcwd) {
/* if running as a Unix filter remember the cwd for outputfile */
if (mode == MODE_FILTER)
getcwd(cwd, MAXPATHLEN);
/* determine dir of source file and switch to it */
strncpy(sourcedir, source, sizeof(sourcedir));
sourcedir[sizeof(sourcedir)-1] = NUL;
for (cp = sourcedir+strlen(sourcedir); cp > sourcedir && *cp != '/'; cp--)
;
*cp = NUL;
chdir(sourcedir);
}
/* Set the previously remembered Perl 5 scalars (option -d) */
Perl5_SetRememberedScalars(aTHX);
/* Force unbuffered I/O */
Perl5_ForceUnbufferedStdout(aTHX);
/* NOW IT IS TIME to evaluate/execute the script!!! */
rc = perl_run(my_perl);
/* pre-close the handles, to be able to check
its size and to be able to display the contents */
fclose(out); out = NULL;
fclose(er); er = NULL;
/* ok, now recover the stdout and stderr */
IO_restore_stdout();
IO_restore_stderr();
/* when the Perl interpreter failed or there
is data on stderr, we print a error page */
if (stat(perlstderr, &st) == 0)
size = st.st_size;
else
size = 0;
if (rc != 0 || size > 0) {
PrintError(mode, source, perlscript, perlstderr, "Perl runtime error (interpreter rc=%d)", rc);
CU(mode == MODE_FILTER ? EX_FAIL : EX_OK);
}
CUS: /* the Clean Up Sequence */
/* Ok, the script got evaluated. Now we can destroy
and de-allocate the Perl interpreter */
if (my_perl) {
perl_destruct(my_perl);
perl_free(my_perl);
}
return rc;
}
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);
}
/* ------------------------------------------------------- destroy_parser --- */
void
destroy_parser()
{
perl_destruct(perl_interp);
perl_free(perl_interp);
}
int
weechat_perl_load (const char *filename)
{
struct t_plugin_script temp_script;
struct stat buf;
char *perl_code;
int length;
#ifndef MULTIPLICITY
char pkgname[64];
#endif /* MULTIPLICITY */
temp_script.filename = NULL;
temp_script.interpreter = NULL;
temp_script.name = NULL;
temp_script.author = NULL;
temp_script.version = NULL;
temp_script.license = NULL;
temp_script.description = NULL;
temp_script.shutdown_func = NULL;
temp_script.charset = NULL;
if (stat (filename, &buf) != 0)
{
weechat_printf (NULL,
weechat_gettext ("%s%s: script \"%s\" not found"),
weechat_prefix ("error"), PERL_PLUGIN_NAME, filename);
return 0;
}
if ((weechat_perl_plugin->debug >= 2) || !perl_quiet)
{
weechat_printf (NULL,
weechat_gettext ("%s: loading script \"%s\""),
PERL_PLUGIN_NAME, filename);
}
perl_current_script = NULL;
perl_current_script_filename = filename;
perl_registered_script = NULL;
#ifdef MULTIPLICITY
perl_current_interpreter = perl_alloc();
if (!perl_current_interpreter)
{
weechat_printf (NULL,
weechat_gettext ("%s%s: unable to create new "
"sub-interpreter"),
weechat_prefix ("error"), PERL_PLUGIN_NAME);
return 0;
}
PERL_SET_CONTEXT (perl_current_interpreter);
perl_construct (perl_current_interpreter);
temp_script.interpreter = (PerlInterpreter *) perl_current_interpreter;
perl_parse (perl_current_interpreter, weechat_perl_api_init,
perl_args_count, perl_args, NULL);
length = strlen (perl_weechat_code) - 2 + strlen (filename) + 1;
perl_code = malloc (length);
if (!perl_code)
return 0;
snprintf (perl_code, length, perl_weechat_code, filename);
#else
snprintf (pkgname, sizeof (pkgname), "%s%d", PKG_NAME_PREFIX, perl_num);
perl_num++;
length = strlen (perl_weechat_code) - 4 + strlen (pkgname) + strlen (filename) + 1;
perl_code = malloc (length);
if (!perl_code)
return 0;
snprintf (perl_code, length, perl_weechat_code, pkgname, filename);
#endif /* MULTIPLICITY */
eval_pv (perl_code, TRUE);
free (perl_code);
if (SvTRUE (ERRSV))
{
weechat_printf (NULL,
weechat_gettext ("%s%s: unable to parse file "
"\"%s\""),
weechat_prefix ("error"), PERL_PLUGIN_NAME,
filename);
weechat_printf (NULL,
weechat_gettext ("%s%s: error: %s"),
weechat_prefix ("error"), PERL_PLUGIN_NAME,
SvPV_nolen(ERRSV));
#ifdef MULTIPLICITY
perl_destruct (perl_current_interpreter);
perl_free (perl_current_interpreter);
#endif /* MULTIPLICITY */
if (perl_current_script && (perl_current_script != &temp_script))
{
plugin_script_remove (weechat_perl_plugin,
&perl_scripts, &last_perl_script,
perl_current_script);
perl_current_script = NULL;
}
return 0;
}
if (!perl_registered_script)
{
weechat_printf (NULL,
weechat_gettext ("%s%s: function \"register\" not "
"found (or failed) in file \"%s\""),
weechat_prefix ("error"), PERL_PLUGIN_NAME, filename);
#ifdef MULTIPLICITY
perl_destruct (perl_current_interpreter);
perl_free (perl_current_interpreter);
#endif /* MULTIPLICITY */
return 0;
}
perl_current_script = perl_registered_script;
#ifndef MULTIPLICITY
perl_current_script->interpreter = strdup (pkgname);
#endif /* MULTIPLICITY */
/*
* set input/close callbacks for buffers created by this script
* (to restore callbacks after upgrade)
*/
plugin_script_set_buffer_callbacks (weechat_perl_plugin,
perl_scripts,
perl_current_script,
&weechat_perl_api_buffer_input_data_cb,
&weechat_perl_api_buffer_close_cb);
(void) weechat_hook_signal_send ("perl_script_loaded",
WEECHAT_HOOK_SIGNAL_STRING,
perl_current_script->filename);
return 1;
}
void IvrPython::run(){
FILE* fp;
int retval;
#ifndef IVR_PERL
pthread_setcancelstate(PTHREAD_CANCEL_ENABLE, 0);
#endif //IVR_PERL
// static PyThreadState* pyMainThreadState;
fp = fopen((char*)fileName,"r");
if(fp != NULL){
#ifndef IVR_PERL
PyMethodDef extIvrPython[] = {
// media functions
{"enqueueMediaFile", ivrEnqueueMediaFile, METH_VARARGS, "ivr: enqueue media file. "
"filename: string, front : int = 1(default true) "},
{"emptyMediaQueue", ivrEmptyMediaQueue, METH_VARARGS, "ivr: empty the media queue."},
{"startRecording", ivrStartRecording, METH_VARARGS, "ivr: start recording to file. filename : string."},
{"stopRecording", ivrStopRecording, METH_VARARGS, "ivr: stop recording to file."},
#ifdef IVR_WITH_TTS
{"say", ivrSay, METH_VARARGS, "ivr tts and enqueue. msg: string, front: boolean "},
#endif //IVR_WITH_TTS
// DTMF functions
{"enableDTMFDetection", ivrEnableDTMFDetection, METH_VARARGS, "enable DTMF detection. "
"setCallback(onDTMF_FUNC, \"onDTMF\") first!"},
{"disableDTMFDetection", ivrDisableDTMFDetection, METH_VARARGS, "disable DTMF detection permanently"},
{"pauseDTMFDetection", ivrPauseDTMFDetection, METH_VARARGS, "pause DTMF detection temporarily, can be resumed"},
{"resumeDTMFDetection", ivrResumeDTMFDetection, METH_VARARGS, "resume DTMF detection"},
// informational
{"getTime", ivrGetTime, METH_VARARGS, "Example Module"},
{"getFrom", ivrGetFrom, METH_VARARGS, "Example Module"},
{"getTo", ivrGetTo, METH_VARARGS, "Example Module"},
{"getFromURI", ivrGetFromURI, METH_VARARGS, "Example Module"},
{"getToURI", ivrGetToURI, METH_VARARGS, "Example Module"},
{"getDomain", ivrGetDomain, METH_VARARGS, "Example Module"},
// call transfer functions
{"redirect", ivrRedirect, METH_VARARGS, "Example Module"},
{"dialout", ivrDialout, METH_VARARGS, "Example Module"},
// setting callbacks
{"setCallback", setCallback, METH_VARARGS, "Example Module"},
{"sleep", ivrSleep, METH_VARARGS, "Sleep n seconds, or until wakeUp"},
{"usleep", ivrUSleep, METH_VARARGS, "Sleep n microseconds, or until wakeUp"},
{"msleep", ivrmSleep, METH_VARARGS, "Sleep n milliseconds, or until wakeUp"},
{"wakeUp", ivrWakeUp, METH_VARARGS, "wake Up from sleep"},
// legacy from old ivr: sequential functions
{"play", ivrPlay, METH_VARARGS, "play and wait for the end of the file (queue empty)"},
{"record", ivrRecord, METH_VARARGS, "record maximum of time secs. Parameter: filename : string, timeout = 0 : int"},
{"playAndDetect", ivrPlayAndDetect, METH_VARARGS, "play and wait for the end of the file (queue empty) or keypress"},
{"detect", ivrDetect, METH_VARARGS, "detect until timeout Parameter: timeout = 0 : int"},
// for jitter/clock skew generation test only
// DONT CALL THIS FUNCTION
{"mediaThreadUSleep", ivrMediaThreadUSleep, METH_VARARGS, "let mthr sleep, dont call this function"},
{NULL, NULL, 0, NULL},
};
if(!Py_IsInitialized()){
DBG("Start" SCRIPT_TYPE "\n");
Py_Initialize();
PyEval_InitThreads();
pyMainThreadState = PyEval_SaveThread();
}
DBG("Start new" SCRIPT_TYPE "interpreter\n");
PyEval_AcquireLock();
// PyThreadState* pyThreadState;
if ( (mainInterpreterThreadState = Py_NewInterpreter()) != NULL){
PyObject* ivrPyInitModule = Py_InitModule(PY_MOD_NAME, extIvrPython);
PyObject* ivrPythonPointer = PyCObject_FromVoidPtr((void*)this,NULL);
if (ivrPythonPointer != NULL)
PyModule_AddObject(ivrPyInitModule, "ivrPythonPointer", ivrPythonPointer);
Py_tracefunc tmp_t = pythonTrace;
PyEval_SetTrace(tmp_t, PyCObject_FromVoidPtr((void*)this,NULL));
if(!PyRun_SimpleFile(fp,(char*)fileName)){
fclose(fp);
retval = 0;// true;
}
else{
PyErr_Print();
ERROR("IVR" SCRIPT_TYPE "Error: Failed to run \"%s\"\n", (char*)fileName);
retval = -1;// false;
}
Py_EndInterpreter(mainInterpreterThreadState);
}
else{
ERROR("IVR" SCRIPT_TYPE "Error: Failed to start new interpreter.\n");
}
PyEval_ReleaseLock();
#else //IVR_PERL
DBG("Start" SCRIPT_TYPE ", about to alloc\n");
my_perl_interp = perl_alloc();
printf("interp is %ld\n", (long) my_perl_interp);
printf("filename is %s\n", fileName);
DBG("finished alloc Perl, about to construct Perl\n");
perl_construct(my_perl_interp);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
char *embedding[] = { "", (char*)fileName};
DBG("finished construct Perl, about to parse Perl\n");
perl_parse(my_perl_interp, xs_init, 2, embedding, (char **)NULL);
DBG("finished parse Perl, about to run Perl\n");
SV *pivr = get_sv("Ivr::__ivrpointer__", TRUE);
DBG("Ivr::__ivrpointer__ is %lx.\n", (unsigned long int) pivr);
sv_setuv(pivr, (unsigned int) this);
perl_run(my_perl_interp);
DBG("finished run Perl, about to sleep 5 seconds to let callback event catch up\n");
sleep(5);
DBG("after sleep, about to destruct\n");
perl_destruct(my_perl_interp);
DBG("finished destruct Perl, about to free\n");
perl_free(my_perl_interp);
#endif //IVR_PERL
}
else{
ERROR("IVR" SCRIPT_TYPE "Error: Can not open file \"%s\"\n",(char*) fileName);
retval = -1;// false;
}
DBG("IVR: run finished. stopping rtp stream...\n");
pAmSession->rtp_str.pause();
}
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;
}
void deinit_embedded_perl(void){
PL_perl_destruct_level=0;
perl_destruct(my_perl);
perl_free(my_perl);
}
static void* run_thread(void* arg) {
mthread* thread = (mthread*) arg;
PerlInterpreter* my_perl = construct_perl();
const message *to_run, *modules, *message;
SV *call, *status;
perl_mutex* shutdown_mutex;
thread->interp = my_perl;
#ifndef WIN32
S_set_sigmask(&thread->initial_sigmask);
#endif
PERL_SET_CONTEXT(my_perl);
store_self(my_perl, thread);
{
dSP;
modules = queue_dequeue(thread->queue, NULL);
load_modules(my_perl, modules);
to_run = queue_dequeue(thread->queue, NULL);
ENTER;
SAVETMPS;
call = SvRV(message_load_value(to_run));
PUSHMARK(SP);
mXPUSHs(newSVpvn("exit", 4));
status = newSVpvn("normal", 6);
mXPUSHs(status);
mXPUSHs(newSViv(thread->id));
ENTER;
PUSHMARK(SP);
PUTBACK;
call_sv(call, G_SCALAR|G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
sv_setpvn(status, "error", 5);
warn("Thread %"UVuf" got error %s\n", thread->id, SvPV_nolen(ERRSV));
PUSHs(ERRSV);
}
message_from_stack_pushed(message);
LEAVE;
send_listeners(thread, message);
destroy_message(message);
FREETMPS;
LEAVE;
}
shutdown_mutex = get_shutdown_mutex();
MUTEX_LOCK(shutdown_mutex);
perl_destruct(my_perl);
MUTEX_UNLOCK(shutdown_mutex);
mthread_destroy(thread);
PerlMemShared_free(thread);
perl_free(my_perl);
return NULL;
}
void swiftperl_deinit() {
perl_destruct(my_perl);
perl_free(my_perl);
my_perl = NULL;
}
int unload_perl(PerlInterpreter *p) {
perl_destruct(p);
perl_free(p);
return 0;
}
static PerlInterpreter *
ngx_http_perl_create_interpreter(ngx_conf_t *cf,
ngx_http_perl_main_conf_t *pmcf)
{
int n;
STRLEN len;
SV *sv;
char *ver, **embedding;
ngx_str_t *m;
ngx_uint_t i;
PerlInterpreter *perl;
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, cf->log, 0, "create perl interpreter");
if (ngx_set_environment(cf->cycle, NULL) == NULL) {
return NULL;
}
perl = perl_alloc();
if (perl == NULL) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0, "perl_alloc() failed");
return NULL;
}
{
dTHXa(perl);
PERL_SET_CONTEXT(perl);
perl_construct(perl);
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
n = (pmcf->modules != NGX_CONF_UNSET_PTR) ? pmcf->modules->nelts * 2 : 0;
embedding = ngx_palloc(cf->pool, (4 + n) * sizeof(char *));
if (embedding == NULL) {
goto fail;
}
embedding[0] = "";
if (n++) {
m = pmcf->modules->elts;
for (i = 0; i < pmcf->modules->nelts; i++) {
embedding[2 * i + 1] = "-I";
embedding[2 * i + 2] = (char *) m[i].data;
}
}
embedding[n++] = "-Mnginx";
embedding[n++] = "-e";
embedding[n++] = "0";
n = perl_parse(perl, ngx_http_perl_xs_init, n, embedding, NULL);
if (n != 0) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0, "perl_parse() failed: %d", n);
goto fail;
}
sv = get_sv("nginx::VERSION", FALSE);
ver = SvPV(sv, len);
if (ngx_strcmp(ver, NGINX_VERSION) != 0) {
ngx_log_error(NGX_LOG_ALERT, cf->log, 0,
"version " NGINX_VERSION " of nginx.pm is required, "
"but %s was found", ver);
goto fail;
}
if (ngx_http_perl_run_requires(aTHX_ pmcf->requires, cf->log) != NGX_OK) {
goto fail;
}
}
return perl;
fail:
(void) perl_destruct(perl);
perl_free(perl);
return NULL;
}