/* Initialize perl interpreter */
void perl_scripts_init(void)
{
char *code, *use_code;
perl_scripts = NULL;
perl_sources_start();
perl_signals_start();
my_perl = perl_alloc();
perl_construct(my_perl);
perl_parse(my_perl, xs_init, G_N_ELEMENTS(perl_args), perl_args, NULL);
#if PERL_STATIC_LIBS == 1
perl_eval_pv("Irssi::Core::->boot_Irssi_Core(0.9);", TRUE);
#endif
perl_common_start();
use_code = perl_get_use_list();
code = g_strdup_printf(irssi_core_code, PERL_STATIC_LIBS, use_code);
perl_eval_pv(code, TRUE);
g_free(code);
g_free(use_code);
}
main (int argc, char **argv, char **env)
{
STRLEN n_a;
char *embedding[] = { "", "-e", "0" };
my_perl = perl_alloc();
perl_construct( my_perl );
perl_parse(my_perl, NULL, 3, embedding, NULL);
perl_run(my_perl);
/** Treat $a as an integer **/
perl_eval_pv("$a = 3; $a **= 2", TRUE);
printf("a = %d\n", SvIV(perl_get_sv("a", FALSE)));
/** Treat $a as a float **/
perl_eval_pv("$a = 3.14; $a **= 2", TRUE);
printf("a = %f\n", SvNV(perl_get_sv("a", FALSE)));
/** Treat $a as a string **/
perl_eval_pv("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a);", TRUE);
printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), n_a));
perl_destruct(my_perl);
perl_free(my_perl);
}
static void coroae_loop() {
if (uwsgi.async < 2) {
if (uwsgi.mywid == 1) {
uwsgi_log("the Coro::AnyEvent loop engine requires async mode (--async <n>)\n");
}
exit(1);
}
if (!uperl.loaded) {
uwsgi_log("no perl/PSGI code loaded (with --psgi), unable to initialize Coro::AnyEvent\n");
exit(1);
}
perl_eval_pv("use Coro;", 0);
if (SvTRUE(ERRSV)) {
uwsgi_log("unable to load Coro module\n");
exit(1);
}
perl_eval_pv("use AnyEvent;", 0);
if (SvTRUE(ERRSV)) {
uwsgi_log("unable to load AnyEvent module\n");
exit(1);
}
perl_eval_pv("use Coro::AnyEvent;", 0);
if (SvTRUE(ERRSV)) {
uwsgi_log("unable to load Coro::AnyEvent module\n");
exit(1);
}
uwsgi.current_wsgi_req = coroae_current_wsgi_req;
uwsgi.wait_write_hook = coroae_wait_fd_write;
uwsgi.wait_read_hook = coroae_wait_fd_read;
I_CORO_API("uwsgi::coroae");
// create signal watchers
if (uwsgi.signal_socket > -1) {
coroae_add_watcher(uwsgi.signal_socket, (SV *) coroae_closure_sighandler(uwsgi.signal_socket));
coroae_add_watcher(uwsgi.my_signal_socket, (SV *) coroae_closure_sighandler(uwsgi.my_signal_socket));
}
struct uwsgi_socket *uwsgi_sock = uwsgi.sockets;
while(uwsgi_sock) {
// check return value here
coroae_add_watcher(uwsgi_sock->fd, (SV *) coroae_closure_acceptor(uwsgi_sock));
uwsgi_sock = uwsgi_sock->next;
};
SV *condvar = coroae_condvar_new();
coroae_wait_condvar(condvar);
if (uwsgi.workers[uwsgi.mywid].manage_next_request == 0) {
uwsgi_log("goodbye to the Coro::AnyEvent loop on worker %d (pid: %d)\n", uwsgi.mywid, uwsgi.mypid);
exit(UWSGI_RELOAD_CODE);
}
uwsgi_log("the Coro::AnyEvent loop is no more :(\n");
}
static void coroae_loop() {
if (uwsgi.async < 1) {
if (uwsgi.mywid == 1) {
uwsgi_log("the Coro::AnyEvent loop engine requires async mode (--async <n>)\n");
}
exit(1);
}
if (!uperl.loaded) {
uwsgi_log("no perl/PSGI code loaded (with --psgi), unable to initialize Coro::AnyEvent\n");
exit(1);
}
perl_eval_pv("use Coro;", 1);
perl_eval_pv("use AnyEvent;", 1);
perl_eval_pv("use Coro::AnyEvent;", 1);
uwsgi.current_wsgi_req = coroae_current_wsgi_req;
uwsgi.wait_write_hook = coroae_wait_fd_write;
uwsgi.wait_read_hook = coroae_wait_fd_read;
uwsgi.wait_milliseconds_hook = coroae_wait_milliseconds;
I_CORO_API("uwsgi::coroae");
// patch goodbye_cruel_world
uwsgi.gbcw_hook = coroae_gbcw;
ucoroae.watchers = newAV();
av_push(ucoroae.watchers, coroae_add_signal_watcher("HUP", newXS(NULL, XS_coroae_hup_sighandler, "uwsgi::coroae")));
av_push(ucoroae.watchers, coroae_add_signal_watcher("INT", newXS(NULL, XS_coroae_int_sighandler, "uwsgi::coroae")));
av_push(ucoroae.watchers, coroae_add_signal_watcher("TERM", newXS(NULL, XS_coroae_int_sighandler, "uwsgi::coroae")));
// create signal watchers
if (uwsgi.signal_socket > -1) {
av_push(ucoroae.watchers, coroae_add_watcher(uwsgi.signal_socket, coroae_closure_sighandler(uwsgi.signal_socket)));
av_push(ucoroae.watchers, coroae_add_watcher(uwsgi.my_signal_socket, coroae_closure_sighandler(uwsgi.my_signal_socket)));
}
struct uwsgi_socket *uwsgi_sock = uwsgi.sockets;
while(uwsgi_sock) {
// check return value here
av_push(ucoroae.watchers, coroae_add_watcher(uwsgi_sock->fd, coroae_closure_acceptor(uwsgi_sock)));
uwsgi_sock = uwsgi_sock->next;
};
ucoroae.condvar = coroae_condvar_new();
coroae_condvar_call(ucoroae.condvar, "recv");
SvREFCNT_dec(ucoroae.condvar);
if (uwsgi.workers[uwsgi.mywid].manage_next_request == 0) {
uwsgi_log("goodbye to the Coro::AnyEvent loop on worker %d (pid: %d)\n", uwsgi.mywid, uwsgi.mypid);
exit(UWSGI_RELOAD_CODE);
}
uwsgi_log("the Coro::AnyEvent loop is no more :(\n");
}
void
do_something_perlish(char *something)
{
if (netsnmp_ds_get_boolean(NETSNMP_DS_APPLICATION_ID,
NETSNMP_DS_AGENT_DISABLE_PERL)) {
return;
}
maybe_source_perl_startup();
if (netsnmp_ds_get_boolean(NETSNMP_DS_APPLICATION_ID,
NETSNMP_DS_AGENT_DISABLE_PERL)) {
return;
}
DEBUGMSGTL(("perl", "calling perl\n"));
#if defined(HAVE_EVAL_PV) || defined(eval_pv)
/* newer perl */
eval_pv(something, TRUE);
#else
#if defined(HAVE_PERL_EVAL_PV_LC) || defined(perl_eval_pv)
/* older perl? */
perl_eval_pv(something, TRUE);
#else /* HAVE_PERL_EVAL_PV_LC */
#ifdef HAVE_PERL_EVAL_PV_UC
/* older perl? */
Perl_eval_pv(my_perl, something, TRUE);
#else /* !HAVE_PERL_EVAL_PV_UC */
#error embedded perl broken
#endif /* !HAVE_PERL_EVAL_PV_LC */
#endif /* !HAVE_PERL_EVAL_PV_UC */
#endif /* !HAVE_EVAL_PV */
DEBUGMSGTL(("perl", "finished calling perl\n"));
}
/* Destroy all perl scripts and deinitialize perl interpreter */
void perl_scripts_deinit(void)
{
if (my_perl == NULL)
return;
/* unload all scripts */
while (perl_scripts != NULL)
perl_script_unload(perl_scripts->data);
signal_emit("perl scripts deinit", 0);
perl_signals_stop();
perl_sources_stop();
perl_common_stop();
/* Unload all perl libraries loaded with dynaloader */
perl_eval_pv("foreach my $lib (@DynaLoader::dl_modules) { if ($lib =~ /^Irssi\\b/) { $lib .= '::deinit();'; eval $lib; } }", TRUE);
/* We could unload all libraries .. but this crashes with some
libraries, probably because we don't call some deinit function..
Anyway, this would free some memory with /SCRIPT RESET, but it
leaks memory anyway. */
/*perl_eval_pv("eval { foreach my $lib (@DynaLoader::dl_librefs) { DynaLoader::dl_unload_file($lib); } }", TRUE);*/
/* perl interpreter */
perl_destruct(my_perl);
perl_free(my_perl);
my_perl = NULL;
}
static void cmd_perl(const char *data)
{
dSP;
GString *code;
char *uses;
SV *sv;
ENTER;
SAVETMPS;
PUSHMARK(SP);
code = g_string_new(NULL);
uses = perl_get_use_list();
g_string_sprintf(code, "sub { use Irssi;%s\n%s }", uses, data);
sv = perl_eval_pv(code->str, TRUE);
perl_call_sv(sv, G_VOID|G_NOARGS|G_EVAL|G_DISCARD);
g_free(uses);
g_string_free(code, TRUE);
SPAGAIN;
if (SvTRUE(ERRSV)) {
STRLEN n_a;
signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a));
}
PUTBACK;
FREETMPS;
LEAVE;
}
static void irssi_perl_start(void)
{
/* stolen from xchat, thanks :) */
char *args[] = {"", "-e", "0"};
char load_file[] =
"sub load_file()\n"
"{\n"
" (my $file_name) = @_;\n"
" open FH, $file_name or return \"File not found: $file_name\";\n"
" local($/) = undef;\n"
" $file = <FH>;\n"
" close FH;\n"
" eval $file;\n"
" eval $file if $@;\n"
" return $@ if $@;\n"
"}";
first_signals = g_hash_table_new((GHashFunc) g_direct_hash, (GCompareFunc) g_direct_equal);
last_signals = g_hash_table_new((GHashFunc) g_direct_hash, (GCompareFunc) g_direct_equal);
perl_timeouts = NULL;
irssi_perl_interp = perl_alloc();
perl_construct(irssi_perl_interp);
perl_parse(irssi_perl_interp, xs_init, 3, args, NULL);
perl_eval_pv(load_file, TRUE);
}
static int coroae_wait_milliseconds(int timeout) {
char buf[256];
double d = ((double)timeout)/1000.0;
int ret = snprintf(buf, 256, "Coro::AnyEvent::sleep %f", d);
if (ret <= 0 || ret > 256) return -1;
perl_eval_pv(buf, 0);
return 0;
}
char match(char *string, char *pattern)
{
char *command;
command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 37);
sprintf(command, "$string = '%s'; $return = $string =~ %s",
string, pattern);
perl_eval_pv(command, TRUE);
free(command);
return SvIV(perl_get_sv("return", FALSE));
}
/* Destroy all perl scripts and deinitialize perl interpreter */
void perl_scripts_deinit(void)
{
if (my_perl == NULL)
return;
/* unload all scripts */
while (perl_scripts != NULL)
perl_script_unload(perl_scripts->data);
signal_emit("perl scripts deinit", 0);
perl_signals_stop();
perl_sources_stop();
perl_common_stop();
/* Unload all perl libraries loaded with dynaloader */
perl_eval_pv("foreach my $lib (@DynaLoader::dl_modules) { if ($lib =~ /^Irssi\\b/) { $lib .= '::deinit();'; eval $lib; } }", TRUE);
#if PERL_STATIC_LIBS == 1
/* If perl is statically built we should manually deinit the modules
which are booted in boot_Irssi_Core above */
perl_eval_pv("foreach my $lib (qw("
"Irssi" " "
"Irssi::Irc" " "
"Irssi::UI" " "
"Irssi::TextUI"
")) { eval $lib . '::deinit();'; }", TRUE);
#endif
/* We could unload all libraries .. but this crashes with some
libraries, probably because we don't call some deinit function..
Anyway, this would free some memory with /SCRIPT RESET, but it
leaks memory anyway. */
/*perl_eval_pv("eval { foreach my $lib (@DynaLoader::dl_librefs) { DynaLoader::dl_unload_file($lib); } }", TRUE);*/
/* perl interpreter */
PL_perl_destruct_level = 1;
perl_destruct(my_perl);
perl_free(my_perl);
my_perl = NULL;
}
int substitute(char *string[], char *pattern)
{
char *command;
STRLEN length;
command = malloc(sizeof(char) * strlen(*string) + strlen(pattern) + 35);
sprintf(command, "$string = '%s'; $ret = ($string =~ %s)",
*string, pattern);
perl_eval_pv(command, TRUE);
free(command);
*string = SvPV(perl_get_sv("string", FALSE), length);
return SvIV(perl_get_sv("ret", FALSE));
}
char* perleval (char* input) {
char *retval=NULL;
if (input && *input) {
SV *sv;
perlstartstop(1);
++perlcalldepth;
ENTER; SAVETMPS;
sv=perl_eval_pv((char*)input, FALSE);
SV2STR(sv,retval);
FREETMPS; LEAVE;
--perlcalldepth;
};
RETURN_MSTR(retval);
}
static void irssi_perl_start(void)
{
char *args[] = {"", "-e", "0"};
char eval_file_code[] =
"package Irssi::Load;\n"
"\n"
"use Symbol qw(delete_package);\n"
"\n"
"sub eval_file {\n"
" my ($filename, $id) = @_;\n"
" my $package = \"Irssi::Script::$id\";\n"
" delete_package($package);\n"
"\n"
" local *FH;\n"
" open FH, $filename or die \"File not found: $filename\";\n"
" local($/) = undef;\n"
" my $sub = <FH>;\n"
" close FH;\n"
"\n"
" my $eval = qq{package $package; %s sub handler { $sub; }};\n"
" {\n"
" # hide our variables within this block\n"
" my ($filename, $package, $sub);\n"
" eval $eval;\n"
" }\n"
" die $@ if $@;\n"
"\n"
" eval {$package->handler;};\n"
" die $@ if $@;\n"
"}\n";
char *code, *use_code;
perl_signals_start();
perl_sources = NULL;
my_perl = perl_alloc();
perl_construct(my_perl);
perl_parse(my_perl, xs_init, 3, args, NULL);
use_code = *PERL_LIB_DIR == '\0' ? "" :
"use lib \""PERL_LIB_DIR"\";";
code = g_strdup_printf(eval_file_code, use_code);
perl_eval_pv(code, TRUE);
g_free(code);
perl_common_init();
}
static int
hbm_perl_exec (HBArgs *d, char *code)
{
dSP;
SV *args;
SV *retval;
args = perl_get_sv("args", TRUE);
if (!args)
printf("PANIC: No args\n");
sv_setref_pv(args, "hbargsPtr", (void*) d);
retval = perl_eval_pv(code, TRUE);
return SvIV(retval);
}
int matches(char *string, char *pattern, char **match_list[])
{
char *command;
SV *current_match;
AV *array;
I32 num_matches;
STRLEN length;
int i;
command = malloc(sizeof(char) * strlen(string) + strlen(pattern) + 38);
sprintf(command, "$string = '%s'; @array = ($string =~ %s)",
string, pattern);
perl_eval_pv(command, TRUE);
free(command);
array = perl_get_av("array", FALSE);
num_matches = av_len(array) + 1; /** assume $[ is 0 **/
*match_list = (char **) malloc(sizeof(char *) * num_matches);
for (i = 0; i <= num_matches; i++) {
current_match = av_shift(array);
(*match_list)[i] = SvPV(current_match, length);
}
return num_matches;
}
static void
perl_end(void)
{
if (my_perl == NULL)
return;
PL_perl_destruct_level = 1;
PERL_SET_CONTEXT(my_perl);
perl_eval_pv(
"foreach my $lib (@DynaLoader::dl_modules) {"
"if ($lib =~ /^Purple\\b/) {"
"$lib .= '::deinit();';"
"eval $lib;"
"}"
"}",
TRUE);
PL_perl_destruct_level = 1;
PERL_SET_CONTEXT(my_perl);
perl_destruct(my_perl);
perl_free(my_perl);
my_perl = NULL;
}
static int
perl_code ( HBArgs *d )
{
char *em[] = { "", "-e", "0" };
char *code;
int code_f;
int retval;
if (!d->sym->arg(d, NULL, &code, NULL, &code_f))
return 0;
if (!code)
return 1;
pthread_mutex_lock(&perl_mutex);
perl_int = perl_alloc();
perl_construct(perl_int);
perl_parse(perl_int, xs_init, 3, em, NULL);
perl_run(perl_int);
perl_eval_pv("use HB;", TRUE);
retval = hbm_perl_exec(d, code);
perl_destruct(perl_int);
perl_free(perl_int);
pthread_mutex_unlock(&perl_mutex);
if (code_f)
free(code);
return retval;
}
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 void
perl_init(void)
{
/* changed the name of the variable from load_file to perl_definitions
* since now it does much more than defining the load_file sub.
* Moreover, deplaced the initialisation to the xs_init function.
* (TheHobbit) */
char *perl_args[] = { "", "-e", "0", "-w" };
char perl_definitions[] =
{
/* We use to function one to load a file the other to execute
* the string obtained from the first and holding the file
* contents. This allows to have a really local $/ without
* introducing temp variables to hold the old value. Just a
* question of style:) */
"package Purple::PerlLoader;"
"use Symbol;"
"sub load_file {"
"my $f_name=shift;"
"local $/=undef;"
"open FH,$f_name or return \"__FAILED__\";"
"$_=<FH>;"
"close FH;"
"return $_;"
"}"
"sub destroy_package {"
"eval { $_[0]->UNLOAD() if $_[0]->can('UNLOAD'); };"
"Symbol::delete_package($_[0]);"
"}"
"sub load_n_eval {"
"my ($f_name, $package) = @_;"
"destroy_package($package);"
"my $strin=load_file($f_name);"
"return 2 if($strin eq \"__FAILED__\");"
"my $eval = qq{package $package; $strin;};"
"{"
" eval $eval;"
"}"
"if($@) {"
/*" #something went wrong\n"*/
"die(\"Errors loading file $f_name: $@\");"
"}"
"return 0;"
"}"
};
my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
PL_perl_destruct_level = 1;
perl_construct(my_perl);
#ifdef DEBUG
perl_parse(my_perl, xs_init, 4, perl_args, NULL);
#else
perl_parse(my_perl, xs_init, 3, perl_args, NULL);
#endif
#ifdef HAVE_PERL_EVAL_PV
eval_pv(perl_definitions, TRUE);
#else
perl_eval_pv(perl_definitions, TRUE); /* deprecated */
#endif
perl_run(my_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;
}
