static perl_parse_and_execute(PerlInterpreter * my_perl, char *input_code, char *setup_code)
{
int error = 0;
if (*input_code == '~') {
char *buff = input_code + 1;
perl_parse(my_perl, xs_init, 3, embedding, NULL);
if (setup_code)
Perl_safe_eval(my_perl, setup_code);
Perl_safe_eval(my_perl, buff);
} else {
int argc = 0;
char *argv[128] = { 0 };
char *err;
argv[0] = "FreeSWITCH";
argc++;
argc += switch_separate_string(input_code, ' ', &argv[1], (sizeof(argv) / sizeof(argv[0])) - 1);
if (!perl_parse(my_perl, xs_init, argc, argv, (char **) NULL)) {
if (setup_code) {
if (!Perl_safe_eval(my_perl, setup_code)) {
perl_run(my_perl);
}
}
}
if ((err = SvPV(get_sv("@", TRUE), n_a)) && !zstr(err)) {
switch_log_printf(SWITCH_CHANNEL_LOG, SWITCH_LOG_ERROR, "%s\n", err);
}
}
}
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;
}
int load_perl__( void )
{
char *embedding[] = {"","-e","0"}; /* perl interpreter config params */
int i;
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
/* check if the perl interpreter is loaded already*/
if ( perlObjectStatus == LOADED ) return SUCCESS;
/*------------------------------------------------------------------------
initial the global variables
----------------------------------------------------------------------*/
for ( i=0; i<MAX_TOTAL_MATCH; i++ )
matchResults[i] = NULL;
preBulkMatchNumber = 0;
bulkMatchList = NULL;
matchPattern = NULL;
substituteString = NULL;
build_sub_match_spec(); /*build the submatch arguments string constant*/
my_perl = perl_alloc();
perl_construct( my_perl );
perl_parse( my_perl, NULL, 3, embedding, (char **)NULL );
perl_run(my_perl);
perlObjectStatus = LOADED;
return (SUCCESS);
}
/* Initialize perl interpreter */
void perl_scripts_init(void)
{
char *code, *use_code;
perl_scripts = NULL;
perl_sources_start();
perl_signals_start();
my_perl = perl_alloc();
perl_construct(my_perl);
perl_parse(my_perl, xs_init, G_N_ELEMENTS(perl_args), perl_args, NULL);
#if PERL_STATIC_LIBS == 1
perl_eval_pv("Irssi::Core::->boot_Irssi_Core(0.9);", TRUE);
#endif
perl_common_start();
use_code = perl_get_use_list();
code = g_strdup_printf(irssi_core_code, PERL_STATIC_LIBS, use_code);
perl_eval_pv(code, TRUE);
g_free(code);
g_free(use_code);
}
main (int argc, char **argv, char **env)
{
STRLEN n_a;
char *embedding[] = { "", "-e", "0" };
my_perl = perl_alloc();
perl_construct( my_perl );
perl_parse(my_perl, NULL, 3, embedding, NULL);
perl_run(my_perl);
/** Treat $a as an integer **/
perl_eval_pv("$a = 3; $a **= 2", TRUE);
printf("a = %d\n", SvIV(perl_get_sv("a", FALSE)));
/** Treat $a as a float **/
perl_eval_pv("$a = 3.14; $a **= 2", TRUE);
printf("a = %f\n", SvNV(perl_get_sv("a", FALSE)));
/** Treat $a as a string **/
perl_eval_pv("$a = 'rekcaH lreP rehtonA tsuJ'; $a = reverse($a);", TRUE);
printf("a = %s\n", SvPV(perl_get_sv("a", FALSE), n_a));
perl_destruct(my_perl);
perl_free(my_perl);
}
/* ---- special pearl parser ----- */
int perl_parse_buf (char *inBuf) {
STRLEN n_a;
char *embedding[] = { "", "-e", "" };
if (!my_perl) {
my_perl = perl_alloc();
perl_construct( my_perl );
perl_parse(my_perl, xs_init, 3, embedding, NULL);
/* PL_exit_flags |= PERL_EXIT_DESTRUCT_END; */
perl_run(my_perl);
}
/* sv_setpv(text,inBuf); */
/* eval_sv(text,G_SCALAR); */
perlBuf = eval_pv(inBuf, TRUE);
if (0) {
perl_destruct(my_perl);
perl_free(my_perl);
}
return 0;
}
static void irssi_perl_start(void)
{
/* stolen from xchat, thanks :) */
char *args[] = {"", "-e", "0"};
char load_file[] =
"sub load_file()\n"
"{\n"
" (my $file_name) = @_;\n"
" open FH, $file_name or return \"File not found: $file_name\";\n"
" local($/) = undef;\n"
" $file = <FH>;\n"
" close FH;\n"
" eval $file;\n"
" eval $file if $@;\n"
" return $@ if $@;\n"
"}";
first_signals = g_hash_table_new((GHashFunc) g_direct_hash, (GCompareFunc) g_direct_equal);
last_signals = g_hash_table_new((GHashFunc) g_direct_hash, (GCompareFunc) g_direct_equal);
perl_timeouts = NULL;
irssi_perl_interp = perl_alloc();
perl_construct(irssi_perl_interp);
perl_parse(irssi_perl_interp, xs_init, 3, args, NULL);
perl_eval_pv(load_file, TRUE);
}
void init_embedded_perl(void) {
char *embedding[] = { "", "p1.pl" };
/* embedding takes the place of argv[] ($argv[0] is the program name.
* - which is not given to Perl).
* Note that the number of args (ie the number of elements in embedding
* [argc] is the third argument of perl_parse().
*/
int exitstatus;
char buffer[132];
if((my_perl=perl_alloc())==NULL){
snprintf(buffer,sizeof(buffer),"Error: Could not allocate memory for embedded Perl interpreter!\n");
buffer[sizeof(buffer)-1]='\x0';
printf("%s\n", buffer);
exit(1);
}
perl_construct(my_perl);
exitstatus=perl_parse(my_perl,xs_init,2,embedding,NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
/* Why is perl_run() necessary ?
* It is needed if the code parsed by perl_parse() has
* any runtime semantics (eg code that gets eval'd,
* behaviour that depends on constants etc).
*/
exitstatus=perl_run(my_perl);
if (exitstatus) {
printf("%s\n", "perl_run() failed.");
exit(1);
}
}
// 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';"
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();
}
/* ---------------------------------------------------------- parse_score --- */
int
parse_score(int argc, char *argv[])
{
int i, status, xargc;
char *xargv[MAXARGS + 2];
assert(argc <= MAXARGS);
/* Insert in arg list the lib dir containing our Perl extension. */
xargv[0] = argv[0];
xargv[1] = extra_lib_dir;
for (i = 1; i < argc; i++)
xargv[i + 1] = argv[i];
xargv[i + 1] = NULL;
xargc = argc + 1;
perl_interp = perl_alloc();
if (perl_interp) {
perl_construct(perl_interp);
status = perl_parse(perl_interp, xs_init, xargc, xargv, (char **)NULL);
if (status == 0)
perl_run(perl_interp);
}
else {
fprintf(stderr, "Can't create Perl interpreter.\n");
status = -1;
}
return status;
}
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);
}
/* Stopping has one big memory leak right now, so it's not used. */
void perlstartstop (int startnotstop)
{
if (startnotstop && !isperlrunning) {
char *embedding[3];
embedding[0] = malloc_strdup(empty_string);
embedding[1] = malloc_strdup("-e");
embedding[2] = malloc_strdup("$SIG{__DIE__}=$SIG{__WARN__}=\\&EPIC::yell;");
++isperlrunning;
my_perl = perl_alloc();
perl_construct( my_perl );
perl_parse(my_perl, xs_init, 3, embedding, NULL);
if (SvTRUE(ERRSV))
yell("perl_parse: %s", SvPV_nolen(ERRSV));
perl_run(my_perl);
if (SvTRUE(ERRSV))
yell("perl_run: %s", SvPV_nolen(ERRSV));
} else if (!startnotstop && isperlrunning && !perlcalldepth) {
perl_destruct(my_perl);
if (SvTRUE(ERRSV))
yell("perl_destruct: %s", SvPV_nolen(ERRSV));
perl_free(my_perl);
if (SvTRUE(ERRSV))
yell("perl_free: %s", SvPV_nolen(ERRSV));
isperlrunning=0;
}
}
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
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 );
}
void perl_interpreter_init_()
{
char *embedding[] = { "", "-e", "0" };
my_perl = perl_alloc();
perl_construct(my_perl);
perl_parse(my_perl, xs_init, 3, embedding, (char **)NULL);
perl_run(my_perl);
}
static PerlInterpreter* campher_new_perl() {
PerlInterpreter* my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
perl_construct(my_perl);
perl_parse(my_perl, xs_init, 3, campher_embedding, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
return my_perl;
}
int main(int argc, char **argv, char **env)
{
my_perl = perl_alloc();
perl_construct(my_perl);
perl_parse(my_perl, NULL, argc, argv, (char **)NULL);
perl_run(my_perl);
perl_destruct(my_perl);
perl_free(my_perl);
}
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 int
check_perl_interpreter (char *err, int max_len)
{
int ret = 0;
PerlInterpreter *intrp;
char *embedding[] = { "CGI", "-e",
"use Config;\n"
"use DynaLoader;\n"
/* "print STDERR 'loading ['.$Config{archlibexp}.'/CORE/'.$Config{libperl}.']\n';\n"*/
#if !defined (__APPLE__)
"DynaLoader::dl_load_file ($Config{archlibexp}.'/CORE/'.$Config{libperl},0x01);\n"
#endif
};
#ifdef MY_ENV
char *envp[] = {
NULL
};
#else
char **envp = NULL;
#endif
if (NULL == (intrp = perl_alloc()))
{
SET_ERR ("Unable to allocate perl interpreter");
return ret;
}
{
dTHX;
perl_construct(intrp);
PERL_SET_CONTEXT(intrp);
if (0 == perl_parse(intrp, xs_init, 3, embedding, envp))
{
PERL_SET_CONTEXT(intrp);
if (0 == perl_run(intrp))
ret = 1;
else
{
SET_ERR ("Unable to run the perl interpreter");
ret = 0;
}
}
else
{
SET_ERR ("Unable to parse virt_handler.pl");
ret = 0;
}
#ifdef PERL_EXIT_DESTRUCT_END
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
#endif
perl_destruct (intrp);
perl_free (intrp);
}
return ret;
}
PerlInterpreter *
new_perl(void)
{
PerlInterpreter *p;
char *embedding[] = { "", "-mPython::Object", "-e", "$| = 1;", NULL };
p = perl_alloc();
#if 0
fprintf(stderr, "creating new perl %p\n", p); fflush(stderr);
#endif
perl_construct(p);
#ifdef BOOT_FROM_PERL
perl_parse(p, 0, 4, embedding, NULL);
#else
perl_parse(p, xs_init, 4, embedding, NULL);
#endif
perl_run(p);
return p;
}
/*
* 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;
}
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);
}
}
int CPerlModule::Init()
{
#ifdef PAYGUIDE_PERL
my_perl = perl_alloc();
perl_construct(my_perl);
PL_perl_destruct_level=1;
broken=perl_parse(my_perl, NULL, argn, argv, NULL);
return broken;
#else
return 0;
#endif
}
static PerlInterpreter* construct_perl() {
PerlInterpreter* my_perl = perl_alloc();
PERL_SET_CONTEXT(my_perl);
perl_construct(my_perl);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_parse(my_perl, xs_init, argc, (char**)argv, NULL);
ENTER;
load_module(PERL_LOADMOD_NOIMPORT, newSVpv("threads::lite", 0), NULL, NULL);
LEAVE;
return my_perl;
}
interp() : my_perl(NULL), stopping(false) {
my_perl = perl_alloc();
perl_construct(my_perl);
const char* embedding[] = {"", "-e", "0"};
perl_parse(my_perl, NULL, 3, (char**)embedding, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
//eval_pv("sub test_method { my $a = @_[0]; $a = $a . \" and something else!\"; return $a; }", TRUE);
eval_pv("sub test_method { my $a = \"test string\"; return $a; }", TRUE);
};
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) {
struct stat stat_buf;
char *p1 = P1FILE;
// try fallback p1 file
if(stat(P1FILE, &stat_buf) != 0 && stat("worker/mod_gearman_p1.pl", &stat_buf) == 0 ) {
p1 = "worker/mod_gearman_p1.pl";
}
char *embedding[] = { "", p1 };
char command_line[MAX_INPUT_CHARS];
int exitstatus;
/* usage? */
if(argc > 1 && (!strcmp(argv[1], "-h") || !strcmp(argv[1], "--help"))) {
printf("Mod-Gearman Mini-ePN:\n");
printf("\n");
printf("Usage: %s [perl_plugin [arguments]]\n", argv[0]);
printf("\n");
printf("test perl plugins as if they were run by ePN.\n");
exit(3);
}
if((my_perl = perl_alloc()) == NULL) {
printf("%s\n", "Error: Could not allocate memory for embedded Perl interpreter!");
exit(1);
}
perl_construct(my_perl);
exitstatus = perl_parse(my_perl, xs_init, 2, embedding, NULL);
if(!exitstatus) {
exitstatus = perl_run(my_perl);
if(argc > 1) {
int x;
command_line[0] = '\0';
for(x=1; x<argc; x++) {
strncat(command_line, argv[x], MAX_INPUT_CHARS - 1);
if(argc != x) {
strncat(command_line, " ", MAX_INPUT_CHARS - 1);
}
}
exitstatus = run_epn(command_line);
} else {
while(printf("Enter file name: ") && fgets(command_line, MAX_INPUT_CHARS - 1, stdin)) {
exitstatus = run_epn(command_line);
}
}
PL_perl_destruct_level = 0;
perl_destruct(my_perl);
perl_free(my_perl);
exit(exitstatus);
}
return 0;
}
int script_new()
{
char *embedding[] = {"", "-e", "0"};
my_perl = perl_alloc();
perl_construct(my_perl);
perl_parse(my_perl, xs_init, 3, embedding, NULL);
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
perl_run(my_perl);
return 0;
}
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();
}