static JSBool
perlsub_call(
JSContext *cx,
DEFJSFSARGS_
) {
dTHX;
DECJSFSARGS;
JSObject *func = JSVAL_TO_OBJECT(JS_ARGV_CALLEE(argv));
SV *callee = (SV *)JS_GetPrivate(cx, func);
JSObject *This = JSVAL_TO_OBJECT(argv[-1]);
JSClass *clasp = PJS_GET_CLASS(cx, This);
SV *caller;
JSBool wanta, isclass = JS_FALSE;
if(!JS_GetProperty(cx, func, "$wantarray", rval) ||
!JS_ValueToBoolean(cx, *rval, &wanta))
return JS_FALSE;
PJS_DEBUG1("In PSC: obj is %s\n", PJS_GET_CLASS(cx, obj)->name);
if(clasp == &perlpackage_class) {
if(!JS_GetProperty(cx, This, "$__im_a_class", rval) ||
!JS_ValueToBoolean(cx, *rval, &isclass))
return JS_FALSE;
}
if(isclass ||
( clasp == &perlsub_class /* Constructors has a Stash in __proto__ */
&& (func = JS_GetPrototype(cx, This))
&& PJS_GET_CLASS(cx, func) == &perlpackage_class)
) { // Caller is a stash, make a static call
char *pkgname = PJS_GetPackageName(aTHX_ cx, This);
if(!pkgname) return JS_FALSE;
caller = newSVpv(pkgname, 0);
PJS_DEBUG1("Caller is a stash: %s\n", pkgname);
#if JS_VERSION >= 185
Safefree(pkgname);
#endif
}
else if(IS_PERL_CLASS(clasp) &&
sv_isobject(caller = (SV *)JS_GetPrivate(cx, This))
) { // Caller is a perl object
SvREFCNT_inc_void_NN(caller);
PJS_DEBUG1("Caller is an object: %s\n", SvPV_nolen(caller));
}
else {
caller = NULL;
PJS_DEBUG1("Caller is %s\n", clasp->name);
}
return PJS_Call_sv_with_jsvals(aTHX_ cx, obj, callee, caller, argc, argv,
rval, wanta ? G_ARRAY : G_SCALAR);
}
static void
Scalarize(pTHX_ SV *sv, AV *av)
{
int n = av_len(av)+1;
if (n == 0)
sv_setpvn(sv,"",0);
else
{
SV **svp;
if (n == 1 && (svp = av_fetch(av, 0, 0)))
{
STRLEN len = 0;
char *s = SvPV(*svp,len);
#ifdef SvUTF8
int utf8 = SvUTF8(*svp);
sv_setpvn(sv,s,len);
if (utf8)
SvUTF8_on(sv);
#else
sv_setpvn(sv,s,len);
#endif
}
else
{
Tcl_DString ds;
int i;
Tcl_DStringInit(&ds);
for (i=0; i < n; i++)
{
if ((svp = av_fetch(av, i, 0)))
{
SV *el = *svp;
int temp = 0;
if (SvROK(el) && !SvOBJECT(SvRV(el)) && SvTYPE(SvRV(el)) == SVt_PVAV)
{
el = newSVpv("",0);
temp = 1;
if ((AV *) SvRV(*svp) == av)
abort();
Scalarize(aTHX_ el,(AV *) SvRV(*svp));
}
Tcl_DStringAppendElement(&ds,Tcl_GetString(el));
if (temp)
SvREFCNT_dec(el);
}
}
sv_setpvn(sv,Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
sv_maybe_utf8(sv);
Tcl_DStringFree(&ds);
}
}
}
/*
* Query table for specified rows
* h: structure representing database connection
* k: key names
* op: operators
* v: values of the keys that must match
* c: column names to return
* n: number of key=values pairs to compare
* nc: number of columns to return
* o: order by the specified column
*/
int perlvdb_db_query(db_con_t* h, db_key_t* k, db_op_t* op, db_val_t* v,
db_key_t* c, int n, int nc,
db_key_t o, db_res_t** r) {
AV *condarr;
AV *retkeysarr;
SV *order;
SV *condarrref;
SV *retkeysref;
SV *resultset;
int retval = 0;
/* Create parameter set */
condarr = conds2perlarray(k, op, v, n);
retkeysarr = keys2perlarray(c, nc);
if (o) order = newSVpv(o, 0);
else order = &PL_sv_undef;
condarrref = newRV_noinc((SV*)condarr);
retkeysref = newRV_noinc((SV*)retkeysarr);
/* Call perl method */
resultset = perlvdb_perlmethod(getobj(h), PERL_VDB_QUERYMETHOD,
condarrref, retkeysref, order, NULL);
av_undef(condarr);
av_undef(retkeysarr);
/* Transform perl result set to OpenSER result set */
if (!resultset) {
/* No results. */
LM_ERR("no perl result set.\n");
retval = -1;
} else {
if (sv_isa(resultset, "OpenSER::VDB::Result")) {
retval = perlresult2dbres(resultset, r);
/* Nested refs are decreased/deleted inside the routine */
SvREFCNT_dec(resultset);
} else {
LM_ERR("invalid result set retrieved from perl call.\n");
retval = -1;
}
}
return retval;
}
static void cmd_run(char *data)
{
dSP;
struct stat statbuf;
char *fname;
int retcount;
/* add .pl suffix if it's missing */
data = (strlen(data) <= 3 || strcmp(data+strlen(data)-3, ".pl") == 0) ?
g_strdup(data) : g_strdup_printf("%s.pl", data);
if (g_path_is_absolute(data)) {
/* whole path specified */
fname = g_strdup(data);
} else {
/* check from ~/.irssi/scripts/ */
fname = g_strdup_printf("%s/.irssi/scripts/%s", g_get_home_dir(), data);
if (stat(fname, &statbuf) != 0) {
/* check from SCRIPTDIR */
g_free(fname),
fname = g_strdup_printf(SCRIPTDIR"/%s", data);
}
}
g_free(data);
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(fname, strlen(fname)))); g_free(fname);
PUTBACK;
retcount = perl_call_pv("load_file", G_EVAL|G_SCALAR);
SPAGAIN;
if (SvTRUE(ERRSV)) {
STRLEN n_a;
signal_emit("gui dialog", 2, "error", SvPV(ERRSV, n_a));
(void) POPs;
}
else if (retcount > 0) {
char *str = POPp;
if (str != NULL && *str != '\0')
signal_emit("gui dialog", 2, "error", str);
}
PUTBACK;
FREETMPS;
LEAVE;
}
static void define_flag_field(const char *ev_name,
const char *field_name,
const char *delim)
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(ev_name, 0)));
XPUSHs(sv_2mortal(newSVpv(field_name, 0)));
XPUSHs(sv_2mortal(newSVpv(delim, 0)));
PUTBACK;
if (get_cv("main::define_flag_field", 0))
call_pv("main::define_flag_field", G_SCALAR);
SPAGAIN;
PUTBACK;
FREETMPS;
LEAVE;
}
void run_filter_perlplugin(char *dst, size_t dst_size, struct fileFilterFormat *filter, struct hashtable **metahash) {
char perlpath[PATH_MAX];
snprintf(perlpath, sizeof perlpath, "%smain.pm", filter->path);
HV *perl_metahash = newHV();
SV *perl_dst = newSVpv("", strlen(""));
//AV *perl_extracted_files = newAV();
HV *params = newHV();
hv_store(params, "file", strlen("file"), sv_2mortal(newSVpv(filter->command, 0)), 0);
hv_store(params, "metadata", strlen("metadata"), sv_2mortal(newRV((SV *) perl_metahash)), 0);
hv_store(params, "data", strlen("data"), sv_2mortal(newRV((SV *) perl_dst)), 0);
//hv_store(params, "extracted_files", strlen("extracted_files"), sv_2mortal(newRV((SV *) perl_extracted_files)), 0);
#ifdef DEBUG
printf("perl run: %s:dump(file=%s, metadata=%p)\n",perlpath,filter->command,perl_metahash);
#endif
if(!perl_embed_run(perlpath, "dump", params, NULL, NULL, NULL, 0))
errx(1, "Perlplugin error on '%s'", filter->command);
STRLEN data_size;
char *data = SvPV(perl_dst, data_size);
// asuming data is a '\0'-terminated string
strlcpy(dst, data, dst_size);
if (metahash) {
*metahash = create_hashtable(3, ht_stringhash, ht_stringcmp);
perl_ht_to_ht(perl_metahash, *metahash);
}
// clean up
hv_undef(perl_metahash);
hv_undef(params);
free(data);
}
static gboolean
perl_worker_vp_add_one(const gchar *name,
TypeHint type, const gchar *value,
gpointer user_data)
{
PerlInterpreter *my_perl = (PerlInterpreter *)((gpointer *)user_data)[0];
HV *kvmap = (HV *)((gpointer *)user_data)[1];
PerlDestDriver *self = (PerlDestDriver *)((gpointer *)user_data)[2];
gboolean need_drop = FALSE;
gboolean fallback = self->template_options.on_error & ON_ERROR_FALLBACK_TO_STRING;
switch (type)
{
case TYPE_HINT_INT32:
{
gint32 i;
if (type_cast_to_int32(value, &i, NULL))
hv_store(kvmap, name, strlen(name), newSViv(i), 0);
else
{
need_drop = type_cast_drop_helper(self->template_options.on_error,
value, "int");
if (fallback)
hv_store(kvmap, name, strlen(name), newSVpv(value, 0), 0);
}
break;
}
case TYPE_HINT_STRING:
hv_store(kvmap, name, strlen(name), newSVpv(value, 0), 0);
break;
default:
need_drop = type_cast_drop_helper(self->template_options.on_error,
value, "<unknown>");
break;
}
return need_drop;
}
/**
* example command
* Just sends "Hello World!" to the services channel
*/
static int load_extension( const CmdParams *cmdparams )
{
SET_SEGV_LOCATION();
irc_chanalert( perl_bot, "%s is trying to load perl extension %s",
cmdparams->source->name, cmdparams->av[0] );
if (load_perlextension(cmdparams->av[0], perl_ext_init, cmdparams->source)) {
perl_sync_module(GET_CUR_MODULE());
} else {
return NS_FAILURE;
}
execute_perl(GET_CUR_MODULE(), sv_2mortal (newSVpv ("NeoStats::Module::extension_2eple::TestCall", 0)), 1, "Hello World");
return NS_SUCCESS;
}
SV* newSVidc(const idc_value_t* val)
{
switch(val->vtype)
{
case VT_STR: return newSVpv(val->str, 0);
case VT_LONG: return newSViv(val->num);
case VT_FLOAT: double nv;
ph.realcvt(&nv, const_cast<ushort*>(val->e), 13);
return newSVnv(nv);
}
// ... error: invalid vtype
return NULL;
}
/*
* Store name of table that will be used by
* subsequent database functions
*/
int perlvdb_use_table(db_con_t* h, const char* t) {
SV *ret;
if (!h || !t) {
LM_ERR("invalid parameter value\n");
return -1;
}
ret = perlvdb_perlmethod(getobj(h), PERL_VDB_USETABLEMETHOD,
sv_2mortal(newSVpv(t, 0)), NULL, NULL, NULL);
return IV2int(ret);
}
static SV *
ForceScalar(pTHX_ SV *sv)
{
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTYPE(sv) == SVt_PVAV)
{
AV *av = (AV *) sv;
SV *newsv = newSVpv("",0);
Scalarize(aTHX_ newsv, (AV *) av);
av_clear(av);
av_store(av,0,newsv);
return newsv;
}
else
{
if (SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV)
{
/* Callbacks and lists often get stringified by mistake due to
Tcl/Tk's string fixation - don't change the real value
*/
SV *newsv = newSVpv("",0);
Scalarize(aTHX_ newsv, (AV *) SvRV(sv));
return sv_2mortal(newsv);
}
else if (!SvOK(sv))
{
/* Map undef to null string */
if (SvREADONLY(sv))
{
SV *newsv = newSVpv("",0);
return sv_2mortal(newsv);
}
else
sv_setpvn(sv,"",0);
}
return sv;
}
}
/* convert array header of modperl_handlers_t's to AV ref of CV refs */
SV *modperl_handler_perl_get_handlers(pTHX_ MpAV **handp, apr_pool_t *p)
{
AV *av = newAV();
int i;
modperl_handler_t **handlers;
if (!(handp && *handp)) {
return &PL_sv_undef;
}
av_extend(av, (*handp)->nelts - 1);
handlers = (modperl_handler_t **)(*handp)->elts;
for (i=0; i<(*handp)->nelts; i++) {
modperl_handler_t *handler = NULL;
GV *gv;
if (MpHandlerPARSED(handlers[i])) {
handler = handlers[i];
}
else {
#ifdef USE_ITHREADS
if (!MpHandlerDYNAMIC(handlers[i])) {
handler = modperl_handler_dup(p, handlers[i]);
}
#endif
if (!handler) {
handler = handlers[i];
}
if (!modperl_mgv_resolve(aTHX_ handler, p, handler->name, TRUE)) {
MP_TRACE_h(MP_FUNC, "failed to resolve handler %s",
handler->name);
}
}
if (handler->mgv_cv) {
if ((gv = modperl_mgv_lookup(aTHX_ handler->mgv_cv))) {
CV *cv = modperl_mgv_cv(gv);
av_push(av, newRV_inc((SV*)cv));
}
}
else {
av_push(av, newSVpv(handler->name, 0));
}
}
return newRV_noinc((SV*)av);
}
int Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode)
{
dSP;
int ret_value = 0;
int count;
std::string error;
ENTER;
SAVETMPS;
PUSHMARK(SP);
if(args && args->size())
{
for(std::vector<std::string>::const_iterator i = args->begin(); i != args->end(); ++i)
{
XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
}
}
PUTBACK;
count = call_pv(subname, mode);
SPAGAIN;
if(SvTRUE(ERRSV))
{
error = SvPV_nolen(ERRSV);
POPs;
}
else
{
if(count == 1) {
SV *ret = POPs;
if(SvTYPE(ret) == SVt_IV) {
IV v = SvIV(ret);
ret_value = v;
}
PUTBACK;
}
}
FREETMPS;
LEAVE;
if(error.length() > 0)
{
std::string errmsg = "Perl runtime error: ";
errmsg += SvPVX(ERRSV);
throw errmsg.c_str();
}
return ret_value;
}
void Embperl::dosub(const char * subname, const std::vector<std::string> * args, int mode)
{//as seen in perlembed docs
#if EQDEBUG >= 5
if(InUse()) {
LogFile->write(EQCLog::Debug, "Warning: Perl dosub called for %s when perl is allready in use.\n", subname);
}
#endif
in_use = true;
bool err = false;
try {
SV **sp = PL_stack_sp;
/* initialize stack pointer */
} catch(const char *err)
{//this should never happen, so if it does, it is something really serious (like a bad perl install), so we'll shutdown.
EQC::Common::Log(EQCLog::Error,CP_ZONESERVER, "Fatal error initializing perl: %s", err);
}
dSP;
ENTER; /* everything created after here */
SAVETMPS; /* ...is a temporary variable. */
PUSHMARK(SP); /* remember the stack pointer */
if(args && args->size())
{
for(std::vector<std::string>::const_iterator i = args->begin(); i != args->end(); ++i)
{/* push the arguments onto the perl stack */
XPUSHs(sv_2mortal(newSVpv(i->c_str(), i->length())));
}
}
PUTBACK; /* make local stack pointer global */
int result = call_pv(subname, mode); /*eval our code*/
SPAGAIN; /* refresh stack pointer */
//if(SvTRUE(ERRSV))
//{
// err = true;
//}
FREETMPS; /* free temp values */
LEAVE; /* ...and the XPUSHed "mortal" args.*/
in_use = false;
if(err)
{
errmsg = "Perl runtime error: ";
errmsg += SvPVX(ERRSV);
throw errmsg.c_str();
}
}
/*
* get the vps and put them in perl hash
* If one VP have multiple values it is added as array_ref
* Example for this is Cisco-AVPair that holds multiple values.
* Which will be available as array_ref in $RAD_REQUEST{'Cisco-AVPair'}
*/
static void perl_store_vps(VALUE_PAIR *vp, HV *rad_hv)
{
VALUE_PAIR *nvp, *vpa, *vpn;
AV *av;
char buffer[1024];
int attr, len;
hv_undef(rad_hv);
nvp = paircopy(vp);
while (nvp != NULL) {
attr = nvp->attribute;
vpa = paircopy2(nvp,attr);
if (vpa->next) {
av = newAV();
vpn = vpa;
while (vpn) {
len = vp_prints_value(buffer, sizeof(buffer),
vpn, FALSE);
av_push(av, newSVpv(buffer, len));
vpn = vpn->next;
}
hv_store(rad_hv, nvp->name, strlen(nvp->name),
newRV_noinc((SV *) av), 0);
} else {
len = vp_prints_value(buffer, sizeof(buffer),
vpa, FALSE);
hv_store(rad_hv, vpa->name, strlen(vpa->name),
newSVpv(buffer, len), 0);
}
pairfree(&vpa);
vpa = nvp; while ((vpa != NULL) && (vpa->attribute == attr))
vpa = vpa->next;
pairdelete(&nvp, attr);
nvp = vpa;
}
}
SV *
fw_c2sv(FwRule *rule)
{
HV *out = newHV();
SV *out_ref = newRV_noinc((SV *)out);
AV *sport, *dport;
char *src, *dst;
int i;
hv_store(out, "fw_device", 9, newSVpv(rule->fw_device, 0), 0);
hv_store(out, "fw_op", 5, newSViv(rule->fw_op), 0);
hv_store(out, "fw_dir", 6, newSViv(rule->fw_dir), 0);
hv_store(out, "fw_proto", 8, newSViv(rule->fw_proto), 0);
src = addr_ntoa(&(rule->fw_src));
if (src == NULL) {
hv_store(out, "fw_src", 6, &PL_sv_undef, 0);
}
else {
hv_store(out, "fw_src", 6, newSVpv(src, 0), 0);
}
dst = addr_ntoa(&(rule->fw_dst));
if (dst == NULL) {
hv_store(out, "fw_dst", 6, &PL_sv_undef, 0);
}
else {
hv_store(out, "fw_dst", 6, newSVpv(dst, 0), 0);
}
sport = newAV();
dport = newAV();
for (i=0; i<2; i++) {
av_push(sport, newSViv(rule->fw_sport[i]));
av_push(dport, newSViv(rule->fw_dport[i]));
}
hv_store(out, "fw_sport", 8, newRV_noinc((SV *)sport), 0);
hv_store(out, "fw_dport", 8, newRV_noinc((SV *)dport), 0);
return out_ref;
}
int WStrToArray(PERL_CALL AV *array, PWSTR str)
{
if(!array)
return 0;
PSTR strPtr = str ? W2S(str) : NULL;
if(strPtr)
av_push(array, newSVpv(strPtr, strlen(strPtr)));
FreeStr(strPtr);
return 1;
}
SV* _org_warhound_mdi_String2SV(CFTypeRef attrItem) {
SV* retval;
int stringSize = CFStringGetMaximumSizeForEncoding(CFStringGetLength(attrItem), kCFStringEncodingUTF8) + 1;
char* tmpptr = (char*)malloc(sizeof(char) * stringSize);
CFStringGetCString(attrItem, tmpptr, stringSize, kCFStringEncodingUTF8);
/* Do not mark this as mortal! We leave that responsibility to our caller,
* b/c XS often autogenerates the code for that and we don't want to
* conflict with XS */
retval = newSVpv(tmpptr, strlen(tmpptr));
free(tmpptr);
SvUTF8_on(retval);
return retval;
}
SV *
c2p_pkgfrom(alpm_pkgfrom_t from)
{
char *str;
switch(from){
case ALPM_PKG_FROM_FILE: str = "file"; break;
case ALPM_PKG_FROM_LOCALDB: str = "localdb"; break;
case ALPM_PKG_FROM_SYNCDB: str = "syncdb"; break;
default: str = "unknown"; break;
}
return newSVpv(str, 0);
}
/* converts siglevel bitflags into a string (default/never) or hashref of strings */
SV*
c2p_siglevel(alpm_siglevel_t sig)
{
HV *hv;
if(sig & ALPM_SIG_USE_DEFAULT){
return newSVpv("default", 7);
}
hv = newHV();
hv_store(hv, "pkg", 3, truststring(sig & MASK_ALL), 0);
hv_store(hv, "db", 2, truststring((sig >> OFFSET_DB) & MASK_ALL), 0);
return newRV_noinc((SV*)hv);
}
static void
perl_end (void)
{
if (my_perl != NULL) {
execute_perl (sv_2mortal (newSVpv ("Xchat::Embed::unload_all", 0)), "");
PL_perl_destruct_level = 1;
perl_destruct (my_perl);
perl_free (my_perl);
PERL_SYS_TERM();
my_perl = NULL;
}
}
int WStrToHash(PERL_CALL HV *hash, PSTR idx, PWSTR str)
{
if(!hash || !idx)
return 0;
PSTR strPtr = str ? W2S(str) : NULL;
if(strPtr)
hv_store(hash, idx, strlen(idx), newSVpv(strPtr, strlen(strPtr)), 0);
FreeStr(strPtr);
return 1;
}
static void
perl_png_scalar_write (png_structp png, png_bytep bytes_to_write,
png_size_t byte_count_to_write)
{
scalar_as_image_t * si;
si = png_get_io_ptr (png);
if (si->png_image == 0) {
si->png_image = newSVpv ((char *) bytes_to_write, byte_count_to_write);
}
else {
sv_catpvn (si->png_image, (char *) bytes_to_write, byte_count_to_write);
}
}
static void get_names_callback(const CMacroInfo *pmi)
{
struct get_names_cb_arg *a = pmi->arg;
if (a->ll)
{
dTHXa(a->interp);
LL_push(a->ll, newSVpv(pmi->name, 0));
}
else
{
a->count++;
}
}
void c2p_logcb(alpm_loglevel_t lvl, const char * fmt, va_list args)
{
SV * svlvl, * svmsg;
const char *str;
char buf[256];
dSP;
if(!logcb_ref) return;
/* convert log level bitflag to a string */
switch(lvl){
case ALPM_LOG_ERROR: str = "error"; break;
case ALPM_LOG_WARNING: str = "warning"; break;
case ALPM_LOG_DEBUG: str = "debug"; break;
case ALPM_LOG_FUNCTION: str = "function"; break;
default: str = "unknown"; break;
}
ENTER;
SAVETMPS;
/* We can't use sv_vsetpvfn because it doesn't like j's: %jd or %ji, etc... */
svlvl = sv_2mortal(newSVpv(str, 0));
vsnprintf(buf, 255, fmt, args);
svmsg = sv_2mortal(newSVpv(buf, 0));
PUSHMARK(SP);
XPUSHs(svlvl);
XPUSHs(svmsg);
PUTBACK;
call_sv(logcb_ref, G_DISCARD);
FREETMPS;
LEAVE;
return;
}
static JSBool
perlsub_construct(
JSContext *cx,
DEFJSFSARGS_
) {
dTHX;
DECJSFSARGS;
JSObject *func = JSVAL_TO_OBJECT(JS_ARGV_CALLEE(argv));
SV *callee = (SV *)JS_GetPrivate(cx, func);
SV *caller = NULL;
#if JS_VERSION < 185
JSObject *This = JSVAL_TO_OBJECT(argv[-1]);
#else
JSObject *This = JS_NewObjectForConstructor(cx, vp);
#endif
JSObject *proto = JS_GetPrototype(cx, This);
PJS_DEBUG1("Want construct, This is a %s", PJS_GET_CLASS(cx, This)->name);
if(PJS_GET_CLASS(cx, proto) == &perlpackage_class ||
( JS_LookupProperty(cx, func, "prototype", &argv[-1])
&& JSVAL_IS_OBJECT(argv[-1]) && !JSVAL_IS_NULL(argv[-1])
&& (proto = JS_GetPrototype(cx, JSVAL_TO_OBJECT(argv[-1])))
&& strEQ(PJS_GET_CLASS(cx, proto)->name, PJS_PACKAGE_CLASS_NAME))
) {
SV *rsv = NULL;
char *pkgname = PJS_GetPackageName(aTHX_ cx, proto);
#if JS_VERSION >= 185
JSAutoByteString bytes;
bytes.initBytes(pkgname);
#endif
caller = newSVpv(pkgname, 0);
argv[-1] = OBJECT_TO_JSVAL(This);
if(!PJS_Call_sv_with_jsvals_rsv(aTHX_ cx, obj, callee, caller,
argc, argv, &rsv, G_SCALAR))
return JS_FALSE;
if(SvROK(rsv) && sv_derived_from(rsv, pkgname)) {
JSObject *newobj = PJS_NewPerlObject(aTHX_ cx, JS_GetParent(cx, func), rsv);
*rval = OBJECT_TO_JSVAL(newobj);
return JS_TRUE;
}
JS_ReportError(cx, "%s's constructor don't return an object",
SvPV_nolen(caller));
}
else JS_ReportError(cx, "Can't use as a constructor"); // Yet! ;-)
return JS_FALSE;
}
int
perl_back_add(
Operation *op,
SlapReply *rs )
{
PerlBackend *perl_back = (PerlBackend *) op->o_bd->be_private;
int len;
int count;
#if defined(HAVE_WIN32_ASPERL) || defined(USE_ITHREADS)
PERL_SET_CONTEXT( PERL_INTERPRETER );
#endif
ldap_pvt_thread_mutex_lock( &perl_interpreter_mutex );
ldap_pvt_thread_mutex_lock( &entry2str_mutex );
{
dSP; ENTER; SAVETMPS;
PUSHMARK(sp);
XPUSHs( perl_back->pb_obj_ref );
XPUSHs(sv_2mortal(newSVpv( entry2str( op->ora_e, &len ), 0 )));
PUTBACK;
#ifdef PERL_IS_5_6
count = call_method("add", G_SCALAR);
#else
count = perl_call_method("add", G_SCALAR);
#endif
SPAGAIN;
if (count != 1) {
croak("Big trouble in back_add\n");
}
rs->sr_err = POPi;
PUTBACK; FREETMPS; LEAVE;
}
ldap_pvt_thread_mutex_unlock( &entry2str_mutex );
ldap_pvt_thread_mutex_unlock( &perl_interpreter_mutex );
send_ldap_result( op, rs );
Debug( LDAP_DEBUG_ANY, "Perl ADD\n", 0, 0, 0 );
return( 0 );
}
void
weechat_perl_hashtable_map_cb (void *data,
struct t_hashtable *hashtable,
const char *key,
const char *value)
{
HV *hash;
/* make C compiler happy */
(void) hashtable;
hash = (HV *)data;
(void) hv_store (hash, key, strlen (key), newSVpv (value, 0), 0);
}
static void
foreach_fn_gslist(gpointer key_p, gpointer value_p, gpointer user_data_p)
{
char *key = key_p;
GSList *value_s = value_p;
GSList *value;
HV *hv = user_data_p;
AV *list = newAV();
for(value=value_s; value != NULL; value = value->next) {
av_push(list, newSVpv(value->data, 0));
}
hv_store(hv, key, strlen(key), newRV_noinc((SV*)list), 0);
}
static void __LogAnswer(
const char *msg,
unsigned append)
{
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs(sv_2mortal(newSVpv(msg, 0)));
XPUSHs(sv_2mortal(newSViv(append)));
PUTBACK;
call_pv("LogAnswer", G_DISCARD);
FREETMPS;
LEAVE;
}
