// create a new coro SV * coroae_coro_new(CV *block) { SV *newobj = NULL; dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv( "Coro", 4))); XPUSHs(newRV_inc((SV *)block)); PUTBACK; call_method("new", G_SCALAR); SPAGAIN; if(SvTRUE(ERRSV)) { uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV)); } else { newobj = SvREFCNT_inc(POPs); } PUTBACK; FREETMPS; LEAVE; return newobj; }
void owl_perlconfig_new_command(const char *name) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(owl_new_sv(name))); PUTBACK; call_pv("BarnOwl::Hooks::_new_command", G_SCALAR|G_VOID); SPAGAIN; if(SvTRUE(ERRSV)) { owl_function_error("%s", SvPV_nolen(ERRSV)); } FREETMPS; LEAVE; }
static SV * fold_results(I32 count) { dSP; SV *retval = &PL_sv_undef; if (count > 1) { /* convert multiple return items into a list reference */ AV *av = newAV(); SV *last_sv = &PL_sv_undef; SV *sv = &PL_sv_undef; I32 i; av_extend(av, count - 1); for(i = 1; i <= count; i++) { last_sv = sv; sv = POPs; if (SvOK(sv) && !av_store(av, count - i, SvREFCNT_inc(sv))) SvREFCNT_dec(sv); } PUTBACK; retval = sv_2mortal((SV *) newRV_noinc((SV *) av)); if (!SvOK(sv) || sv == &PL_sv_undef) { /* if first element was undef, die */ croak(ERRMSG "Call error"); } return retval; } else { if (count) retval = POPs; PUTBACK; return retval; } }
static XS (XS_Xchat_get_info) { SV *temp = NULL; dXSARGS; if (items != 1) { hexchat_print (ph, "Usage: Xchat::get_info(id)"); } else { SV *id = ST (0); const char *RETVAL; RETVAL = hexchat_get_info (ph, SvPV_nolen (id)); if (RETVAL == NULL) { XSRETURN_UNDEF; } if (!strncmp ("win_ptr", SvPV_nolen (id), 7) || !strncmp ("gtkwin_ptr", SvPV_nolen (id), 10)) { XSRETURN_IV (PTR2IV (RETVAL)); } else { if ( !strncmp ("libdirfs", SvPV_nolen (id), 8) || !strncmp ("xchatdirfs", SvPV_nolen (id), 10) || !strncmp ("configdir", SvPV_nolen (id), 9) ) { XSRETURN_PV (RETVAL); } else { temp = newSVpv (RETVAL, 0); SvUTF8_on (temp); PUSHMARK (SP); XPUSHs (sv_2mortal (temp)); PUTBACK; } } } }
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(EQEMuLog::Debug, "Warning: Perl dosub called for %s when perl is allready in use.\n", subname); } #endif in_use = true; bool err = false; dSP; /* initialize stack pointer */ 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 */ 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(); } }
void ht_to_perl_ht(HV *perl_ht, struct hashtable *params) { if (!hashtable_count(params)) return; struct hashtable_itr *itr; itr = hashtable_iterator(params); do { char *param = hashtable_iterator_key(itr); char *value = hashtable_iterator_value(itr); // check if key already exists if (hv_exists(perl_ht, param, strlen(param))) { fprintf(stderr, "Parameter '%s' is already defined. Ignoring.\n", param); continue; } hv_store(perl_ht, param, strlen(param), sv_2mortal(newSVpv(value, 0)), 0); } while (hashtable_iterator_advance(itr)); free(itr); }
static void destroy_package(const char *package) { dSP; PERL_SET_CONTEXT(my_perl); SPAGAIN; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv(package, strlen(package)))); PUTBACK; perl_call_pv("Purple::PerlLoader::destroy_package", G_VOID | G_EVAL | G_DISCARD); SPAGAIN; PUTBACK; FREETMPS; LEAVE; }
SV* ffi_pl_custom_perl(SV *subref, SV *in_arg, int i) { if(subref == NULL) { return newSVsv(in_arg); } else { dSP; int count; SV *out_arg; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(in_arg); XPUSHs(sv_2mortal(newSViv(i))); PUTBACK; count = call_sv(subref, G_ARRAY); SPAGAIN; if(count >= 1) out_arg = SvREFCNT_inc(POPs); else out_arg = NULL; PUTBACK; FREETMPS; LEAVE; return out_arg; } }
void IvrPython::onNotify(AmSessionEvent* event) { if (onNotifyCallback == NULL) { DBG("IvrPython::onNotify, but script did not set onNotify callback!\n"); return; } DBG("IvrPython::onNotify(): calling onNotifyCallback ...\n"); #ifndef IVR_PERL PyThreadState* pyThreadState; if ( (pyThreadState = Py_NewInterpreter()) != NULL){ PyObject *arglist; PyObject *result; arglist = Py_BuildValue("(s)", event->request.getBody().c_str());; result = PyEval_CallObject(onNotifyCallback, arglist); Py_DECREF(arglist); if (result == NULL) { DBG("Calling IVR" SCRIPT_TYPE "onNotify failed.\n"); // PyErr_Print(); return ; } Py_DECREF(result); } Py_EndInterpreter(pyThreadState); #else //IVR_PERL PERL_SET_CONTEXT(my_perl_interp); DBG("context is %ld\n", (long) Perl_get_context()); dSP ; ENTER ; SAVETMPS ; PUSHMARK(SP) ; XPUSHs(sv_2mortal(newSVpv((event->request.getBody().c_str()), 0))); PUTBACK ; call_pv(onNotifyCallback, G_DISCARD); FREETMPS ; LEAVE ; #endif //IVR_PERL }
PJS_EXTERN SV * PJS_CallPerlMethod( pTHX_ JSContext *cx, const char *method, ... ) { dSP; va_list ap; SV *arg, *ret; PJS_Context *pcx = PJS_GET_CONTEXT(cx); ENTER; SAVETMPS; PUSHMARK(SP); sv_setiv(save_scalar(PJS_Context_SV), PTR2IV(pcx)); va_start(ap, method); while( (arg = va_arg(ap, SV*)) ) XPUSHs(arg); va_end(ap); PUTBACK; call_method(method, G_SCALAR | G_EVAL); ret = newSVsv(*PL_stack_sp--); FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sv_free(ret); // Don't want leaks propagate2JS(aTHX_ pcx, NULL); return NULL; } return sv_2mortal(ret); }
/* caller must free the result */ CALLER_OWN char *owl_perlconfig_perlcmd(const owl_cmd *cmd, int argc, const char *const *argv) { int i, count; char * ret = NULL; SV *rv; dSP; ENTER; SAVETMPS; PUSHMARK(SP); for(i=0;i<argc;i++) { XPUSHs(sv_2mortal(owl_new_sv(argv[i]))); } PUTBACK; count = call_sv(cmd->cmd_perl, G_SCALAR|G_EVAL); SPAGAIN; if(SvTRUE(ERRSV)) { owl_function_error("%s", SvPV_nolen(ERRSV)); (void)POPs; } else { if(count != 1) croak("Perl command %s returned more than one value!", cmd->name); rv = POPs; if(SvTRUE(rv)) { ret = g_strdup(SvPV_nolen(rv)); } } FREETMPS; LEAVE; return ret; }
JSObject* PJS_InitPerlSubClass( pTHX_ JSContext *cx, JSObject *global ) { CV *pcv = get_cv(NAMESPACE"PerlSub::prototype", 0); JSObject *proto; if(pcv && (CvROOT(pcv) || CvXSUB(pcv))) { proto = JS_InitClass( cx, global, PJS_GetPackageObject(aTHX_ cx, PerlSubPkg), &perlsub_class, PerlSub, 1, NULL, NULL, NULL, NULL ); return PJS_CreateJSVis(aTHX_ cx, proto, sv_2mortal(newRV_inc((SV *)pcv))); } croak("Can't locate PerlSub::prototype"); return NULL; }
static XS (XS_Xchat_get_prefs) { const char *str; int integer; SV *temp = NULL; dXSARGS; if (items != 1) { xchat_print (ph, "Usage: Xchat::get_prefs(name)"); } else { switch (xchat_get_prefs (ph, SvPV_nolen (ST (0)), &str, &integer)) { case 0: XSRETURN_UNDEF; break; case 1: temp = newSVpv (str, 0); SvUTF8_on (temp); SP -= items; sp = mark; XPUSHs (sv_2mortal (temp)); PUTBACK; break; case 2: XSRETURN_IV (integer); break; case 3: if (integer) { XSRETURN_YES; } else { XSRETURN_NO; } } } }
int report_cluster_rec_list_to_av(List list, AV* av) { HV* rh; ListIterator itr = NULL; slurmdb_report_cluster_rec_t* rec = NULL; if (list) { itr = slurm_list_iterator_create(list); while ((rec = slurm_list_next(itr))) { rh = (HV*)sv_2mortal((SV*)newHV()); if (report_cluster_rec_to_hv(rec, rh) < 0) { Perl_warn(aTHX_ "Failed to convert a report_cluster_rec to a hv"); slurm_list_iterator_destroy(itr); return -1; } else { av_push(av, newRV((SV*)rh)); } } slurm_list_iterator_destroy(itr); } return 0; }
static SV *coroae_add_watcher(int fd, SV *cb) { SV *newobj; dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv( "AnyEvent", 8))); XPUSHs(sv_2mortal(newSVpv( "fh", 2))); XPUSHs(sv_2mortal(newSViv(fd))); XPUSHs(sv_2mortal(newSVpv( "poll", 4))); XPUSHs(sv_2mortal(newSVpv( "r", 1))); XPUSHs(sv_2mortal(newSVpv( "cb", 2))); XPUSHs(newRV_inc(cb)); PUTBACK; call_method( "io", G_SCALAR); SPAGAIN; if(SvTRUE(ERRSV)) { // no need to continue... uwsgi_log("[uwsgi-perl error] %s", SvPV_nolen(ERRSV)); exit(1); } else { newobj = SvREFCNT_inc(POPs); } PUTBACK; FREETMPS; LEAVE; return newobj; }
static void perl_call_signal(PERL_SCRIPT_REC *script, SV *func, int signal_id, gconstpointer *args) { dSP; PERL_SIGNAL_ARGS_REC *rec; SV *sv, *perlarg, *saved_args[SIGNAL_MAX_ARGUMENTS]; AV *av; void *arg; int n; ENTER; SAVETMPS; PUSHMARK(sp); /* push signal argument to perl stack */ rec = perl_signal_args_find(signal_id); memset(saved_args, 0, sizeof(saved_args)); for (n = 0; n < SIGNAL_MAX_ARGUMENTS && rec != NULL && rec->args[n] != NULL; n++) { arg = (void *) args[n]; if (strncmp(rec->args[n], "glistptr_", 9) == 0) { /* pointer to linked list - push as AV */ GList *tmp, **ptr; int is_iobject, is_str; is_iobject = strcmp(rec->args[n]+9, "iobject") == 0; is_str = strcmp(rec->args[n]+9, "char*") == 0; av = newAV(); ptr = arg; for (tmp = *ptr; tmp != NULL; tmp = tmp->next) { sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) : is_str ? new_pv(tmp->data) : irssi_bless_plain(rec->args[n]+9, tmp->data); av_push(av, sv); } saved_args[n] = perlarg = newRV_noinc((SV *) av); } else if (strcmp(rec->args[n], "int") == 0) perlarg = newSViv((IV)arg); else if (arg == NULL) perlarg = &PL_sv_undef; else if (strcmp(rec->args[n], "string") == 0) perlarg = new_pv(arg); else if (strcmp(rec->args[n], "ulongptr") == 0) perlarg = newSViv(*(unsigned long *) arg); else if (strcmp(rec->args[n], "intptr") == 0) saved_args[n] = perlarg = newRV_noinc(newSViv(*(int *) arg)); else if (strncmp(rec->args[n], "gslist_", 7) == 0) { /* linked list - push as AV */ GSList *tmp; int is_iobject; is_iobject = strcmp(rec->args[n]+7, "iobject") == 0; av = newAV(); for (tmp = arg; tmp != NULL; tmp = tmp->next) { sv = is_iobject ? iobject_bless((SERVER_REC *) tmp->data) : irssi_bless_plain(rec->args[n]+7, tmp->data); av_push(av, sv); } perlarg = newRV_noinc((SV *) av); } else if (strcmp(rec->args[n], "iobject") == 0) { /* "irssi object" - any struct that has "int type; int chat_type" as it's first variables (server, channel, ..) */ perlarg = iobject_bless((SERVER_REC *) arg); } else if (strcmp(rec->args[n], "siobject") == 0) { /* "simple irssi object" - any struct that has int type; as it's first variable (dcc) */ perlarg = simple_iobject_bless((SERVER_REC *) arg); } else { /* blessed object */ perlarg = plain_bless(arg, rec->args[n]); } XPUSHs(sv_2mortal(perlarg)); } PUTBACK; perl_call_sv(func, G_EVAL|G_DISCARD); SPAGAIN; if (SvTRUE(ERRSV)) { char *error = g_strdup(SvPV_nolen(ERRSV)); signal_emit("script error", 2, script, error); g_free(error); rec = NULL; } /* restore arguments the perl script modified */ for (n = 0; n < SIGNAL_MAX_ARGUMENTS && rec != NULL && rec->args[n] != NULL; n++) { arg = (void *) args[n]; if (saved_args[n] == NULL) continue; if (strcmp(rec->args[n], "intptr") == 0) { int *val = arg; *val = SvIV(SvRV(saved_args[n])); } else if (strncmp(rec->args[n], "glistptr_", 9) == 0) { GList **ret = arg; GList *out = NULL; void *val; int count; av = (AV *) SvRV(saved_args[n]); count = av_len(av); while (count-- >= 0) { sv = av_shift(av); if (SvPOKp(sv)) val = g_strdup(SvPV_nolen(sv)); else val = GINT_TO_POINTER(SvIV(sv)); out = g_list_append(out, val); } if (strcmp(rec->args[n]+9, "char*") == 0) g_list_foreach(*ret, (GFunc) g_free, NULL); g_list_free(*ret); *ret = out; } } FREETMPS; LEAVE; }
/* * Run function, with current SIP message as a parameter */ int perl_exec(struct sip_msg* _msg, str* _fnc_s, str* mystr) { int retval; SV *m; str reason; str pfnc, pparam; char *fnc; fnc = pkg_malloc(_fnc_s->len); if (!fnc) { LM_ERR("No more pkg mem!\n"); return -1; } memcpy(fnc, _fnc_s->s, _fnc_s->len); fnc[_fnc_s->len] = 0; dSP; if (!perl_checkfnc(fnc)) { LM_ERR("unknown perl function called.\n"); reason.s = "Internal error"; reason.len = sizeof("Internal error")-1; if (sigb.reply(_msg, 500, &reason, NULL) == -1) { LM_ERR("failed to send reply\n"); } goto error; } switch ((_msg->first_line).type) { case SIP_REQUEST: if (parse_sip_msg_uri(_msg) < 0) { LM_ERR("failed to parse Request-URI\n"); reason.s = "Bad Request-URI"; reason.len = sizeof("Bad Request-URI")-1; if (sigb.reply(_msg, 400, &reason, NULL) == -1) { LM_ERR("failed to send reply\n"); } goto error; } break; case SIP_REPLY: break; default: LM_ERR("invalid firstline\n"); goto error; } ENTER; /* everything created after here */ SAVETMPS; /* ...is a temporary variable. */ PUSHMARK(SP); /* remember the stack pointer */ m = sv_newmortal(); /* create a mortal SV to be killed on FREETMPS */ sv_setref_pv(m, "OpenSIPS::Message", (void *)_msg); /* bless the message with a class */ SvREADONLY_on(SvRV(m)); /* set the content of m to be readonly */ XPUSHs(m); /* Our reference to the stack... */ if (mystr) XPUSHs(sv_2mortal(newSVpv(mystr->s, mystr->len))); /* Our string to the stack... */ PUTBACK; /* make local stack pointer global */ call_pv(fnc, G_EVAL|G_SCALAR); /* call the function */ SPAGAIN; /* refresh stack pointer */ /* pop the return value from stack */ retval = POPi; PUTBACK; FREETMPS; /* free that return value */ LEAVE; /* ...and the XPUSHed "mortal" args.*/ return retval; error: pkg_free(fnc); return -1; }
/* Takes a string, sent with command_to_script, and sends it to the script * itself, i.e, we are in the script parsing process */ void sub_to_script(char *buf) { char subname[31]; /* Name of the Perl sub */ char *arg1 = NULL; /* First argument to the sub */ char *arg2 = NULL; /* Second argument to the sub */ char *arg3 = NULL; /* Third argument to the sub */ char *temp; char temp_nick[MAX_NICK_LEN+1]; struct user_t *temp_user; int i; if(sscanf(buf, "%30[^| ]", subname) != 1) { logprintf(1, "Got incomplete command to to_script()\n"); return; } /* user_info is a special case, since it isn't sent to the scripts, it's * only used to set variables of the user in the script parsing process. */ if(!strncmp(subname, "user_info", 9)) { sscanf(buf + 10, "%50s", temp_nick); /* If the user isn't already here, allocate a new user. */ if((temp_user = get_human_user(temp_nick)) == NULL) { if((temp_user = malloc(sizeof(struct user_t))) == NULL) { logprintf(1, "Error - In sub_to_script()/malloc(): "); logerror(1, errno); quit = 1; return; } temp_user->email = NULL; temp_user->desc = NULL; temp_user->buf = NULL; temp_user->outbuf = NULL; } else { remove_human_from_hash(temp_user->nick); if(temp_user->email != NULL) free(temp_user->email); temp_user->email = NULL; if(temp_user->desc != NULL) free(temp_user->desc); temp_user->desc = NULL; if(temp_user->buf != NULL) free(temp_user->buf); temp_user->buf = NULL; if(temp_user->outbuf != NULL) free(temp_user->outbuf); temp_user->outbuf = NULL; } temp_user->type = NON_LOGGED; memset(temp_user->version, 0, MAX_VERSION_LEN+1); temp_user->con_type = 0; temp_user->flag = 0; temp_user->share = 0; temp_user->timeout = 0; temp_user->rem = 0; temp_user->key = 0; temp_user->last_search = (time_t)0; /* The sock won't be used in the script, so set it to 0. */ temp_user->sock = 0; /* Set the nick. */ strcpy(temp_user->nick, temp_nick); /* Add to hashtable. */ add_human_to_hash(temp_user); sscanf(buf + 10, "%50s %lu %120s %d %30[^ |]", temp_user->nick, &temp_user->ip, temp_user->hostname, &temp_user->type, temp_user->version); return; } /* First argument */ if(((i = cut_string(buf, '\005')) != -1) /* Do we have a first argument? */ && (*(buf+i+1) == '\005')) { temp = buf + i + 2; if(!(((i = cut_string(temp, '\005')) != -1) /* Do we not have a second argument? */ && (*(temp+i+1) == '\005'))) { if((arg1 = malloc(sizeof(char) * (cut_string(temp, '|') + 2))) == NULL) { logprintf(1, "Error - In sub_to_script()/malloc(): "); logerror(1, errno); quit = 1; return; } memset(arg1, 0, cut_string(temp, '|') + 1); strncpy(arg1, temp, cut_string(temp, '|')); } else /* We have a second argument. */ { if((arg1 = malloc(sizeof(char) * (cut_string(temp, '\005') + 2))) == NULL) { logprintf(1, "Error - In sub_to_script()/malloc(): "); logerror(1, errno); quit = 1; return; } memset(arg1, 0, cut_string(temp, '\005') + 1); strncpy(arg1, temp, cut_string(temp, '\005')); /* Second argument */ temp = temp + cut_string(temp, '\005') + 2; if(!(((i = cut_string(temp, '\005')) != -1) /* Do we not have a third argument? */ && (*(temp+i+1) == '\005'))) { if((arg2 = malloc(sizeof(char) * (cut_string(temp, '|') + 2))) == NULL) { logprintf(1, "Error - In sub_to_script()/malloc(): "); logerror(1, errno); quit = 1; return; } memset(arg2, 0, cut_string(temp, '|') + 2); strncpy(arg2, temp, cut_string(temp, '|')); } else /* We have a third argument */ { if((arg2 = malloc(sizeof(char) * (cut_string(temp, '\005') + 2))) == NULL) { logprintf(1, "Error - In sub_to_script()/malloc(): "); logerror(1, errno); quit = 1; return; } memset(arg2, 0, cut_string(temp, '\005') + 2); strncpy(arg2, temp, cut_string(temp, '\005') + 1); /* Third argument */ temp = temp + cut_string(temp, '\005') + 1; if((arg3 = malloc(sizeof(char) * (cut_string(temp, '|') + 2))) == NULL) { logprintf(1, "Error - In sub_to_script()/malloc(): "); logerror(1, errno); quit = 1; return; } memset(arg3, 0, cut_string(temp, '|') + 2); strncpy(arg3, temp, cut_string(temp, '|')); } } } /* And call the sub. */ { dSP; ENTER; SAVETMPS; PUSHMARK(SP); /* These subs take three arguments: */ if(!strncmp(subname, "added_temp_ban", 14)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); XPUSHs(sv_2mortal(newSVuv(atol(arg2)))); if(arg3 != NULL) XPUSHs(sv_2mortal(newSVpvn(arg3, strlen(arg3)))); } else if(!strncmp(subname, "added_temp_allow", 16)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); XPUSHs(sv_2mortal(newSVuv(atol(arg2)))); if(arg3 != NULL) XPUSHs(sv_2mortal(newSVpvn(arg3, strlen(arg3)))); } /* These subs take two arguments: */ else if(!strncmp(subname, "data_arrival", 12)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); /* We'll have to add the pipe here, since we actually want it in * this argument. It looks a bit ugly, but it seems to be the best * way since the pipe can't be used internally between processes. * Maybe Open DC Hub shouldn't be using the flawed Direct Connect * protocol between processes, but thats a _big_ todo... */ strcat(arg2, "|"); XPUSHs(sv_2mortal(newSVpvn(arg2, strlen(arg2)))); } else if(!strncmp(subname, "added_multi_hub", 15)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); XPUSHs(sv_2mortal(newSViv(atoi(arg2)))); } else if(!strncmp(subname, "added_perm_ban", 14)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); if(arg2 != NULL) XPUSHs(sv_2mortal(newSVpvn(arg2, strlen(arg2)))); } else if(!strncmp(subname, "added_perm_allow", 16)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); if(arg2 != NULL) XPUSHs(sv_2mortal(newSVpvn(arg2, strlen(arg2)))); } else if(!strncmp(subname, "added_perm_nickban", 18)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); } else if(!strncmp(subname, "added_temp_nickban", 18)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); XPUSHs(sv_2mortal(newSVuv(atol(arg2)))); } else if(!strncmp(subname, "kicked_user", 11)) { XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); XPUSHs(sv_2mortal(newSVpvn(arg2, strlen(arg2)))); } /* If it isn't the ones with no arguments or the ones with two, * it has one argument. */ else if(strncmp(subname, "started_serving", 15)) if(strncmp(subname, "hub_timer", 9)) XPUSHs(sv_2mortal(newSVpvn(arg1, strlen(arg1)))); PUTBACK; call_pv(subname, G_DISCARD|G_EVAL); FREETMPS; LEAVE; } /* If it was user_disconnected, remove the user. */ if(!strncmp(subname, "user_disconnected", 17)) { if((temp_user = get_human_user(arg1)) != NULL) { if(temp_user->buf != NULL) { free(temp_user->buf); temp_user->buf = NULL; } if(temp_user->outbuf != NULL) { free(temp_user->outbuf); temp_user->outbuf = NULL; } if(temp_user->email != NULL) { free(temp_user->email); temp_user->email = NULL; } if(temp_user->desc != NULL) { free(temp_user->desc); temp_user->desc = NULL; } remove_human_from_hash(temp_user->nick); } } if(arg1 != NULL) free(arg1); if(arg2 != NULL) free(arg2); }
GV * Perl_gv_fetchmethod_autoload(pTHX_ HV *stash, const char *name, I32 autoload) { register const char *nend; const char *nsplit = 0; GV* gv; HV* ostash = stash; if (stash && SvTYPE(stash) < SVt_PVHV) stash = Nullhv; for (nend = name; *nend; nend++) { if (*nend == '\'') nsplit = nend; else if (*nend == ':' && *(nend + 1) == ':') nsplit = ++nend; } if (nsplit) { const char *origname = name; name = nsplit + 1; if (*nsplit == ':') --nsplit; if ((nsplit - origname) == 5 && strnEQ(origname, "SUPER", 5)) { /* ->SUPER::method should really be looked up in original stash */ SV *tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%s::SUPER", CopSTASHPV(PL_curcop))); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_stashpvn(SvPVX(tmpstr), SvCUR(tmpstr), TRUE); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", origname, HvNAME(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ stash = gv_stashpvn(origname, nsplit - origname, FALSE); /* however, explicit calls to Pkg::SUPER::method may happen, and may require autovivification to work */ if (!stash && (nsplit - origname) >= 7 && strnEQ(nsplit - 7, "::SUPER", 7) && gv_stashpvn(origname, nsplit - origname - 7, FALSE)) stash = gv_stashpvn(origname, nsplit - origname, TRUE); } ostash = stash; } gv = gv_fetchmeth(stash, name, nend - name, 0); if (!gv) { if (strEQ(name,"import") || strEQ(name,"unimport")) gv = (GV*)&PL_sv_yes; else if (autoload) gv = gv_autoload4(ostash, name, nend - name, TRUE); } else if (autoload) { CV* cv = GvCV(gv); if (!CvROOT(cv) && !CvXSUB(cv)) { GV* stubgv; GV* autogv; if (CvANON(cv)) stubgv = gv; else { stubgv = CvGV(cv); if (GvCV(stubgv) != cv) /* orphaned import */ stubgv = gv; } autogv = gv_autoload4(GvSTASH(stubgv), GvNAME(stubgv), GvNAMELEN(stubgv), TRUE); if (autogv) gv = autogv; } } return gv; }
static SV *sv2mortal_shim(SV **&sp, SV *sv) { return sv_2mortal(sv); }
isc_result_t dlz_create(const char *dlzname, unsigned int argc, char *argv[], void **dbdata, ...) { config_data_t *cd; char *init_args[] = { NULL, NULL }; char *perlrun[] = { "", NULL, "dlz perl", NULL }; char *perl_class_name; int r; va_list ap; const char *helper_name; const char *missing_method_name; char *call_argv_args = NULL; #ifdef MULTIPLICITY PerlInterpreter *my_perl; #endif cd = malloc(sizeof(config_data_t)); if (cd == NULL) return (ISC_R_NOMEMORY); memset(cd, 0, sizeof(config_data_t)); /* fill in the helper functions */ va_start(ap, dbdata); while ((helper_name = va_arg(ap, const char *)) != NULL) { b9_add_helper(cd, helper_name, va_arg(ap, void*)); } va_end(ap); if (argc < 2) { cd->log(ISC_LOG_ERROR, "DLZ Perl '%s': Missing script argument.", dlzname); return (ISC_R_FAILURE); } if (argc < 3) { cd->log(ISC_LOG_ERROR, "DLZ Perl '%s': Missing class name argument.", dlzname); return (ISC_R_FAILURE); } perl_class_name = argv[2]; cd->log(ISC_LOG_INFO, "DLZ Perl '%s': Loading '%s' from location '%s'", dlzname, perl_class_name, argv[1], argc); #ifndef MULTIPLICITY if (global_perl) { /* * PERL_SET_CONTEXT not needed here as we're guaranteed to * have an implicit context thanks to an undefined * MULTIPLICITY. */ PL_perl_destruct_level = 1; perl_destruct(global_perl); perl_free(global_perl); global_perl = NULL; global_perl_dont_free = 1; } #endif cd->perl = perl_alloc(); if (cd->perl == NULL) { free(cd); return (ISC_R_FAILURE); } #ifdef MULTIPLICITY my_perl = cd->perl; #endif PERL_SET_CONTEXT(cd->perl); /* * We will re-create the interpreter during an rndc reconfig, so we * must set this variable per perlembed in order to insure we can * clean up Perl at a later time. */ PL_perl_destruct_level = 1; perl_construct(cd->perl); PL_exit_flags |= PERL_EXIT_DESTRUCT_END; /* Prevent crashes from clients writing to $0 */ PL_origalen = 1; cd->perl_source = strdup(argv[1]); if (cd->perl_source == NULL) { free(cd); return (ISC_R_NOMEMORY); } perlrun[1] = cd->perl_source; if (perl_parse(cd->perl, xs_init, 3, perlrun, (char **)NULL)) { cd->log(ISC_LOG_ERROR, "DLZ Perl '%s': Failed to parse Perl script, aborting", dlzname); goto CLEAN_UP_PERL_AND_FAIL; } /* Let Perl know about our callbacks. */ call_argv("DLZ_Perl::clientinfo::bootstrap", G_DISCARD|G_NOARGS, &call_argv_args); call_argv("DLZ_Perl::bootstrap", G_DISCARD|G_NOARGS, &call_argv_args); /* * Run the script. We don't really need to do this since we have * the init callback, but there's not really a downside either. */ if (perl_run(cd->perl)) { cd->log(ISC_LOG_ERROR, "DLZ Perl '%s': Script exited with an error, aborting", dlzname); goto CLEAN_UP_PERL_AND_FAIL; } #ifdef MULTIPLICITY if (missing_method_name = missing_perl_method(perl_class_name, my_perl)) #else if (missing_method_name = missing_perl_method(perl_class_name)) #endif { cd->log(ISC_LOG_ERROR, "DLZ Perl '%s': Missing required function '%s', " "aborting", dlzname, missing_method_name); goto CLEAN_UP_PERL_AND_FAIL; } dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv(perl_class_name, 0))); /* Build flattened hash of config info. */ XPUSHs(sv_2mortal(newSVpv("log_context", 0))); XPUSHs(sv_2mortal(newSViv((IV)cd->log))); /* Argument to pass to new? */ if (argc == 4) { XPUSHs(sv_2mortal(newSVpv("argv", 0))); XPUSHs(sv_2mortal(newSVpv(argv[3], 0))); } PUTBACK; r = call_method("new", G_EVAL|G_SCALAR); SPAGAIN; if (r) cd->perl_class = SvREFCNT_inc(POPs); PUTBACK; FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { POPs; cd->log(ISC_LOG_ERROR, "DLZ Perl '%s': new died in eval: %s", dlzname, SvPV_nolen(ERRSV)); goto CLEAN_UP_PERL_AND_FAIL; } if (!r || !sv_isobject(cd->perl_class)) { cd->log(ISC_LOG_ERROR, "DLZ Perl '%s': new failed to return a blessed object", dlzname); goto CLEAN_UP_PERL_AND_FAIL; } *dbdata = cd; #ifndef MULTIPLICITY global_perl = cd->perl; #endif return (ISC_R_SUCCESS); CLEAN_UP_PERL_AND_FAIL: PL_perl_destruct_level = 1; perl_destruct(cd->perl); perl_free(cd->perl); free(cd->perl_source); free(cd); return (ISC_R_FAILURE); }
isc_result_t dlz_findzonedb(void *dbdata, const char *name, dns_clientinfomethods_t *methods, dns_clientinfo_t *clientinfo) #endif { config_data_t *cd = (config_data_t *) dbdata; int r; isc_result_t retval; #ifdef MULTIPLICITY PerlInterpreter *my_perl = cd->perl; #endif #if DLZ_DLOPEN_VERSION >= 3 UNUSED(methods); UNUSED(clientinfo); #endif dSP; carp("DLZ Perl: findzone looking for '%s'", name); PERL_SET_CONTEXT(cd->perl); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(cd->perl_class); XPUSHs(sv_2mortal(newSVpv(name, 0))); PUTBACK; r = call_method("findzone", G_SCALAR|G_EVAL); SPAGAIN; if (SvTRUE(ERRSV)) { /* * On error there's an undef at the top of the stack. Pop * it away so we don't leave junk on the stack for the next * caller. */ POPs; cd->log(ISC_LOG_ERROR, "DLZ Perl: findzone died in eval: %s", SvPV_nolen(ERRSV)); retval = ISC_R_FAILURE; } else if (r == 0) { retval = ISC_R_FAILURE; } else if (r > 1) { /* Once again, clean out the stack when possible. */ while (r--) POPi; cd->log(ISC_LOG_ERROR, "DLZ Perl: findzone returned too many parameters!"); retval = ISC_R_FAILURE; } else { r = POPi; if (r) retval = ISC_R_SUCCESS; else retval = ISC_R_NOTFOUND; } PUTBACK; FREETMPS; LEAVE; return (retval); }
static SV * plperl_create_sub(char *s, bool trusted) { dSP; SV *subref; int count; char *compile_sub; if (trusted && !plperl_safe_init_done) { plperl_safe_init(); SPAGAIN; } ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv("my $_TD=$_[0]; shift;", 0))); XPUSHs(sv_2mortal(newSVpv(s, 0))); PUTBACK; /* * G_KEEPERR seems to be needed here, else we don't recognize compile * errors properly. Perhaps it's because there's another level of eval * inside mksafefunc? */ if (trusted && plperl_use_strict) compile_sub = "::mk_strict_safefunc"; else if (plperl_use_strict) compile_sub = "::mk_strict_unsafefunc"; else if (trusted) compile_sub = "::mksafefunc"; else compile_sub = "::mkunsafefunc"; count = perl_call_pv(compile_sub, G_SCALAR | G_EVAL | G_KEEPERR); SPAGAIN; if (count != 1) { PUTBACK; FREETMPS; LEAVE; elog(ERROR, "didn't get a return item from mksafefunc"); } if (SvTRUE(ERRSV)) { (void) POPs; PUTBACK; FREETMPS; LEAVE; ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("creation of Perl function failed: %s", strip_trailing_ws(SvPV(ERRSV, PL_na))))); } /* * need to make a deep copy of the return. it comes off the stack as a * temporary. */ subref = newSVsv(POPs); if (!SvROK(subref) || SvTYPE(SvRV(subref)) != SVt_PVCV) { PUTBACK; FREETMPS; LEAVE; /* * subref is our responsibility because it is not mortal */ SvREFCNT_dec(subref); elog(ERROR, "didn't get a code ref"); } PUTBACK; FREETMPS; LEAVE; return subref; }
/* * This is the main Load function. * It takes a yaml stream and turns it into 0 or more Perl objects. */ void Load(SV *yaml_sv) { dXSARGS; perl_yaml_loader_t loader; SV *node; char *yaml_str; STRLEN yaml_len; /* If UTF8, make copy and downgrade */ if (SvPV_nolen(yaml_sv) && SvUTF8(yaml_sv)) { yaml_sv = sv_mortalcopy(yaml_sv); } yaml_str = SvPVbyte(yaml_sv, yaml_len); sp = mark; if (0 && (items || ax)) {} /* XXX Quiet the -Wall warnings for now. */ yaml_parser_initialize(&loader.parser); loader.document = 0; yaml_parser_set_input_string( &loader.parser, (unsigned char *)yaml_str, yaml_len ); /* Get the first event. Must be a STREAM_START */ if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type != YAML_STREAM_START_EVENT) croak(ERRMSG "Expected STREAM_START_EVENT; Got: %d != %d", loader.event.type, YAML_STREAM_START_EVENT ); loader.anchors = newHV(); sv_2mortal((SV*)loader.anchors); /* Keep calling load_node until end of stream */ while (1) { loader.document++; if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type == YAML_STREAM_END_EVENT) break; node = load_node(&loader); hv_clear(loader.anchors); if (! node) break; XPUSHs(sv_2mortal(node)); if (!yaml_parser_parse(&loader.parser, &loader.event)) goto load_error; if (loader.event.type != YAML_DOCUMENT_END_EVENT) croak(ERRMSG "Expected DOCUMENT_END_EVENT"); } /* Make sure the last event is a STREAM_END */ if (loader.event.type != YAML_STREAM_END_EVENT) croak(ERRMSG "Expected STREAM_END_EVENT; Got: %d != %d", loader.event.type, YAML_STREAM_END_EVENT ); yaml_parser_delete(&loader.parser); PUTBACK; return; load_error: croak(loader_error_msg(&loader, NULL)); }
/* * The xlat function */ static ssize_t perl_xlat(UNUSED TALLOC_CTX *ctx, char **out, size_t outlen, void const *mod_inst, UNUSED void const *xlat_inst, REQUEST *request, char const *fmt) { rlm_perl_t *inst; char *tmp; char const *p, *q; int count; size_t ret = 0; STRLEN n_a; memcpy(&inst, &mod_inst, sizeof(inst)); #ifdef USE_ITHREADS PerlInterpreter *interp; pthread_mutex_lock(&inst->clone_mutex); interp = rlm_perl_clone(inst->perl, inst->thread_key); { dTHXa(interp); PERL_SET_CONTEXT(interp); } pthread_mutex_unlock(&inst->clone_mutex); #else PERL_SET_CONTEXT(inst->perl); #endif { dSP; ENTER;SAVETMPS; PUSHMARK(SP); p = q = fmt; while (*p == ' ') { p++; q++; } while (*q) { if (*q == ' ') { XPUSHs(sv_2mortal(newSVpvn(p, q - p))); p = q + 1; /* * Don't use an empty string */ while (*p == ' ') p++; q = p; } q++; } /* * And the last bit. */ if (*p) { XPUSHs(sv_2mortal(newSVpvn(p, strlen(p)))); } PUTBACK; count = call_pv(inst->func_xlat, G_SCALAR | G_EVAL); SPAGAIN; if (SvTRUE(ERRSV)) { REDEBUG("Exit %s", SvPV(ERRSV,n_a)); (void)POPs; } else if (count > 0) { tmp = POPp; strlcpy(*out, tmp, outlen); ret = strlen(*out); RDEBUG2("Len is %zu , out is %s freespace is %zu", ret, *out, outlen); } PUTBACK ; FREETMPS ; LEAVE ; } return ret; }
isc_result_t dlz_lookup(const char *zone, const char *name, void *dbdata, dns_sdlzlookup_t *lookup, dns_clientinfomethods_t *methods, dns_clientinfo_t *clientinfo) #endif { isc_result_t retval; config_data_t *cd = (config_data_t *) dbdata; int rrcount, r; dlz_perl_clientinfo_opaque opaque; SV *record_ref; SV **rr_type; SV **rr_ttl; SV **rr_data; #ifdef MULTIPLICITY PerlInterpreter *my_perl = cd->perl; #endif #if DLZ_DLOPEN_VERSION >= 2 UNUSED(methods); UNUSED(clientinfo); #endif dSP; PERL_SET_CONTEXT(cd->perl); ENTER; SAVETMPS; opaque.methods = methods; opaque.clientinfo = clientinfo; PUSHMARK(SP); XPUSHs(cd->perl_class); XPUSHs(sv_2mortal(newSVpv(name, 0))); XPUSHs(sv_2mortal(newSVpv(zone, 0))); XPUSHs(sv_2mortal(newSViv((IV)&opaque))); PUTBACK; carp("DLZ Perl: Searching for name %s in zone %s", name, zone); rrcount = call_method("lookup", G_ARRAY|G_EVAL); carp("DLZ Perl: Call to lookup returned %i", rrcount); SPAGAIN; if (SvTRUE(ERRSV)) { POPs; cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup died in eval: %s", SvPV_nolen(ERRSV)); retval = ISC_R_FAILURE; goto CLEAN_UP_AND_RETURN; } if (!rrcount) { retval = ISC_R_NOTFOUND; goto CLEAN_UP_AND_RETURN; } retval = ISC_R_SUCCESS; r = 0; while (r++ < rrcount) { record_ref = POPs; if ((!SvROK(record_ref)) || (SvTYPE(SvRV(record_ref)) != SVt_PVAV)) { cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup returned an " "invalid value (expected array of arrayrefs)!"); retval = ISC_R_FAILURE; break; } record_ref = SvRV(record_ref); rr_type = av_fetch((AV *) record_ref, 0, 0); rr_ttl = av_fetch((AV *) record_ref, 1, 0); rr_data = av_fetch((AV *) record_ref, 2, 0); if (rr_type == NULL || rr_ttl == NULL || rr_data == NULL) { cd->log(ISC_LOG_ERROR, "DLZ Perl: lookup for record %s in " "zone %s returned an array that was " "missing data", name, zone); retval = ISC_R_FAILURE; break; } carp("DLZ Perl: Got record %s = %s", SvPV_nolen(*rr_type), SvPV_nolen(*rr_data)); retval = cd->putrr(lookup, SvPV_nolen(*rr_type), SvIV(*rr_ttl), SvPV_nolen(*rr_data)); if (retval != ISC_R_SUCCESS) { cd->log(ISC_LOG_ERROR, "DLZ Perl: putrr for lookup of %s in " "zone %s failed with code %i " "(did lookup return invalid record data?)", name, zone, retval); break; } } CLEAN_UP_AND_RETURN: PUTBACK; FREETMPS; LEAVE; carp("DLZ Perl: Returning from lookup, r = %i, retval = %i", r, retval); return (retval); }
static SV * plperl_call_perl_func(plperl_proc_desc *desc, FunctionCallInfo fcinfo) { dSP; SV *retval; int i; int count; SV *sv; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(&PL_sv_undef); /* no trigger data */ for (i = 0; i < desc->nargs; i++) { if (fcinfo->argnull[i]) XPUSHs(&PL_sv_undef); else if (desc->arg_is_rowtype[i]) { HeapTupleHeader td; Oid tupType; int32 tupTypmod; TupleDesc tupdesc; HeapTupleData tmptup; SV *hashref; td = DatumGetHeapTupleHeader(fcinfo->arg[i]); /* Extract rowtype info and find a tupdesc */ tupType = HeapTupleHeaderGetTypeId(td); tupTypmod = HeapTupleHeaderGetTypMod(td); tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod); /* Build a temporary HeapTuple control structure */ tmptup.t_len = HeapTupleHeaderGetDatumLength(td); tmptup.t_data = td; hashref = plperl_hash_from_tuple(&tmptup, tupdesc); XPUSHs(sv_2mortal(hashref)); } else { char *tmp; tmp = DatumGetCString(FunctionCall1(&(desc->arg_out_func[i]), fcinfo->arg[i])); sv = newSVpv(tmp, 0); #if PERL_BCDVERSION >= 0x5006000L if (GetDatabaseEncoding() == PG_UTF8) SvUTF8_on(sv); #endif XPUSHs(sv_2mortal(sv)); pfree(tmp); } } PUTBACK; /* Do NOT use G_KEEPERR here */ count = perl_call_sv(desc->reference, G_SCALAR | G_EVAL); SPAGAIN; if (count != 1) { PUTBACK; FREETMPS; LEAVE; elog(ERROR, "didn't get a return item from function"); } if (SvTRUE(ERRSV)) { (void) POPs; PUTBACK; FREETMPS; LEAVE; /* XXX need to find a way to assign an errcode here */ ereport(ERROR, (errmsg("error from Perl function: %s", strip_trailing_ws(SvPV(ERRSV, PL_na))))); } retval = newSVsv(POPs); PUTBACK; FREETMPS; LEAVE; return retval; }
void _mpack_item(SV *res, SV *o) { size_t len, res_len, new_len; char *s, *res_s; res_s = SvPVbyte(res, res_len); unsigned i; if (!SvOK(o)) { new_len = res_len + mp_sizeof_nil(); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_nil(res_s + res_len); return; } if (SvROK(o)) { o = SvRV(o); if (SvOBJECT(o)) { SvGETMAGIC(o); HV *stash = SvSTASH(o); GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0); if (!mtd) croak("Object has no method 'msgpack'"); dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash)); PUTBACK; call_sv((SV *)GvCV(mtd), G_SCALAR); SPAGAIN; SV *pkt = POPs; if (!SvOK(pkt)) croak("O->msgpack returned undef"); s = SvPV(pkt, len); new_len = res_len + len; res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); memcpy(res_s + res_len, s, len); PUTBACK; FREETMPS; LEAVE; return; } switch(SvTYPE(o)) { case SVt_PVAV: { AV *a = (AV *)o; len = av_len(a) + 1; new_len = res_len + mp_sizeof_array(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_array(res_s + res_len, len); for (i = 0; i < len; i++) { SV **item = av_fetch(a, i, 0); if (!item) _mpack_item(res, 0); else _mpack_item(res, *item); } break; } case SVt_PVHV: { HV *h = (HV *)o; len = hv_iterinit(h); new_len = res_len + mp_sizeof_map(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_map(res_s + res_len, len); for (;;) { HE * iter = hv_iternext(h); if (!iter) break; SV *k = hv_iterkeysv(iter); SV *v = HeVAL(iter); _mpack_item(res, k); _mpack_item(res, v); } break; } default: croak("Can't serialize reference"); } return; } switch(SvTYPE(o)) { case SVt_PV: case SVt_PVIV: case SVt_PVNV: case SVt_PVMG: case SVt_REGEXP: if (!looks_like_number(o)) { s = SvPV(o, len); new_len = res_len + mp_sizeof_str(len); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_str(res_s + res_len, s, len); break; } case SVt_NV: { NV v = SvNV(o); IV iv = (IV)v; if (v != iv) { new_len = res_len + mp_sizeof_double(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_double(res_s + res_len, v); break; } } case SVt_IV: { IV v = SvIV(o); if (v >= 0) { new_len = res_len + mp_sizeof_uint(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_uint(res_s + res_len, v); } else { new_len = res_len + mp_sizeof_int(v); res_s = SvGROW(res, new_len); SvCUR_set(res, new_len); mp_encode_int(res_s + res_len, v); } break; } default: croak("Internal msgpack error %d", SvTYPE(o)); } }
/********************************************************** * * Bind * **********************************************************/ int perl_back_bind( Operation *op, SlapReply *rs ) { int count; PerlBackend *perl_back = (PerlBackend *) op->o_bd->be_private; /* allow rootdn as a means to auth without the need to actually * contact the proxied DSA */ switch ( be_rootdn_bind( op, rs ) ) { case SLAP_CB_CONTINUE: break; default: return rs->sr_err; } #if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS) PERL_SET_CONTEXT( PERL_INTERPRETER ); #endif ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex ); { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs( perl_back->pb_obj_ref ); XPUSHs(sv_2mortal(newSVpv( op->o_req_dn.bv_val , 0))); XPUSHs(sv_2mortal(newSVpv( op->orb_cred.bv_val , op->orb_cred.bv_len))); PUTBACK; #ifdef PERL_IS_5_6 count = call_method("bind", G_SCALAR); #else count = perl_call_method("bind", G_SCALAR); #endif SPAGAIN; if (count != 1) { croak("Big trouble in back_bind\n"); } rs->sr_err = POPi; PUTBACK; FREETMPS; LEAVE; } ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex ); Debug( LDAP_DEBUG_ANY, "Perl BIND returned 0x%04x\n", rs->sr_err, 0, 0 ); /* frontend will send result on success (0) */ if( rs->sr_err != LDAP_SUCCESS ) send_ldap_result( op, rs ); return ( rs->sr_err ); }
isc_result_t dlz_allnodes(const char *zone, void *dbdata, dns_sdlzallnodes_t *allnodes) { config_data_t *cd = (config_data_t *) dbdata; isc_result_t retval; int rrcount, r; SV *record_ref; SV **rr_name; SV **rr_type; SV **rr_ttl; SV **rr_data; #ifdef MULTIPLICITY PerlInterpreter *my_perl = cd->perl; #endif dSP; PERL_SET_CONTEXT(cd->perl); ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(cd->perl_class); XPUSHs(sv_2mortal(newSVpv(zone, 0))); PUTBACK; carp("DLZ Perl: Calling allnodes for zone %s", zone); rrcount = call_method("allnodes", G_ARRAY|G_EVAL); carp("DLZ Perl: Call to allnodes returned rrcount of %i", rrcount); SPAGAIN; if (SvTRUE(ERRSV)) { POPs; cd->log(ISC_LOG_ERROR, "DLZ Perl: allnodes for zone %s died in eval: %s", zone, SvPV_nolen(ERRSV)); retval = ISC_R_FAILURE; goto CLEAN_UP_AND_RETURN; } if (!rrcount) { retval = ISC_R_NOTFOUND; goto CLEAN_UP_AND_RETURN; } retval = ISC_R_SUCCESS; r = 0; while (r++ < rrcount) { record_ref = POPs; if ( (!SvROK(record_ref)) || (SvTYPE(SvRV(record_ref)) != SVt_PVAV) ) { cd->log(ISC_LOG_ERROR, "DLZ Perl: allnodes for zone %s " "returned an invalid value " "(expected array of arrayrefs)", zone); retval = ISC_R_FAILURE; break; } record_ref = SvRV(record_ref); rr_name = av_fetch((AV *) record_ref, 0, 0); rr_type = av_fetch((AV *) record_ref, 1, 0); rr_ttl = av_fetch((AV *) record_ref, 2, 0); rr_data = av_fetch((AV *) record_ref, 3, 0); if (rr_name == NULL || rr_type == NULL || rr_ttl == NULL || rr_data == NULL) { cd->log(ISC_LOG_ERROR, "DLZ Perl: allnodes for zone %s " "returned an array that was missing data", zone); retval = ISC_R_FAILURE; break; } carp("DLZ Perl: Got record %s/%s = %s", SvPV_nolen(*rr_name), SvPV_nolen(*rr_type), SvPV_nolen(*rr_data)); retval = cd->putnamedrr(allnodes, SvPV_nolen(*rr_name), SvPV_nolen(*rr_type), SvIV(*rr_ttl), SvPV_nolen(*rr_data)); if (retval != ISC_R_SUCCESS) { cd->log(ISC_LOG_ERROR, "DLZ Perl: putnamedrr in allnodes " "for zone %s failed with code %i " "(did lookup return invalid record data?)", zone, retval); break; } } CLEAN_UP_AND_RETURN: PUTBACK; FREETMPS; LEAVE; carp("DLZ Perl: Returning from allnodes, r = %i, retval = %i", r, retval); return (retval); }