/* Destroy all perl scripts and deinitialize perl interpreter */
void perl_scripts_deinit(void)
{
if (my_perl == NULL)
return;
/* unload all scripts */
while (perl_scripts != NULL)
perl_script_unload(perl_scripts->data);
signal_emit("perl scripts deinit", 0);
perl_signals_stop();
perl_sources_stop();
perl_common_stop();
/* Unload all perl libraries loaded with dynaloader */
perl_eval_pv("foreach my $lib (@DynaLoader::dl_modules) { if ($lib =~ /^Irssi\\b/) { $lib .= '::deinit();'; eval $lib; } }", TRUE);
/* We could unload all libraries .. but this crashes with some
libraries, probably because we don't call some deinit function..
Anyway, this would free some memory with /SCRIPT RESET, but it
leaks memory anyway. */
/*perl_eval_pv("eval { foreach my $lib (@DynaLoader::dl_librefs) { DynaLoader::dl_unload_file($lib); } }", TRUE);*/
/* perl interpreter */
perl_destruct(my_perl);
perl_free(my_perl);
my_perl = NULL;
}
/* ---- 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 rlm_perl_destruct(PerlInterpreter *perl)
{
dTHXa(perl);
PERL_SET_CONTEXT(perl);
PL_perl_destruct_level = 2;
PL_origenviron = environ;
{
dTHXa(perl);
}
/*
* FIXME: This shouldn't happen
*
*/
while (PL_scopestack_ix > 1) {
LEAVE;
}
perl_destruct(perl);
perl_free(perl);
}
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();
}
static void
ngx_http_perl_exit(ngx_cycle_t *cycle)
{
#if (NGX_HAVE_PERL_MULTIPLICITY)
/*
* the master exit hook is run before global pool cleanup,
* therefore just set flag here
*/
ngx_perl_term = 1;
#else
if (nginx_stash) {
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, cycle->log, 0, "perl term");
(void) perl_destruct(perl);
perl_free(perl);
PERL_SYS_TERM();
}
#endif
}
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);
}
static void irssi_perl_stop(void)
{
g_hash_table_foreach(first_signals, (GHFunc) signal_destroy_hash, NULL);
g_hash_table_destroy(first_signals);
g_hash_table_foreach(last_signals, (GHFunc) signal_destroy_hash, NULL);
g_hash_table_destroy(last_signals);
first_signals = last_signals = NULL;
if (signal_grabbed) {
signal_grabbed = FALSE;
signal_remove("signal", (SIGNAL_FUNC) sig_signal);
}
if (siglast_grabbed) {
siglast_grabbed = FALSE;
signal_remove("last signal", (SIGNAL_FUNC) sig_lastsignal);
}
while (perl_timeouts != NULL)
perl_timeout_destroy(perl_timeouts->data);
perl_destruct(irssi_perl_interp);
perl_free(irssi_perl_interp);
irssi_perl_interp = NULL;
}
void Embperl::Reinit() {
in_use = true;
PL_perl_destruct_level = 1;
perl_destruct(my_perl);
DoInit();
in_use = false;
}
int
ClsPerlHost::PerlDestroy(PerlInterpreter *my_perl)
{
int ret = perl_destruct(my_perl); // Destructor for Perl.
//// perl_free(my_perl); // Free the memory allocated for Perl.
return(ret);
}
static void destroy_perl(PerlInterpreter ** to_destroy)
{
Perl_safe_eval(*to_destroy, HACK_CLEAN_CODE);
perl_destruct(*to_destroy);
perl_free(*to_destroy);
*to_destroy = NULL;
}
void
weechat_perl_unload (struct t_plugin_script *script)
{
int *rc;
void *interpreter;
char *filename;
if ((weechat_perl_plugin->debug >= 2) || !perl_quiet)
{
weechat_printf (NULL,
weechat_gettext ("%s: unloading script \"%s\""),
PERL_PLUGIN_NAME, script->name);
}
#ifdef MULTIPLICITY
PERL_SET_CONTEXT (script->interpreter);
#endif /* MULTIPLICITY */
if (script->shutdown_func && script->shutdown_func[0])
{
rc = (int *)weechat_perl_exec (script,
WEECHAT_SCRIPT_EXEC_INT,
script->shutdown_func,
NULL, NULL);
if (rc)
free (rc);
}
filename = strdup (script->filename);
interpreter = script->interpreter;
if (perl_current_script == script)
{
perl_current_script = (perl_current_script->prev_script) ?
perl_current_script->prev_script : perl_current_script->next_script;
}
plugin_script_remove (weechat_perl_plugin, &perl_scripts, &last_perl_script,
script);
#ifdef MULTIPLICITY
if (interpreter)
{
perl_destruct (interpreter);
perl_free (interpreter);
}
if (perl_current_script)
{
PERL_SET_CONTEXT (perl_current_script->interpreter);
}
#else
if (interpreter)
free (interpreter);
#endif /* MULTIPLICITY */
(void) weechat_hook_signal_send ("perl_script_unloaded",
WEECHAT_HOOK_SIGNAL_STRING, filename);
if (filename)
free (filename);
}
/* 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;
}
}
int script_free()
{
perl_destruct(my_perl);
perl_free(my_perl);
return 0;
}
int unload_perl__( void )
{
int i;
#ifdef MULTI_THREAD
if( NULL == th)
th = xsb_get_main_thread();
#endif
PL_perl_destruct_level = 1;
perl_destruct( my_perl );
perl_free( my_perl );
/*-------------------------------------------------------------------------
free all the space allocated for perl match functions
-------------------------------------------------------------------------*/
for ( i=0; i<preBulkMatchNumber; i++ )
free(bulkMatchList[i]);
if (bulkMatchList != NULL ) free(bulkMatchList);
if (matchPattern != NULL ) free(matchPattern);
if (substituteString != NULL ) free(substituteString);
free(subMatchSpec);
perlObjectStatus = UNLOADED;
return SUCCESS;
}
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);
}
void clear_perl(void *nothing) {
dTHX;
/* warn ("destroying perl engine %x", my_perl); */
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SET_CONTEXT(NULL);
}
/* cleanup time! */
static void pl_perl_shutdown_perl(void) {
if (my_perl != NULL) {
perl_destruct(my_perl);
perl_free(my_perl);
my_perl = NULL;
}
}
static void
PurlDestroy()
{
perl_destruct(my_perl);
perl_free(my_perl);
PERL_SYS_TERM();
}
static void
stop_perl_interpreter (PerlInterpreter *interp)
{
log_debug ("stop_perl_interpreter");
PERL_SET_CONTEXT(interp);
perl_destruct(interp);
perl_free (interp);
}
int C2PERLPerlDestroy()
///////////////////////////////////////////////////////////////////////////
{
perl_destruct(my_perl);
perl_free(my_perl);
g_init=0;
return(0);
}
void KviPerlInterpreter::done()
{
if(!m_pInterpreter)return;
PERL_SET_CONTEXT(m_pInterpreter);
PL_perl_destruct_level = 1;
perl_destruct(m_pInterpreter);
perl_free(m_pInterpreter);
m_pInterpreter = 0;
}
void
cleanup_perl(void)
{
if (!interp_perl)
return;
perl_destruct(interp_perl);
perl_free(interp_perl);
interp_perl = 0;
}
static void
precleanup_perl(struct module *module)
{
if (!my_perl) return;
perl_destruct(my_perl);
perl_free(my_perl);
my_perl = NULL;
}
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);
}
void nsperl2_free_master_context (void *context)
{
extern perl_master_context *nsperl2_master_context;
assert (nsperl2_master_context);
Ns_Log (Notice, "in nsperl2_free_master_context - about to free and destruct master perl context");
PERL_SET_CONTEXT (nsperl2_master_context->perl_master_interp);
perl_destruct (nsperl2_master_context->perl_master_interp);
perl_free (nsperl2_master_context->perl_master_interp);
PERL_SYS_TERM();
}
void
free_perl(PerlInterpreter *p)
{
#if 0
fprintf(stderr, "destructing perl %p\n", p); fflush(stderr);
#endif
perl_destruct(p);
perl_free(p);
PERL_SET_CONTEXT(0);
}
virtual ~CModPerl() {
if (m_pPerl) {
PSTART;
PCALL("ZNC::Core::UnloadAll");
PEND;
perl_destruct(m_pPerl);
perl_free(m_pPerl);
PERL_SYS_TERM();
}
}
static void
ngx_http_perl_cleanup_perl(void *data)
{
PerlInterpreter *perl = data;
PERL_SET_CONTEXT(perl);
(void) perl_destruct(perl);
perl_free(perl);
}
void
script_shutdown ()
{
#ifdef USE_GUILE
#endif
#ifdef USE_PERL
perl_destruct (perl_env);
perl_free (perl_env);
#endif
}
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;
}
