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;
}
