static void define_symbolic_value(const char *ev_name,
const char *field_name,
const char *field_value,
const char *field_str)
{
unsigned long long value;
dSP;
value = eval_flag(field_value);
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
XPUSHs(sv_2mortal(newSVuv(value)));
XPUSHs(sv_2mortal(newSVpv(field_str, 0)));
PUTBACK;
if (get_cv("main::define_symbolic_value", 0))
call_pv("main::define_symbolic_value", G_SCALAR);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
}
static void run_start_sub(void)
{
dSP; /* access to Perl stack */
PUSHMARK(SP);
if (get_cv("main::trace_begin", 0))
call_pv("main::trace_begin", G_DISCARD | G_NOARGS);
}
/*
* Check for existence of a function.
*/
int perl_checkfnc(char *fnc) {
if (get_cv(fnc, 0)) {
return 1;
} else {
return 0;
}
}
static void init_perl_variables()
{
dTHX;
GV *exit_gv = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV);
GvCV(exit_gv) = get_cv("ModPSGI::exit", TRUE);
GvIMPORTED_CV_on(exit_gv);
(void) hv_store(GvHV(PL_envgv), "MOD_PSGI", 8, newSVpv(MOD_PSGI_VERSION, 0), 0);
}
/*
* Stop trace script
*/
static int perl_stop_script(void)
{
dSP; /* access to Perl stack */
PUSHMARK(SP);
if (get_cv("main::trace_end", 0))
call_pv("main::trace_end", G_DISCARD | G_NOARGS);
perl_destruct(my_perl);
perl_free(my_perl);
return 0;
}
START_MY_CXT
#define dl_last_error (SvPVX(MY_CXT.x_dl_last_error))
#define dl_nonlazy (MY_CXT.x_dl_nonlazy)
#ifdef DL_LOADONCEONLY
#define dl_loaded_files (MY_CXT.x_dl_loaded_files)
#endif
#ifdef DL_CXT_EXTRA
#define dl_cxtx (MY_CXT.x_dl_cxtx)
#endif
#ifdef DEBUGGING
#define dl_debug (MY_CXT.x_dl_debug)
#endif
#ifdef DEBUGGING
#define DLDEBUG(level,code) \
STMT_START { \
dMY_CXT; \
if (dl_debug>=level) { code; } \
} STMT_END
#else
#define DLDEBUG(level,code) NOOP
#endif
#ifdef DL_UNLOAD_ALL_AT_EXIT
/* Close all dlopen'd files */
static void
dl_unload_all_files(pTHX_ void *unused)
{
CV *sub;
AV *dl_librefs;
SV *dl_libref;
if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) {
dl_librefs = get_av("DynaLoader::dl_librefs", FALSE);
while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(dl_libref));
PUTBACK;
call_sv((SV*)sub, G_DISCARD | G_NODEBUG);
FREETMPS;
LEAVE;
}
}
}
/*
Returns the Perl reference to the Code object
(sub-routine, method, etc.) identified by the S
character vector `name'.
*/
SV *
getPerlCodeObject(USER_OBJECT_ name)
{
SV *val;
SV *tmp;
Rboolean recurse = FALSE;
dTHX;
if(IS_CHARACTER(name)) {
val = (SV *) get_cv(CHAR_DEREF(STRING_ELT(name, 0)), FALSE);
return(val);
} else
tmp = getForeignPerlReference(name);
if(tmp == NULL)
return(NULL);
do {
recurse = FALSE;
switch(SvTYPE(tmp)) {
case SVt_PVGV:
/*XXX Is this correct? or should it be GvCV() */
tmp = GvSV(tmp);
recurse = TRUE;
break;
case SVt_PVCV:
val = tmp;
break;
#if 0
/* SVt_RV no longer exists in modern perl versions */
case SVt_RV:
val = SvRV(tmp);
break;
#endif
default:
val = NULL;
getPerlType(tmp);
break;
}
} while(recurse);
return(val);
}
missing_perl_method(const char *perl_class_name)
#endif
{
const int BUF_LEN = 64; /* Should be big enough, right? hah */
char full_name[BUF_LEN];
const char *methods[] = { "new", "findzone", "lookup", NULL };
int i = 0;
while( methods[i] != NULL ) {
snprintf(full_name, BUF_LEN, "%s::%s",
perl_class_name, methods[i]);
if (get_cv(full_name, 0) == NULL) {
return methods[i];
}
i++;
}
return (NULL);
}
static void define_symbolic_field(const char *ev_name,
const char *field_name)
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
PUTBACK;
if (get_cv("main::define_symbolic_field", 0))
call_pv("main::define_symbolic_field", G_SCALAR);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
}
/* Close all dlopen'd files */
static void
dl_unload_all_files(pTHXo_ void *unused)
{
CV *sub;
AV *dl_librefs;
SV *dl_libref;
if ((sub = get_cv("DynaLoader::dl_unload_file", FALSE)) != NULL) {
dl_librefs = get_av("DynaLoader::dl_librefs", FALSE);
while ((dl_libref = av_pop(dl_librefs)) != &PL_sv_undef) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(dl_libref));
PUTBACK;
call_sv((SV*)sub, G_DISCARD | G_NODEBUG);
FREETMPS;
LEAVE;
}
}
}
static void perl_process_event_generic(union perf_event *event,
struct perf_sample *sample,
struct perf_evsel *evsel)
{
dSP;
if (!get_cv("process_event", 0))
return;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpvn((const char *)event, event->header.size)));
XPUSHs(sv_2mortal(newSVpvn((const char *)&evsel->attr, sizeof(evsel->attr))));
XPUSHs(sv_2mortal(newSVpvn((const char *)sample, sizeof(*sample))));
XPUSHs(sv_2mortal(newSVpvn((const char *)sample->raw_data, sample->raw_size)));
PUTBACK;
call_pv("process_event", G_SCALAR);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
}
JSObject*
PJS_InitPerlSubClass(
pTHX_
JSContext *cx,
JSObject *global
) {
CV *pcv = get_cv(NAMESPACE"PerlSub::prototype", 0);
JSObject *proto;
if(pcv && (CvROOT(pcv) || CvXSUB(pcv))) {
proto = JS_InitClass(
cx,
global,
PJS_GetPackageObject(aTHX_ cx, PerlSubPkg),
&perlsub_class,
PerlSub, 1,
NULL, NULL,
NULL, NULL
);
return PJS_CreateJSVis(aTHX_ cx, proto,
sv_2mortal(newRV_inc((SV *)pcv)));
}
croak("Can't locate PerlSub::prototype");
return NULL;
}
/* returns whether or not a function exists */
int owl_perlconfig_is_function(const char *fn) {
if (get_cv(fn, FALSE)) return(1);
else return(0);
}
const Ref<Code>::Temp Interpreter::code(const char* name) const {
CV* const cv = get_cv(name, true);
return Ref<Code>::Temp(raw_interp.get(), newRV_inc((SV*)cv), true);
}
/*
* 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;
}
static void perl_process_tracepoint(struct perf_sample *sample,
struct perf_evsel *evsel,
struct thread *thread)
{
struct event_format *event = evsel->tp_format;
struct format_field *field;
static char handler[256];
unsigned long long val;
unsigned long s, ns;
int pid;
int cpu = sample->cpu;
void *data = sample->raw_data;
unsigned long long nsecs = sample->time;
const char *comm = thread__comm_str(thread);
dSP;
if (evsel->attr.type != PERF_TYPE_TRACEPOINT)
return;
if (!event)
die("ug! no event found for type %" PRIu64, (u64)evsel->attr.config);
pid = raw_field_value(event, "common_pid", data);
sprintf(handler, "%s::%s", event->system, event->name);
if (!test_and_set_bit(event->id, events_defined))
define_event_symbols(event, handler, event->print_fmt.args);
s = nsecs / NSECS_PER_SEC;
ns = nsecs - s * NSECS_PER_SEC;
scripting_context->event_data = data;
scripting_context->pevent = evsel->tp_format->pevent;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(handler, 0)));
XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context))));
XPUSHs(sv_2mortal(newSVuv(cpu)));
XPUSHs(sv_2mortal(newSVuv(s)));
XPUSHs(sv_2mortal(newSVuv(ns)));
XPUSHs(sv_2mortal(newSViv(pid)));
XPUSHs(sv_2mortal(newSVpv(comm, 0)));
/* common fields other than pid can be accessed via xsub fns */
for (field = event->format.fields; field; field = field->next) {
if (field->flags & FIELD_IS_STRING) {
int offset;
if (field->flags & FIELD_IS_DYNAMIC) {
offset = *(int *)(data + field->offset);
offset &= 0xffff;
} else
offset = field->offset;
XPUSHs(sv_2mortal(newSVpv((char *)data + offset, 0)));
} else { /* FIELD_IS_NUMERIC */
val = read_size(event, data + field->offset,
field->size);
if (field->flags & FIELD_IS_SIGNED) {
XPUSHs(sv_2mortal(newSViv(val)));
} else {
XPUSHs(sv_2mortal(newSVuv(val)));
}
}
}
PUTBACK;
if (get_cv(handler, 0))
call_pv(handler, G_SCALAR);
else if (get_cv("main::trace_unhandled", 0)) {
XPUSHs(sv_2mortal(newSVpv(handler, 0)));
XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context))));
XPUSHs(sv_2mortal(newSVuv(cpu)));
XPUSHs(sv_2mortal(newSVuv(nsecs)));
XPUSHs(sv_2mortal(newSViv(pid)));
XPUSHs(sv_2mortal(newSVpv(comm, 0)));
call_pv("main::trace_unhandled", G_SCALAR);
}
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
}
static void perl_process_event(int cpu, void *data,
int size __unused,
unsigned long long nsecs, char *comm)
{
struct format_field *field;
static char handler[256];
unsigned long long val;
unsigned long s, ns;
struct event *event;
int type;
int pid;
dSP;
type = trace_parse_common_type(data);
event = find_cache_event(type);
if (!event)
die("ug! no event found for type %d", type);
pid = trace_parse_common_pid(data);
sprintf(handler, "%s::%s", event->system, event->name);
s = nsecs / NSECS_PER_SEC;
ns = nsecs - s * NSECS_PER_SEC;
scripting_context->event_data = data;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(handler, 0)));
XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context))));
XPUSHs(sv_2mortal(newSVuv(cpu)));
XPUSHs(sv_2mortal(newSVuv(s)));
XPUSHs(sv_2mortal(newSVuv(ns)));
XPUSHs(sv_2mortal(newSViv(pid)));
XPUSHs(sv_2mortal(newSVpv(comm, 0)));
/* common fields other than pid can be accessed via xsub fns */
for (field = event->format.fields; field; field = field->next) {
if (field->flags & FIELD_IS_STRING) {
int offset;
if (field->flags & FIELD_IS_DYNAMIC) {
offset = *(int *)(data + field->offset);
offset &= 0xffff;
} else
offset = field->offset;
XPUSHs(sv_2mortal(newSVpv((char *)data + offset, 0)));
} else { /* FIELD_IS_NUMERIC */
val = read_size(data + field->offset, field->size);
if (field->flags & FIELD_IS_SIGNED) {
XPUSHs(sv_2mortal(newSViv(val)));
} else {
XPUSHs(sv_2mortal(newSVuv(val)));
}
}
}
PUTBACK;
if (get_cv(handler, 0))
call_pv(handler, G_SCALAR);
else if (get_cv("main::trace_unhandled", 0)) {
XPUSHs(sv_2mortal(newSVpv(handler, 0)));
XPUSHs(sv_2mortal(newSViv(PTR2IV(scripting_context))));
XPUSHs(sv_2mortal(newSVuv(cpu)));
XPUSHs(sv_2mortal(newSVuv(nsecs)));
XPUSHs(sv_2mortal(newSViv(pid)));
XPUSHs(sv_2mortal(newSVpv(comm, 0)));
call_pv("main::trace_unhandled", G_SCALAR);
}
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
}
