static bool do_script_unload(const char *filename)
{
bool retval = true;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(filename, 0)));
PUTBACK;
call_pv("Atheme::Init::unload_script", G_EVAL | G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV))
{
retval = false;
mowgli_strlcpy(perl_error, SvPV_nolen(ERRSV), sizeof(perl_error));
POPs;
}
FREETMPS;
LEAVE;
invalidate_object_references();
return retval;
}
static bool do_script_list(sourceinfo_t *si)
{
bool retval = true;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
SV *arg = newSV(0);
sv_setref_pv(arg, "Atheme::Sourceinfo", si);
XPUSHs(sv_2mortal(arg));
PUTBACK;
call_pv("Atheme::Init::list_scripts", G_EVAL | G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV))
{
retval = false;
mowgli_strlcpy(perl_error, SvPV_nolen(ERRSV), sizeof(perl_error));
POPs;
}
FREETMPS;
LEAVE;
invalidate_object_references();
return retval;
}
/*
* 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
perl_command_handler(struct sourceinfo *si, const int parc, char **parv)
{
struct perl_command * pc = (struct perl_command *) si->command;
dTHX;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(pc->handler);
SV *sourceinfo_sv = newSV(0);
sv_setref_pv(sourceinfo_sv, "Atheme::Sourceinfo", si);
XPUSHs(sv_2mortal(sourceinfo_sv));
for (int i = 0; i < parc; ++i)
XPUSHs(sv_2mortal(newSVpv(parv[i], 0)));
PUTBACK;
call_pv("Atheme::Init::call_wrapper", G_VOID | G_DISCARD | G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV))
{
command_fail(si, fault_unimplemented, _("Unexpected error occurred: %s"), SvPV_nolen(ERRSV));
slog(LG_ERROR, "Perl handler for command %s/%s returned error: %s",
si->service->internal_name, si->command->name, SvPV_nolen(ERRSV));
}
PUTBACK;
FREETMPS;
LEAVE;
/* Control has now handed back to Atheme, so all references held
* by Perl to Atheme objects are invalid.
*/
invalidate_object_references();
}
/*
* Implementation functions: load or unload a perl script.
*/
static module_t *do_script_load(const char *filename)
{
/* Remember, this must now be re-entrant. The use of the static
* perl_error buffer is still OK, as it's only used immediately after
* setting, without control passing from this function.
*/
perl_script_module_t *m = mowgli_heap_alloc(perl_script_module_heap);
mowgli_strlcpy(m->filename, filename, sizeof(m->filename));
snprintf(perl_error, sizeof(perl_error), "Unknown error attempting to load perl script %s",
filename);
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(newRV_noinc((SV*)get_cv("Atheme::Init::load_script", 0)));
XPUSHs(sv_2mortal(newSVpv(filename, 0)));
PUTBACK;
int perl_return_count = call_pv("Atheme::Init::call_wrapper", G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV))
{
mowgli_strlcpy(perl_error, SvPV_nolen(ERRSV), sizeof(perl_error));
goto fail;
}
if (1 != perl_return_count)
{
snprintf(perl_error, sizeof(perl_error), "Script load didn't return a package name");
goto fail;
}
/* load_script should have returned the package name that was just
* loaded...
*/
const char *packagename = POPp;
char info_varname[BUFSIZE];
snprintf(info_varname, BUFSIZE, "%s::Info", packagename);
/* ... so use that name to grab the script information hash...
*/
HV *info_hash = get_hv(info_varname, 0);
if (!info_hash)
{
snprintf(perl_error, sizeof(perl_error), "Couldn't get package info hash %s", info_varname);
goto fail;
}
/* ..., extract the canonical name...
*/
SV **name_var = hv_fetch(info_hash, "name", 4, 0);
if (!name_var)
{
snprintf(perl_error, sizeof(perl_error), "Couldn't find canonical name in package info hash");
goto fail;
}
mowgli_strlcpy(m->mod.name, SvPV_nolen(*name_var), sizeof(m->mod.name));
/* ... and dependency list.
*/
SV **deplist_var = hv_fetch(info_hash, "depends", 7, 0);
/* Not declaring this is legal... */
if (deplist_var)
{
/* ... but having it as anything but an arrayref isn't. */
if (!SvROK(*deplist_var) || SvTYPE(SvRV(*deplist_var)) != SVt_PVAV)
{
snprintf(perl_error, sizeof(perl_error), "$Info::depends must be an array reference");
goto fail;
}
AV *deplist = (AV*)SvRV(*deplist_var);
I32 len = av_len(deplist);
/* av_len returns max index, not number of items */
for (I32 i = 0; i <= len; ++i)
{
SV **item = av_fetch(deplist, i, 0);
if (!item)
continue;
const char *dep_name = SvPV_nolen(*item);
if (!module_request(dep_name))
{
snprintf(perl_error, sizeof(perl_error), "Dependent module %s failed to load",
dep_name);
goto fail;
}
module_t *dep_mod = module_find_published(dep_name);
mowgli_node_add(dep_mod, mowgli_node_create(), &m->mod.deplist);
mowgli_node_add(m, mowgli_node_create(), &dep_mod->dephost);
}
}
FREETMPS;
LEAVE;
invalidate_object_references();
/* Now that everything's loaded, do the module housekeeping stuff. */
m->mod.unload_handler = perl_script_module_unload_handler;
/* Can't do much better than the address of the module_t here */
m->mod.address = m;
m->mod.can_unload = MODULE_UNLOAD_CAPABILITY_OK;
return (module_t*)m;
fail:
slog(LG_ERROR, "Failed to load Perl script %s: %s", filename, perl_error);
if (info_hash)
SvREFCNT_dec((SV*)info_hash);
do_script_unload(filename);
mowgli_heap_free(perl_script_module_heap, m);
POPs;
FREETMPS;
LEAVE;
invalidate_object_references();
return NULL;
}