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