static void run_start_sub(void)
{
dSP; /* access to Perl stack */
PUSHMARK(SP);
if (get_cv("main::trace_begin", 0))
call_pv("main::trace_begin", G_DISCARD | G_NOARGS);
}
void DoDump(SV *dumpme) {
dSP;
PUSHMARK(SP);
XPUSHs(dumpme);
PUTBACK;
call_pv("Devel::Peek::Dump", G_DISCARD);
}
static inline void
do_script_hook_quit(void)
{
dSP;
PUSHMARK(SP);
call_pv("quit_hook", G_EVAL | G_DISCARD | G_NOARGS);
}
// NEED ANSWER: what in the hades does this property init function even do? why do we need it???
void RPerl_object_property_init(SV* initee)
{
dSP;
PUSHMARK(SP);
XPUSHs(initee);
PUTBACK;
call_pv("Dumper", G_SCALAR);
printf("in HelperFunctions::RPerl_object_property_init(), have initee->flags =\n0x%x\n", initee->sv_flags);
}
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;
}
int execute_perl( const char *function, char **args, char *data ) {
int count = 0, i, ret_value = 1;
STRLEN na;
SV *sv_args[0];
dSP;
PERL_SET_CONTEXT( my_perl );
/*
* Set up the perl environment, push arguments onto the perl stack, then
* call the given function
*/
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK( sp );
for ( i = 0; i < ( int )sizeof( args ) - 1; i++ ) {
if ( args[i] != NULL ) {
sv_args[i] = sv_2mortal( newSVpv( args[i], 0 ) );
XPUSHs( sv_args[i] );
}
}
PUTBACK;
PERL_SET_CONTEXT( my_perl );
count = call_pv( function, G_EVAL | G_SCALAR );
SPAGAIN;
/*
* Check for "die," make sure we have 1 argument, and set our return value
*/
if ( SvTRUE( ERRSV ) ) {
sprintf( data,
"%sPerl function (%s) exited abnormally: %s",
( loaded ? "ERR " : "" ), function, SvPV( ERRSV, na ) );
( void )POPs;
}
else if ( count != 1 ) {
/*
* This should NEVER happen. G_SCALAR ensures that we WILL have 1
* parameter
*/
sprintf( data,
"%sPerl error executing '%s': expected 1 return value; received %s",
( loaded ? "ERR " : "" ), function, count );
}
else {
sprintf( data, "%s%s", ( loaded ? "OK " : "" ), POPpx );
}
/* Check for changed arguments */
for ( i = 0; i < ( int )sizeof( args ) - 1; i++ ) {
if ( args[i] && strcmp( args[i], SvPVX( sv_args[i] ) ) ) {
args[i] = strdup( SvPV( sv_args[i], na ) );
}
}
PUTBACK;
FREETMPS;
LEAVE;
return ret_value;
}
static void
forward(pTHX_ const char *function)
{
dXSARGS;
DWORD err = GetLastError();
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("Win32",5), newSVnv(0.27));
SetLastError(err);
SPAGAIN;
PUSHMARK(SP-items);
call_pv(function, GIMME_V);
}
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 IvrPython::onDTMFEvent(int detectedKey) {
dtmfKey.set(detectedKey); // wake up waiting functions...
if (onDTMFCallback == NULL) {
DBG("IvrPython::onDTMFEvent, but script did not set onDTMF callback!\n");
return;
}
DBG("IvrPython::onDTMFEvent(): calling onDTMFCallback key is %d...\n", detectedKey);
#ifndef IVR_PERL
PyThreadState *tstate;
/* interp is your reference to an interpreter object. */
tstate = PyThreadState_New(mainInterpreterThreadState->interp);
PyEval_AcquireThread(tstate);
/* Perform Python actions here. */
PyObject *arglist = Py_BuildValue("(i)", detectedKey);
PyObject *result = PyEval_CallObject(onDTMFCallback, arglist);
Py_DECREF(arglist);
if (result == NULL) {
DBG("Calling IVR" SCRIPT_TYPE "onDTMF failed.\n");
PyErr_Print();
//return ;
} else {
Py_DECREF(result);
}
/* Release the thread. No Python API allowed beyond this point. */
PyEval_ReleaseThread(tstate);
/* You can either delete the thread state, or save it
until you need it the next time. */
PyThreadState_Delete(tstate);
#else //IVR_PERL
DBG("IvrPython::onDTMFEvent(): calling onDTMFCallback func is %s...\n", onDTMFCallback);
PERL_SET_CONTEXT(my_perl_interp);
DBG("context is %ld\n", (long) Perl_get_context());
dSP ;
ENTER ;
SAVETMPS ;
PUSHMARK(SP) ;
XPUSHs(sv_2mortal(newSViv(detectedKey)));
PUTBACK ;
call_pv(onDTMFCallback, G_DISCARD);
FREETMPS ;
LEAVE ;
#endif //IVR_PERL
DBG("IvrPython::onDTMFEvent done...\n");
}
GList *
purple_perl_plugin_actions(PurplePlugin *plugin, gpointer context)
{
GList *l = NULL;
PurplePerlScript *gps;
int i = 0, count = 0;
dSP;
gps = plugin->info->extra_info;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(purple_perl_bless_object(plugin, "Purple::Plugin")));
/* XXX This *will* cease working correctly if context gets changed to
* ever be able to hold anything other than a PurpleConnection */
if (context != NULL)
XPUSHs(sv_2mortal(purple_perl_bless_object(context,
"Purple::Connection")));
else
XPUSHs(&PL_sv_undef);
PUTBACK;
count = call_pv(gps->plugin_action_sub, G_EVAL | G_ARRAY);
SPAGAIN;
if (SvTRUE(ERRSV)) {
purple_debug_error("perl",
"Perl plugin actions lookup exited abnormally: %s\n",
SvPVutf8_nolen(ERRSV));
}
if (count == 0)
croak("The plugin_actions sub didn't return anything.\n");
for (i = 0; i < count; i++) {
SV *sv;
PurplePluginAction *act;
sv = POPs;
act = purple_plugin_action_new(SvPVutf8_nolen(sv), purple_perl_plugin_action_cb);
l = g_list_prepend(l, act);
}
PUTBACK;
FREETMPS;
LEAVE;
return l;
}
/*
* Stop trace script
*/
static int perl_stop_script(void)
{
dSP; /* access to Perl stack */
PUSHMARK(SP);
if (get_cv("main::trace_end", 0))
call_pv("main::trace_end", G_DISCARD | G_NOARGS);
perl_destruct(my_perl);
perl_free(my_perl);
return 0;
}
void Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode)
{//as seen in perlembed docs
#if EQDEBUG >= 5
if(InUse()) {
LogFile->write(EQCLog::Debug, "Warning: Perl dosub called for %s when perl is allready in use.\n", subname);
}
#endif
in_use = true;
bool err = false;
try {
SV **sp = PL_stack_sp;
/* initialize stack pointer */
} catch(const char *err)
{//this should never happen, so if it does, it is something really serious (like a bad perl install), so we'll shutdown.
EQC::Common::Log(EQCLog::Error,CP_ZONESERVER, "Fatal error initializing perl: %s", err);
}
dSP;
ENTER; /* everything created after here */
SAVETMPS; /* ...is a temporary variable. */
PUSHMARK(SP); /* remember the stack pointer */
if(args && args->size())
{
for(std::vector<std::string>::const_iterator i = args->begin(); i != args->end(); ++i)
{/* push the arguments onto the perl stack */
XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
}
}
PUTBACK; /* make local stack pointer global */
int result = call_pv(subname, mode); /*eval our code*/
SPAGAIN; /* refresh stack pointer */
//if(SvTRUE(ERRSV))
//{
// err = true;
//}
FREETMPS; /* free temp values */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
in_use = false;
if(err)
{
errmsg = "Perl runtime error: ";
errmsg += SvPVX(ERRSV);
throw errmsg.c_str();
}
}
int Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode)
{
dSP;
int ret_value = 0;
int count;
std::string error;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if(args && args->size())
{
for(std::vector<std::string>::const_iterator i = args->begin(); i != args->end(); ++i)
{
XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
}
}
PUTBACK;
count = call_pv(subname, mode);
SPAGAIN;
if(SvTRUE(ERRSV))
{
error = SvPV_nolen(ERRSV);
POPs;
}
else
{
if(count == 1) {
SV *ret = POPs;
if(SvTYPE(ret) == SVt_IV) {
IV v = SvIV(ret);
ret_value = v;
}
PUTBACK;
}
}
FREETMPS;
LEAVE;
if(error.length() > 0)
{
std::string errmsg = "Perl runtime error: ";
errmsg += SvPVX(ERRSV);
throw errmsg.c_str();
}
return ret_value;
}
void
lucy_Err_do_throw(lucy_Err *err) {
dSP;
SV *error_sv = (SV*)Lucy_Err_To_Host(err);
CFISH_DECREF(err);
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(error_sv));
PUTBACK;
call_pv("Clownfish::Err::do_throw", G_DISCARD);
FREETMPS;
LEAVE;
}
/**
* file_path - full path to perl file to load
* func_name - function to run within loaded file
* func_params - hashref to send to function
* obj_name - class name, when run_func is a class method (NULL if not used)
* obj_attr - hashref obj_name is blessed with (NULL if not used)
*/
int perl_embed_run(char *file_path, char *func_name, HV *func_params, char *obj_name, HV *obj_attr, char *error, int errorlength) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
//filnavnet
XPUSHs(sv_2mortal(newSVpv(file_path, 0) ));
//mappen, for å inkludere
//XPUSHs(sv_2mortal(newSVpv(collection->crawlLibInfo->resourcepath, 0) ));
XPUSHs(sv_2mortal(newSViv(perl_opt_cache)));
XPUSHs(sv_2mortal(newSVpv(func_name, 0)));
XPUSHs(sv_2mortal(newRV((SV *) func_params)));
if (obj_name != NULL)
XPUSHs(sv_2mortal(newSVpv(obj_name, 0)));
if (obj_attr != NULL)
XPUSHs(sv_2mortal(newRV((SV *) obj_attr)));
PUTBACK;
int retn = call_pv("Embed::Persistent::eval_file2", G_SCALAR | G_EVAL);
//antar at rutiner som ikke returnerer noe mislykkes. Dette kan for eks skje hvis vi kaller die, eller ikke trenger retur koden
int retv = 0;
SPAGAIN; //refresh stack pointer
if (SvTRUE(ERRSV)) {
fprintf(stderr, "Perl preprocessor error: %s\n", SvPV_nolen(ERRSV));
// overfører error beskjeden.
if (errorlength != 0) {
snprintf(error,errorlength,SvPV_nolen(ERRSV));
}
retv = -1;
}
else if (retn == 1) {
//pop the return value, as a int
retv = POPi;
}
else {
fprintf(stderr, "perlfunc returned %i values, expected 0 or 1. Ignored.\n", retn);
}
FREETMPS;
LEAVE;
printf("~perl_embed_run=%i\n",retv);
return retv;
}
static void __LogAnswer(
const char *msg,
unsigned append)
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(msg, 0)));
XPUSHs(sv_2mortal(newSViv(append)));
PUTBACK;
call_pv("LogAnswer", G_DISCARD);
FREETMPS;
LEAVE;
}
void
ffi_pl_closure_add_data(SV *closure, ffi_pl_closure *closure_data)
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(closure);
XPUSHs(sv_2mortal(newSViv(PTR2IV(closure_data))));
XPUSHs(sv_2mortal(newSViv(PTR2IV(closure_data->type))));
PUTBACK;
call_pv("FFI::Platypus::Closure::add_data", G_DISCARD);
FREETMPS;
LEAVE;
}
static
void call_dump_perl(void *sv) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVsv((SV *)sv)));
PUTBACK;
call_pv("dump_perl", G_DISCARD);
FREETMPS;
LEAVE;
}
static void
call_helper(AV *resobj, int cbtype, const lcb_RESPBASE *resp)
{
dSP;
const char *methname;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newRV_inc((SV*)resobj)));
if (cbtype == LCB_CALLBACK_STATS) {
const lcb_RESPSTATS *sresp = (const void *)resp;
/** Call as statshelper($doc,$server,$key,$value); */
XPUSHs(sv_2mortal(newSVpv(sresp->server, 0)));
XPUSHs(sv_2mortal(newSVpvn(sresp->key, sresp->nkey)));
if (sresp->value) {
XPUSHs(sv_2mortal(newSVpvn(sresp->value, sresp->nvalue)));
}
methname = PLCB_STATS_PLHELPER;
} else if (cbtype == LCB_CALLBACK_OBSERVE) {
const lcb_RESPOBSERVE *oresp = (const void *)resp;
/** Call as obshelper($doc,$status,$cas,$ismaster) */
XPUSHs(sv_2mortal(newSVuv(oresp->status)));
XPUSHs(sv_2mortal(plcb_sv_from_u64_new(&oresp->cas)));
XPUSHs(oresp->ismaster ? &PL_sv_yes : &PL_sv_no);
methname = PLCB_OBS_PLHELPER;
} else {
return;
}
PUTBACK;
call_pv(methname, G_DISCARD|G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
warn("Got error in %s: %s", methname, SvPV_nolen(ERRSV));
}
FREETMPS;
LEAVE;
}
static GnmValue*
call_perl_function_args (GnmFuncEvalInfo *ei, GnmValue const * const *args)
{
GnmFunc *fndef;
gint min_n_args, max_n_args, n_args;
gint i;
gchar *perl_func;
GnmValue* result;
dSP;
fndef = gnm_expr_get_func_def ((GnmExpr *)(ei->func_call));
perl_func = g_strconcat ("func_", gnm_func_get_name (fndef, FALSE), NULL);
gnm_func_count_args (fndef, &min_n_args, &max_n_args);
for (n_args = min_n_args; n_args < max_n_args && args[n_args] != NULL; n_args++);
ENTER;
SAVETMPS;
PUSHMARK(SP);
for (i = 0; i < n_args; i++) {
SV* sv = value2perl (args[i]);
XPUSHs(sv_2mortal(sv));
}
PUTBACK;
call_pv (perl_func, G_EVAL | G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV)) { /* Error handling */
gchar *errmsg;
STRLEN n_a;
errmsg = g_strconcat (_("Perl error: "), SvPV (ERRSV, n_a), NULL);
POPs;
result = value_new_error (ei->pos, errmsg);
g_free (errmsg);
} else {
result = perl2value (POPs);
}
PUTBACK;
FREETMPS;
LEAVE;
g_free (perl_func);
return result;
}
static int mod_detach(void *instance)
{
rlm_perl_t *inst = (rlm_perl_t *) instance;
int exitstatus = 0, count = 0;
if (inst->perl_parsed) {
dTHXa(inst->perl);
PERL_SET_CONTEXT(inst->perl);
if (inst->rad_perlconf_hv != NULL) hv_undef(inst->rad_perlconf_hv);
if (inst->func_detach) {
dSP; ENTER; SAVETMPS;
PUSHMARK(SP);
count = call_pv(inst->func_detach, G_SCALAR | G_EVAL );
SPAGAIN;
if (count == 1) {
exitstatus = POPi;
if (exitstatus >= 100 || exitstatus < 0) {
exitstatus = RLM_MODULE_FAIL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
}
}
#ifdef USE_ITHREADS
rlm_perl_destruct(inst->perl);
pthread_mutex_destroy(&inst->clone_mutex);
#else
perl_destruct(inst->perl);
perl_free(inst->perl);
#endif
/*
* Hope this is not really needed.
* Is only allowed to be called once just before exit().
*
PERL_SYS_TERM();
*/
return exitstatus;
}
void
perl_sub(int tid, char* str)
{
dSP; /* initialize stack pointer */
ENTER; /* everything created after here */
SAVETMPS; /* ...is a temporary variable. */
PUSHMARK(SP); /* remember the stack pointer */
XPUSHs(sv_2mortal(newSVpv(str,0))); /* push the str onto the stack */
PUTBACK; /* make local stack pointer global */
call_pv(perl_subs[tid], G_SCALAR); /* call the function */
SPAGAIN; /* refresh stack pointer */
/* pop the return value from stack */
printf ("original string '%s'\nprocessed string '%s'\n", str, POPp);
PUTBACK;
FREETMPS; /* free that return value */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
}
static void
set(SV *sv, SV *new_value, int imag)
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv);
XPUSHs(new_value);
PUTBACK;
call_pv(imag ? "Math::Complex::Im" : "Math::Complex::Re", G_DISCARD);
FREETMPS;
LEAVE;
}
void IvrPython::onMediaQueueEmpty() {
isMediaQueueEmpty.set(true);
DBG("executiong MQE callback...\n");
if (onMediaQueueEmptyCallback == NULL) {
DBG("IvrPython::onMediaQueueEmpty, but script did not set onMediaQueueEmpty callback.\n");
return;
}
#ifndef IVR_PERL
PyThreadState *tstate;
/* interp is your reference to an interpreter object. */
tstate = PyThreadState_New(mainInterpreterThreadState->interp);
PyEval_AcquireThread(tstate);
/* Perform Python actions here. */
PyObject *arglist = Py_BuildValue("()");
PyObject *result = PyEval_CallObject(onMediaQueueEmptyCallback, arglist);
Py_DECREF(arglist);
if (result == NULL) {
DBG("Calling IVR" SCRIPT_TYPE "onMediaQueueEmpty failed.\n");
// PyErr_Print();
//return ;
} else {
Py_DECREF(result);
}
/* Release the thread. No Python API allowed beyond this point. */
PyEval_ReleaseThread(tstate);
/* You can either delete the thread state, or save it
until you need it the next time. */
PyThreadState_Delete(tstate);
#else //IVR_PERL
PERL_SET_CONTEXT(my_perl_interp);
DBG("context is %ld\n", (long) Perl_get_context());
dSP ;
PUSHMARK(SP) ;
call_pv(onMediaQueueEmptyCallback, G_DISCARD|G_NOARGS) ;
#endif //IVR_PERL
DBG("IvrPython::onMediaQueueEmpty done.\n");
}
static void
Encode_XSEncoding(pTHX_ encode_t *enc)
{
dSP;
HV *stash = gv_stashpv("Encode::XS", TRUE);
SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
int i = 0;
PUSHMARK(sp);
XPUSHs(sv);
while (enc->name[i])
{
const char *name = enc->name[i++];
XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
}
PUTBACK;
call_pv("Encode::define_encoding",G_DISCARD);
SvREFCNT_dec(sv);
}
static SV*
S_compile_token_re(pTHX_ cfish_String *pattern) {
dSP;
ENTER;
SAVETMPS;
EXTEND(SP, 1);
PUSHMARK(SP);
XPUSHs((SV*)CFISH_Str_To_Host(pattern));
PUTBACK;
call_pv("Lucy::Analysis::RegexTokenizer::_compile_token_re", G_SCALAR);
SPAGAIN;
SV *token_re_sv = POPs;
(void)SvREFCNT_inc(token_re_sv);
PUTBACK;
FREETMPS;
LEAVE;
return token_re_sv;
}
char* RPerl_DUMPER__perl_from_c(SV* dumpee)
{
dSP;
int retcnt;
char* retval;
ENTER;
SAVETMPS;
PUSHMARK(SP); XPUSHs(dumpee); PUTBACK;
retcnt = call_pv("RPerl::DUMPER", G_SCALAR);
SPAGAIN;
if (retcnt != 1) { croak("RPerl::DUMPER(dumpee) return count is %d, expected 1, croaking", retcnt); }
retval = POPp; PUTBACK;
// FREETMPS;
LEAVE;
return retval;
}
/* 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;
}
static SV*
S_nfreeze_fields(lucy_Doc *self) {
lucy_DocIVARS *const ivars = lucy_Doc_IVARS(self);
dSP;
ENTER;
SAVETMPS;
EXTEND(SP, 1);
PUSHMARK(SP);
mPUSHs((SV*)newRV_inc((SV*)ivars->fields));
PUTBACK;
call_pv("Storable::nfreeze", G_SCALAR);
SPAGAIN;
SV *frozen = POPs;
(void)SvREFCNT_inc(frozen);
PUTBACK;
FREETMPS;
LEAVE;
return frozen;
}
static inline void
do_script_hook_goto_url(struct session *ses, unsigned char **url)
{
int count;
dSP; /* Keep in variables declaration block. */
ENTER;
SAVETMPS;
PUSHMARK(SP);
my_XPUSHs(*url, strlen((const char *)*url));
if (!ses || !have_location(ses)) {
XPUSHs(sv_2mortal(newSV(0)));
} else {
unsigned char *uri = struri(cur_loc(ses)->vs.uri);
my_XPUSHs(uri, strlen((const char *)uri));
}
PUTBACK;
count = call_pv("goto_url_hook", G_EVAL | G_SCALAR);
if (SvTRUE(ERRSV)) count = 0; /* FIXME: error message ? */
SPAGAIN;
if (count == 1) {
#ifndef CONFIG_PERL_POPPX_WITHOUT_N_A
STRLEN n_a; /* Used by POPpx macro. */
#endif
unsigned char *new_url = POPpx;
if (new_url) {
unsigned char *n = stracpy(new_url);
if (n) {
mem_free_set(url, n);
}
}
}
PUTBACK;
FREETMPS;
LEAVE;
}
