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;
}
}
}
}
static void
S_set_token_re_but_not_pattern(lucy_RegexTokenizer *self, void *token_re) {
#if (PERL_VERSION > 10)
REGEXP *rx = SvRX((SV*)token_re);
#else
MAGIC *magic = NULL;
if (SvMAGICAL((SV*)token_re)) {
magic = mg_find((SV*)token_re, PERL_MAGIC_qr);
}
if (!magic) {
THROW(LUCY_ERR, "token_re is not a qr// entity");
}
REGEXP *rx = (REGEXP*)magic->mg_obj;
#endif
if (rx == NULL) {
THROW(LUCY_ERR, "Failed to extract REGEXP from token_re '%s'",
SvPV_nolen((SV*)token_re));
}
if (self->token_re) {
ReREFCNT_dec(((REGEXP*)self->token_re));
}
self->token_re = rx;
(void)ReREFCNT_inc(((REGEXP*)self->token_re));
}
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;
}
}
}
}
/*
* 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));
}
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;
}
/* transfer and may_be_null can be gotten from arg_info, but sv_to_arg is also
* called from places which don't have access to a GIArgInfo. */
static void
sv_to_arg (SV * sv,
GIArgument * arg,
GIArgInfo * arg_info,
GITypeInfo * type_info,
GITransfer transfer,
gboolean may_be_null,
GPerlI11nInvocationInfo * invocation_info)
{
GITypeTag tag = g_type_info_get_tag (type_info);
if (!gperl_sv_is_defined (sv))
/* Interfaces and void types need to be able to handle undef
* separately. */
if (!may_be_null && tag != GI_TYPE_TAG_INTERFACE
&& tag != GI_TYPE_TAG_VOID) {
if (arg_info) {
ccroak ("undefined value for mandatory argument '%s' encountered",
g_base_info_get_name ((GIBaseInfo *) arg_info));
} else {
ccroak ("undefined value encountered");
}
}
switch (tag) {
case GI_TYPE_TAG_VOID:
/* returns NULL if no match is found */
arg->v_pointer = sv_to_callback_data (sv, invocation_info);
break;
case GI_TYPE_TAG_BOOLEAN:
arg->v_boolean = SvTRUE (sv);
break;
case GI_TYPE_TAG_INT8:
arg->v_int8 = (gint8) SvIV (sv);
break;
case GI_TYPE_TAG_UINT8:
arg->v_uint8 = (guint8) SvUV (sv);
break;
case GI_TYPE_TAG_INT16:
arg->v_int16 = (gint16) SvIV (sv);
break;
case GI_TYPE_TAG_UINT16:
arg->v_uint16 = (guint16) SvUV (sv);
break;
case GI_TYPE_TAG_INT32:
arg->v_int32 = (gint32) SvIV (sv);
break;
case GI_TYPE_TAG_UINT32:
arg->v_uint32 = (guint32) SvUV (sv);
break;
case GI_TYPE_TAG_INT64:
arg->v_int64 = SvGInt64 (sv);
break;
case GI_TYPE_TAG_UINT64:
arg->v_uint64 = SvGUInt64 (sv);
break;
case GI_TYPE_TAG_FLOAT:
arg->v_float = (gfloat) SvNV (sv);
break;
case GI_TYPE_TAG_DOUBLE:
arg->v_double = SvNV (sv);
break;
case GI_TYPE_TAG_UNICHAR:
arg->v_uint32 = g_utf8_get_char (SvGChar (sv));
break;
case GI_TYPE_TAG_GTYPE:
/* GType == gsize */
arg->v_size = gperl_type_from_package (SvPV_nolen (sv));
if (!arg->v_size)
arg->v_size = g_type_from_name (SvPV_nolen (sv));
break;
case GI_TYPE_TAG_ARRAY:
arg->v_pointer = sv_to_array (transfer, type_info, sv, invocation_info);
break;
case GI_TYPE_TAG_INTERFACE:
dwarn (" type %p -> interface\n", type_info);
sv_to_interface (arg_info, type_info, transfer, may_be_null,
sv, arg, invocation_info);
break;
case GI_TYPE_TAG_GLIST:
case GI_TYPE_TAG_GSLIST:
arg->v_pointer = sv_to_glist (transfer, type_info, sv);
break;
case GI_TYPE_TAG_GHASH:
arg->v_pointer = sv_to_ghash (transfer, type_info, sv);
break;
case GI_TYPE_TAG_ERROR:
ccroak ("FIXME - A GError as an in/inout arg? Should never happen!");
break;
case GI_TYPE_TAG_UTF8:
arg->v_string = gperl_sv_is_defined (sv) ? SvGChar (sv) : NULL;
if (transfer >= GI_TRANSFER_CONTAINER)
arg->v_string = g_strdup (arg->v_string);
break;
case GI_TYPE_TAG_FILENAME:
/* FIXME: Should we use SvPVbyte_nolen here? */
arg->v_string = gperl_sv_is_defined (sv) ? SvPV_nolen (sv) : NULL;
if (transfer >= GI_TRANSFER_CONTAINER)
arg->v_string = g_strdup (arg->v_string);
break;
default:
ccroak ("Unhandled info tag %d in sv_to_arg", tag);
}
}
GV*
Perl_gv_autoload4(pTHX_ HV *stash, const char *name, STRLEN len, I32 method)
{
char autoload[] = "AUTOLOAD";
STRLEN autolen = sizeof(autoload)-1;
GV* gv;
CV* cv;
HV* varstash;
GV* vargv;
SV* varsv;
char *packname = "";
if (len == autolen && strnEQ(name, autoload, autolen))
return Nullgv;
if (stash) {
if (SvTYPE(stash) < SVt_PVHV) {
packname = SvPV_nolen((SV*)stash);
stash = Nullhv;
}
else {
packname = HvNAME(stash);
}
}
if (!(gv = gv_fetchmeth(stash, autoload, autolen, FALSE)))
return Nullgv;
cv = GvCV(gv);
if (!(CvROOT(cv) || CvXSUB(cv)))
return Nullgv;
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX) && !method &&
(GvCVGEN(gv) || GvSTASH(gv) != stash))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
packname, (int)len, name);
if (CvXSUB(cv)) {
/* rather than lookup/init $AUTOLOAD here
* only to have the XSUB do another lookup for $AUTOLOAD
* and split that value on the last '::',
* pass along the same data via some unused fields in the CV
*/
CvSTASH(cv) = stash;
SvPVX(cv) = (char *)name; /* cast to lose constness warning */
SvCUR(cv) = len;
return gv;
}
/*
* Given &FOO::AUTOLOAD, set $FOO::AUTOLOAD to desired function name.
* The subroutine's original name may not be "AUTOLOAD", so we don't
* use that, but for lack of anything better we will use the sub's
* original package to look up $AUTOLOAD.
*/
varstash = GvSTASH(CvGV(cv));
vargv = *(GV**)hv_fetch(varstash, autoload, autolen, TRUE);
ENTER;
if (!isGV(vargv))
gv_init(vargv, varstash, autoload, autolen, FALSE);
LEAVE;
varsv = GvSV(vargv);
sv_setpv(varsv, packname);
sv_catpvn(varsv, "::", 2);
sv_catpvn(varsv, name, len);
SvTAINTED_off(varsv);
return gv;
}
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);
}
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);
}
char *swiftperl_hv_iterkey(void *vp) {
SV *ksv = hv_iterkeysv((HE *)vp);
return SvPV_nolen(ksv);
}
ngx_int_t
ngx_http_psgi_process_headers(pTHX_ ngx_http_request_t *r, SV *headers, SV *status)
{
ngx_log_debug0(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"Process PSGI headers");
if (r->headers_out.status == 0) {
r->headers_out.status = SvIV(status);
}
if (!SvROK(headers) || SvTYPE(SvRV(headers)) != SVt_PVAV) {
ngx_log_error(NGX_LOG_ERR, r->connection->log, 0,
"PSGI app returned wrong headers: %s", SvPV_nolen(headers));
return NGX_ERROR;
}
AV *h = (AV *)SvRV(headers);
int len = av_len(h);
int i;
if (!(len % 2)) {
ngx_log_error(NGX_LOG_ERR, r->connection->log, 0,
"Even number of header-value elements: %i. Possible error.", len);
}
for (i = 0; i <= len; i+=2) {
if (i + 1 > len)
break;
SV **header = av_fetch(h, i, 0);
u_char *key, *value;
STRLEN klen, vlen;
key = (u_char *) SvPV(header[0], klen);
value = (u_char *) SvPV(header[1], vlen);
if (ngx_strncasecmp(key, (u_char *)"CONTENT-TYPE", klen) == 0) {
r->headers_out.content_type.data = ngx_pnalloc(r->pool, vlen);
if (r->headers_out.content_type.data == NULL) {
ngx_log_error(NGX_LOG_ERR, r->connection->log, 0,
"In PSGI response: header 'Content-Type' not defined");
return NGX_ERROR;
}
r->headers_out.content_type.len = vlen;
ngx_memcpy(r->headers_out.content_type.data, value, vlen);
} else {
ngx_table_elt_t *header_ent;
header_ent = ngx_list_push(&r->headers_out.headers);
header_ent->hash = 1;
if (header_ent == NULL) {
return NGX_ERROR;
}
if (ngx_sv2str(r, &header_ent->key, key, klen) != NGX_OK) {
return NGX_ERROR;
}
if (ngx_sv2str(r, &header_ent->value, value, vlen) != NGX_OK) {
return NGX_ERROR;
}
}
}
ngx_http_send_header(r);
return NGX_OK;
}
ngx_int_t
ngx_http_psgi_process_array_response(pTHX_ ngx_http_request_t *r, SV *response)
{
// Response should be reference to ARRAY
if (SvTYPE(response) != SVt_PVAV) {
ngx_log_error(NGX_LOG_ERR, r->connection->log, 0,
"PSGI app returned wrong value: %s", SvPV_nolen(response));
return NGX_HTTP_INTERNAL_SERVER_ERROR;
}
/* Create chained response from ARRAY:
* convert each array element to buffer
* and pass to filter
*/
AV *psgir = (AV*)response;
// Array should contain at least 3 elements
if (av_len(psgir) < 2) {
ngx_http_psgi_ctx_t *ctx = ngx_http_get_module_ctx(r, ngx_http_psgi_module);
if (!ctx->callback) {
ngx_log_error(
NGX_LOG_ERR, r->connection->log,
0,
"PSGI app is expected to return array of 3 elements. Returned %d",
av_len(psgir)
);
return NGX_HTTP_INTERNAL_SERVER_ERROR;
} else if (av_len(psgir) < 1) {
ngx_log_error(
NGX_LOG_ERR, r->connection->log,
0,
"PSGI app returned an array of %d elements. Expected 2 or 3",
av_len(psgir)
);
return NGX_HTTP_INTERNAL_SERVER_ERROR;
}
}
// Process HTTP status code
SV **http_status = av_fetch(psgir, 0, 0);
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"PSGI app returned status code: %d", SvIV(http_status[0]));
// Process headers
SV **headers = av_fetch(psgir, 1, 0);
if (ngx_http_psgi_process_headers(aTHX_ r, *headers, *http_status) != NGX_OK) {
ngx_log_error(NGX_LOG_ERR, r->connection->log, 0,
"Failed to process PSGI response headers");
return NGX_HTTP_INTERNAL_SERVER_ERROR;
}
// Process body
SV **body = av_fetch(psgir, 2, 0);
return ngx_http_psgi_process_body(aTHX_ r, *body);
}
ngx_int_t
ngx_http_psgi_process_body_glob(pTHX_ ngx_http_request_t *r, SV *body)
{
ngx_log_debug1(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"PSGI app returned handle '%s'", SvPV_nolen((SV*)body));
ngx_chain_t *first_chain = NULL;
ngx_chain_t *last_chain = NULL;
int result = NGX_OK;
bool data = 1;
/* TODO: Call $body->close when done
* TODO: Support sendfile option
* FIXME: This sucks. Push handle to stack and loop readline, save time
* FIXME: This sucks. Do async event-based writing
* FIXME: This sucks. Readline can return lines 1-10 bytes long. Buffer data instead of chaining each line
*/
// TODO: bufsize should be defined in context and then reused
SV * ngx_sv_bufsize = newSViv(8192);
SV * ngx_PL_rs = sv_2mortal(newRV_noinc(ngx_sv_bufsize));
// TODO: find out what is the right way to do local $/ = \123
SV *old_rs = PL_rs;
sv_setsv(PL_rs, ngx_PL_rs); // $/ = \8192
sv_setsv(get_sv("/", GV_ADD), PL_rs);
while (data && result < NGX_HTTP_SPECIAL_RESPONSE) {
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(body);
PUTBACK;
call_method("getline", G_SCALAR|G_EVAL);
SPAGAIN;
SV *buffer = POPs;
if (SvTRUE(ERRSV))
{
ngx_log_error(NGX_LOG_ERR, r->connection->log, 0,
"Error reading from a handle: '%s'", SvPV_nolen(ERRSV));
result = NGX_HTTP_INTERNAL_SERVER_ERROR;
} else if (!SvOK(buffer)) {
data = 0;
} else {
u_char *p;
STRLEN len;
p = (u_char*)SvPV(buffer, len);
if (len) { // Skip zero-length but defined chunks
if (chain_buffer(r, p, len, &first_chain, &last_chain) != NGX_OK) {
ngx_log_error(NGX_LOG_DEBUG_HTTP, r->connection->log, 0,
"Error chaining psgi response buffer");
result = NGX_HTTP_INTERNAL_SERVER_ERROR;
}
} else {
ngx_http_output_filter(r, first_chain);
first_chain = last_chain = NULL;
}
}
PUTBACK;
FREETMPS;
LEAVE;
}
PL_rs = old_rs;
sv_setsv(get_sv("/", GV_ADD), old_rs);
if (first_chain != NULL) {
ngx_http_output_filter(r, first_chain);
return result;
}
return result < NGX_HTTP_SPECIAL_RESPONSE ? NGX_DONE : result;
}
void SState::Load()
{
std::string sFilename = GetConfigFilename();
g_oBackend.PerlEvalF( "ParseConfig('%s');", sFilename.c_str() );
SV* poSv;
// poSv = get_sv("", FALSE); if (poSv) m_ = SvIV( poSv );
poSv = get_sv("NUMPLAYERS", FALSE);
if (poSv) m_iNumPlayers = SvIV( poSv );
poSv = get_sv("TEAMMODE", FALSE);
if (poSv) m_enTeamMode = (TTeamModeEnum) SvIV( poSv );
poSv = get_sv("TEAMSIZE", FALSE);
if (poSv) m_iTeamSize = SvIV( poSv );
poSv = get_sv("TEAMMULTISELECT", FALSE);
if (poSv) m_bTeamMultiselect = SvIV( poSv );
poSv = get_sv("ROUNDLENGTH", FALSE);
if (poSv) m_iRoundLength = SvIV( poSv );
poSv = get_sv("HITPOINTS", FALSE);
if (poSv) m_iHitPoints = SvIV( poSv );
poSv = get_sv("GAMESPEED", FALSE);
if (poSv) m_iGameSpeed = SvIV( poSv );
poSv = get_sv("FULLSCREEN", FALSE);
if (poSv) m_bFullscreen = SvIV( poSv ) != 0;
poSv = get_sv("CHANNELS", FALSE);
if (poSv) m_iChannels = SvIV( poSv );
poSv = get_sv("MIXINGRATE", FALSE);
if (poSv) m_iMixingRate = SvIV( poSv );
poSv = get_sv("MIXINGBITS", FALSE);
if (poSv) m_iMixingBits = SvIV( poSv );
poSv = get_sv("MUSICVOLUME", FALSE);
if (poSv) m_iMusicVolume = SvIV( poSv );
poSv = get_sv("SOUNDVOLUME", FALSE);
if (poSv) m_iSoundVolume = SvIV( poSv );
poSv = get_sv("LANGUAGE", FALSE);
if (poSv) {
strncpy( m_acLanguage, SvPV_nolen( poSv ), 9 );
m_acLanguage[9] = 0;
}
poSv = get_sv("LATESTSERVER", FALSE);
if (poSv) {
strncpy( m_acLatestServer, SvPV_nolen( poSv ), 255 );
m_acLatestServer[255] = 0;
}
poSv = get_sv("SERVER", FALSE);
if (poSv) m_bServer = SvIV( poSv ) != 0;
poSv = get_sv("NICK", FALSE);
if (poSv) {
strncpy( m_acNick, SvPV_nolen( poSv ), 127 );
m_acNick[127] = 0;
}
char pcBuffer[1024];
for ( int i=0; i<MAXPLAYERS; ++i )
{
for ( int j=0; j<9; ++j )
{
sprintf( pcBuffer, "PLAYER%dKEY%d", i, j );
poSv = get_sv(pcBuffer, FALSE);
if (poSv) m_aiPlayerKeys[i][j] = SvIV( poSv );
}
}
}
static void bitfields_option(pTHX_ BitfieldLayouter *layouter, SV *sv_val, SV **rval)
{
BitfieldLayouter bl_new = NULL;
BitfieldLayouter bl = *layouter;
if(sv_val)
{
if (SvROK(sv_val))
{
sv_val = SvRV(sv_val);
if (SvTYPE(sv_val) == SVt_PVHV)
{
HV *hv = (HV *) sv_val;
HE *entry;
SV **engine = hv_fetch(hv, "Engine", 6, 0);
int noptions;
const BLOption *options;
if (engine && *engine)
{
const char *name = SvPV_nolen(*engine);
bl = bl_new = bl_create(name);
if (bl_new == NULL)
Perl_croak(aTHX_ "Unknown bitfield layout engine '%s'", name);
}
(void) hv_iterinit(hv);
options = bl->m->options(bl, &noptions);
while ((entry = hv_iternext(hv)) != NULL)
{
SV *value;
I32 keylen;
int i;
const char *prop_string = hv_iterkey(entry, &keylen);
BLProperty prop;
BLPropValue prop_value;
const BLOption *opt = NULL;
enum BLError error;
if (strEQ(prop_string, "Engine"))
continue;
prop = bl_property(prop_string);
for (i = 0; i < noptions; i++)
if (options[i].prop == prop)
{
opt = &options[i];
break;
}
if (opt == NULL)
FAIL_CLEAN((aTHX_ "Invalid option '%s' for bitfield layout engine '%s'",
prop_string, bl->m->class_name(bl)));
value = hv_iterval(hv, entry);
prop_value.type = opt->type;
switch (opt->type)
{
case BLPVT_INT:
prop_value.v.v_int = SvIV(value);
if (opt->nval)
{
const BLPropValInt *pval = opt->pval;
for (i = 0; i < opt->nval; i++)
if (pval[i] == prop_value.v.v_int)
break;
}
break;
case BLPVT_STR:
prop_value.v.v_str = bl_propval(SvPV_nolen(value));
if (opt->nval)
{
const BLPropValStr *pval = opt->pval;
for (i = 0; i < opt->nval; i++)
if (pval[i] == prop_value.v.v_str)
break;
}
break;
default:
fatal("unknown opt->type (%d) in bitfields_option()", opt->type);
break;
}
if (opt->nval && i == opt->nval)
FAIL_CLEAN((aTHX_ "Invalid value '%s' for option '%s'",
SvPV_nolen(value), prop_string));
error = bl->m->set(bl, prop, &prop_value);
switch (error)
{
case BLE_NO_ERROR:
break;
case BLE_INVALID_PROPERTY:
FAIL_CLEAN((aTHX_ "Invalid value '%s' for option '%s'",
SvPV_nolen(value), prop_string));
break;
default:
fatal("unknown error code (%d) returned by set method", error);
break;
}
}
if (bl_new)
{
(*layouter)->m->destroy(*layouter);
*layouter = bl_new;
}
}
else
Perl_croak(aTHX_ "Bitfields wants a hash reference");
}
else
Perl_croak(aTHX_ "Bitfields wants a hash reference");
}
if (rval)
{
int noptions;
const BLOption *opt;
int i;
HV *hv = newHV();
SV *sv = newSVpv(bl->m->class_name(bl), 0);
if (hv_store(hv, "Engine", 6, sv, 0) == NULL)
SvREFCNT_dec(sv);
opt = bl->m->options(bl, &noptions);
for (i = 0; i < noptions; i++, opt++)
{
BLPropValue value;
enum BLError error;
const char *prop_string;
error = bl->m->get(bl, opt->prop, &value);
if (error != BLE_NO_ERROR)
fatal("unexpected error (%d) returned by get method", error);
assert(value.type == opt->type);
switch (opt->type)
{
case BLPVT_INT:
sv = newSViv(value.v.v_int);
break;
case BLPVT_STR:
{
const char *valstr = bl_propval_string(value.v.v_str);
assert(valstr != NULL);
sv = newSVpv(valstr, 0);
}
break;
default:
fatal("unknown opt->type (%d) in bitfields_option()", opt->type);
break;
}
prop_string = bl_property_string(opt->prop);
assert(prop_string != NULL);
if (hv_store(hv, prop_string, strlen(prop_string), sv, 0) == NULL)
SvREFCNT_dec(sv);
}
*rval = newRV_noinc((SV *) hv);
}
}
int
weechat_perl_load (const char *filename)
{
struct t_plugin_script temp_script;
struct stat buf;
char *perl_code;
int length;
#ifndef MULTIPLICITY
char pkgname[64];
#endif /* MULTIPLICITY */
temp_script.filename = NULL;
temp_script.interpreter = NULL;
temp_script.name = NULL;
temp_script.author = NULL;
temp_script.version = NULL;
temp_script.license = NULL;
temp_script.description = NULL;
temp_script.shutdown_func = NULL;
temp_script.charset = NULL;
if (stat (filename, &buf) != 0)
{
weechat_printf (NULL,
weechat_gettext ("%s%s: script \"%s\" not found"),
weechat_prefix ("error"), PERL_PLUGIN_NAME, filename);
return 0;
}
if ((weechat_perl_plugin->debug >= 2) || !perl_quiet)
{
weechat_printf (NULL,
weechat_gettext ("%s: loading script \"%s\""),
PERL_PLUGIN_NAME, filename);
}
perl_current_script = NULL;
perl_current_script_filename = filename;
perl_registered_script = NULL;
#ifdef MULTIPLICITY
perl_current_interpreter = perl_alloc();
if (!perl_current_interpreter)
{
weechat_printf (NULL,
weechat_gettext ("%s%s: unable to create new "
"sub-interpreter"),
weechat_prefix ("error"), PERL_PLUGIN_NAME);
return 0;
}
PERL_SET_CONTEXT (perl_current_interpreter);
perl_construct (perl_current_interpreter);
temp_script.interpreter = (PerlInterpreter *) perl_current_interpreter;
perl_parse (perl_current_interpreter, weechat_perl_api_init,
perl_args_count, perl_args, NULL);
length = strlen (perl_weechat_code) - 2 + strlen (filename) + 1;
perl_code = malloc (length);
if (!perl_code)
return 0;
snprintf (perl_code, length, perl_weechat_code, filename);
#else
snprintf (pkgname, sizeof (pkgname), "%s%d", PKG_NAME_PREFIX, perl_num);
perl_num++;
length = strlen (perl_weechat_code) - 4 + strlen (pkgname) + strlen (filename) + 1;
perl_code = malloc (length);
if (!perl_code)
return 0;
snprintf (perl_code, length, perl_weechat_code, pkgname, filename);
#endif /* MULTIPLICITY */
eval_pv (perl_code, TRUE);
free (perl_code);
if (SvTRUE (ERRSV))
{
weechat_printf (NULL,
weechat_gettext ("%s%s: unable to parse file "
"\"%s\""),
weechat_prefix ("error"), PERL_PLUGIN_NAME,
filename);
weechat_printf (NULL,
weechat_gettext ("%s%s: error: %s"),
weechat_prefix ("error"), PERL_PLUGIN_NAME,
SvPV_nolen(ERRSV));
#ifdef MULTIPLICITY
perl_destruct (perl_current_interpreter);
perl_free (perl_current_interpreter);
#endif /* MULTIPLICITY */
if (perl_current_script && (perl_current_script != &temp_script))
{
plugin_script_remove (weechat_perl_plugin,
&perl_scripts, &last_perl_script,
perl_current_script);
perl_current_script = NULL;
}
return 0;
}
if (!perl_registered_script)
{
weechat_printf (NULL,
weechat_gettext ("%s%s: function \"register\" not "
"found (or failed) in file \"%s\""),
weechat_prefix ("error"), PERL_PLUGIN_NAME, filename);
#ifdef MULTIPLICITY
perl_destruct (perl_current_interpreter);
perl_free (perl_current_interpreter);
#endif /* MULTIPLICITY */
return 0;
}
perl_current_script = perl_registered_script;
#ifndef MULTIPLICITY
perl_current_script->interpreter = strdup (pkgname);
#endif /* MULTIPLICITY */
/*
* set input/close callbacks for buffers created by this script
* (to restore callbacks after upgrade)
*/
plugin_script_set_buffer_callbacks (weechat_perl_plugin,
perl_scripts,
perl_current_script,
&weechat_perl_api_buffer_input_data_cb,
&weechat_perl_api_buffer_close_cb);
(void) weechat_hook_signal_send ("perl_script_loaded",
WEECHAT_HOOK_SIGNAL_STRING,
perl_current_script->filename);
return 1;
}
static int
convert_valspec(plcb_OPTION *dst, SV *src)
{
switch (dst->type) {
case PLCB_ARG_T_PAD:
return 0;
case PLCB_ARG_T_INT:
case PLCB_ARG_T_BOOL: {
int assigned_val = 0;
if (SvTYPE(src) == SVt_NULL) {
assigned_val = 0;
} else {
assigned_val = SvIV(src);
}
*((int*)(dst->value)) = assigned_val;
break;
}
#define EXPECT_RV(subtype, friendly_name) \
if (SvROK(src) == 0 || SvTYPE(SvRV(src)) != subtype) { \
die("Expected %s for %s", friendly_name, dst->key); \
} \
*(void**)dst->value = src;
case PLCB_ARG_T_SV:
*(SV**)dst->value = src;
break;
case PLCB_ARG_T_HV:
EXPECT_RV(SVt_PVHV, "Hash");
break;
case PLCB_ARG_T_AV:
EXPECT_RV(SVt_PVAV, "Array");
break;
case PLCB_ARG_T_CV:
EXPECT_RV(SVt_PVCV, "CODE");
break;
#undef EXPECT_RV
case PLCB_ARG_T_RV:
if (!SvROK(src)) {
die("Expected reference for %s", dst->key);
}
*(SV**)dst->value = src;
break;
case PLCB_ARG_T_CAS: {
if (SvTYPE(src) == SVt_NULL) {
break;
}
*(uint64_t*)dst->value = plcb_sv2cas(src);
break;
}
case PLCB_ARG_T_EXP:
case PLCB_ARG_T_EXPTT: {
UV exp_uv = plcb_exp_from_sv(src);
if (dst->type == PLCB_ARG_T_EXP) {
*((UV*)dst->value) = exp_uv;
} else {
*(time_t*)dst->value = exp_uv;
}
break;
}
case PLCB_ARG_T_I64:
*(int64_t*)dst->value = plcb_sv_to_64(src);
break;
case PLCB_ARG_T_U64:
*(uint64_t*)dst->value = plcb_sv_to_u64(src);
break;
case PLCB_ARG_T_U32:
*(uint32_t*)dst->value = SvUV(src);
break;
case PLCB_ARG_T_STRING:
case PLCB_ARG_T_STRING_NN: {
PLCB_XS_STRING_t *str = dst->value;
str->origsv = src;
str->base = SvPV(src, str->len);
if (str->len == 0 && dst->type == PLCB_ARG_T_STRING_NN) {
die("Value cannot be an empty string for %s", dst->key);
}
break;
}
case PLCB_ARG_T_CSTRING:
case PLCB_ARG_T_CSTRING_NN: {
*(const char **)dst->value = SvPV_nolen(src);
if (dst->type == PLCB_ARG_T_CSTRING_NN) {
if (dst->value == NULL|| *(const char*)dst->value == '\0') {
die("Value passed must not be empty for %s", dst->key);
}
}
break;
}
default:
return -1;
break;
}
return 0;
}
char *swiftperl_svpv(void *vp) {
return SvPV_nolen((SV *)vp);
}
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 int
print_cb (char *word[], void *userdata)
{
HookData *data = (HookData *) userdata;
SV *temp = NULL;
int retVal = 0;
int count = 1;
int last_index = 31;
/* must be initialized after SAVETMPS */
AV *wd = NULL;
dSP;
ENTER;
SAVETMPS;
if (data->depth)
return XCHAT_EAT_NONE;
wd = newAV ();
sv_2mortal ((SV *) wd);
/* need to scan backwards to find the index of the last element since some
events such as "DCC Timeout" can have NULL elements in between non NULL
elements */
while (last_index >= 0
&& (word[last_index] == NULL || word[last_index][0] == 0)) {
last_index--;
}
for (count = 1; count <= last_index; count++) {
if (word[count] == NULL) {
av_push (wd, &PL_sv_undef);
} else if (word[count][0] == 0) {
av_push (wd, newSVpvn ("",0));
} else {
temp = newSVpv (word[count], 0);
SvUTF8_on (temp);
av_push (wd, temp);
}
}
/*xchat_printf (ph, "Recieved %d words in print callback", av_len (wd)+1); */
PUSHMARK (SP);
XPUSHs (newRV_noinc ((SV *) wd));
XPUSHs (data->userdata);
PUTBACK;
data->depth++;
count = call_sv (data->callback, G_EVAL);
data->depth--;
SPAGAIN;
if (SvTRUE (ERRSV)) {
xchat_printf (ph, "Error in print callback %s", SvPV_nolen (ERRSV));
if (!SvOK (POPs)) {} /* remove undef from the top of the stack */
retVal = XCHAT_EAT_NONE;
} else {
if (count != 1) {
xchat_print (ph, "Print handler should only return 1 value.");
retVal = XCHAT_EAT_NONE;
} else {
retVal = POPi;
}
}
PUTBACK;
FREETMPS;
LEAVE;
return retVal;
}
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);
}
static
XS (XS_Xchat_emit_print)
{
char *event_name;
int RETVAL;
int count;
dXSARGS;
if (items < 1) {
xchat_print (ph, "Usage: Xchat::emit_print(event_name, ...)");
} else {
event_name = (char *) SvPV_nolen (ST (0));
RETVAL = 0;
/* we need to figure out the number of defined values passed in */
for (count = 0; count < items; count++) {
if (!SvOK (ST (count))) {
break;
}
}
switch (count) {
case 1:
RETVAL = xchat_emit_print (ph, event_name, NULL);
break;
case 2:
RETVAL = xchat_emit_print (ph, event_name,
SvPV_nolen (ST (1)), NULL);
break;
case 3:
RETVAL = xchat_emit_print (ph, event_name,
SvPV_nolen (ST (1)),
SvPV_nolen (ST (2)), NULL);
break;
case 4:
RETVAL = xchat_emit_print (ph, event_name,
SvPV_nolen (ST (1)),
SvPV_nolen (ST (2)),
SvPV_nolen (ST (3)), NULL);
break;
case 5:
RETVAL = xchat_emit_print (ph, event_name,
SvPV_nolen (ST (1)),
SvPV_nolen (ST (2)),
SvPV_nolen (ST (3)),
SvPV_nolen (ST (4)), NULL);
break;
}
XSRETURN_IV (RETVAL);
}
}
Package::Package(interpreter* _interp, SV* _name) : interp(_interp), package_name(SvPV_nolen(_name)), stash(gv_stashsv(_name, GV_ADD)) {
}
int init_psgi_app(struct wsgi_request *wsgi_req, char *app, uint16_t app_len, PerlInterpreter **interpreters) {
struct stat st;
int i;
SV **callables;
time_t now = uwsgi_now();
char *app_name = uwsgi_concat2n(app, app_len, "", 0);
// prepare for $0
uperl.embedding[1] = app_name;
int fd = open(app_name, O_RDONLY);
if (fd < 0) {
uwsgi_error_open(app_name);
goto clear2;
}
if (fstat(fd, &st)) {
uwsgi_error("fstat()");
close(fd);
goto clear2;
}
char *buf = uwsgi_calloc(st.st_size+1);
if (read(fd, buf, st.st_size) != st.st_size) {
uwsgi_error("read()");
close(fd);
free(buf);
goto clear2;
}
close(fd);
// the first (default) app, should always be loaded in the main interpreter
if (interpreters == NULL) {
if (uwsgi_apps_cnt) {
interpreters = uwsgi_calloc(sizeof(PerlInterpreter *) * uwsgi.threads);
interpreters[0] = uwsgi_perl_new_interpreter();
if (!interpreters[0]) {
uwsgi_log("unable to create new perl interpreter\n");
free(interpreters);
goto clear2;
}
}
else {
interpreters = uperl.main;
}
}
if (!interpreters) {
goto clear2;
}
callables = uwsgi_calloc(sizeof(SV *) * uwsgi.threads);
uperl.tmp_streaming_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads);
uperl.tmp_input_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads);
uperl.tmp_error_stash = uwsgi_calloc(sizeof(HV *) * uwsgi.threads);
uperl.tmp_stream_responder = uwsgi_calloc(sizeof(CV *) * uwsgi.threads);
uperl.tmp_psgix_logger = uwsgi_calloc(sizeof(CV *) * uwsgi.threads);
for(i=0;i<uwsgi.threads;i++) {
if (i > 0 && interpreters != uperl.main) {
interpreters[i] = uwsgi_perl_new_interpreter();
if (!interpreters[i]) {
uwsgi_log("unable to create new perl interpreter\n");
// what to do here ? i hope no-one will use threads with dynamic apps...but clear the whole stuff...
free(callables);
uwsgi_perl_free_stashes();
while(i>=0) {
perl_destruct(interpreters[i]);
perl_free(interpreters[i]);
goto clear2;
}
}
}
PERL_SET_CONTEXT(interpreters[i]);
uperl.tmp_current_i = i;
if (uperl.locallib) {
uwsgi_log("using %s as local::lib directory\n", uperl.locallib);
uperl.embedding[1] = uwsgi_concat2("-Mlocal::lib=", uperl.locallib);
uperl.embedding[2] = app_name;
if (perl_parse(interpreters[i], xs_init, 3, uperl.embedding, NULL)) {
// what to do here ? i hope no-one will use threads with dynamic apps... but clear the whole stuff...
free(uperl.embedding[1]);
uperl.embedding[1] = app_name;
free(callables);
uwsgi_perl_free_stashes();
goto clear;
}
free(uperl.embedding[1]);
uperl.embedding[1] = app_name;
}
else {
if (perl_parse(interpreters[i], xs_init, 2, uperl.embedding, NULL)) {
// what to do here ? i hope no-one will use threads with dynamic apps... but clear the whole stuff...
free(callables);
uwsgi_perl_free_stashes();
goto clear;
}
}
perl_eval_pv("use IO::Handle;", 0);
perl_eval_pv("use IO::File;", 0);
perl_eval_pv("use Scalar::Util;", 0);
if (!uperl.no_die_catch) {
perl_eval_pv("use Devel::StackTrace;", 0);
if (!SvTRUE(ERRSV)) {
uperl.stacktrace_available = 1;
perl_eval_pv("$SIG{__DIE__} = \\&uwsgi::stacktrace;", 0);
}
}
SV *dollar_zero = get_sv("0", GV_ADD);
sv_setsv(dollar_zero, newSVpv(app, app_len));
callables[i] = perl_eval_pv(uwsgi_concat4("#line 1 ", app_name, "\n", buf), 0);
if (!callables[i]) {
uwsgi_log("unable to find PSGI function entry point.\n");
// what to do here ? i hope no-one will use threads with dynamic apps...
free(callables);
uwsgi_perl_free_stashes();
goto clear;
}
PERL_SET_CONTEXT(interpreters[0]);
}
free(buf);
if(SvTRUE(ERRSV)) {
uwsgi_log("%s\n", SvPV_nolen(ERRSV));
free(callables);
uwsgi_perl_free_stashes();
goto clear;
}
if (uwsgi_apps_cnt >= uwsgi.max_apps) {
uwsgi_log("ERROR: you cannot load more than %d apps in a worker\n", uwsgi.max_apps);
goto clear;
}
int id = uwsgi_apps_cnt;
struct uwsgi_app *wi = NULL;
if (wsgi_req) {
// we need a copy of app_id
wi = uwsgi_add_app(id, psgi_plugin.modifier1, uwsgi_concat2n(wsgi_req->appid, wsgi_req->appid_len, "", 0), wsgi_req->appid_len, interpreters, callables);
}
else {
wi = uwsgi_add_app(id, psgi_plugin.modifier1, "", 0, interpreters, callables);
}
wi->started_at = now;
wi->startup_time = uwsgi_now() - now;
uwsgi_log("PSGI app %d (%s) loaded in %d seconds at %p (interpreter %p)\n", id, app_name, (int) wi->startup_time, callables[0], interpreters[0]);
free(app_name);
// copy global data to app-specific areas
wi->stream = uperl.tmp_streaming_stash;
wi->input = uperl.tmp_input_stash;
wi->error = uperl.tmp_error_stash;
wi->responder0 = uperl.tmp_stream_responder;
wi->responder1 = uperl.tmp_psgix_logger;
uwsgi_emulate_cow_for_apps(id);
// restore context if required
if (interpreters != uperl.main) {
PERL_SET_CONTEXT(uperl.main[0]);
}
return id;
clear:
if (interpreters != uperl.main) {
for(i=0;i<uwsgi.threads;i++) {
perl_destruct(interpreters[i]);
perl_free(interpreters[i]);
}
free(interpreters);
}
PERL_SET_CONTEXT(uperl.main[0]);
clear2:
free(app_name);
return -1;
}
static void* run_thread(void* arg) {
mthread* thread = (mthread*) arg;
PerlInterpreter* my_perl = construct_perl();
const message *to_run, *modules, *message;
SV *call, *status;
perl_mutex* shutdown_mutex;
thread->interp = my_perl;
#ifndef WIN32
S_set_sigmask(&thread->initial_sigmask);
#endif
PERL_SET_CONTEXT(my_perl);
store_self(my_perl, thread);
{
dSP;
modules = queue_dequeue(thread->queue, NULL);
load_modules(my_perl, modules);
to_run = queue_dequeue(thread->queue, NULL);
ENTER;
SAVETMPS;
call = SvRV(message_load_value(to_run));
PUSHMARK(SP);
mXPUSHs(newSVpvn("exit", 4));
status = newSVpvn("normal", 6);
mXPUSHs(status);
mXPUSHs(newSViv(thread->id));
ENTER;
PUSHMARK(SP);
PUTBACK;
call_sv(call, G_SCALAR|G_EVAL);
SPAGAIN;
if (SvTRUE(ERRSV)) {
sv_setpvn(status, "error", 5);
warn("Thread %"UVuf" got error %s\n", thread->id, SvPV_nolen(ERRSV));
PUSHs(ERRSV);
}
message_from_stack_pushed(message);
LEAVE;
send_listeners(thread, message);
destroy_message(message);
FREETMPS;
LEAVE;
}
shutdown_mutex = get_shutdown_mutex();
MUTEX_LOCK(shutdown_mutex);
perl_destruct(my_perl);
MUTEX_UNLOCK(shutdown_mutex);
mthread_destroy(thread);
PerlMemShared_free(thread);
perl_free(my_perl);
return NULL;
}
std::string sv_to_string(SV* sv) {
if (SvTYPE(sv) != SVt_PV)
Perl_croak(aTHX_ "Expected a perl string");
return std::string( SvPV_nolen(sv), SvCUR(sv) );
}
void perl_signal_args_to_c(
void (*callback)(void *, void **), void *cb_arg,
int signal_id, SV **args, size_t n_args)
{
union {
int v_int;
unsigned long v_ulong;
GSList *v_gslist;
GList *v_glist;
} saved_args[SIGNAL_MAX_ARGUMENTS];
void *p[SIGNAL_MAX_ARGUMENTS];
PERL_SIGNAL_ARGS_REC *rec;
size_t n;
if (!(rec = perl_signal_args_find(signal_id))) {
const char *name = signal_get_id_str(signal_id);
if (!name) {
croak("%d is not a known signal id", signal_id);
}
croak("\"%s\" is not a registered signal", name);
}
for (n = 0; n < SIGNAL_MAX_ARGUMENTS && n < n_args && rec->args[n] != NULL; ++n) {
void *c_arg;
SV *arg = args[n];
if (!SvOK(arg)) {
c_arg = NULL;
} else if (strcmp(rec->args[n], "string") == 0) {
c_arg = SvPV_nolen(arg);
} else if (strcmp(rec->args[n], "int") == 0) {
c_arg = (void *)SvIV(arg);
} else if (strcmp(rec->args[n], "ulongptr") == 0) {
saved_args[n].v_ulong = SvUV(arg);
c_arg = &saved_args[n].v_ulong;
} else if (strcmp(rec->args[n], "intptr") == 0) {
saved_args[n].v_int = SvIV(SvRV(arg));
c_arg = &saved_args[n].v_int;
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
GList *gl;
int is_str;
AV *av;
SV *t;
int count;
t = SvRV(arg);
if (SvTYPE(t) != SVt_PVAV) {
croak("Not an ARRAY reference");
}
av = (AV *)t;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
gl = NULL;
count = av_len(av) + 1;
while (count-- > 0) {
SV **px = av_fetch(av, count, 0);
SV *x = px ? *px : NULL;
gl = g_list_prepend(
gl,
x == NULL ? NULL :
is_str ? g_strdup(SvPV_nolen(x)) :
irssi_ref_object(x)
);
}
saved_args[n].v_glist = gl;
c_arg = &saved_args[n].v_glist;
} else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
GSList *gsl;
AV *av;
SV *t;
int count;
t = SvRV(arg);
if (SvTYPE(t) != SVt_PVAV) {
croak("Not an ARRAY reference");
}
av = (AV *)t;
gsl = NULL;
count = av_len(av) + 1;
while (count-- > 0) {
SV **x = av_fetch(av, count, 0);
gsl = g_slist_prepend(
gsl,
x == NULL ? NULL :
irssi_ref_object(*x)
);
}
c_arg = saved_args[n].v_gslist = gsl;
} else {
c_arg = irssi_ref_object(arg);
}
p[n] = c_arg;
}
for (; n < SIGNAL_MAX_ARGUMENTS; ++n) {
p[n] = NULL;
}
callback(cb_arg, p);
for (n = 0; n < SIGNAL_MAX_ARGUMENTS && n < n_args && rec->args[n] != NULL; ++n) {
SV *arg = args[n];
if (!SvOK(arg)) {
continue;
}
if (strcmp(rec->args[n], "intptr") == 0) {
SV *t = SvRV(arg);
SvIOK_only(t);
SvIV_set(t, saved_args[n].v_int);
} else if (strncmp(rec->args[n], "gslist_", 7) == 0) {
g_slist_free(saved_args[n].v_gslist);
} else if (strncmp(rec->args[n], "glistptr_", 9) == 0) {
int is_iobject, is_str;
AV *av;
GList *gl, *tmp;
is_iobject = strcmp(rec->args[n]+9, "iobject") == 0;
is_str = strcmp(rec->args[n]+9, "char*") == 0;
av = (AV *)SvRV(arg);
av_clear(av);
gl = saved_args[n].v_glist;
for (tmp = gl; tmp != NULL; tmp = tmp->next) {
av_push(av,
is_iobject ? iobject_bless((SERVER_REC *)tmp->data) :
is_str ? new_pv(tmp->data) :
irssi_bless_plain(rec->args[n]+9, tmp->data)
);
}
if (is_str) {
g_list_foreach(gl, (GFunc)g_free, NULL);
}
g_list_free(gl);
}
}
}
static int proxenet_perl_load_file(plugin_t* plugin)
{
char *pathname = NULL;
size_t pathlen = 0;
SV* sv = NULL;
int nb_res = -1;
SV* package_sv = NULL;
char *required = NULL;
char *package_name = NULL;
size_t package_len, len = 0;
int ret = -1;
pathlen = strlen(cfg->plugins_path) + 1 + strlen(plugin->filename) + 1;
pathname = (char*) alloca(pathlen+1);
proxenet_xzero(pathname, pathlen+1);
snprintf(pathname, pathlen, "%s/%s", cfg->plugins_path, plugin->filename);
#ifdef DEBUG
xlog(LOG_DEBUG, "[Perl] Loading '%s'\n", pathname);
#endif
/* Load the file through perl's require mechanism */
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
PUTBACK;
sv = newSVpvf("$package = require q%c%s%c", 0, pathname, 0);
nb_res = eval_sv(sv_2mortal(sv), G_EVAL);
if (nb_res != 1) {
xlog(LOG_ERROR,
"[Perl] Invalid number of response returned while loading '%s' (got %d, expected 1)\n",
pathname,
nb_res);
} else if (SvTRUE(ERRSV)) {
xlog(LOG_ERROR, "[Perl] Eval error for '%s': %s\n", pathname, SvPV_nolen(ERRSV));
} else {
/* Get the package name from the package (which should follow the convention...) */
package_sv = get_sv("package", 0);
/* Check if the SV* stores a string */
if (!SvPOK(package_sv)) {
xlog(LOG_ERROR, "[Perl] Invalid convention for '%s': the package should return a string\n", pathname);
} else {
required = (char*) SvPV_nolen(package_sv);
package_len = strlen(required);
package_name = (char*) alloca(package_len+1);
proxenet_xzero(package_name, package_len+1);
memcpy(package_name, required, package_len);
#ifdef DEBUG
xlog(LOG_DEBUG, "[Perl] Package of name '%s' loaded\n", package_name);
#endif
/* Save the functions' full name to call them later */
len = package_len + 2 + strlen(CFG_REQUEST_PLUGIN_FUNCTION);
plugin->pre_function = proxenet_xmalloc(len + 1);
snprintf(plugin->pre_function, len+1, "%s::%s", package_name, CFG_REQUEST_PLUGIN_FUNCTION);
len = package_len + 2 + strlen(CFG_RESPONSE_PLUGIN_FUNCTION);
plugin->post_function = proxenet_xmalloc(len + 1);
snprintf(plugin->post_function, len+1, "%s::%s", package_name, CFG_RESPONSE_PLUGIN_FUNCTION);
ret = 0;
}
}
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
return ret;
}
JSBool PJS_invoke_perl_property_getter(JSContext *cx, JSObject *obj, jsval id, jsval *vp) {
dSP;
PJS_Context *pcx;
PJS_Class *pcls;
PJS_Property *pprop;
SV *caller;
char *name;
jsint slot;
U8 invocation_mode;
if (!(JSVAL_IS_INT(id) || JSVAL_IS_STRING(id))) {
return JS_TRUE;
}
if((pcx = PJS_GET_CONTEXT(cx)) == NULL) {
JS_ReportError(cx, "Can't find context %d", cx);
return JS_FALSE;
}
if (JS_TypeOfValue(cx, OBJECT_TO_JSVAL(obj)) == JSTYPE_OBJECT) {
/* Called as instsance */
JSClass *clasp = PJS_GET_CLASS(cx, obj);
name = (char *) clasp->name;
invocation_mode = 1;
}
else {
/* Called as static */
JSFunction *parent_jfunc = JS_ValueToFunction(cx, OBJECT_TO_JSVAL(obj));
if (parent_jfunc == NULL) {
JS_ReportError(cx, "Failed to extract class for static property getter");
return JS_FALSE;
}
name = (char *) JS_GetFunctionName(parent_jfunc);
invocation_mode = 0;
}
if ((pcls = PJS_GetClassByName(pcx, name)) == NULL) {
JS_ReportError(cx, "Can't find class '%s'", name);
return JS_FALSE;
}
if (invocation_mode) {
caller = (SV *) JS_GetPrivate(cx, obj);
}
else {
caller = newSVpv(pcls->pkg, 0);
}
if (JSVAL_IS_INT(id)) {
slot = JSVAL_TO_INT(id);
if ((pprop = PJS_get_property_by_id(pcls, (int8) slot)) == NULL) {
if (SvTRUE(pcls->property_getter)) {
if (perl_call_sv_with_jsvals(cx, obj, pcls->property_getter, caller, 1, &id, vp) < 0) {
return JS_FALSE;
}
return JS_TRUE;
}
JS_ReportError(cx, "Can't find property handler");
return JS_FALSE;
}
if (pprop->getter == NULL) {
JS_ReportError(cx, "Property is write-only");
return JS_FALSE;
}
if (perl_call_sv_with_jsvals(cx, obj, pprop->getter, caller, 0, NULL, vp) < 0) {
return JS_FALSE;
}
}
else if (JSVAL_IS_STRING(id) && SvTRUE(pcls->property_getter)) {
SV *sv = sv_newmortal();
#ifdef JS_C_STRINGS_ARE_UTF8
char *tmp = JS_smprintf("%hs", JS_GetStringChars(JSVAL_TO_STRING(id)));
sv_setpv(sv, tmp);
SvUTF8_on(sv);
free(tmp);
#else
sv_setpv(sv, JS_GetStringBytes(JSVAL_TO_STRING(id)));
#endif
if (PJS_get_method_by_name(pcls, SvPV_nolen(sv))) {
return JS_TRUE;
}
if (perl_call_sv_with_jsvals(cx, obj, pcls->property_getter, caller, 1, &id, vp) < 0) {
return JS_FALSE;
}
}
return JS_TRUE;
}
void *
weechat_perl_exec (struct t_plugin_script *script,
int ret_type, const char *function,
const char *format, void **argv)
{
char *func;
unsigned int count;
void *ret_value;
int *ret_i, mem_err, length, i, argc;
SV *ret_s;
HV *hash;
struct t_plugin_script *old_perl_current_script;
#ifdef MULTIPLICITY
void *old_context;
#endif /* MULTIPLICITY */
old_perl_current_script = perl_current_script;
perl_current_script = script;
#ifdef MULTIPLICITY
(void) length;
func = (char *) function;
old_context = PERL_GET_CONTEXT;
if (script->interpreter)
PERL_SET_CONTEXT (script->interpreter);
#else
length = strlen ((script->interpreter) ? script->interpreter : perl_main) +
strlen (function) + 3;
func = (char *) malloc (length);
if (!func)
return NULL;
snprintf (func, length, "%s::%s",
(char *) ((script->interpreter) ? script->interpreter : perl_main),
function);
#endif /* MULTIPLICITY */
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if (format && format[0])
{
argc = strlen (format);
for (i = 0; i < argc; i++)
{
switch (format[i])
{
case 's': /* string */
XPUSHs(sv_2mortal(newSVpv((char *)argv[i], 0)));
break;
case 'i': /* integer */
XPUSHs(sv_2mortal(newSViv(*((int *)argv[i]))));
break;
case 'h': /* hash */
hash = weechat_perl_hashtable_to_hash (argv[i]);
XPUSHs(sv_2mortal(newRV_inc((SV *)hash)));
break;
}
}
}
PUTBACK;
count = call_pv (func, G_EVAL | G_SCALAR);
ret_value = NULL;
mem_err = 1;
SPAGAIN;
if (SvTRUE (ERRSV))
{
weechat_printf (NULL,
weechat_gettext ("%s%s: error: %s"),
weechat_prefix ("error"), PERL_PLUGIN_NAME,
SvPV_nolen (ERRSV));
(void) POPs; /* poping the 'undef' */
mem_err = 0;
}
else
{
if (count != 1)
{
weechat_printf (NULL,
weechat_gettext ("%s%s: function \"%s\" must "
"return one valid value (%d)"),
weechat_prefix ("error"), PERL_PLUGIN_NAME,
function, count);
mem_err = 0;
}
else
{
if (ret_type == WEECHAT_SCRIPT_EXEC_STRING)
{
ret_s = newSVsv(POPs);
ret_value = strdup (SvPV_nolen (ret_s));
SvREFCNT_dec (ret_s);
}
else if (ret_type == WEECHAT_SCRIPT_EXEC_INT)
{
ret_i = malloc (sizeof (*ret_i));
if (ret_i)
*ret_i = POPi;
ret_value = ret_i;
}
else if (ret_type == WEECHAT_SCRIPT_EXEC_HASHTABLE)
{
ret_value = weechat_perl_hash_to_hashtable (POPs,
WEECHAT_SCRIPT_HASHTABLE_DEFAULT_SIZE,
WEECHAT_HASHTABLE_STRING,
WEECHAT_HASHTABLE_STRING);
}
else
{
weechat_printf (NULL,
weechat_gettext ("%s%s: function \"%s\" is "
"internally misused"),
weechat_prefix ("error"), PERL_PLUGIN_NAME,
function);
mem_err = 0;
}
}
}
PUTBACK;
FREETMPS;
LEAVE;
perl_current_script = old_perl_current_script;
#ifdef MULTIPLICITY
PERL_SET_CONTEXT (old_context);
#else
free (func);
#endif /* MULTIPLICITY */
if (!ret_value && (mem_err == 1))
{
weechat_printf (NULL,
weechat_gettext ("%s%s: not enough memory in function "
"\"%s\""),
weechat_prefix ("error"), PERL_PLUGIN_NAME, function);
return NULL;
}
return ret_value;
}
