bool OnLoad(const CString& sArgsi, CString& sMessage) {
CString sModPath, sTmp;
if (!CModules::FindModPath("modperl/startup.pl", sModPath, sTmp)) {
sMessage = "startup.pl not found.";
return false;
}
sTmp = CDir::ChangeDir(sModPath, "..");
int argc = 6;
char *pArgv[] = {"", "-T", "-w",
"-I", const_cast<char*>(sTmp.c_str()),
const_cast<char*>(sModPath.c_str()), NULL};
char **argv = pArgv;
PERL_SYS_INIT3(&argc, &argv, &environ);
m_pPerl = perl_alloc();
perl_construct(m_pPerl);
if (perl_parse(m_pPerl, xs_init, argc, argv, environ)) {
perl_free(m_pPerl);
PERL_SYS_TERM();
m_pPerl = NULL;
sMessage = "Can't initialize perl.";
DEBUG(__PRETTY_FUNCTION__ << " can't init perl");
return false;
}
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
PSTART;
PCALL("ZNC::Core::Init");
PEND;
return true;
}
// Get everything going...
int __declspec( dllexport ) __stdcall LoadDll( LOADINFO * limIRC ) {
mWnd = limIRC->mHwnd;
limIRC->mKeep = TRUE; // TODO: Set to FALSE if the inline perl fails
if ( my_perl == NULL ) {
/* Get things set for mIRC<=>perl IO */
hMapFile = CreateFileMapping( INVALID_HANDLE_VALUE, 0, PAGE_READWRITE, 0, 4096, NAMESPACE );
mData = ( LPSTR )MapViewOfFile( hMapFile, FILE_MAP_ALL_ACCESS, 0, 0, 0 );
/* Create our persistant interpreter */
char * perl_args[] = { "", "-e", "", "0" };
PERL_SYS_INIT3( NULL, NULL, NULL );
if ( ( my_perl = perl_alloc() ) == NULL ) {
mIRC_execute( "/echo Failed to load DLL: No memory" ); /* TODO: make this an error message */
limIRC->mKeep = FALSE;
return 0;
}
perl_construct( my_perl );
PL_origalen = 1; /* Don't let $0 assignment update the proctitle or perl_args[0] */
perl_parse( my_perl, xs_init, 6, perl_args, NULL );
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run( my_perl );
{
#ifdef PERLIO_LAYERS /* Layers available */
PerlIO_define_layer( aTHX_ PERLIO_FUNCS_CAST( &PerlIO_mIRC ) );
PerlIO_apply_layers( aTHX_ PerlIO_stderr( ), NULL, ":mIRC" );
PerlIO_apply_layers( aTHX_ PerlIO_stdout( ), NULL, ":mIRC" );
#endif /* PERLIO_LAYERS */
}
SV * result = eval_pv( form(
"use FindBin;" /* CORE */
"use lib qq[$FindBin::Bin/lib];" /* Search %mIRC%/lib for modules */
"use lib qq[$FindBin::Bin/perl];" /* Look for modules in %mIRC%/perl */
"my $mIRC = bless \{ }, 'mIRC';"
static void
gplp_load_base (GOPluginLoader *loader, GOErrorInfo **ret_error)
{
char *argv[] = { (char*)"", NULL, NULL, NULL };
char const *arg;
int argc;
arg = go_plugin_get_dir_name (go_plugin_loader_get_plugin (loader));
argv[1] = g_strconcat ("-I", arg, NULL);
argv[2] = g_build_filename (arg, "perl_func.pl", NULL);
argc = 2;
if (g_file_test (argv[2], G_FILE_TEST_EXISTS)) {
PERL_SYS_INIT3 (&argc, (char ***)&argv, NULL);
gnm_perl_interp = perl_alloc ();
perl_construct (gnm_perl_interp);
perl_parse (gnm_perl_interp, xs_init, 3, argv, NULL);
my_perl = gnm_perl_interp;
init_help_consts ();
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
} else {
*ret_error = go_error_info_new_printf (
_("perl_func.pl doesn't exist."));
}
g_free (argv[1]);
g_free (argv[2]);
}
int main(int argc, char **argv, char **env)
{
//if (argc < 2) {
// fprintf(stderr, "you must specify at least one argument\n");
// exit(0);
//}
pthread_t threads[NUM_THREADS];
pthread_mutex_init(&mutex_perl, NULL);
PERL_SYS_INIT3(&argc,&argv,&env);
char *my_argv[] = { "", PERL_SCRIPT };
my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
perl_construct(my_perl);
perl_parse(my_perl, NULL, 2, my_argv, (char **)NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
int t;
for (t=0; t<NUM_THREADS; t++) {
printf("creating thread %d\n", t);
(void)pthread_create(&threads[t], NULL, thread_context, (void *)t);
}
for (t=0;t<NUM_THREADS;t++) {
(void)pthread_join(threads[t], NULL);
printf("joined thread %d\n", t);
}
perl_destruct(my_perl);
perl_free(my_perl);
pthread_exit(NULL);
pthread_mutex_destroy(&mutex_perl);
PERL_SYS_TERM();
}
void h3(void *arg) {
int argc = 3;
char *argv[] = { "", "-e", "use Data::Dumper;"
"sub dump_perl { print STDERR Data::Dumper::Dumper([shift]); }",
NULL };
char *env[] = { NULL };
void *original_context = PERL_GET_CONTEXT;
SV *sv;
PERL_SYS_INIT3(&argc,&argv,&env);
my_perl = perl_alloc();
sv = newRV_inc(newSViv(5));
PERL_SET_CONTEXT(my_perl);
perl_construct(my_perl);
perl_parse(my_perl, mine_xs_init, argc, argv, NULL);
call_dump_perl(sv);
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SET_CONTEXT(original_context);
}
int
perl_back_initialize(
BackendInfo *bi
)
{
char *embedding[] = { "", "-e", "0" };
int argc = 3;
bi->bi_open = NULL;
bi->bi_config = 0;
bi->bi_close = perl_back_close;
bi->bi_destroy = 0;
bi->bi_db_init = perl_back_db_init;
bi->bi_db_config = perl_back_db_config;
bi->bi_db_open = perl_back_db_open;
bi->bi_db_close = 0;
bi->bi_db_destroy = perl_back_db_destroy;
bi->bi_op_bind = perl_back_bind;
bi->bi_op_unbind = 0;
bi->bi_op_search = perl_back_search;
bi->bi_op_compare = perl_back_compare;
bi->bi_op_modify = perl_back_modify;
bi->bi_op_modrdn = perl_back_modrdn;
bi->bi_op_add = perl_back_add;
bi->bi_op_delete = perl_back_delete;
bi->bi_op_abandon = 0;
bi->bi_extended = 0;
bi->bi_chk_referrals = 0;
bi->bi_connection_init = 0;
bi->bi_connection_destroy = 0;
/* injecting code from perl_back_open, because using fonction reference (bi->bi_open) is not functional */
Debug( LDAP_DEBUG_TRACE, "perl backend open\n", 0, 0, 0 );
if( PERL_INTERPRETER != NULL ) {
Debug( LDAP_DEBUG_ANY, "perl backend open: already opened\n",
0, 0, 0 );
return 1;
}
ldap_pvt_thread_mutex_init( &perl_interpreter_mutex );
#ifdef PERL_SYS_INIT3
PERL_SYS_INIT3(&argc, &embedding, (char ***)NULL);
#endif
PERL_INTERPRETER = perl_alloc();
perl_construct(PERL_INTERPRETER);
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
perl_parse(PERL_INTERPRETER, perl_back_xs_init, argc, embedding, (char **)NULL);
perl_run(PERL_INTERPRETER);
return perl_back_init_cf( bi );
}
Embperl::Embperl()
{
char **argv = (char **)argv_eqemu;
char **env = { nullptr };
in_use = true; //in case one of these files generates an event
PERL_SYS_INIT3(&argc, &argv, &env);
DoInit();
}
/*
* mod_init
* Called by kamailio at init time
*/
static int mod_init(void) {
int argc = 1;
char *argt[] = { MOD_NAME, NULL };
char **argv;
struct timeval t1;
struct timeval t2;
if(ap_init_rpc()<0) {
LM_ERR("failed to register RPC commands\n");
return -1;
}
if (!filename) {
LM_ERR("insufficient module parameters. Module not loaded.\n");
return -1;
}
/* bind the SL API */
if (sl_load_api(&slb)!=0) {
LM_ERR("cannot bind to SL API\n");
return -1;
}
_ap_reset_cycles = shm_malloc(sizeof(int));
if(_ap_reset_cycles == NULL) {
LM_ERR("no more shared memory\n");
return -1;
}
*_ap_reset_cycles = _ap_reset_cycles_init;
argv = argt;
PERL_SYS_INIT3(&argc, &argv, &environ);
gettimeofday(&t1, NULL);
my_perl = parser_init();
gettimeofday(&t2, NULL);
if (my_perl==NULL)
goto error;
LM_INFO("perl interpreter has been initialized (%d.%06d => %d.%06d)\n",
(int)t1.tv_sec, (int)t1.tv_usec,
(int)t2.tv_sec, (int)t2.tv_usec);
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#else
PL_exit_flags |= PERL_EXIT_EXPECTED;
#endif
return 0;
error:
if(_ap_reset_cycles!=NULL)
shm_free(_ap_reset_cycles);
_ap_reset_cycles = NULL;
return -1;
}
int
weechat_plugin_init (struct t_weechat_plugin *plugin, int argc, char *argv[])
{
struct t_plugin_script_init init;
#ifdef PERL_SYS_INIT3
int a;
char **perl_args_local;
char *perl_env[] = {};
a = perl_args_count;
perl_args_local = perl_args;
(void) perl_env;
PERL_SYS_INIT3 (&a, (char ***)&perl_args_local, (char ***)&perl_env);
#endif /* PERL_SYS_INIT3 */
weechat_perl_plugin = plugin;
#ifndef MULTIPLICITY
perl_main = perl_alloc ();
if (!perl_main)
{
weechat_printf (NULL,
weechat_gettext ("%s%s: unable to initialize %s"),
weechat_prefix ("error"), PERL_PLUGIN_NAME,
PERL_PLUGIN_NAME);
return WEECHAT_RC_ERROR;
}
perl_construct (perl_main);
perl_parse (perl_main, weechat_perl_api_init, perl_args_count,
perl_args, NULL);
#endif /* MULTIPLICITY */
init.callback_command = &weechat_perl_command_cb;
init.callback_completion = &weechat_perl_completion_cb;
init.callback_hdata = &weechat_perl_hdata_cb;
init.callback_infolist = &weechat_perl_infolist_cb;
init.callback_signal_debug_dump = &weechat_perl_signal_debug_dump_cb;
init.callback_signal_debug_libs = &weechat_perl_signal_debug_libs_cb;
init.callback_signal_script_action = &weechat_perl_signal_script_action_cb;
init.callback_load_file = &weechat_perl_load_cb;
perl_quiet = 1;
plugin_script_init (weechat_perl_plugin, argc, argv, &init);
perl_quiet = 0;
plugin_script_display_short_list (weechat_perl_plugin,
perl_scripts);
weechat_hook_signal ("quit",
&weechat_perl_signal_quit_upgrade_cb, NULL, NULL);
weechat_hook_signal ("upgrade",
&weechat_perl_signal_quit_upgrade_cb, NULL, NULL);
/* init OK */
return WEECHAT_RC_OK;
}
static void campher_init() {
dummy_argv = malloc(sizeof(char*) * 3);
dummy_env = malloc(sizeof(char*) * 2);
dummy_argv[0] = "campher";
dummy_argv[1] = "-e";
dummy_argv[2] = "0";
dummy_env[0] = "FOO=bar";
dummy_env[1] = NULL;
PERL_SYS_INIT3(&dummy_argc,&dummy_argv,&dummy_env);
}
/*
* Startup and shutdown routines.
*
* These deal with starting and stopping the perl interpreter.
*/
static bool startup_perl(void)
{
/*
* Hack: atheme modules (hence our dependent libperl.so) are loaded with
* RTLD_LOCAL, meaning that they're not available for later resolution. Perl
* extension modules assume that libperl.so is already loaded and available.
* Make it so.
*
* Secondary hack: some linkers do not respect rpath in dlopen(), so we fall back
* to some secondary paths where libperl.so may be living. --nenolod
*/
if (!(libperl_handle = dlopen("libperl.so", RTLD_NOW | RTLD_GLOBAL)) &&
!(libperl_handle = dlopen("/usr/lib/perl5/core_perl/CORE/libperl.so", RTLD_NOW | RTLD_GLOBAL)) &&
!(libperl_handle = dlopen("/usr/lib64/perl5/core_perl/CORE/libperl.so", RTLD_NOW | RTLD_GLOBAL)))
{
slog(LG_INFO, "Couldn't dlopen libperl.so");
return false;
}
int perl_argc = 2;
char **env = NULL;
PERL_SYS_INIT3(&perl_argc, &perl_argv, &env);
if (!(my_perl = perl_alloc()))
{
slog(LG_INFO, "Couldn't allocate a perl interpreter.");
return false;
}
PL_perl_destruct_level = 1;
perl_construct(my_perl);
PL_origalen = 1;
int exitstatus = perl_parse(my_perl, xs_init, perl_argc, perl_argv, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
if (exitstatus != 0)
{
slog(LG_INFO, "Couldn't parse perl startup file: %s", SvPV_nolen(ERRSV));
return false;
}
exitstatus = perl_run(my_perl);
if (exitstatus != 0)
{
slog(LG_INFO, "Couldn't run perl startup file: %s", SvPV_nolen(ERRSV));
return false;
}
invalidate_object_references();
return true;
}
int PerlInit(const char *prg_name, const char *perl_file)
{
#ifdef PAYGUIDE_PERL
argv=new char *[2];
argv[0]=new char[strlen(prg_name)+1]; strncpy(argv[0], prg_name, strlen(prg_name)+1);
argv[1]=new char[strlen(perl_file)+1]; strncpy(argv[1], perl_file, strlen(perl_file)+1);
//int argn=1;
PERL_SYS_INIT3(&argn,&argv,NULL);
PL_perl_destruct_level=1;
#endif
return 0;
}
static void
perl_init (void)
{
int warn;
int arg_count;
char *perl_args[] = { "", "-e", "0", "-w" };
char *env[] = { "" };
static const char xchat_definitions[] = {
/* Redefine the $SIG{__WARN__} handler to have XChat
printing warnings in the main window. (TheHobbit) */
#include "xchat.pm.h"
};
#ifdef OLD_PERL
static const char irc_definitions[] = {
#include "irc.pm.h"
};
#endif
#ifdef ENABLE_NLS
/* Problem is, dynamicaly loaded modules check out the $]
var. It appears that in the embedded interpreter we get
5,00503 as soon as the LC_NUMERIC locale calls for a comma
instead of a point in separating integer and decimal
parts. I realy can't understant why... The following
appears to be an awful workaround... But it'll do until I
(or someone else :)) found the "right way" to solve this
nasty problem. (TheHobbit <*****@*****.**>) */
setlocale (LC_NUMERIC, "C");
#endif
warn = 0;
xchat_get_prefs (ph, "perl_warnings", NULL, &warn);
arg_count = warn ? 4 : 3;
PERL_SYS_INIT3 (&arg_count, (char ***)&perl_args, (char ***)&env);
my_perl = perl_alloc ();
perl_construct (my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse (my_perl, xs_init, arg_count, perl_args, (char **)NULL);
/*
Now initialising the perl interpreter by loading the
perl_definition array.
*/
eval_pv (xchat_definitions, TRUE);
#ifdef OLD_PERL
eval_pv (irc_definitions, TRUE);
#endif
}
int main(int argc, char *argv[])
{
char **env = environ;
PERL_SYS_INIT3(&argc,&argv, &env);
my_perl = perl_alloc();
perl_construct(my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
perl_run(my_perl);
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SYS_TERM();
}
int
main( int argc, char **argv, char **env ) {
int exit_status;
#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_GPROF_MONCONTROL( 0 );
PERL_SYS_INIT3( &argc, &argv, &env );
#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
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;
exit_status = perl_parse( my_perl, xs_init, argc, argv, NULL );
if ( !exit_status ) {
runops_hook( );
perl_run( my_perl );
}
exit_status = perl_destruct( my_perl );
perl_free( my_perl );
PERL_SYS_TERM( );
exit( exit_status );
return exit_status;
}
static bool perlcore_module_init(KviModule *)
{
#ifdef COMPILE_PERL_SUPPORT
g_pInterpreters = new KviPointerHashTable<QString,KviPerlInterpreter>(17,false);
g_pInterpreters->setAutoDelete(false);
int daArgc = 4;
const char * daArgs[] = { "yo", "-e", "0", "-w" };
char ** daEnv=NULL;
PERL_SYS_INIT3(&daArgc,(char ***)&daArgs,&daEnv);
return true;
#else // !COMPILE_PERL_SUPPORT
return false;
#endif // !COMPILE_PERL_SUPPORT
}
static void
PurlInit()
{
PL_origalen = 1;
dummy_argv = malloc(sizeof(char*) * 3);
dummy_argv[0] = "purl";
dummy_argv[1] = "-e";
dummy_argv[2] = "0";
PERL_SYS_INIT3(&dummy_argc,&dummy_argv,&dummy_env);
my_perl = perl_alloc();
perl_construct(my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse(my_perl, xs_init, dummy_argc, dummy_argv, (char **)NULL);
//perl_run(my_perl);
}
int perl_init(){
int myargc=0;
char **myenv = NULL;
char **myargv = NULL;
char *embedding[]={"","-e","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;
perl_parse(my_perl, NULL, 3, embedding, NULL);
perl_run(my_perl);
return 1;
}
int proxenet_perl_initialize_vm(plugin_t* plugin)
{
interpreter_t *interpreter;
char *perl_args[] = { "", "/dev/null", NULL };
int perl_args_count = 2;
#ifdef PERL_SYS_INIT3
int a;
char **perl_args_local;
char *perl_env[] = {};
a = perl_args_count;
perl_args_local = perl_args;
(void) perl_env;
PERL_SYS_INIT3 (&a, (char ***)&perl_args_local, (char ***)&perl_env);
#endif
interpreter = plugin->interpreter;
/* checks */
if (interpreter->ready)
return 0;
#ifdef DEBUG
xlog_perl(LOG_DEBUG, "%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_perl(LOG_ERROR, "%s\n", "failed init-ing vm");
return -1;
}
perl_parse(my_perl, NULL, perl_args_count, perl_args, (char **)NULL);
interpreter->vm = (void*) my_perl;
interpreter->ready = true;
return 0;
}
void
init_perl(struct module *module)
{
/* FIXME: it seems that some systems like OS/2 requires PERL_SYS_INIT3
* and PERL_SYS_TERM to open/close the same block, at least regarding
* some ml messages.
*
* Is passing @environ strictly needed ? --Zas */
/* PERL_SYS_INIT3 may not be defined, it depends on the system. */
#ifdef PERL_SYS_INIT3
char *my_argvec[] = { NULL, NULL };
char **my_argv = my_argvec;
int my_argc = 0;
/* A hack to prevent unused variables warnings. */
my_argv[my_argc++] = "";
PERL_SYS_INIT3(&my_argc, &my_argv, &environ);
#endif
my_perl = perl_alloc();
if (my_perl) {
char *hook_global = get_global_hook_file();
char *hook_local = get_local_hook_file();
char *global_argv[] = { "", hook_global};
char *local_argv[] = { "", hook_local};
int err = 1;
perl_construct(my_perl);
if (hook_local)
err = perl_parse(my_perl, NULL, 2, local_argv, NULL);
else if (hook_global)
err = perl_parse(my_perl, NULL, 2, global_argv, NULL);
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
if (!err) err = perl_run(my_perl);
if (err) precleanup_perl(module);
}
}
void perl_embed_init(char **incl_path, int cache_perl_files) {
static int is_initialized = 0;
if (is_initialized) {
fprintf(stderr, "perl_embed_init has already been initialized, ignoring call.\n");
return;
}
is_initialized = 1;
int incl_n = _chararray_size(incl_path);
perl_opt_cache = cache_perl_files;
char sdlib_arg[512];
snprintf(sdlib_arg, sizeof sdlib_arg, "-Mblib=%s", bfile(SD_CRAWL_LIB_PATH));
//char *perl_argv[] = { "", blib, "-I", bfile("crawlers/Modules/"), bfile2("perl/persistent.pl"), NULL };
char *perl_argv[incl_n ? incl_n + 4 : 3];
int perl_argc = 0;
perl_argv[perl_argc++] = "";
if (incl_n) {
perl_argv[perl_argc++] = "-I";
int i;
for (i = 0; i < incl_n; i++)
perl_argv[perl_argc++] = incl_path[i];
}
perl_argv[perl_argc++] = sdlib_arg;
perl_argv[perl_argc++] = bfile(PERSISTENT_PATH);
perl_argv[perl_argc] = NULL;
extern char **environ;
PERL_SYS_INIT3(&argc, &argv, &environ);
my_perl = perl_alloc();
perl_construct(my_perl);
//int j = 0;
//while (perl_argv[j++] != NULL)
//printf("perl argument %s\n", perl_argv[j]);
perl_parse(my_perl, xs_init, perl_argc, perl_argv, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
}
/*
* mod_init
* Called by opensips at init time
*/
static int mod_init(void) {
int ret = 0;
static int argc = 1;
static char *argv_name = "opensips";
static char **argv = { &argv_name };
LM_INFO("initializing...\n");
if (!filename) {
LM_ERR("insufficient module parameters. Module not loaded.\n");
return -1;
}
/**
* We will need reply() from signaling
* module for sending replies
*/
/* load SIGNALING API */
if(load_sig_api(&sigb)< 0) {
LM_ERR("can't load signaling functions\n");
return -1;
}
PERL_SYS_INIT3(&argc, &argv, &environ);
if ((my_perl = parser_init())) {
ret = 0;
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#else
PL_exit_flags |= PERL_EXIT_EXPECTED;
#endif
} else {
ret = -1;
}
return ret;
}
int main(int argc, char** argv) {
PERL_SYS_INIT3(NULL, NULL, NULL);
{
interp a, b;
boost::thread th1 = boost::thread(boost::bind(&interp::process, &a, "thread 1"));
boost::thread th2 = boost::thread(boost::bind(&interp::process, &b, "thread 2"));
sleep(3);
a.stopping = true;
b.stopping = true;
th1.join();
th2.join();
}
PERL_SYS_TERM();
return 0;
}
/***********************************************************************************************************************************
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();
}
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;
}
void perl_core_init(void)
{
int argc = G_N_ELEMENTS(perl_args);
char **argv = perl_args;
PERL_SYS_INIT3(&argc, &argv, &environ);
print_script_errors = 1;
settings_add_str("perl", "perl_use_lib", PERL_USE_LIB);
/*PL_perl_destruct_level = 1; - this crashes with some people.. */
perl_signals_init();
signal_add_last("script error", (SIGNAL_FUNC) sig_script_error);
perl_scripts_init();
if (irssi_init_finished)
perl_scripts_autorun();
else {
signal_add("irssi init finished", (SIGNAL_FUNC) sig_autorun);
settings_check();
}
module_register("perl", "core");
}
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;
}
void proxenet_perl_preinitialisation(int argc, char** argv, char** envp)
{
PERL_SYS_INIT3(&argc, &argv, &envp);
}
/*
* 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;
}
/*
* 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;
}
