void EQWParser::EQW_eval(const char *pkg, const char *code) { char namebuf[64]; snprintf(namebuf, 64, "package %s;", pkg); eval_pv(namebuf, FALSE); //make sure the EQW pointer is set up EQW *curc = EQW::Singleton(); snprintf(namebuf, 64, "EQW"); // snprintf(namebuf, 64, "%s::EQW", pkg); SV *l = get_sv(namebuf, true); if(curc != nullptr) { sv_setref_pv(l, "EQW", curc); } else { //clear out the value, mainly to get rid of blessedness sv_setsv(l, _empty_sv); } //make sure the EQDB pointer is set up EQDB *curc_db = EQDB::Singleton(); snprintf(namebuf, 64, "EQDB"); // snprintf(namebuf, 64, "%s::EQW", pkg); SV *l_db = get_sv(namebuf, true); if(curc_db != nullptr) { sv_setref_pv(l_db, "EQDB", curc_db); } else { //clear out the value, mainly to get rid of blessedness sv_setsv(l_db, _empty_sv); } std::string err; if(!eval(code, err)) { EQW::Singleton()->AppendOutput(err.c_str()); } }
void decode_boolean(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { if (UNLIKELY(len != 1)) croak("decode_boolean: len != 1"); if (*input) sv_setsv(output, &PL_sv_yes); else sv_setsv(output, &PL_sv_no); }
void ffi_pl_complex_float_to_perl(SV *sv, float *ptr) { if(SvOK(sv) && sv_isobject(sv) && sv_derived_from(sv, "Math::Complex")) { /* the complex variable is a Math::Complex object */ set(sv, sv_2mortal(newSVnv(ptr[0])), 0); set(sv, sv_2mortal(newSVnv(ptr[1])), 1); } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { /* the compex variable is already an array */ AV *av = (AV*) SvRV(sv); av_store(av, 0, newSVnv(ptr[0])); av_store(av, 1, newSVnv(ptr[1])); } else { /* the complex variable is something else and an array needs to be created */ SV *values[2]; AV *av; values[0] = newSVnv(ptr[0]); values[1] = newSVnv(ptr[1]); av = av_make(2, values); sv_setsv(sv, newRV_noinc((SV*)av)); } }
void decode_tuple(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { SV *the_rv; AV *the_tuple; struct cc_tuple *tuple; int i; STRLEN pos; the_tuple = newAV(); the_rv = newRV_noinc((SV*)the_tuple); sv_setsv(output, the_rv); SvREFCNT_dec(the_rv); tuple = type->tuple; assert(tuple); pos = 0; for (i = 0; i < tuple->field_count; i++) { struct cc_type *type = &tuple->fields[i]; SV *decoded = newSV(0); av_push(the_tuple, decoded); decode_cell(aTHX_ input, len, &pos, type, decoded); } }
void decode_udt(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { struct cc_udt *udt; int i; STRLEN pos; HV *the_obj; SV *the_rv; the_obj = newHV(); the_rv = newRV_noinc((SV*)the_obj); sv_setsv(output, the_rv); SvREFCNT_dec(the_rv); udt = type->udt; assert(udt && udt->fields); pos = 0; for (i = 0; i < udt->field_count; i++) { if (len == pos) { break; } struct cc_udt_field *field; SV *value; field = &udt->fields[i]; value = newSV(0); hv_store_ent(the_obj, field->name, value, field->name_hash); decode_cell(aTHX_ input, len, &pos, &field->type, value); } }
void decode_list(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { struct cc_type *inner_type; int i; AV *the_list; SV *the_rv; STRLEN pos; inner_type = type->inner_type; assert(inner_type); if (UNLIKELY(len < 4)) croak("decode_list: len < 4"); int32_t num_elements = (int32_t)ntohl(*(uint32_t*)(input)); if (UNLIKELY(num_elements < 0)) croak("decode_list: num_elements < 0"); the_list = newAV(); the_rv = newRV_noinc((SV*)the_list); sv_setsv(output, the_rv); SvREFCNT_dec(the_rv); pos = 4; for (i = 0; i < num_elements; i++) { SV *decoded = newSV(0); av_push(the_list, decoded); decode_cell(aTHX_ input, len, &pos, inner_type, decoded); } }
void owl_perlconfig_perl_timer(owl_timer *t, void *data) { dSP; SV *obj = data; if(!SvROK(obj)) { return; } ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(obj); PUTBACK; call_method("do_callback", G_DISCARD|G_EVAL); SPAGAIN; if (SvTRUE(ERRSV)) { owl_function_error("Error in callback: '%s'", SvPV_nolen(ERRSV)); sv_setsv (ERRSV, &PL_sv_undef); } PUTBACK; FREETMPS; LEAVE; }
AV* coerce1D ( SV* arg, int n ) { /* n is the size of array var[] (n=1 for 1 element, etc.) */ AV* array; I32 i,m; /* In ref to scalar case we can do nothing - we can only hope the caller made the scalar the right size in the first place */ if (is_scalar_ref(arg)) /* Do nothing */ return (AV*)NULL; /* Check what has been passed and create array reference whether it exists or not */ if (SvTYPE(arg)==SVt_PVGV) { array = GvAVn((GV*)arg); /* glob */ }else if (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV) { array = (AV *) SvRV(arg); /* reference */ }else{ array = newAV(); /* Create */ sv_setsv(arg, newRV((SV*) array)); } m = av_len(array); for (i=m+1; i<n; i++) { av_store( array, i, newSViv( (IV) 0 ) ); } return array; }
// convert from (C integer) to (Perl SV containing integer) void XS_pack_integer(SV* output_sv, integer input_integer) { //fprintf(stderr, "in CPPOPS_CPPTYPES XS_pack_integer(), top of subroutine\n"); //fprintf(stderr, "in CPPOPS_CPPTYPES XS_pack_integer(), received input_integer = %d\n", input_integer); sv_setsv(output_sv, sv_2mortal(newSViv(input_integer))); //fprintf(stderr, "in CPPOPS_CPPTYPES XS_pack_integer(), have output_sv = '%s'\n", SvPV_nolen(output_sv)); //fprintf(stderr, "in CPPOPS_CPPTYPES XS_pack_integer(), bottom of subroutine\n"); }
static void put_op_bitspec(pTHX_ const char *optag, STRLEN len, SV *mask) { SV **svp; dMY_CXT; verify_opset(aTHX_ mask,1); svp = hv_fetch(op_named_bits, optag, len, 1); if (SvOK(*svp)) croak("Opcode tag \"%s\" already defined", optag); sv_setsv(*svp, mask); SvREADONLY_on(*svp); }
/* Calls a method on a perl object representing a message. If the return value is non-null, the caller must free it. */ CALLER_OWN char *owl_perlconfig_message_call_method(const owl_message *m, const char *method, int argc, const char **argv) { dSP; unsigned int count, i; SV *msgref, *srv; char *out; msgref = owl_perlconfig_message2hashref(m); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(msgref)); for(i=0;i<argc;i++) { XPUSHs(sv_2mortal(owl_new_sv(argv[i]))); } PUTBACK; count = call_method(method, G_SCALAR|G_EVAL); SPAGAIN; if(count != 1) { fprintf(stderr, "perl returned wrong count %u\n", count); abort(); } if (SvTRUE(ERRSV)) { owl_function_error("Error: '%s'", SvPV_nolen(ERRSV)); /* and clear the error */ sv_setsv (ERRSV, &PL_sv_undef); } srv = POPs; if (srv) { out = g_strdup(SvPV_nolen(srv)); } else { out = NULL; } PUTBACK; FREETMPS; LEAVE; return out; }
void Perl_save_list(pTHX_ register SV **sarg, I32 maxsarg) { dVAR; register I32 i; PERL_ARGS_ASSERT_SAVE_LIST; for (i = 1; i <= maxsarg; i++) { register SV * const sv = newSV(0); sv_setsv(sv,sarg[i]); SSCHECK(3); SSPUSHPTR(sarg[i]); /* remember the pointer */ SSPUSHPTR(sv); /* remember the value */ SSPUSHUV(SAVEt_ITEM); } }
void EQWParser::SetHTTPRequest(const char *pkg, HTTPRequest *it) { char namebuf[64]; snprintf(namebuf, 64, "package %s;", pkg); eval_pv(namebuf, FALSE); snprintf(namebuf, 64, "request"); // snprintf(namebuf, 64, "%s::EQW", pkg); SV *l = get_sv(namebuf, true); if(it != nullptr) { sv_setref_pv(l, "HTTPRequest", it); } else { //clear out the value, mainly to get rid of blessedness sv_setsv(l, _empty_sv); } }
void propagate2JS( pTHX_ PJS_Context *pcx, JSObject *obj ) { JSContext *cx = PJS_getJScx(pcx); if(PJS_getFlag(pcx, "ReflectExceptions")) { jsval rval; SV* cp = newSVsv(ERRSV); if(!PJS_ReflectPerl2JS(aTHX_ cx, obj, cp, &rval)) croak("Can't convert perl error into JSVAL"); JS_SetPendingException(cx, rval); sv_setsv(ERRSV, &PL_sv_undef); sv_free(cp); } else { JS_ClearPendingException(cx); } }
/* Calls in a scalar context, passing it a hash reference. If return value is non-null, caller must free. */ CALLER_OWN char *owl_perlconfig_call_with_message(const char *subname, const owl_message *m) { dSP ; int count; SV *msgref, *srv; char *out; ENTER ; SAVETMPS; PUSHMARK(SP) ; msgref = owl_perlconfig_message2hashref(m); XPUSHs(sv_2mortal(msgref)); PUTBACK ; count = call_pv(subname, G_SCALAR|G_EVAL); SPAGAIN ; if (SvTRUE(ERRSV)) { owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV)); /* and clear the error */ sv_setsv (ERRSV, &PL_sv_undef); } if (count != 1) { fprintf(stderr, "bad perl! no biscuit! returned wrong count!\n"); abort(); } srv = POPs; if (srv) { out = g_strdup(SvPV_nolen(srv)); } else { out = NULL; } PUTBACK ; FREETMPS ; LEAVE ; return out; }
void decode_map(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { struct cc_type *key_type, *value_type; int i; STRLEN pos; HV *the_map; SV *the_rv; key_type = &type->inner_type[0]; value_type = &type->inner_type[1]; assert(key_type && value_type); if (UNLIKELY(len < 4)) croak("decode_map: len < 4"); int32_t num_elements = (int32_t)ntohl(*(uint32_t*)(input)); if (UNLIKELY(num_elements < 0)) croak("decode_map: num_elements < 0"); the_map = newHV(); the_rv = newRV_noinc((SV*)the_map); sv_setsv(output, the_rv); SvREFCNT_dec(the_rv); pos = 4; for (i = 0; i < num_elements; i++) { SV *key, *value; key = newSV(0); sv_2mortal(key); decode_cell(aTHX_ input, len, &pos, key_type, key); value = newSV(0); hv_store_ent(the_map, key, value, 0); decode_cell(aTHX_ input, len, &pos, value_type, value); } }
/* Called by context when a branch occurs */ JSBool PJS_branch_handler(JSContext *cx, JSScript *script) { dSP; PJS_Context *pcx; SV *rv; I32 rc = 0; JSBool status = JS_TRUE; pcx = PJS_GET_CONTEXT(cx); if (pcx != NULL && pcx->branch_handler) { ENTER ; SAVETMPS ; PUSHMARK(SP); rc = perl_call_sv(SvRV(pcx->branch_handler), G_SCALAR | G_EVAL); SPAGAIN; rv = POPs; if (!SvTRUE(rv)) { status = JS_FALSE; } if (SvTRUE(ERRSV)) { sv_setsv(ERRSV, &PL_sv_undef); status = JS_FALSE; } PUTBACK; FREETMPS; LEAVE; } return status; }
/* caller is responsible for freeing returned string */ CALLER_OWN char *owl_perlconfig_execute(const char *line) { STRLEN len; SV *response; char *out; if (!owl_global_have_config(&g)) return NULL; ENTER; SAVETMPS; /* execute the subroutine */ response = eval_pv(line, FALSE); if (SvTRUE(ERRSV)) { owl_function_error("Perl Error: '%s'", SvPV_nolen(ERRSV)); sv_setsv (ERRSV, &PL_sv_undef); /* and clear the error */ } out = g_strdup(SvPV(response, len)); FREETMPS; LEAVE; return(out); }
int init_psgi_app(struct wsgi_request *wsgi_req, char *app, uint16_t app_len, PerlInterpreter **interpreters) { struct stat st; int i; SV **callables; time_t now = uwsgi_now(); char *app_name = uwsgi_concat2n(app, app_len, "", 0); // prepare for $0 uperl.embedding[1] = app_name; int fd = open(app_name, O_RDONLY); if (fd < 0) { uwsgi_error_open(app_name); goto clear2; } if (fstat(fd, &st)) { uwsgi_error("fstat()"); close(fd); goto clear2; } char *buf = uwsgi_calloc(st.st_size+1); if (read(fd, buf, st.st_size) != st.st_size) { uwsgi_error("read()"); close(fd); free(buf); goto clear2; } close(fd); // the first (default) app, should always be loaded in the main interpreter if (interpreters == NULL) { if (uwsgi_apps_cnt) { interpreters = uwsgi_calloc(sizeof(PerlInterpreter *) * uwsgi.threads); interpreters[0] = uwsgi_perl_new_interpreter(); if (!interpreters[0]) { uwsgi_log("unable to create new perl interpreter\n"); free(interpreters); goto clear2; } } else { interpreters = uperl.main; } } if (!interpreters) { goto clear2; } callables = uwsgi_calloc(sizeof(SV *) * uwsgi.threads); uperl.tmp_streaming_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads); uperl.tmp_input_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads); uperl.tmp_error_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads); uperl.tmp_stream_responder = uwsgi_calloc(sizeof(CV *) * uwsgi.threads); uperl.tmp_psgix_logger = uwsgi_calloc(sizeof(CV *) * uwsgi.threads); for(i=0;i<uwsgi.threads;i++) { if (i > 0 && interpreters != uperl.main) { interpreters[i] = uwsgi_perl_new_interpreter(); if (!interpreters[i]) { uwsgi_log("unable to create new perl interpreter\n"); // what to do here ? i hope no-one will use threads with dynamic apps...but clear the whole stuff... free(callables); uwsgi_perl_free_stashes(); while(i>=0) { perl_destruct(interpreters[i]); perl_free(interpreters[i]); goto clear2; } } } PERL_SET_CONTEXT(interpreters[i]); uperl.tmp_current_i = i; if (uperl.locallib) { uwsgi_log("using %s as local::lib directory\n", uperl.locallib); uperl.embedding[1] = uwsgi_concat2("-Mlocal::lib=", uperl.locallib); uperl.embedding[2] = app_name; if (perl_parse(interpreters[i], xs_init, 3, uperl.embedding, NULL)) { // what to do here ? i hope no-one will use threads with dynamic apps... but clear the whole stuff... free(uperl.embedding[1]); uperl.embedding[1] = app_name; free(callables); uwsgi_perl_free_stashes(); goto clear; } free(uperl.embedding[1]); uperl.embedding[1] = app_name; } else { if (perl_parse(interpreters[i], xs_init, 2, uperl.embedding, NULL)) { // what to do here ? i hope no-one will use threads with dynamic apps... but clear the whole stuff... free(callables); uwsgi_perl_free_stashes(); goto clear; } } perl_eval_pv("use IO::Handle;", 0); perl_eval_pv("use IO::File;", 0); perl_eval_pv("use Scalar::Util;", 0); if (!uperl.no_die_catch) { perl_eval_pv("use Devel::StackTrace;", 0); if (!SvTRUE(ERRSV)) { uperl.stacktrace_available = 1; perl_eval_pv("$SIG{__DIE__} = \\&uwsgi::stacktrace;", 0); } } SV *dollar_zero = get_sv("0", GV_ADD); sv_setsv(dollar_zero, newSVpv(app, app_len)); callables[i] = perl_eval_pv(uwsgi_concat4("#line 1 ", app_name, "\n", buf), 0); if (!callables[i]) { uwsgi_log("unable to find PSGI function entry point.\n"); // what to do here ? i hope no-one will use threads with dynamic apps... free(callables); uwsgi_perl_free_stashes(); goto clear; } PERL_SET_CONTEXT(interpreters[0]); } free(buf); if(SvTRUE(ERRSV)) { uwsgi_log("%s\n", SvPV_nolen(ERRSV)); free(callables); uwsgi_perl_free_stashes(); goto clear; } if (uwsgi_apps_cnt >= uwsgi.max_apps) { uwsgi_log("ERROR: you cannot load more than %d apps in a worker\n", uwsgi.max_apps); goto clear; } int id = uwsgi_apps_cnt; struct uwsgi_app *wi = NULL; if (wsgi_req) { // we need a copy of app_id wi = uwsgi_add_app(id, psgi_plugin.modifier1, uwsgi_concat2n(wsgi_req->appid, wsgi_req->appid_len, "", 0), wsgi_req->appid_len, interpreters, callables); } else { wi = uwsgi_add_app(id, psgi_plugin.modifier1, "", 0, interpreters, callables); } wi->started_at = now; wi->startup_time = uwsgi_now() - now; uwsgi_log("PSGI app %d (%s) loaded in %d seconds at %p (interpreter %p)\n", id, app_name, (int) wi->startup_time, callables[0], interpreters[0]); free(app_name); // copy global data to app-specific areas wi->stream = uperl.tmp_streaming_stash; wi->input = uperl.tmp_input_stash; wi->error = uperl.tmp_error_stash; wi->responder0 = uperl.tmp_stream_responder; wi->responder1 = uperl.tmp_psgix_logger; uwsgi_emulate_cow_for_apps(id); // restore context if required if (interpreters != uperl.main) { PERL_SET_CONTEXT(uperl.main[0]); } return id; clear: if (interpreters != uperl.main) { for(i=0;i<uwsgi.threads;i++) { perl_destruct(interpreters[i]); perl_free(interpreters[i]); } free(interpreters); } PERL_SET_CONTEXT(uperl.main[0]); clear2: free(app_name); return -1; }
int PerlembParser::SendCommands(const char *pkgprefix, const char *event, uint32 npcid, Mob* other, Mob* mob, ItemInst* iteminst) { if(!perl) return 0; int ret_value = 0; if(mob && mob->IsClient()) quest_manager.StartQuest(other, mob->CastToClient(), iteminst); else quest_manager.StartQuest(other, nullptr, nullptr); try { std::string cmd = "package " + (std::string)(pkgprefix) + (std::string)(";"); perl->eval(cmd.c_str()); #ifdef EMBPERL_XS_CLASSES { std::string cl = (std::string)"$" + (std::string)pkgprefix + (std::string)"::client"; std::string np = (std::string)"$" + (std::string)pkgprefix + (std::string)"::npc"; std::string qi = (std::string)"$" + (std::string)pkgprefix + (std::string)"::questitem"; std::string enl = (std::string)"$" + (std::string)pkgprefix + (std::string)"::entity_list"; if(clear_vars_.find(cl) != clear_vars_.end()) { std::string eval_str = cl; eval_str += " = undef;"; perl->eval(eval_str.c_str()); } if (clear_vars_.find(np) != clear_vars_.end()) { std::string eval_str = np; eval_str += " = undef;"; perl->eval(eval_str.c_str()); } if (clear_vars_.find(qi) != clear_vars_.end()) { std::string eval_str = qi; eval_str += " = undef;"; perl->eval(eval_str.c_str()); } if (clear_vars_.find(enl) != clear_vars_.end()) { std::string eval_str = enl; eval_str += " = undef;"; perl->eval(eval_str.c_str()); } } char namebuf[64]; //init a couple special vars: client, npc, entity_list Client *curc = quest_manager.GetInitiator(); snprintf(namebuf, 64, "%s::client", pkgprefix); SV *client = get_sv(namebuf, true); if(curc != nullptr) { sv_setref_pv(client, "Client", curc); } else { //clear out the value, mainly to get rid of blessedness sv_setsv(client, _empty_sv); } //only export NPC if it's a npc quest if(!other->IsClient()) { NPC *curn = quest_manager.GetNPC(); snprintf(namebuf, 64, "%s::npc", pkgprefix); SV *npc = get_sv(namebuf, true); sv_setref_pv(npc, "NPC", curn); } //only export QuestItem if it's an item quest if(iteminst) { ItemInst* curi = quest_manager.GetQuestItem(); snprintf(namebuf, 64, "%s::questitem", pkgprefix); SV *questitem = get_sv(namebuf, true); sv_setref_pv(questitem, "QuestItem", curi); } snprintf(namebuf, 64, "%s::entity_list", pkgprefix); SV *el = get_sv(namebuf, true); sv_setref_pv(el, "EntityList", &entity_list); #endif //now call the requested sub ret_value = perl->dosub(std::string(pkgprefix).append("::").append(event).c_str()); #ifdef EMBPERL_XS_CLASSES { std::string cl = (std::string)"$" + (std::string)pkgprefix + (std::string)"::client"; std::string np = (std::string)"$" + (std::string)pkgprefix + (std::string)"::npc"; std::string qi = (std::string)"$" + (std::string)pkgprefix + (std::string)"::questitem"; std::string enl = (std::string)"$" + (std::string)pkgprefix + (std::string)"::entity_list"; clear_vars_[cl] = 1; clear_vars_[np] = 1; clear_vars_[qi] = 1; clear_vars_[enl] = 1; } #endif } catch(const char * err) { //try to reduce some of the console spam... //todo: tweak this to be more accurate at deciding what to filter (we don't want to gag legit errors) if(!strstr(err,"Undefined subroutine")) { std::string error = "Script error: "; error += pkgprefix; error += "::"; error += event; error += " - "; if(strlen(err) > 0) error += err; AddError(error); } } quest_manager.EndQuest(); #ifdef EMBPERL_XS_CLASSES if(!quest_manager.QuestsRunning()) { auto iter = clear_vars_.begin(); std::string eval_str; while(iter != clear_vars_.end()) { eval_str += iter->first; eval_str += " = undef;"; ++iter; } clear_vars_.clear(); try { perl->eval(eval_str.c_str()); } catch (const char * err) { std::string error = "Script clear error: "; if (strlen(err) > 0) error += err; AddError(error); } } #endif return ret_value; }
void EQWParser::DoInit() { const char *argv_eqemu[] = { "", "-w", "-W", "-e", "0;", nullptr }; int argc = 5; char **argv = (char **)argv_eqemu; char **env = { nullptr }; PL_perl_destruct_level = 1; perl_construct(my_perl); PERL_SYS_INIT3(&argc, &argv, &env); perl_parse(my_perl, xs_init, argc, argv, env); perl_run(my_perl); //a little routine we use a lot. eval_pv("sub my_eval {eval $_[0];}", TRUE); //dies on error //ruin the perl exit and command: eval_pv("sub my_exit {}",TRUE); eval_pv("sub my_sleep {}",TRUE); if(gv_stashpv("CORE::GLOBAL", FALSE)) { GV *exitgp = gv_fetchpv("CORE::GLOBAL::exit", TRUE, SVt_PVCV); GvCV_set(exitgp, perl_get_cv("my_exit", TRUE)); //dies on error GvIMPORTED_CV_on(exitgp); GV *sleepgp = gv_fetchpv("CORE::GLOBAL::sleep", TRUE, SVt_PVCV); GvCV_set(sleepgp, perl_get_cv("my_sleep", TRUE)); //dies on error GvIMPORTED_CV_on(sleepgp); } //setup eval_file eval_pv( "our %Cache;" "use Symbol qw(delete_package);" "sub eval_file {" "my($package, $filename) = @_;" "$filename=~s/\'//g;" "if(! -r $filename) { print \"Unable to read perl file '$filename'\\n\"; return; }" "my $mtime = -M $filename;" "if(defined $Cache{$package}{mtime}&&$Cache{$package}{mtime} <= $mtime && !($package eq 'plugin')){" " return;" "} else {" //we 'my' $filename,$mtime,$package,$sub to prevent them from changing our state up here. " eval(\"package $package; my(\\$filename,\\$mtime,\\$package,\\$sub); \\$isloaded = 1; require '$filename'; \");" "}" "}" ,FALSE); //make a tie-able class to capture IO and get it where it needs to go eval_pv( "package EQWIO; " // "&boot_EQEmuIO;" "sub TIEHANDLE { my $me = bless {}, $_[0]; $me->PRINT('Creating '.$me); return($me); } " "sub WRITE { } " "sub PRINTF { my $me = shift; my $fmt = shift; $me->PRINT(sprintf($fmt, @_)); } " "sub CLOSE { my $me = shift; $me->PRINT('Closing '.$me); } " "sub DESTROY { my $me = shift; $me->PRINT('Destroying '.$me); } " //this ties us for all packages "package MAIN;" " if(tied *STDOUT) { untie(*STDOUT); }" " if(tied *STDERR) { untie(*STDERR); }" " tie *STDOUT, 'EQWIO';" " tie *STDERR, 'EQWIO';" ,FALSE); eval_pv( "package world; " ,FALSE ); //make sure the EQW pointer is set up in this package EQW *curc = EQW::Singleton(); SV *l = get_sv("world::EQW", true); if(curc != nullptr) { sv_setref_pv(l, "EQW", curc); } else { //clear out the value, mainly to get rid of blessedness sv_setsv(l, _empty_sv); } //make sure the EQDB pointer is set up in this package EQDB::SetMySQL(database.getMySQL()); EQDB *curc_db = EQDB::Singleton(); SV *l_db = get_sv("world::EQDB", true); if(curc_db != nullptr) { sv_setref_pv(l_db, "EQDB", curc_db); } else { //clear out the value, mainly to get rid of blessedness sv_setsv(l_db, _empty_sv); } //load up EQW eval_pv( "package EQW;" "&boot_EQW;" //load our EQW XS "package EQDB;" "&boot_EQDB;" //load our EQW XS "package EQDBRes;" "&boot_EQDBRes;" //load our EQW XS "package HTTPRequest;" "&boot_HTTPRequest;" //load our HTTPRequest XS "package EQLConfig;" "&boot_EQLConfig;" //load our EQLConfig XS , FALSE ); #ifdef EMBPERL_PLUGIN Log.Out(Logs::Detail, Logs::World_Server, "Loading worldui perl plugins."); std::string err; if(!eval_file("world", "worldui.pl", err)) { Log.Out(Logs::Detail, Logs::World_Server, "Warning - world.pl: %s", err.c_str()); } eval_pv( "package world; " "if(opendir(D,'worldui')) { " " my @d = readdir(D);" " closedir(D);" " foreach(@d){ " " next unless(/\\.pl$); " " require 'templates/'.$_;" " }" "}" ,FALSE); #endif //EMBPERL_PLUGIN }
/* Wrap a JS value to export into perl * Returns a new SV, REFCNT_dec is caller's responsability */ JSBool PJS_ReflectJS2Perl( pTHX_ JSContext *cx, jsval value, SV** sv, int full ) { if(JSVAL_IS_PRIMITIVE(value)) { *sv = PrimJSVALToSV(aTHX_ cx, value); if(*sv) return JS_TRUE; } else if(JSVAL_IS_OBJECT(value)) { PJS_Context *pcx = PJS_GET_CONTEXT(cx); JSObject *object = JSVAL_TO_OBJECT(value); JSClass *clasp = PJS_GET_CLASS(cx, object); const char *classname = clasp->name; JSObject *passport; SV *wrapper; SV *box; char hkey[32]; jsval temp = JSVAL_VOID; snprintf(hkey, 32, "%p", (void *)object); PJS_DEBUG2("Wrapping a %s(%s)\n", classname, hkey); if(PJS_getFlag(pcx, "ConvertRegExp") && strEQ(classname, "RegExp")) { jsval src; char *str; if(JS_CallFunctionName(cx, object, "toSource", 0, NULL, &src) && (str = JS_GetStringBytes(JS_ValueToString(cx, src))) ) { dSP; SV *tmp = newSVpvf("qr%s", str); eval_sv(tmp, G_SCALAR); sv_free(tmp); // Don't leak SPAGAIN; tmp = POPs; PUTBACK; if(!SvTRUE(ERRSV)) { *sv = SvREFCNT_inc_simple_NN(tmp); return JS_TRUE; } } return JS_FALSE; } if(IS_PERL_CLASS(clasp)) { /* IS_PERL_CLASS means actual perl object is there */ SV *priv = (SV *)JS_GetPrivate(cx, object); if(priv && SvOK(priv) && SvROK(priv)) { *sv = SvREFCNT_inc_simple_NN(priv); return JS_TRUE; } croak("A private %s?!\n", classname); return JS_FALSE; } /* Common JSObject case */ /* Check registered perl visitors */ JS_LookupProperty(cx, pcx->pvisitors, hkey, &temp); if(temp != JSVAL_VOID) { /* Already registered, so exits a reference in perl space * _must_ hold a PASSPORT */ assert(JSVAL_TO_OBJECT(temp) == object); box = PJS_GetPassport(aTHX_ cx, object); SvREFCNT_inc_void_NN(box); /* In perl should be one more */ PJS_DEBUG1("Cached!: %s\n", hkey); } else { /* Check if with a PASSPORT */ JS_LookupPropertyWithFlags(cx, object, PJS_PASSPORT_PROP, 0, &temp); if(JSVAL_IS_OBJECT(temp) && (passport = JSVAL_TO_OBJECT(temp)) && PJS_GET_CLASS(cx, passport) == &passport_class && JS_GetReservedSlot(cx, passport, 0, &temp) && object == (JSObject *)JSVAL_TO_PRIVATE(temp) ) { /* Yes, reentering perl */ box = (SV *)JS_GetPrivate(cx, passport); /* Here we don't increment refcount, the ownership in passport is * transferred to perl land. */ PJS_DEBUG1("Reenter: %s\n", hkey); } else { /* No, first time, must wrap the object */ SV *boxref; const char *package; SV *robj = newSV(0); SV *rjsv = newSV(0); if (JS_ObjectIsFunction(cx, object)) package = PJS_FUNCTION_PACKAGE; else if(JS_IsArrayObject(cx, object)) package = PJS_ARRAY_PACKAGE; else if(strEQ(classname, PJS_PACKAGE_CLASS_NAME)) package = PJS_STASH_PACKAGE; #if JS_HAS_XML_SUPPORT else if(strEQ(classname, "XML")) package = PJS_XMLOBJ_PACKAGE; #endif else if(strEQ(classname, "Error")) package = PJS_ERROR_PACKAGE; else { SV **sv = hv_fetch(get_hv(NAMESPACE"ClassMap", 1), classname, strlen(classname), 0); if(sv) package = SvPV_nolen(*sv); else package = PJS_OBJECT_PACKAGE; } sv_setref_pv(robj, PJS_RAW_OBJECT, (void*)object); sv_setref_iv(rjsv, PJS_RAW_JSVAL, (IV)value); boxref = PJS_CallPerlMethod(aTHX_ cx, "__new", sv_2mortal(newSVpv(package, 0)), // package sv_2mortal(robj), // content sv_2mortal(rjsv), // jsval NULL ); if(!boxref) return JS_FALSE; if(!SvOK(boxref) || !sv_derived_from(boxref, PJS_BOXED_PACKAGE)) croak("PJS_Assert: Contructor must return a "NAMESPACE"Boxed"); /* Create a new PASSPORT */ passport = JS_NewObject(cx, &passport_class, NULL, object); if(!passport || !JS_DefineProperty(cx, object, PJS_PASSPORT_PROP, OBJECT_TO_JSVAL(passport), NULL, NULL, JSPROP_READONLY | JSPROP_PERMANENT)) return JS_FALSE; box = SvRV(boxref); /* boxref is mortal, so we need to increment its rc, at end of * scope, PASSPORT owns created box */ JS_SetPrivate(cx, passport, (void *)SvREFCNT_inc_simple_NN(box)); JS_SetReservedSlot(cx, passport, 0, PRIVATE_TO_JSVAL(object)); PJS_DEBUG2("New boxed: %s brc: %d\n", hkey, SvREFCNT(box)); } /* Root object adding it to pvisitors list, will be unrooted by * jsc_free_root at Boxed DESTROY time */ JS_DefineProperty(cx, pcx->pvisitors, hkey, value, NULL, NULL, 0); } /* Here the RC of box in PASSPORT reflects wrapper's ownership */ if(full && PJS_getFlag(pcx, "AutoTie") && (strEQ(classname, "Object") || strEQ(classname, "Array")) ) { /* Return tied */ AV *avbox = (AV *)SvRV(box); SV **last; SV *tied; SV *tier; if(strEQ(classname, "Array")) { last = av_fetch(avbox, 6, 1); if(last && SvOK(*last) && SvROK(*last)) { // Cached *sv = newSVsv(*last); sv_free(box); /* Hard copy 'sv' owns the reference */ return JS_TRUE; } tied = (SV *)newAV(); } else { // Object last = av_fetch(avbox, 5, 1); if(last && SvOK(*last) && SvROK(*last)) { // Cached *sv = newSVsv(*last); sv_free(box); /* Hard copy 'sv' owns the reference */ return JS_TRUE; } tied = (SV *)newHV(); } /* hv_magic below own a reference to box, we use an explicit path, * to make clear that to perl land only one reference is given */ tier = newRV_inc(box); hv_magic((HV *)tied, (GV *)tier, PERL_MAGIC_tied); sv_free(tier); wrapper = newRV_noinc(tied); /* Don't leak the hidden tied variable */ /* Save in cache a weaken copy, the cache itself dosn't hold a reference */ sv_setsv(*last, wrapper); sv_rvweaken(*last); PJS_DEBUG1("Return tied for %s\n", SvPV_nolen(tier)); } else { wrapper = newRV_noinc(box); /* Transfer ownership to wrapper */ #if PERL_VERSION < 9 sv_bless(wrapper, SvSTASH(box)); #endif } *sv = wrapper; return JS_TRUE; } return JS_FALSE; }
void decode_cell(pTHX_ unsigned char *input, STRLEN len, STRLEN *pos, struct cc_type *type, SV *output) { unsigned char *bytes; STRLEN bytes_len; if (unpack_bytes(aTHX_ input, len, pos, &bytes, &bytes_len) != 0) { sv_setsv(output, &PL_sv_undef); return; } switch (type->type_id) { case CC_TYPE_ASCII: case CC_TYPE_CUSTOM: case CC_TYPE_BLOB: decode_blob(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_BOOLEAN: decode_boolean(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_VARCHAR: case CC_TYPE_TEXT: decode_utf8(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_INET: decode_inet(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_SET: case CC_TYPE_LIST: decode_list(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_UUID: case CC_TYPE_TIMEUUID: decode_uuid(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_FLOAT: decode_float(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_DOUBLE: decode_double(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_DECIMAL: decode_decimal(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_VARINT: case CC_TYPE_BIGINT: case CC_TYPE_COUNTER: case CC_TYPE_TIMESTAMP: case CC_TYPE_SMALLINT: case CC_TYPE_TINYINT: case CC_TYPE_INT: decode_varint(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_DATE: decode_date(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_TIME: decode_time(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_MAP: decode_map(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_UDT: decode_udt(aTHX_ bytes, bytes_len, type, output); break; case CC_TYPE_TUPLE: decode_tuple(aTHX_ bytes, bytes_len, type, output); break; default: sv_setsv(output, &PL_sv_undef); warn("Decoder doesn't yet understand type %d, returning undef instead", type->type_id); break; } }
ngx_int_t ngx_http_psgi_process_body_glob(pTHX_ ngx_http_request_t *r, SV *body) { ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "PSGI app returned handle '%s'", SvPV_nolen((SV*)body)); ngx_chain_t *first_chain = NULL; ngx_chain_t *last_chain = NULL; int result = NGX_OK; bool data = 1; /* TODO: Call $body->close when done * TODO: Support sendfile option * FIXME: This sucks. Push handle to stack and loop readline, save time * FIXME: This sucks. Do async event-based writing * FIXME: This sucks. Readline can return lines 1-10 bytes long. Buffer data instead of chaining each line */ // TODO: bufsize should be defined in context and then reused SV * ngx_sv_bufsize = newSViv(8192); SV * ngx_PL_rs = sv_2mortal(newRV_noinc(ngx_sv_bufsize)); // TODO: find out what is the right way to do local $/ = \123 SV *old_rs = PL_rs; sv_setsv(PL_rs, ngx_PL_rs); // $/ = \8192 sv_setsv(get_sv("/", GV_ADD), PL_rs); while (data && result < NGX_HTTP_SPECIAL_RESPONSE) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(body); PUTBACK; call_method("getline", G_SCALAR|G_EVAL); SPAGAIN; SV *buffer = POPs; if (SvTRUE(ERRSV)) { ngx_log_error(NGX_LOG_ERR, r->connection->log, 0, "Error reading from a handle: '%s'", SvPV_nolen(ERRSV)); result = NGX_HTTP_INTERNAL_SERVER_ERROR; } else if (!SvOK(buffer)) { data = 0; } else { u_char *p; STRLEN len; p = (u_char*)SvPV(buffer, len); if (len) { // Skip zero-length but defined chunks if (chain_buffer(r, p, len, &first_chain, &last_chain) != NGX_OK) { ngx_log_error(NGX_LOG_DEBUG_HTTP, r->connection->log, 0, "Error chaining psgi response buffer"); result = NGX_HTTP_INTERNAL_SERVER_ERROR; } } else { ngx_http_output_filter(r, first_chain); first_chain = last_chain = NULL; } } PUTBACK; FREETMPS; LEAVE; } PL_rs = old_rs; sv_setsv(get_sv("/", GV_ADD), old_rs); if (first_chain != NULL) { ngx_http_output_filter(r, first_chain); return result; } return result < NGX_HTTP_SPECIAL_RESPONSE ? NGX_DONE : result; }
/* caller must free result, if not NULL */ CALLER_OWN char *owl_perlconfig_initperl(const char *file, int *Pargc, char ***Pargv, char ***Penv) { int ret; PerlInterpreter *p; char *err; const char *args[4] = {"", "-e", "0;", NULL}; AV *inc; char *path; /* create and initialize interpreter */ PERL_SYS_INIT3(Pargc, Pargv, Penv); p=perl_alloc(); owl_global_set_perlinterp(&g, p); perl_construct(p); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; owl_global_set_no_have_config(&g); ret=perl_parse(p, owl_perl_xs_init, 2, (char **)args, NULL); if (ret || SvTRUE(ERRSV)) { err=g_strdup(SvPV_nolen(ERRSV)); sv_setsv(ERRSV, &PL_sv_undef); /* and clear the error */ return(err); } ret=perl_run(p); if (ret || SvTRUE(ERRSV)) { err=g_strdup(SvPV_nolen(ERRSV)); sv_setsv(ERRSV, &PL_sv_undef); /* and clear the error */ return(err); } owl_global_set_have_config(&g); /* create legacy variables */ get_sv("BarnOwl::id", TRUE); get_sv("BarnOwl::class", TRUE); get_sv("BarnOwl::instance", TRUE); get_sv("BarnOwl::recipient", TRUE); get_sv("BarnOwl::sender", TRUE); get_sv("BarnOwl::realm", TRUE); get_sv("BarnOwl::opcode", TRUE); get_sv("BarnOwl::zsig", TRUE); get_sv("BarnOwl::msg", TRUE); get_sv("BarnOwl::time", TRUE); get_sv("BarnOwl::host", TRUE); get_av("BarnOwl::fields", TRUE); if(file) { SV * cfg = get_sv("BarnOwl::configfile", TRUE); sv_setpv(cfg, file); } sv_setpv(get_sv("BarnOwl::VERSION", TRUE), OWL_VERSION_STRING); /* Add the system lib path to @INC */ inc = get_av("INC", 0); path = g_build_filename(owl_get_datadir(), "lib", NULL); av_unshift(inc, 1); av_store(inc, 0, owl_new_sv(path)); g_free(path); eval_pv("use BarnOwl;", FALSE); if (SvTRUE(ERRSV)) { err=g_strdup(SvPV_nolen(ERRSV)); sv_setsv (ERRSV, &PL_sv_undef); /* and clear the error */ return(err); } /* check if we have the formatting function */ if (owl_perlconfig_is_function("BarnOwl::format_msg")) { owl_global_set_config_format(&g, 1); } return(NULL); }
PJS_EXTERN JSBool PJS_Call_sv_with_jsvals_rsv( pTHX_ JSContext *cx, JSObject *obj, SV *code, SV *caller, /* Will be disposed inside */ uintN argc, jsval *argv, SV **rsv, I32 flag ) { dSP; JSBool ok = JS_TRUE; uintN arg; I32 rcount = caller ? 1 : 0; PJS_Context *pcx = PJS_GET_CONTEXT(cx); if(SvROK(code) && SvTYPE(SvRV(code)) == SVt_PVCV) { ENTER; SAVETMPS; PUSHMARK(SP) ; sv_setiv(save_scalar(PJS_Context_SV), PTR2IV(pcx)); EXTEND(SP, argc + rcount); PUTBACK; /* From here we are working with the global stack, * a) at PUSH time we can fail, so we need to abort the call * b) Want to avoid copying local <=> global SP at every single PUSH * * Before 'call_sv', rcount is the number of SVs pushed so far */ if(caller) *++PL_stack_sp = sv_2mortal(caller); if(argv && !(flag & G_NOARGS)) { /* HACK: We use G_NOARGS as a guard against use argv[-1] to get This. * Needed for the use in PJS_invoke_perl_property_setter where given * argc is faked */ SV *This; ok = PJS_ReflectJS2Perl(aTHX_ cx, argv[-1], &This, 0); if(ok) sv_setsv(save_scalar(PJS_This), sv_2mortal(This)); else goto forget; } else flag &= ~G_NOARGS; for(arg = 0; arg < argc; arg++) { SV *sv; ok = PJS_ReflectJS2Perl(aTHX_ cx, argv[arg], &sv, 1); if(!ok) { rcount += arg; goto forget; } *++PL_stack_sp = sv_2mortal(sv); } rcount = call_sv(code, flag | G_EVAL); if(rsv) { if(flag == G_SCALAR || rcount == 1) *rsv = SvREFCNT_inc_simple_NN(*PL_stack_sp); else *rsv = newRV((SV *)av_make(rcount, PL_stack_sp-rcount+1)); SAVEMORTALIZESV(*rsv); } forget: PL_stack_sp -= rcount; FREETMPS; LEAVE; if(ok && SvTRUE(ERRSV)) { propagate2JS(aTHX_ pcx, obj); ok = JS_FALSE; } } else croak("Not a coderef"); return ok; }
inline void Zmqxs_set_bang(pTHX_ int err){ SV *errsv; errsv = get_sv("!", GV_ADD); sv_setsv(errsv, newSViv(err)); }
static GIOPConnection * do_demarshal (CV *cv, I32 ax, I32 items, CORBA_InterfaceDef_FullInterfaceDescription *desc, I32 index, GPtrArray *return_types, guint *return_count, CORBA_Object obj, GIOPConnection *connection, GIOP_unsigned_long request_id) { GIOPRecvBuffer *recv_buffer; SV *error_sv = NULL; SV **results = NULL; CORBA_unsigned_long i; CORBA_OperationDescription *opr = NULL; dTHR; if (index >= PORBIT_OPERATION_BASE && index < PORBIT_GETTER_BASE) opr = &desc->operations._buffer[index-PORBIT_OPERATION_BASE]; recv_buffer = giop_recv_reply_buffer_use_2(connection, request_id, TRUE); if (!recv_buffer) { error_sv = porbit_system_except ("IDL:omg.org/CORBA/COMM_FAILURE:1.0", 0, CORBA_COMPLETED_MAYBE); goto exception; } if (recv_buffer->message.u.reply.reply_status == GIOP_LOCATION_FORWARD) { if (obj->forward_locations != NULL) ORBit_delete_profiles(obj->forward_locations); obj->forward_locations = ORBit_demarshal_IOR(recv_buffer); connection = ORBit_object_get_forwarded_connection(obj); giop_recv_buffer_unuse(recv_buffer); return connection; } else if (recv_buffer->message.u.reply.reply_status != GIOP_NO_EXCEPTION) { error_sv = porbit_get_exception (recv_buffer, NULL, recv_buffer->message.u.reply.reply_status, opr); if (!error_sv) error_sv = porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0", 0, CORBA_COMPLETED_YES); goto exception; } /* Demarshal return parameters */ results = g_new0 (SV *, return_types->len); for (i=0; i<return_types->len; i++) { results[i] = porbit_get_sv (recv_buffer, return_types->pdata[i]); if (!results[i]) { warn ("Error demarshalling result"); error_sv = porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0", 0, CORBA_COMPLETED_YES); goto exception; } } if (index >= PORBIT_OPERATION_BASE && index < PORBIT_GETTER_BASE) { CORBA_unsigned_long i, st_index, ret_index; /* First write back INOUT parameters into their references. * (Is this safe? If we end up calling back to perl, could the * stack already be overridden?) */ st_index = 1; ret_index = (opr->result->kind == CORBA_tk_void) ? 0 : 1; for (i = 0 ; i<opr->parameters._length; i++) { switch (opr->parameters._buffer[i].mode) { case CORBA_PARAM_IN: st_index++; break; case CORBA_PARAM_INOUT: sv_setsv (SvRV(ST(st_index)), results[ret_index]); st_index++; ret_index++; break; case CORBA_PARAM_OUT: ret_index++; break; } } /* Now write out return value and OUT parameters to stack */ st_index = 0; ret_index = 0; if (opr->result->kind != CORBA_tk_void) { ST(st_index) = sv_2mortal(results[0]); st_index++; ret_index++; } for (i = 0 ; i<opr->parameters._length; i++) { switch (opr->parameters._buffer[i].mode) { case CORBA_PARAM_IN: break; case CORBA_PARAM_INOUT: ret_index++; break; case CORBA_PARAM_OUT: ST(st_index) = sv_2mortal (results[ret_index]); st_index++; ret_index++; break; } } *return_count = st_index; } else if (index >= PORBIT_GETTER_BASE && index < PORBIT_SETTER_BASE) { ST(0) = sv_2mortal(results[0]); } g_free (results); results = NULL; exception: if (results) { for (i=0; i < return_types->len; i++) if (results[i]) SvREFCNT_dec (results[i]); g_free (results); } g_ptr_array_free (return_types, TRUE); giop_recv_buffer_unuse(recv_buffer); if (error_sv) porbit_throw (error_sv); return NULL; }