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; }