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