int main(int argc, char **argv){ struct stat sb; char *buf,*last; FILE *fp; fp=fopen(argv[argc-1],"r"); if(!fp)return fprintf(stderr,"unable to open file `%s'\n",argv[argc-1]); strcpy(argv[argc-1],"-e0");//filename should be long enough :P fstat(fileno(fp),&sb); last=buf=malloc(sb.st_size+1); if(!buf)return fprintf(stderr,"unable to malloc %d bytes\n",sb.st_size+1); fread(buf,1,sb.st_size,fp); buf[sb.st_size]=0; my_perl = perl_alloc(); perl_construct(my_perl); perl_parse(my_perl, NULL, argc, argv, NULL); perl_run(my_perl); for(;*buf;buf++){ if(*buf=='<'&&buf[1]==TAG){ *buf=0; fputs(last,stdout); last=buf+=2; for(;*buf;buf++){ if(*buf==TAG&&buf[1]=='>'){ *buf=0; eval_pv(last,TRUE); last=buf+=2; break; } } if(!buf){ eval_pv(last,TRUE); break; } } } fputs(last,stdout); perl_destruct(my_perl); perl_free(my_perl); }
/*********************************************************************************************************************************** Initialize Perl ***********************************************************************************************************************************/ static void perlInit(void) { FUNCTION_TEST_VOID(); if (!my_perl) { // Initialize Perl with dummy args and environment int argc = 1; const char *argv[1] = {strPtr(cfgExe())}; const char *env[1] = {NULL}; PERL_SYS_INIT3(&argc, (char ***)&argv, (char ***)&env); // Create the interpreter const char *embedding[] = {"", "-e", "0"}; my_perl = perl_alloc(); perl_construct(my_perl); // Don't let $0 assignment update the proctitle or embedding[0] PL_origalen = 1; // Start the interpreter perl_parse(my_perl, xs_init, 3, (char **)embedding, NULL); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; perl_run(my_perl); // Use customer loader to get all embedded modules eval_pv("splice(@INC, 0, 0, " LOADER_SUB ");", true); // Now that the custom loader is installed, load the main module; eval_pv("use " PGBACKREST_MODULE ";", true); // Set config data -- this is done separately to avoid it being included in stack traces perlEval(strNewFmt(PGBACKREST_MAIN "ConfigSet('%s', '%s')", strPtr(cfgExe()), strPtr(perlOptionJson()))); } FUNCTION_TEST_RETURN_VOID(); }
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 main(int argc, char * argv[]) { PerlInterpreter *my_perl; my_perl = perl_alloc(); perl_construct( my_perl ); char pzObjectAndPath[512]; sprintf(pzObjectAndPath,"%s%s",(const char *)"C:\\Users\\Brian\\Desktop\\XMLFoundation\\Examples\\Perl\\","PerlTest.pl"); // sprintf(pzObjectAndPath,"%s%s",(const char *)"/home/ubt/Desktop/XMLFoundation/Examples/Perl/","PerlTest.pl"); char *pzPerlFileArg[] = { "", pzObjectAndPath }; // parse the Perl Script perl_parse(my_perl, 0, 2, pzPerlFileArg, (char **)NULL); char *args[] = { NULL }; perl_call_argv("showtime", G_DISCARD | G_NOARGS, args); perl_destruct(my_perl); perl_free(my_perl); return 0; }
int main(int argc, char **argv, char **env) { char *args[] = { NULL }; int exitstatus, i; AV* plargv; PERL_SYS_INIT3(&argc,&argv,&env); my_perl = perl_alloc(); perl_construct(my_perl); perl_parse(my_perl, xs_init, argc, argv, NULL); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; /*** skipping perl_run() ***/ plargv = GvAV(PL_argvgv); for (i = 0; i <= av_len(plargv); ++i) { SV **item = av_fetch(plargv, i, 0); call_argv(SvPV_nolen(*item), G_SCALAR | G_NOARGS, args); { dSP; SV *res = POPs; printf("RES=%s\n", SvOK(res) ? SvPV_nolen(res) : "undef"); } } exitstatus = perl_destruct(my_perl); perl_free(my_perl); PERL_SYS_TERM(); return exitstatus; }
static void _perl_thread_init(LogThrDestDriver *d) { PerlDestDriver *self = (PerlDestDriver *)d; PerlInterpreter *my_perl; char *argv[] = { "syslog-ng", self->filename }; self->perl = perl_alloc(); perl_construct(self->perl); my_perl = self->perl; PL_exit_flags |= PERL_EXIT_DESTRUCT_END; perl_parse(self->perl, xs_init, 2, (char **)argv, NULL); if (!self->queue_func_name) self->queue_func_name = g_strdup("queue"); if (self->init_func_name) _call_perl_function_with_no_arguments(self, self->init_func_name); msg_verbose("Initializing Perl destination", evt_tag_str("driver", self->super.super.super.id), evt_tag_str("script", self->filename), NULL); }
int proxenet_perl_initialize_vm(plugin_t* plugin) { interpreter_t *interpreter; interpreter = plugin->interpreter; /* In order to perl_parse nothing */ char *args[2] = { "", "/dev/null" }; /* checks */ if (!interpreter->ready){ #ifdef DEBUG xlog(LOG_DEBUG, "[Perl] %s\n", "Initializing VM"); #endif /* vm init */ my_perl = perl_alloc(); perl_construct(my_perl); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; if (!my_perl) { xlog(LOG_ERROR, "[Perl] %s\n", "failed init-ing vm"); return -1; } interpreter->vm = (void*) my_perl; interpreter->ready = true; perl_parse(my_perl, NULL, 2, args, (char **)NULL); } return proxenet_perl_load_file(plugin); }
static apr_status_t psgi_pre_config(apr_pool_t *pconf, apr_pool_t *plog, apr_pool_t *ptemp) { int argc = 2; char *argv[] = { "perl", "-e;0", NULL }; char **envp = NULL; PERL_SYS_INIT3(&argc, (char ***) argv, &envp); perlinterp = perl_alloc(); PL_perl_destruct_level = 1; perl_construct(perlinterp); perl_parse(perlinterp, xs_init, argc, argv, envp); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; perl_run(perlinterp); init_perl_variables(); ap_mpm_query(AP_MPMQ_IS_THREADED, &psgi_multithread); psgi_multithread = (psgi_multithread != AP_MPMQ_NOT_SUPPORTED); ap_mpm_query(AP_MPMQ_IS_FORKED, &psgi_multiprocess); psgi_multiprocess = (psgi_multiprocess != AP_MPMQ_NOT_SUPPORTED); return OK; }
int perl_reinit() { int myargc=0; char **myenv = NULL; char **myargv = NULL; char *embedding1[]={"","-e","0"}; if(my_perl) { return 0; } // PERL_SYS_INIT3(&myargc, &myargv, &myenv); my_perl=perl_alloc(); sv=NEWSV(1099,0); perl_construct(my_perl); // PL_exit_flags |= PERL_EXIT_DESTRUCT_END; PL_perl_destruct_level = 2; perl_parse(my_perl, NULL, 3, embedding1, NULL); perl_run(my_perl); return 1; }
static int perl_metric_init(apr_pool_t *p) { DIR *dp; struct dirent *entry; int i, size; char* modname; char *modpath; HV *pparamhash; pl_metric_init_t minfo; Ganglia_25metric *gmi; mapped_info_t *mi; const char* path = perl_module.module_params; cfg_t *module_cfg; PerlInterpreter *perl = NULL; int argc = 0; char *argv[] = { }; char *env[] = { }; char *embedding[] = {"", ""}; /* Allocate a pool that will be used by this module */ apr_pool_create(&pool, p); metric_info = apr_array_make(pool, 10, sizeof(Ganglia_25metric)); metric_mapping_info = apr_array_make(pool, 10, sizeof(mapped_info_t)); /* Verify path exists and can be read */ if (!path) { err_msg("[PERL] Missing perl module path.\n"); return -1; } if (access(path, F_OK)) { /* 'path' does not exist */ err_msg("[PERL] Can't open the perl module path %s.\n", path); return -1; } if (access(path, R_OK)) { /* Don't have read access to 'path' */ err_msg("[PERL] Can't read from the perl module path %s.\n", path); return -1; } /* Initialize each perl module */ if ((dp = opendir(path)) == NULL) { /* Error: Cannot open the directory - Shouldn't happen */ /* Log? */ err_msg("[PERL] Can't open the perl module path %s.\n", path); return -1; } PERL_SYS_INIT3(&argc, (char ***) &argv, (char ***) &env); i = 0; while ((entry = readdir(dp)) != NULL) { modname = is_perl_module(entry->d_name); if (modname == NULL) continue; /* Find the specified module configuration in gmond.conf If this return NULL then either the module config doesn't exist or the module is disabled. */ module_cfg = find_module_config(modname); if (!module_cfg) continue; size_t path_len = strlen(path) + strlen(modname) + 5; modpath = malloc(path_len); modpath = strncpy(modpath, path, path_len); modpath = strcat(modpath, "/"); modpath = strcat(modpath, modname); modpath = strcat(modpath, ".pl"); embedding[1] = modpath ; perl = perl_alloc(); PL_perl_destruct_level = 0; PERL_SET_CONTEXT(perl); perl_construct(perl); PL_origalen = 1; PERL_SET_CONTEXT(perl); perl_parse(perl, NULL, 1, embedding, NULL); /* Run the perl script so that global variables can be accessed */ perl_run(perl); free(modpath); /* Build a parameter dictionary to pass to the module */ pparamhash = build_params_hash(module_cfg); if (!pparamhash) { err_msg("[PERL] Can't build the parameters hash for [%s].\n", modname); continue; } dSP; ENTER; SAVETMPS; PUSHMARK(SP); /* Push a reference to the pparamhash to the Perl stack */ XPUSHs(sv_2mortal(newRV_noinc((SV*)pparamhash))); PUTBACK; size = call_pv("metric_init", G_ARRAY|G_EVAL); SPAGAIN; /*SP -= size; ax = (SP - PL_stack_base) + 1; SvGETMAGIC(plarray); */ if (SvTRUE(ERRSV)) { /* failed calling metric_init */ err_msg("[PERL] Can't call the metric_init function in the perl module [%s].\n", modname); continue; } else { if (size) { int j; for (j = 0; j < size; j++) { SV* sref = POPs; if (!SvROK(sref)) { err_msg("[PERL] No descriptors returned from metric_init call in the perl module [%s].\n", modname); continue; } /* Dereference the reference */ HV* plhash = (HV*)(SvRV(sref)); if (plhash != NULL) { fill_metric_info(plhash, &minfo, modname, pool); gmi = (Ganglia_25metric*)apr_array_push(metric_info); fill_gmi(gmi, &minfo); mi = (mapped_info_t*)apr_array_push(metric_mapping_info); mi->mod_name = apr_pstrdup(pool, modname); mi->pcb = apr_pstrdup(pool, minfo.pcb); mi->perl = perl; } } } } PUTBACK; FREETMPS; LEAVE; } closedir(dp); apr_pool_cleanup_register(pool, NULL, perl_metric_cleanup, apr_pool_cleanup_null); /* Replace the empty static metric definition array with the dynamic array that we just created */ /*XXX Need to put this into a finalize MACRO. This is just pushing a NULL entry onto the array so that the looping logic can determine the end if the array. We should probably give back a ready APR array rather than a pointer to a Ganglia_25metric array. */ gmi = apr_array_push(metric_info); memset (gmi, 0, sizeof(*gmi)); mi = apr_array_push(metric_mapping_info); memset (mi, 0, sizeof(*mi)); perl_module.metrics_info = (Ganglia_25metric *)metric_info->elts; return 0; }
void Embperl::DoInit() { const char *argv_eqemu[] = { "", #ifdef EMBPERL_IO_CAPTURE "-w", "-W", #endif "-e", "0;", NULL }; int argc = 3; #ifdef EMBPERL_IO_CAPTURE argc = 5; #endif char **argv = (char **)argv_eqemu; char **env = { NULL }; PL_perl_destruct_level = 1; perl_construct(my_perl); PERL_SYS_INIT3(&argc, &argv, &env); perl_parse(my_perl, xs_init, argc, argv, env); perl_run(my_perl); //a little routine we use a lot. eval_pv("sub my_eval {eval $_[0];}", TRUE); //dies on error //ruin the perl exit and command: eval_pv("sub my_exit {}",TRUE); eval_pv("sub my_sleep {}",TRUE); if(gv_stashpv("CORE::GLOBAL", FALSE)) { GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV); //#if _MSC_VER >= 1600 //GvCV_set(exitgp, perl_get_cv("my_exit", TRUE)); //dies on error //#else GvCV(exitgp) = perl_get_cv("my_exit", TRUE); //dies on error //#endif //dies on error GvIMPORTED_CV_on(exitgp); GV *sleepgp = gv_fetchpv("CORE::GLOBAL::sleep", TRUE, SVt_PVCV); //#if _MSC_VER >= 1600 //GvCV_set(sleepgp, perl_get_cv("my_sleep", TRUE)); //dies on error //#else GvCV(sleepgp) = perl_get_cv("my_sleep", TRUE); //dies on error //#endif GvIMPORTED_CV_on(sleepgp); } //declare our file eval routine. try { init_eval_file(); } catch(const char *err) { //remember... lasterr() is no good if we crap out here, in construction EQC::Common::Log(EQCLog::Error,CP_QUESTS, "perl error: %s", err); throw "failed to install eval_file hook"; } #ifdef EMBPERL_IO_CAPTURE EQC::Common::Log(EQCLog::Debug,CP_QUESTS, "Tying perl output to eqemu logs"); //make a tieable class to capture IO and pass it into EQEMuLog eval_pv( "package EQEmuIO; " // "&boot_EQEmuIO;" "sub TIEHANDLE { my $me = bless {}, $_[0]; $me->PRINT('Creating '.$me); return($me); } " "sub WRITE { } " //dunno why I need to shift off fmt here, but it dosent like without it "sub PRINTF { my $me = shift; my $fmt = shift; $me->PRINT(sprintf($fmt, @_)); } " "sub CLOSE { my $me = shift; $me->PRINT('Closing '.$me); } " "sub DESTROY { my $me = shift; $me->PRINT('Destroying '.$me); } " //this ties us for all packages, just do it in quest since thats kinda 'our' package "package quest;" " if(tied *STDOUT) { untie(*STDOUT); }" " if(tied *STDERR) { untie(*STDERR); }" " tie *STDOUT, 'EQEmuIO';" " tie *STDERR, 'EQEmuIO';" ,FALSE); #endif //EMBPERL_IO_CAPTURE #ifdef EMBPERL_PLUGIN eval_pv( "package plugin; " ,FALSE ); #ifdef EMBPERL_EVAL_COMMANDS try { eval_pv( "use IO::Scalar;" "$plugin::printbuff='';" "tie *PLUGIN,'IO::Scalar',\\$plugin::printbuff;" ,FALSE); } catch(const char *err) { throw "failed to install plugin printhook, do you lack IO::Scalar?"; } #endif EQC::Common::Log(EQCLog::Status,CP_QUESTS, "Loading perlemb plugins."); try { eval_pv("main::eval_file('plugin', 'plugin.pl');", FALSE); } catch(const char *err) { EQC::Common::Log(EQCLog::Status,CP_QUESTS, "Warning - plugin.pl: %s", err); } // Harakiri, this reads all the plugins in \plugins like // check_handin.pl // check_hasitem.pl try { //should probably read the directory in c, instead, so that //I can echo filenames as I do it, but c'mon... I'm lazy and this 1 line reads in all the plugins eval_pv( "if(opendir(D,'plugins')) { " " my @d = readdir(D);" " closedir(D);" " foreach(@d){ " " main::eval_file('plugin','plugins/'.$_)if/\\.pl$/;" " }" "}" ,FALSE); } catch(const char *err) { EQC::Common::Log(EQCLog::Status,CP_QUESTS, "Perl warning while loading plugins : %s", err); } // Harakiri, this reads all the plugins in quest\plugins like try { //should probably read the directory in c, instead, so that //I can echo filenames as I do it, but c'mon... I'm lazy and this 1 line reads in all the plugins eval_pv( "if(opendir(D,'quests/plugins/')) { " " my @d = readdir(D);" " closedir(D);" " foreach(@d){ " " main::eval_file('plugin','quests/plugins/'.$_)if/\\.pl$/;" " }" "}" ,FALSE); } catch(const char *err) { EQC::Common::Log(EQCLog::Status,CP_QUESTS, "Perl warning while loading plugins : %s", err); } #endif //EMBPERL_PLUGIN //Harakiri these are used to create perl bases #commands #ifdef EMBPERL_COMMANDS EQC::Common::Log(EQCLog::Normal,CP_QUESTS, "Loading perl commands..."); try { eval_pv( "package commands;" "main::eval_file('commands', 'commands.pl');" "&commands::commands_init();" , FALSE); } catch(const char *err) { EQC::Common::Log(EQCLog::Error,CP_ZONESERVER, "Warning - commands.pl: %s", err); } EQC::Common::Log(EQCLog::Normal,CP_QUESTS, "Perl commands loaded...."); #endif //EMBPERL_COMMANDS in_use = false; }
/* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ static int mod_instantiate(CONF_SECTION *conf, void *instance) { rlm_perl_t *inst = instance; AV *end_AV; char const **embed_c; /* Stupid Perl and lack of const consistency */ char **embed; char **envp = NULL; char const *xlat_name; int exitstatus = 0, argc=0; MEM(embed_c = talloc_zero_array(inst, char const *, 4)); memcpy(&embed, &embed_c, sizeof(embed)); /* * Create pthread key. This key will be stored in instance */ #ifdef USE_ITHREADS pthread_mutex_init(&inst->clone_mutex, NULL); inst->thread_key = rad_malloc(sizeof(*inst->thread_key)); memset(inst->thread_key,0,sizeof(*inst->thread_key)); rlm_perl_make_key(inst->thread_key); #endif char arg[] = "0"; embed_c[0] = NULL; if (inst->perl_flags) { embed_c[1] = inst->perl_flags; embed_c[2] = inst->module; embed_c[3] = arg; argc = 4; } else { embed_c[1] = inst->module; embed_c[2] = arg; argc = 3; } PERL_SYS_INIT3(&argc, &embed, &envp); if ((inst->perl = perl_alloc()) == NULL) { ERROR("rlm_perl: No memory for allocating new perl !"); return (-1); } perl_construct(inst->perl); #ifdef USE_ITHREADS PL_perl_destruct_level = 2; { dTHXa(inst->perl); } PERL_SET_CONTEXT(inst->perl); #endif #if PERL_REVISION >= 5 && PERL_VERSION >=8 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL); end_AV = PL_endav; PL_endav = Nullav; if(!exitstatus) { perl_run(inst->perl); } else { ERROR("rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module); return (-1); } PL_endav = end_AV; xlat_name = cf_section_name2(conf); if (!xlat_name) xlat_name = cf_section_name1(conf); if (xlat_name) { xlat_register(xlat_name, perl_xlat, NULL, inst); } /* parse perl configuration sub-section */ CONF_SECTION *cs; cs = cf_section_sub_find(conf, "config"); if (cs) { DEBUG("rlm_perl (%s): parsing 'config' section...", xlat_name); inst->rad_perlconf_hv = get_hv("RAD_PERLCONF",1); perl_parse_config(cs, 0, inst->rad_perlconf_hv); DEBUG("rlm_perl (%s): done parsing 'config'.", xlat_name); } return 0; }
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); }
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 ); }
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; }
/* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Boyan: * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ static int mod_instantiate(CONF_SECTION *conf, void *instance) { rlm_perl_t *inst = instance; AV *end_AV; char **embed; char **envp = NULL; char const *xlat_name; int exitstatus = 0, argc=0; MEM(embed = talloc_zero_array(inst, char *, 4)); /* * Create pthread key. This key will be stored in instance */ #ifdef USE_ITHREADS pthread_mutex_init(&inst->clone_mutex, NULL); inst->thread_key = rad_malloc(sizeof(*inst->thread_key)); memset(inst->thread_key,0,sizeof(*inst->thread_key)); rlm_perl_make_key(inst->thread_key); #endif char arg[] = "0"; embed[0] = NULL; if (inst->perl_flags) { embed[1] = inst->perl_flags; embed[2] = inst->module; embed[3] = arg; argc = 4; } else { embed[1] = inst->module; embed[2] = arg; argc = 3; } PERL_SYS_INIT3(&argc, &embed, &envp); if ((inst->perl = perl_alloc()) == NULL) { ERROR("rlm_perl: No memory for allocating new perl !"); return (-1); } perl_construct(inst->perl); #ifdef USE_ITHREADS PL_perl_destruct_level = 2; { dTHXa(inst->perl); } PERL_SET_CONTEXT(inst->perl); #endif #if PERL_REVISION >= 5 && PERL_VERSION >=8 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL); end_AV = PL_endav; PL_endav = Nullav; if(!exitstatus) { perl_run(inst->perl); } else { ERROR("rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module); return (-1); } PL_endav = end_AV; xlat_name = cf_section_name2(conf); if (!xlat_name) xlat_name = cf_section_name1(conf); if (xlat_name) { xlat_register(xlat_name, perl_xlat, NULL, inst); } return 0; }
/* * Initialize the perl interpreter. * This might later be used to reinit the module. */ PerlInterpreter *parser_init(void) { int argc = 0; char *argv[MAX_LIB_PATHS + 3]; PerlInterpreter *new_perl = NULL; char *entry, *stop, *end; int modpathset_start = 0; int modpathset_end = 0; int i; int pr; new_perl = perl_alloc(); if (!new_perl) { LM_ERR("could not allocate perl.\n"); return NULL; } perl_construct(new_perl); argv[0] = ""; argc++; /* First param _needs_ to be empty */ /* Possible Include path extension by modparam */ if (modpath && (strlen(modpath) > 0)) { modpathset_start = argc; entry = modpath; stop = modpath + strlen(modpath); for (end = modpath; end <= stop; end++) { if ( (end[0] == ':') || (end[0] == '\0') ) { end[0] = '\0'; if (argc > MAX_LIB_PATHS) { LM_ERR("too many lib paths, skipping lib path: '%s'\n", entry); } else { LM_INFO("setting lib path: '%s'\n", entry); argv[argc] = pkg_malloc(strlen(entry)+20); sprintf(argv[argc], "-I%s", entry); modpathset_end = argc; argc++; } entry = end + 1; } } } argv[argc] = "-M"DEFAULTMODULE; argc++; /* Always "use" Kamailio.pm */ argv[argc] = filename; /* The script itself */ argc++; pr=perl_parse(new_perl, xs_init, argc, argv, NULL); if (pr) { LM_ERR("failed to load perl file \"%s\" with code %d.\n", argv[argc-1], pr); if (modpathset_start) { for (i = modpathset_start; i <= modpathset_end; i++) { pkg_free(argv[i]); } } return NULL; } else { LM_INFO("successfully loaded perl file \"%s\"\n", argv[argc-1]); } if (modpathset_start) { for (i = modpathset_start; i <= modpathset_end; i++) { pkg_free(argv[i]); } } perl_run(new_perl); return new_perl; }
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); }
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(); }
/* caller must free result, if not NULL */ CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv) { int ret; PerlInterpreter *p; char *err; const char *args[4] = {"", "-e", "0;", NULL}; AV *inc; char *path; /* create and initialize interpreter */ PERL_SYS_INIT3(Pargc, Pargv, Penv); p=perl_alloc(); owl_global_set_perlinterp(&g, p); perl_construct(p); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; owl_global_set_no_have_config(&g); ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL); if (ret || SvTRUE(ERRSV)) { err=g_strdup(SvPV_nolen(ERRSV)); sv_setsv(ERRSV, &PL_sv_undef); /* and clear the error */ return(err); } ret=perl_run(p); if (ret || SvTRUE(ERRSV)) { err=g_strdup(SvPV_nolen(ERRSV)); sv_setsv(ERRSV, &PL_sv_undef); /* and clear the error */ return(err); } owl_global_set_have_config(&g); /* create legacy variables */ get_sv("BarnOwl::id", TRUE); get_sv("BarnOwl::class", TRUE); get_sv("BarnOwl::instance", TRUE); get_sv("BarnOwl::recipient", TRUE); get_sv("BarnOwl::sender", TRUE); get_sv("BarnOwl::realm", TRUE); get_sv("BarnOwl::opcode", TRUE); get_sv("BarnOwl::zsig", TRUE); get_sv("BarnOwl::msg", TRUE); get_sv("BarnOwl::time", TRUE); get_sv("BarnOwl::host", TRUE); get_av("BarnOwl::fields", TRUE); if(file) { SV * cfg = get_sv("BarnOwl::configfile", TRUE); sv_setpv(cfg, file); } sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING); /* Add the system lib path to @INC */ inc = get_av("INC", 0); path = g_build_filename(owl_get_datadir(), "lib", NULL); av_unshift(inc, 1); av_store(inc, 0, owl_new_sv(path)); g_free(path); eval_pv("use BarnOwl;", FALSE); if (SvTRUE(ERRSV)) { err=g_strdup(SvPV_nolen(ERRSV)); sv_setsv (ERRSV, &PL_sv_undef); /* and clear the error */ return(err); } /* check if we have the formatting function */ if (owl_perlconfig_is_function("BarnOwl::format_msg")) { owl_global_set_config_format(&g, 1); } return(NULL); }
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 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 EQWParser::DoInit() { const char *argv_eqemu[] = { "", "-w", "-W", "-e", "0;", nullptr }; int argc = 5; char **argv = (char **)argv_eqemu; char **env = { nullptr }; PL_perl_destruct_level = 1; perl_construct(my_perl); PERL_SYS_INIT3(&argc, &argv, &env); perl_parse(my_perl, xs_init, argc, argv, env); perl_run(my_perl); //a little routine we use a lot. eval_pv("sub my_eval {eval $_[0];}", TRUE); //dies on error //ruin the perl exit and command: eval_pv("sub my_exit {}",TRUE); eval_pv("sub my_sleep {}",TRUE); if(gv_stashpv("CORE::GLOBAL", FALSE)) { GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV); GvCV_set(exitgp, perl_get_cv("my_exit", TRUE)); //dies on error GvIMPORTED_CV_on(exitgp); GV *sleepgp = gv_fetchpv("CORE::GLOBAL::sleep", TRUE, SVt_PVCV); GvCV_set(sleepgp, perl_get_cv("my_sleep", TRUE)); //dies on error GvIMPORTED_CV_on(sleepgp); } //setup eval_file eval_pv( "our %Cache;" "use Symbol qw(delete_package);" "sub eval_file {" "my($package, $filename) = @_;" "$filename=~s/\'//g;" "if(! -r $filename) { print \"Unable to read perl file '$filename'\\n\"; return; }" "my $mtime = -M $filename;" "if(defined $Cache{$package}{mtime}&&$Cache{$package}{mtime} <= $mtime && !($package eq 'plugin')){" " return;" "} else {" //we 'my' $filename,$mtime,$package,$sub to prevent them from changing our state up here. " eval(\"package $package; my(\\$filename,\\$mtime,\\$package,\\$sub); \\$isloaded = 1; require '$filename'; \");" "}" "}" ,FALSE); //make a tie-able class to capture IO and get it where it needs to go eval_pv( "package EQWIO; " // "&boot_EQEmuIO;" "sub TIEHANDLE { my $me = bless {}, $_[0]; $me->PRINT('Creating '.$me); return($me); } " "sub WRITE { } " "sub PRINTF { my $me = shift; my $fmt = shift; $me->PRINT(sprintf($fmt, @_)); } " "sub CLOSE { my $me = shift; $me->PRINT('Closing '.$me); } " "sub DESTROY { my $me = shift; $me->PRINT('Destroying '.$me); } " //this ties us for all packages "package MAIN;" " if(tied *STDOUT) { untie(*STDOUT); }" " if(tied *STDERR) { untie(*STDERR); }" " tie *STDOUT, 'EQWIO';" " tie *STDERR, 'EQWIO';" ,FALSE); eval_pv( "package world; " ,FALSE ); //make sure the EQW pointer is set up in this package EQW *curc = EQW::Singleton(); SV *l = get_sv("world::EQW", true); if(curc != nullptr) { sv_setref_pv(l, "EQW", curc); } else { //clear out the value, mainly to get rid of blessedness sv_setsv(l, _empty_sv); } //make sure the EQDB pointer is set up in this package EQDB::SetMySQL(database.getMySQL()); EQDB *curc_db = EQDB::Singleton(); SV *l_db = get_sv("world::EQDB", true); if(curc_db != nullptr) { sv_setref_pv(l_db, "EQDB", curc_db); } else { //clear out the value, mainly to get rid of blessedness sv_setsv(l_db, _empty_sv); } //load up EQW eval_pv( "package EQW;" "&boot_EQW;" //load our EQW XS "package EQDB;" "&boot_EQDB;" //load our EQW XS "package EQDBRes;" "&boot_EQDBRes;" //load our EQW XS "package HTTPRequest;" "&boot_HTTPRequest;" //load our HTTPRequest XS "package EQLConfig;" "&boot_EQLConfig;" //load our EQLConfig XS , FALSE ); #ifdef EMBPERL_PLUGIN Log.Out(Logs::Detail, Logs::World_Server, "Loading worldui perl plugins."); std::string err; if(!eval_file("world", "worldui.pl", err)) { Log.Out(Logs::Detail, Logs::World_Server, "Warning - world.pl: %s", err.c_str()); } eval_pv( "package world; " "if(opendir(D,'worldui')) { " " my @d = readdir(D);" " closedir(D);" " foreach(@d){ " " next unless(/\\.pl$); " " require 'templates/'.$_;" " }" "}" ,FALSE); #endif //EMBPERL_PLUGIN }
/* Returns 1 on success and 0 on failure */ int perl_init(void) { char path[MAX_FDP_LEN+1]; char *script_list[256]; char *myargv[] = {"", NULL}; int i, k, len; int sock; struct sockaddr_un remote_addr; char temp_nick[MAX_NICK_LEN+1]; char temp_host[MAX_HOST_LEN+1]; char *buf, *bufp; int spaces=0, entries=0; int l; int erret; int flags; memset(&remote_addr, 0, sizeof(struct sockaddr_un)); /* First kill off scripts that is already running. */ remove_all(SCRIPT, 1, 1); /* Reads the script names in the script directory */ snprintf(path, MAX_FDP_LEN, "%s/%s", config_dir, SCRIPT_DIR); i = my_scandir(path, script_list); if(i == 0) return 1; k = i-1; for(i = 0; i <= k; i++) { myargv[1] = script_list[i]; if((pid = fork()) == -1) { logprintf(1, "Fork failed, exiting process\n"); logerror(1, errno); quit = 1; return 0;; } /* If we are the parent */ if(pid > 0) { logprintf(3, "Forked new script parsing process for script %s, childs pid is %d and parents pid is %d\n", script_list[i], pid, getpid()); pid = getpid(); } /* And if we are the child */ else { pid = -1; /* Close the listening sockets */ while(((erret = close(listening_unx_socket)) != 0) && (errno == EINTR)) logprintf(1, "Error - In perl_init()/close(): Interrupted system call. Trying again.\n"); if(erret != 0) { logprintf(1, "Error - In perl_init()/close(): "); logerror(1, errno); } while(((erret = close(listening_udp_socket)) != 0) && (errno == EINTR)) logprintf(1, "Error - In perl_init()/close(): Interrupted system call. Trying again.\n"); if(erret != 0) { logprintf(1, "Error - In perl_init()/close(): "); logerror(1, errno); } /* Set the alarm */ alarm(ALARM_TIME); /* And connect to parent process */ if((sock = socket(AF_UNIX, SOCK_STREAM, 0)) == -1) { logprintf(1, "Error - In perl_init()/socket(): "); logerror(1, errno); free(script_list[i]); exit(EXIT_FAILURE); } remote_addr.sun_family = AF_UNIX; strcpy(remote_addr.sun_path, un_sock_path); len = strlen(remote_addr.sun_path) + sizeof(remote_addr.sun_family) + 1; if(connect(sock, (struct sockaddr *)&remote_addr, len) == -1) { logprintf(1, "Error - In perl_init()/connect(): "); logerror(1, errno); free(script_list[i]); exit(EXIT_FAILURE); } if((flags = fcntl(sock, F_GETFL, 0)) < 0) { logprintf(1, "Error - In new_human_user()/in fcntl(): "); logerror(1, errno); close(sock); return -1; } /* Non blocking mode */ if(fcntl(sock, F_SETFL, flags | O_NONBLOCK) < 0) { logprintf(1, "Error - In new_human_user()/in fcntl(): "); logerror(1, errno); close(sock); return -1; } /* The parent process will be a special kind of user */ /* Allocate space for the new user. Since the process * should be empty on users and no one is to be added, * we use non_human_user_list. */ /* Allocate space for the new user */ if((non_human_user_list = malloc(sizeof(struct user_t))) == NULL) { logprintf(1, "Error - In parl_init()/malloc(): "); logerror(1, errno); quit = 1; free(script_list[i]); exit(EXIT_FAILURE); } non_human_user_list->sock = sock; non_human_user_list->rem = 0; non_human_user_list->type = SCRIPT; non_human_user_list->buf = NULL; non_human_user_list->outbuf = NULL; non_human_user_list->next = NULL; non_human_user_list->email = NULL; non_human_user_list->desc = NULL; memset(non_human_user_list->nick, 0, MAX_NICK_LEN+1); sprintf(non_human_user_list->nick, "parent process"); sprintf(non_human_user_list->hostname, "parent_process"); send_to_user("$NewScript|", non_human_user_list); /* Remove all users. */ remove_all(~SCRIPT, 0, 0); /* Initialize the perl interpreter for this process */ if((my_perl = perl_alloc()) == NULL) { logprintf(1, "perl_alloc() failed\n"); free(script_list[i]); exit(EXIT_FAILURE); } perl_construct(my_perl); if(perl_parse(my_perl, xs_init, 2, myargv, NULL)) { logprintf(1, "Parse of %s failed.\n", script_list[i]); free(script_list[i]); exit(EXIT_FAILURE); } if(perl_run(my_perl)) { logprintf(1, "Couldn't run perl script %s.\n", script_list[i]); free(script_list[i]); exit(EXIT_FAILURE); } /* Run the scripts main sub if it exists. */ { dSP; ENTER; SAVETMPS; PUSHMARK(SP); PUTBACK; call_pv("main", G_DISCARD|G_EVAL); SPAGAIN; PUTBACK; FREETMPS; LEAVE; } free(script_list[i]); /* Get info of all users. */ if(i == 0) { sem_take(user_list_sem); /* Attach to the shared segment */ if((buf = (char *)shmat(get_user_list_shm_id(), NULL, 0)) == (char *)-1) { logprintf(1, "Error - In perl_init()/shmat(): "); logerror(1, errno); sem_give(user_list_sem); quit = 1; return -1; } if(sscanf(buf, "%d %d", &spaces, &entries) != 2) { logprintf(1, "Error - In perl_init(): Couldn't get number of entries\n"); shmdt(buf); sem_give(user_list_sem); quit = 1; return -1; } bufp = buf + 30; for(l = 1; l <= spaces; l++) { if(*bufp != '\0') { sscanf(bufp, "%50s %120s", temp_nick, temp_host); uprintf(non_human_user_list, "$GetINFO %s $Script|", temp_nick); } bufp += USER_LIST_ENT_SIZE; } shmdt(buf); sem_give(user_list_sem); } return 1; } free(script_list[i]); } 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; 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; }
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); }
/* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Boyan: * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ static int perl_instantiate(CONF_SECTION *conf, void **instance) { PERL_INST *inst = (PERL_INST *) instance; HV *rad_reply_hv; HV *rad_check_hv; HV *rad_config_hv; HV *rad_request_hv; #ifdef WITH_PROXY HV *rad_request_proxy_hv; HV *rad_request_proxy_reply_hv; #endif AV *end_AV; char **embed; char **envp = NULL; const char *xlat_name; int exitstatus = 0, argc=0; embed = rad_malloc(4 * sizeof(char *)); memset(embed, 0, 4 *sizeof(char *)); /* * Set up a storage area for instance data */ inst = rad_malloc(sizeof(PERL_INST)); memset(inst, 0, sizeof(PERL_INST)); /* * If the configuration parameters can't be parsed, then * fail. */ if (cf_section_parse(conf, inst, module_config) < 0) { free(embed); free(inst); return -1; } /* * Create pthread key. This key will be stored in instance */ #ifdef USE_ITHREADS pthread_mutex_init(&inst->clone_mutex, NULL); inst->thread_key = rad_malloc(sizeof(*inst->thread_key)); memset(inst->thread_key,0,sizeof(*inst->thread_key)); rlm_perl_make_key(inst->thread_key); #endif char arg[] = "0"; embed[0] = NULL; if (inst->perl_flags) { embed[1] = inst->perl_flags; embed[2] = inst->module; embed[3] = arg; argc = 4; } else { embed[1] = inst->module; embed[2] = arg; argc = 3; } PERL_SYS_INIT3(&argc, &embed, &envp); #ifdef USE_ITHREADS if ((inst->perl = perl_alloc()) == NULL) { radlog(L_DBG, "rlm_perl: No memory for allocating new perl !"); free(embed); free(inst); return (-1); } perl_construct(inst->perl); PL_perl_destruct_level = 2; { dTHXa(inst->perl); } PERL_SET_CONTEXT(inst->perl); #else if ((inst->perl = perl_alloc()) == NULL) { radlog(L_ERR, "rlm_perl: No memory for allocating new perl !"); free(embed); free(inst); return -1; } perl_construct(inst->perl); #endif #if PERL_REVISION >= 5 && PERL_VERSION >=8 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL); end_AV = PL_endav; PL_endav = Nullav; newXS("radiusd::radlog",XS_radiusd_radlog, "rlm_perl"); if(!exitstatus) { exitstatus = perl_run(inst->perl); } else { radlog(L_ERR,"rlm_perl: perl_parse failed: %s not found or has syntax errors. \n", inst->module); free(embed); free(inst); return (-1); } PL_endav = end_AV; rad_reply_hv = newHV(); rad_check_hv = newHV(); rad_config_hv = newHV(); rad_request_hv = newHV(); #ifdef WITH_PROXY rad_request_proxy_hv = newHV(); rad_request_proxy_reply_hv = newHV(); #endif rad_reply_hv = get_hv("RAD_REPLY",1); rad_check_hv = get_hv("RAD_CHECK",1); rad_config_hv = get_hv("RAD_CONFIG",1); rad_request_hv = get_hv("RAD_REQUEST",1); #ifdef WITH_PROXY rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1); rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1); #endif xlat_name = cf_section_name2(conf); if (xlat_name == NULL) xlat_name = cf_section_name1(conf); if (xlat_name){ inst->xlat_name = strdup(xlat_name); xlat_register(xlat_name, perl_xlat, inst); } *instance = inst; return 0; }
/* * Do any per-module initialization that is separate to each * configured instance of the module. e.g. set up connections * to external databases, read configuration files, set up * dictionary entries, etc. * * If configuration information is given in the config section * that must be referenced in later calls, store a handle to it * in *instance otherwise put a null pointer there. * * Setup a hashes wich we will use later * parse a module and give him a chance to live * */ static int mod_instantiate(void *instance, CONF_SECTION *conf) { rlm_perl_t *inst = instance; AV *end_AV; char const **embed_c; /* Stupid Perl and lack of const consistency */ char **embed; char **envp = NULL; int exitstatus = 0, argc=0; char arg[] = "0"; CONF_SECTION *cs; #ifdef USE_ITHREADS /* * Create pthread key. This key will be stored in instance */ pthread_mutex_init(&inst->clone_mutex, NULL); MEM(inst->thread_key = talloc_zero(inst, pthread_key_t)); rlm_perl_make_key(inst->thread_key); #endif /* * Setup the argument array we pass to the perl interpreter */ MEM(embed_c = talloc_zero_array(inst, char const *, 4)); memcpy(&embed, &embed_c, sizeof(embed)); embed_c[0] = NULL; if (inst->perl_flags) { embed_c[1] = inst->perl_flags; embed_c[2] = inst->module; embed_c[3] = arg; argc = 4; } else { embed_c[1] = inst->module; embed_c[2] = arg; argc = 3; } /* * Create tweak the server's environment to support * perl. Docs say only call this once... Oops. */ if (!perl_sys_init3_called) { PERL_SYS_INIT3(&argc, &embed, &envp); perl_sys_init3_called = 1; } /* * Allocate a new perl interpreter to do the parsing */ if ((inst->perl = perl_alloc()) == NULL) { ERROR("No memory for allocating new perl interpretor!"); return -1; } perl_construct(inst->perl); /* ...and initialise it */ #ifdef USE_ITHREADS PL_perl_destruct_level = 2; { dTHXa(inst->perl); } PERL_SET_CONTEXT(inst->perl); #endif #if PERL_REVISION >= 5 && PERL_VERSION >=8 PL_exit_flags |= PERL_EXIT_DESTRUCT_END; #endif exitstatus = perl_parse(inst->perl, xs_init, argc, embed, NULL); end_AV = PL_endav; PL_endav = (AV *)NULL; if (exitstatus) { ERROR("Perl_parse failed: %s not found or has syntax errors", inst->module); return -1; } /* parse perl configuration sub-section */ cs = cf_section_find(conf, "config", NULL); if (cs) { inst->rad_perlconf_hv = get_hv("RAD_PERLCONF", 1); perl_parse_config(cs, 0, inst->rad_perlconf_hv); } inst->perl_parsed = true; perl_run(inst->perl); PL_endav = end_AV; 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[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; }