static void
call_async(plcb_OPCTX *ctx, AV *resobj)
{
SV *cv = ctx->u.callback;
dSP;
if (cv == NULL || SvOK(cv) == 0) {
warn("Context does not have a callback (%p)!", cv);
return;
}
if ((ctx->flags & PLCB_OPCTXf_IMPLICIT) == 0) {
if (ctx->nremaining && (ctx->flags & PLCB_OPCTXf_CALLEACH) == 0) {
return; /* Still have ops. Only call once they're all complete */
}
}
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc((SV*)resobj)));
PUTBACK;
call_sv(cv, G_DISCARD);
FREETMPS;
LEAVE;
if (ctx->nremaining == 0 && (ctx->flags & PLCB_OPCTXf_CALLDONE)) {
ENTER;
SAVETMPS;
PUSHMARK(SP);
call_sv(cv, G_DISCARD);
FREETMPS;
LEAVE;
}
}
void
__getdns_callback(Net__GetDNS__XS__Context * context,
getdns_callback_type_t callback_type, Net__GetDNS__XS__Dict * response,
void * userarg, getdns_transaction_t transaction_id)
{
dSP;
struct __callback * cb;
if (!userarg) return;
cb = (struct __callback *)userarg;
if (!cb->callbackfn) return;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(sv_setref_pv(newSV(0), "Net::GetDNS::XS::ContextPtr", (void *)context)));
XPUSHs(sv_2mortal(newSVuv(callback_type)));
XPUSHs(sv_2mortal(sv_setref_pv(newSV(0), "Net::GetDNS::XS::DictPtr", (void *)response)));
XPUSHs(sv_2mortal(newSVsv(cb->userarg)));
XPUSHs(sv_2mortal(newSVuv(transaction_id)));
PUTBACK;
call_sv((SV*)(cb->callbackfn), G_VOID);
FREETMPS;
LEAVE;
SvREFCNT_dec(cb->callbackfn);
Safefree(cb);
}
static SV *
call_sv_va (SV *func, int num, ...) {
dSP;
SV *ret;
I32 count;
va_list args;
ENTER;
SAVETMPS;
PUSHMARK (SP);
va_start (args, num);
for( ; num > 0; num-- ) {
XPUSHs (va_arg( args, SV* ));
}
va_end(args);
PUTBACK;
count = call_sv(func, G_SCALAR);
SPAGAIN;
if (count != 1) {
croak ("method didn't return a value");
}
ret = POPs;
SvREFCNT_inc (ret);
PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
void
blizkost_call_in(BLIZKOST_NEXUS, SV *what, U32 mode, PMC *positp, PMC *namedp,
PMC **retp) {
dBNPERL; dBNINTERP;
int num_returns, i;
{
/* Set up the stack. */
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
PUTBACK;
blizkost_slurpy_to_stack(nexus, positp, namedp);
/* Invoke the methods. */
num_returns = call_sv(what, mode);
SPAGAIN;
/* Build the results PMC array. */
*retp = pmc_new(interp, enum_class_ResizablePMCArray);
for (i = 0; i < num_returns; i++) {
SV *result_sv = POPs;
PMC *result_pmc = blizkost_wrap_sv(nexus, result_sv);
VTABLE_unshift_pmc(interp, *retp, result_pmc);
}
PUTBACK;
FREETMPS;
LEAVE;
}
}
void modperl_perl_call_list(pTHX_ AV *subs, const char *name)
{
I32 i, oldscope = PL_scopestack_ix;
SV **ary = AvARRAY(subs);
MP_TRACE_g(MP_FUNC, "pid %lu" MP_TRACEf_TID MP_TRACEf_PERLID
" running %d %s subs",
(unsigned long)getpid(), MP_TRACEv_TID_ MP_TRACEv_PERLID_
AvFILLp(subs)+1, name);
for (i=0; i<=AvFILLp(subs); i++) {
CV *cv = (CV*)ary[i];
SV *atsv = ERRSV;
PUSHMARK(PL_stack_sp);
call_sv((SV*)cv, G_EVAL|G_DISCARD);
if (SvCUR(atsv)) {
Perl_sv_catpvf(aTHX_ atsv, "%s failed--call queue aborted",
name);
while (PL_scopestack_ix > oldscope) {
LEAVE;
}
Perl_croak(aTHX_ "%s", SvPVX(atsv));
}
}
}
SV *p5_scalar_call_gv_two_args(PerlInterpreter *my_perl, GV *gv, SV *arg, SV *arg2, I32 *count, I32 *type, I32 *err) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval = NULL;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs((SV*)arg);
XPUSHs((SV*)arg2);
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
*count = call_sv(rv, G_SCALAR | G_EVAL);
SPAGAIN;
handle_p5_error(err);
if (*err)
fprintf(stderr, "err: %d\n", *err);
retval = pop_return_values(my_perl, sp, *count, type);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
}
/* Handles the row, adding it into the internal structure */
static void
invoke_row(AV *req, SV *reqrv, SV *rowsrv)
{
SV *meth;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
/* First arg */
XPUSHs(reqrv);
meth = *av_fetch(req, PLCB_VHIDX_PRIVCB, 0);
if (rowsrv) {
XPUSHs(rowsrv);
}
PUTBACK;
call_sv(meth, G_DISCARD|G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
warn("Got error in %s", SvPV_nolen(ERRSV));
}
if (rowsrv) {
av_clear((AV *)SvRV(rowsrv));
}
FREETMPS;
LEAVE;
}
void owl_perlconfig_edit_callback(owl_editwin *e, bool success)
{
SV *cb = owl_editwin_get_cbdata(e);
SV *text;
dSP;
if(cb == NULL) {
owl_function_error("Perl callback is NULL!");
return;
}
text = owl_new_sv(owl_editwin_get_text(e));
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(text));
XPUSHs(sv_2mortal(newSViv(success)));
PUTBACK;
call_sv(cb, G_DISCARD|G_EVAL);
if(SvTRUE(ERRSV)) {
owl_function_error("%s", SvPV_nolen(ERRSV));
}
FREETMPS;
LEAVE;
}
static SV *run_app(request_rec *r, SV *app, SV *env)
{
dTHX;
int count;
SV *res;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP) ;
XPUSHs(sv_2mortal(env));
PUTBACK;
count = call_sv(app, G_EVAL|G_SCALAR|G_KEEPERR);
SPAGAIN;
if (SvTRUE(ERRSV)) {
res = NULL;
server_error(r, "%s", SvPV_nolen(ERRSV));
CLEAR_ERRSV();
(void) POPs;
} else if (count > 0) {
res = POPs;
SvREFCNT_inc(res);
} else {
res = NULL;
}
PUTBACK;
FREETMPS;
LEAVE;
return res;
}
static gboolean
perl_timeout_cb(gpointer data)
{
PurplePerlTimeoutHandler *handler = data;
gboolean ret = FALSE;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs((SV *)handler->data);
PUTBACK;
call_sv(handler->callback, G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV)) {
purple_debug_error("perl",
"Perl timeout function exited abnormally: %s\n",
SvPVutf8_nolen(ERRSV));
}
ret = POPi;
PUTBACK;
FREETMPS;
LEAVE;
if (ret == FALSE)
destroy_timeout_handler(handler);
return ret;
}
static inline void do_check(SV *cv, SV *value, SV *key) {
dTHX;
SV *ok = &PL_sv_undef, *msg = &PL_sv_undef;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
PUSHs(sv_mortalcopy(value));
PUTBACK;
int count = call_sv(cv, G_ARRAY);
// could return 0 or 1 or 2 or more
SPAGAIN;
if (count) count == 1 ? (ok = POPs) : (msg = POPs, ok = POPs);
if (!SvTRUE(ok)) {
croak("Bad value \"%s\" for attribute \"%s\": %s", SvPV_nolen(value),
SvPV_nolen(key), SvTRUE(msg) ? SvPV_nolen(msg) : "");
}
PUTBACK;
FREETMPS;
LEAVE;
};
static void plcb_call_sv_with_args_noret(SV *code, int mortalize, int nargs, ...)
{
va_list ap;
SV *cursv;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
EXTEND(SP, nargs);
va_start(ap, nargs);
while (nargs) {
cursv = va_arg(ap, SV*);
if (mortalize) {
cursv = sv_2mortal(cursv);
}
PUSHs(cursv);
nargs--;
}
va_end(ap);
PUTBACK;
call_sv(code, G_DISCARD);
FREETMPS;
LEAVE;
}
/*
this is used for autoload and shutdown callbacks
*/
static int
execute_perl (SV * function, char *args)
{
int count, ret_value = 1;
dSP;
ENTER;
SAVETMPS;
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSVpv (args, 0)));
PUTBACK;
count = call_sv (function, G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE (ERRSV)) {
xchat_printf(ph, "Perl error: %s\n", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
} else if (count != 1) {
xchat_printf (ph, "Perl error: expected 1 value from %s, "
"got: %d\n", SvPV_nolen (function), count);
} else {
ret_value = POPi;
}
PUTBACK;
FREETMPS;
LEAVE;
return ret_value;
}
static void
bootstrap_callback(lcb_t instance, lcb_error_t status)
{
dSP;
PLCB_t *obj = (PLCB_t*) lcb_get_cookie(instance);
if (!obj->async) {
return;
}
if (!obj->conncb) {
warn("Object %p does not have a connect callback!", obj);
return;
}
printf("Invoking callback for connect..!\n");
ENTER;SAVETMPS;PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc(obj->selfobj)));
XPUSHs(sv_2mortal(newSViv(status)));
PUTBACK;
call_sv(obj->conncb, G_DISCARD);
SPAGAIN;
FREETMPS;LEAVE;
SvREFCNT_dec(obj->conncb); obj->conncb = NULL;
}
void
c2p_dlcb(const char * name, off_t curr, off_t total)
{
SV * svname, * svcurr, * svtotal;
dSP;
if(!dlcb_ref){
return;
}
ENTER;
SAVETMPS;
svname = sv_2mortal(newSVpv(name, 0));
svcurr = sv_2mortal(newSViv(curr));
svtotal = sv_2mortal(newSViv(total));
PUSHMARK(SP);
XPUSHs(svname);
XPUSHs(svcurr);
XPUSHs(svtotal);
PUTBACK;
call_sv(dlcb_ref, G_DISCARD);
FREETMPS;
LEAVE;
return;
}
static void
perl_pref_cb(const char *name, PurplePrefType type, gconstpointer value,
gpointer data)
{
PurplePerlPrefsHandler *handler = data;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(newSVpv(name, 0)));
XPUSHs(sv_2mortal(newSViv(type)));
switch(type) {
case PURPLE_PREF_INT:
XPUSHs(sv_2mortal(newSViv(GPOINTER_TO_INT(value))));
break;
case PURPLE_PREF_BOOLEAN:
XPUSHs((GPOINTER_TO_INT(value) == FALSE) ? &PL_sv_no : &PL_sv_yes);
break;
case PURPLE_PREF_STRING:
case PURPLE_PREF_PATH:
XPUSHs(sv_2mortal(newSVGChar(value)));
break;
case PURPLE_PREF_STRING_LIST:
case PURPLE_PREF_PATH_LIST:
{
AV* av = newAV();
const GList *l = value;
/* Append stuff backward to preserve order */
while (l && l->next) l = l->next;
while (l) {
av_push(av, sv_2mortal(newSVGChar(l->data)));
l = l->prev;
}
XPUSHs(sv_2mortal(newRV_noinc((SV *) av)));
} break;
default:
case PURPLE_PREF_NONE:
XPUSHs(&PL_sv_undef);
break;
}
XPUSHs((SV *)handler->data);
PUTBACK;
call_sv(handler->callback, G_EVAL | G_VOID | G_DISCARD);
SPAGAIN;
if (SvTRUE(ERRSV)) {
purple_debug_error("perl",
"Perl prefs callback function exited abnormally: %s\n",
SvPVutf8_nolen(ERRSV));
}
PUTBACK;
FREETMPS;
LEAVE;
}
SV *p5_call_code_ref(PerlInterpreter *my_perl, SV *code_ref, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
SV * retval = NULL;
int flags = G_ARRAY | G_EVAL;
ENTER;
SAVETMPS;
PUSHMARK(SP);
push_arguments(sp, len, args);
*count = call_sv(code_ref, flags);
SPAGAIN;
handle_p5_error(err);
retval = pop_return_values(my_perl, sp, *count, type);
FREETMPS;
LEAVE;
return retval;
}
}
static SV *
call_perl_function__one_arg(SV * function_name, SV * arg1) {
dSP;
int count;
SV *res;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(arg1));
PUTBACK;
count = call_sv(function_name, G_SCALAR);
SPAGAIN;
if (count == 1)
res = newSVsv(POPs);
else
res = &PL_sv_undef;
PUTBACK;
FREETMPS;
LEAVE;
return res;
}
SV *
callFilter(SV *filter, SV *el)
{
SV *val;
I32 n;
dTHX;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(el);
PUTBACK;
n = call_sv(filter, (G_SCALAR | G_EVAL));
SPAGAIN;
val = POPs;
SvREFCNT_inc(val);
PUTBACK;
FREETMPS;
LEAVE;
return(val);
}
// arg is NULL-terminated and caller must free.
static void campher_call_sv_scalar(PerlInterpreter* my_perl, SV* sv, SV** arg, SV** ret) {
PERL_SET_CONTEXT(my_perl);
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if (arg != NULL) {
while (*arg != NULL) {
XPUSHs(*arg);
arg++;
}
}
PUTBACK;
I32 count = call_sv(sv, G_SCALAR);
// TOD: deal with error flag. will just crash process for now.
SPAGAIN;
if (count != 1) {
croak("expected 1 in campher_call_sv_scalar");
}
SV* result = POPs;
SvREFCNT_inc(result);
*ret = result;
PUTBACK;
FREETMPS;
LEAVE;
}
// arg is NULL-terminated and caller must free.
static void campher_call_sv_void(PerlInterpreter* my_perl, SV* sv, SV** arg) {
PERL_SET_CONTEXT(my_perl);
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if (arg != NULL) {
while (*arg != NULL) {
XPUSHs(*arg);
arg++;
}
}
PUTBACK;
I32 ret = call_sv(sv, G_VOID);
if (ret != 0) {
assert(false);
}
FREETMPS;
LEAVE;
}
static int sandwich_sapi_ub_write(const char *str, uint str_length TSRMLS_DC)
{
// FIXME - call out to Perl's selected fh
SV *oh;
sandwich_per_interp *interp = SG(server_context);
if(!interp || !interp->output_handler || interp->output_handler == &PL_sv_undef) {
fwrite(str, 1, str_length, stdout);
return str_length;
}
oh = interp->output_handler;
if (SvROK(oh) && (SvTYPE(SvRV(oh)) == SVt_PVCV)) {
dTHX;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpvn(str, str_length)));
PUTBACK;
call_sv(oh, G_VOID | G_EVAL);
FREETMPS;
LEAVE;
} else {
if(SvROK(oh) && !SvPOK(SvRV(oh))) {
sv_setpvn_mg(SvRV(oh), str, str_length);
} else {
sv_catpvn_mg(SvROK(oh)?SvRV(oh):oh, str, str_length);
}
}
return str_length;
}
static SV*
serialize_convert(SV *meth, SV *input, int direction)
{
dSP;
SV *ret;
int count;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(input);
PUTBACK;
if (direction == CONVERT_OUT) {
count = call_sv(meth, G_SCALAR);
SPAGAIN;
/*for ouptut we must have this function succeed!*/
if (count != 1) {
croak("Serialization method returned nothing!");
}
ret = POPs;
} else {
count = call_sv(meth, G_SCALAR|G_EVAL);
SPAGAIN;
/*if someone has messed up our flags, don't die, but throw a warning*/
if (SvTRUE(ERRSV)) {
warn("Couldn't deserialize data: %s", SvPV_nolen(ERRSV));
ret = input;
} else {
if (count != 1) {
croak("Serialization method returned nothing?");
}
ret = POPs;
}
}
SvREFCNT_inc(ret);
FREETMPS;
LEAVE;
return ret;
}
/* this is public so that other extensions which use GtkMenuPosFunc (e.g.
* libgnomeui) don't need to reimplement it. */
void
gtk2perl_menu_position_func (GtkMenu * menu,
gint * x,
gint * y,
gboolean * push_in,
GPerlCallback * callback)
{
int n;
dGPERL_CALLBACK_MARSHAL_SP;
GPERL_CALLBACK_MARSHAL_INIT (callback);
ENTER;
SAVETMPS;
PUSHMARK (SP);
EXTEND (SP, 3);
PUSHs (sv_2mortal (newSVGtkMenu (menu)));
PUSHs (sv_2mortal (newSViv (*x)));
PUSHs (sv_2mortal (newSViv (*y)));
if (callback->data)
XPUSHs (sv_2mortal (newSVsv (callback->data)));
/* A die() from callback->func is suspected to be bad or very bad.
Circa Gtk 2.18 a jump out of $menu->popup seems to leave an X
grab with no way to get rid of it (no keyboard Esc, and no mouse
click handlers). The position func can also be called later for
things like resizing or move to a different GdkScreen, and such a
call might come straight from the main loop, where a die() would
jump out of Gtk2->main. */
PUTBACK;
n = call_sv (callback->func, G_ARRAY | G_EVAL);
SPAGAIN;
if (SvTRUE (ERRSV)) {
g_warning ("menu position callback ignoring error: %s",
SvPVutf8_nolen (ERRSV));
} else if (n < 2 || n > 3) {
g_warning ("menu position callback must return two integers "
"(x, and y) or two integers and a boolean "
"(x, y, and push_in)");
} else {
/* POPs and POPi take things off the *end* of the stack! */
if (n > 2) {
SV *sv = POPs;
*push_in = sv_2bool (sv);
}
if (n > 1) *y = POPi;
if (n > 0) *x = POPi;
}
PUTBACK;
FREETMPS;
LEAVE;
}
static PurpleCmdRet
perl_cmd_cb(PurpleConversation *conv, const gchar *command,
gchar **args, gchar **error, void *data)
{
int i = 0, count, ret_value = PURPLE_CMD_RET_OK;
SV *cmdSV, *tmpSV, *convSV;
PurplePerlCmdHandler *handler = data;
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
/* Push the conversation onto the perl stack */
convSV = sv_2mortal(purple_perl_bless_object(conv, "Purple::Conversation"));
XPUSHs(convSV);
/* Push the command string onto the perl stack */
cmdSV = newSVpv(command, 0);
cmdSV = sv_2mortal(cmdSV);
XPUSHs(cmdSV);
/* Push the data onto the perl stack */
XPUSHs((SV *)handler->data);
/* Push any arguments we may have */
for (i = 0; args[i] != NULL; i++) {
/* XXX The mortality of these created SV's should prevent
* memory issues, if I read/understood everything correctly...
*/
tmpSV = newSVpv(args[i], 0);
tmpSV = sv_2mortal(tmpSV);
XPUSHs(tmpSV);
}
PUTBACK;
count = call_sv(handler->callback, G_EVAL | G_SCALAR);
if (count != 1)
croak("call_sv: Did not return the correct number of values.\n");
if (SvTRUE(ERRSV)) {
purple_debug_error("perl",
"Perl plugin command function exited abnormally: %s\n",
SvPVutf8_nolen(ERRSV));
}
SPAGAIN;
ret_value = POPi;
PUTBACK;
FREETMPS;
LEAVE;
return ret_value;
}
static int
fd_cb (int fd, int flags, void *userdata)
{
HookData *data = (HookData *) userdata;
int retVal = 0;
int count = 0;
dSP;
ENTER;
SAVETMPS;
PUSHMARK (SP);
XPUSHs (data->userdata);
PUTBACK;
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
SPAGAIN;
if (SvTRUE (ERRSV)) {
hexchat_printf (ph, "Error in fd callback %s", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
retVal = HEXCHAT_EAT_ALL;
} else {
if (count != 1) {
hexchat_print (ph, "Fd handler should only return 1 value.");
retVal = HEXCHAT_EAT_NONE;
} else {
retVal = POPi;
if (retVal == 0) {
/* if 0 is returned, the fd is going to get unhooked */
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSViv (PTR2IV (data->hook))));
PUTBACK;
call_pv ("Xchat::unhook", G_EVAL);
SPAGAIN;
SvREFCNT_dec (data->callback);
if (data->userdata) {
SvREFCNT_dec (data->userdata);
}
free (data);
}
}
}
PUTBACK;
FREETMPS;
LEAVE;
return retVal;
}
static int
timer_cb (void *userdata)
{
HookData *data = (HookData *) userdata;
int retVal = 0;
int count = 0;
dSP;
ENTER;
SAVETMPS;
PUSHMARK (SP);
XPUSHs (data->userdata);
PUTBACK;
if (data->ctx) {
xchat_set_context (ph, data->ctx);
}
set_current_package (data->package);
count = call_sv (data->callback, G_EVAL);
set_current_package (&PL_sv_undef);
SPAGAIN;
if (SvTRUE (ERRSV)) {
xchat_printf (ph, "Error in timer callback %s", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
retVal = XCHAT_EAT_ALL;
} else {
if (count != 1) {
xchat_print (ph, "Timer handler should only return 1 value.");
retVal = XCHAT_EAT_NONE;
} else {
retVal = POPi;
if (retVal == 0) {
/* if 0 is return the timer is going to get unhooked */
PUSHMARK (SP);
XPUSHs (sv_2mortal (newSViv (PTR2IV (data->hook))));
XPUSHs (sv_mortalcopy (data->package));
PUTBACK;
call_pv ("Xchat::unhook", G_EVAL);
SPAGAIN;
}
}
}
PUTBACK;
FREETMPS;
LEAVE;
return retVal;
}
void
ffi_pl_custom_perl_cb(SV *subref, SV *in_arg, int i)
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(in_arg);
XPUSHs(sv_2mortal(newSViv(i)));
PUTBACK;
call_sv(subref, G_VOID|G_DISCARD);
FREETMPS;
LEAVE;
}
SV *
PerlIOVia_method(pTHX_ PerlIO * f, char *method, CV ** save, int flags,
...)
{
PerlIOVia *s = PerlIOSelf(f, PerlIOVia);
CV *cv =
(*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s, method, save);
SV *result = Nullsv;
va_list ap;
va_start(ap, flags);
if (cv != (CV *) - 1) {
IV count;
dSP;
SV *arg;
PUSHSTACKi(PERLSI_MAGIC);
ENTER;
SPAGAIN;
PUSHMARK(sp);
XPUSHs(s->obj);
while ((arg = va_arg(ap, SV *))) {
XPUSHs(arg);
}
if (*PerlIONext(f)) {
if (!s->fh) {
GV *gv = newGVgen(HvNAME(s->stash));
GvIOp(gv) = newIO();
s->fh = newRV_noinc((SV *) gv);
s->io = GvIOp(gv);
}
IoIFP(s->io) = PerlIONext(f);
IoOFP(s->io) = PerlIONext(f);
XPUSHs(s->fh);
}
else {
PerlIO_debug("No next\n");
/* FIXME: How should this work for OPEN etc? */
}
PUTBACK;
count = call_sv((SV *) cv, flags);
if (count) {
SPAGAIN;
result = POPs;
PUTBACK;
}
else {
result = &PL_sv_undef;
}
LEAVE;
POPSTACK;
}
SV *p5_call_parent_method(PerlInterpreter *my_perl, char *package, SV *obj, I32 context, char *name, int len, SV *args[], I32 *count, I32 *err, I32 *type) {
PERL_SET_CONTEXT(my_perl);
{
dSP;
int i;
SV * retval = NULL;
int flags = (context ? G_SCALAR : G_ARRAY) | G_EVAL;
ENTER;
SAVETMPS;
HV * const pkg = package != NULL ? gv_stashpv(package, 0) : SvSTASH((SV*)SvRV(obj));
GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, name, TRUE);
if (gv && isGV(gv)) {
PUSHMARK(SP);
if (len > 1) {
XPUSHs(package != NULL ? sv_2mortal(args[0]) : args[0]);
for (i = 1; i < len; i++) {
if (args[i] != NULL) /* skip Nil which gets turned into NULL */
XPUSHs(sv_2mortal(args[i]));
}
}
else if (len > 0)
if (args != NULL) /* skip Nil which gets turned into NULL */
XPUSHs(package != NULL ? sv_2mortal((SV*)args) : (SV*)args);
PUTBACK;
SV * const rv = sv_2mortal(newRV((SV*)GvCV(gv)));
*count = call_sv(rv, flags);
SPAGAIN;
handle_p5_error(err);
retval = pop_return_values(my_perl, sp, *count, type);
SPAGAIN;
}
else {
ERRSV = newSVpvf("Could not find method \"%s\" of \"%s\" object", name, HvNAME(pkg));
}
PUTBACK;
FREETMPS;
LEAVE;
return retval;
}
}