static SV *make_env(request_rec *r, psgi_dir_config *c) { dTHX; HV *env; AV *version; char *url_scheme, *script_name, *vpath, *path_info; SV *input, *errors; env = newHV(); ap_add_cgi_vars(r); ap_add_common_vars(r); /* fix SCRIPT_NAME & PATH_INFO */ if (c->location == NULL || strcmp(c->location, "/") == 0) { script_name = ""; } else { script_name = c->location; } vpath = apr_pstrcat(r->pool, apr_table_get(r->subprocess_env, "SCRIPT_NAME"), apr_table_get(r->subprocess_env, "PATH_INFO"), NULL); path_info = &vpath[strlen(script_name)]; apr_table_set(r->subprocess_env, "PATH_INFO", path_info); apr_table_set(r->subprocess_env, "SCRIPT_NAME", script_name); apr_table_do(copy_env, env, r->subprocess_env, NULL); version = newAV(); av_push(version, newSViv(1)); av_push(version, newSViv(0)); (void) hv_store(env, "psgi.version", 12, newRV_noinc((SV *) version), 0); url_scheme = apr_table_get(r->subprocess_env, "HTTPS") == NULL ? "http" : "https"; (void) hv_store(env, "psgi.url_scheme", 15, newSVpv(url_scheme, 0), 0); input = newRV_noinc(newSV(0)); sv_magic(SvRV(input), NULL, PERL_MAGIC_ext, NULL, 0); mg_find(SvRV(input), PERL_MAGIC_ext)->mg_obj = (void *) r; sv_bless(input, gv_stashpv("ModPSGI::Input", 1)); (void) hv_store(env, "psgi.input", 10, input, 0); errors = newRV_noinc(newSV(0)); sv_magic(SvRV(errors), NULL, PERL_MAGIC_ext, NULL, 0); mg_find(SvRV(errors), PERL_MAGIC_ext)->mg_obj = (void *) r; sv_bless(errors, gv_stashpv("ModPSGI::Errors", 1)); (void) hv_store(env, "psgi.errors", 11, errors, 0); (void) hv_store(env, "psgi.multithread", 16, newSViv(psgi_multithread), 0); (void) hv_store(env, "psgi.multiprocess", 17, newSViv(psgi_multiprocess), 0); (void) hv_store(env, "psgi.run_once", 13, newSViv(0), 0); (void) hv_store(env, "psgi.nonblocking", 16, newSViv(0), 0); return newRV_inc((SV *) env); }
SV * PLCB__viewhandle_new(PLCB_t *parent, const char *ddoc, const char *view, const char *options, int flags) { AV *req = NULL; SV *blessed; lcb_CMDVIEWQUERY cmd = { 0 }; lcb_VIEWHANDLE vh = NULL; lcb_error_t rc; req = newAV(); rowreq_init_common(parent, req); blessed = newRV_noinc((SV*)req); sv_bless(blessed, parent->view_stash); lcb_view_query_initcmd(&cmd, ddoc, view, options, viewrow_callback); cmd.cmdflags = flags; /* Trust lcb on this */ cmd.handle = &vh; rc = lcb_view_query(parent->instance, req, &cmd); if (rc != LCB_SUCCESS) { SvREFCNT_dec(blessed); die("Couldn't issue view query: (0x%x): %s", rc, lcb_strerror(NULL, rc)); } else { SvREFCNT_inc(req); /* For the callback */ av_store(req, PLCB_VHIDX_VHANDLE, newSVuv(PTR2UV(vh))); } return blessed; }
static JSBool PerlArray( JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *rval ) { dTHX; AV *av = newAV(); SV *ref = newRV_noinc((SV *)av); uintN arg; JSBool ok = JS_FALSE; SV *sv; /* If the path fails, the object will be finalized */ JS_SetPrivate(cx, obj, (void *)newRV(&PL_sv_undef)); av_extend(av, argc); for(arg = 0; arg < argc; arg++) { if(!PJS_ReflectJS2Perl(aTHX_ cx, argv[arg], &sv, 1) || !av_store(av, arg, sv)) goto fail; } if(SvTRUE(get_sv(NAMESPACE"PerlArray::construct_blessed", 0))) sv_bless(ref, gv_stashpv(PerlArrayPkg,0)); ok = PJS_CreateJSVis(aTHX_ cx, obj, ref) != NULL; fail: sv_free(ref); return ok; }
SV * newSVMiscRef(void * object, char * classname, int * newref) { HV * previous; SV * result; if (!object) return newSVsv(&PL_sv_undef); previous = RetrieveMisc(object); if (previous) { /*printf("Retriveing object %d as HV %d\n", object, previous);*/ result = newRV((SV*)previous); if (newref) *newref = 0; } else { HV * h = newHV(); hv_store(h, "_gtk", 4, newSViv((long)object), 0); result = newRV((SV*)h); RegisterMisc(h, object); sv_bless(result, gv_stashpv(classname, FALSE)); SvREFCNT_dec(h); if (newref) *newref = 1; /*printf("Storing object %p (%s) as HV %p (refcount: %d, %d)\n", object, classname, h, SvREFCNT(h), SvREFCNT(result));*/ } return result; }
SV * PLCB__n1qlhandle_new(PLCB_t *parent, lcb_N1QLPARAMS *params, const char *host) { AV *req; SV *blessed; lcb_CMDN1QL cmd = { 0 }; lcb_error_t rc; rc = lcb_n1p_mkcmd(params, &cmd); if (rc != LCB_SUCCESS) { die("Error encoding N1QL parameters: %s", lcb_strerror(NULL, rc)); } if (host && *host) { cmd.host = host; } cmd.callback = n1ql_callback; req = newAV(); rowreq_init_common(parent, req); blessed = newRV_noinc((SV*)req); sv_bless(blessed, parent->n1ql_stash); rc = lcb_n1ql_query(parent->instance, req, &cmd); if (rc != LCB_SUCCESS) { SvREFCNT_dec(blessed); die("Couldn't issue N1QL query: (0x%x): %s", rc, lcb_strerror(NULL, rc)); } else { SvREFCNT_inc(req); } return blessed; }
/** * NI_aggregate(): aggregate two IP address ranges into new object. * @ipo1: first Net::IP::XS object. * @ipo2: second Net::IP::XS object. */ SV * NI_aggregate(SV *ipo1, SV *ipo2) { int version; int res; char buf[90]; HV *stash; HV *hash; SV *ref; switch ((version = NI_hv_get_iv(ipo1, "ipversion", 9))) { case 4: res = NI_aggregate_ipv4(ipo1, ipo2, buf); break; case 6: res = NI_aggregate_ipv6(ipo1, ipo2, buf); break; default: res = 0; } if (!res) { return NULL; } hash = newHV(); ref = newRV_noinc((SV*) hash); stash = gv_stashpv("Net::IP::XS", 1); sv_bless(ref, stash); res = NI_set(ref, buf, version); if (!res) { return NULL; } return ref; }
SV* create_perl_object(void* cpp_obj, const char* perl_class_name, bool must_not_delete) { HV* underlying_hash; SV* perl_obj; HV* perl_obj_stash; object_link_data* link = new object_link_data; if (cpp_obj == NULL) return &PL_sv_undef; // create the underlying hash and make a ref to it underlying_hash = newHV(); perl_obj = newRV_noinc((SV*)underlying_hash); //sv_2mortal(perl_obj); // get the stash and bless the ref (to the underlying hash) into it perl_obj_stash = gv_stashpv(perl_class_name, TRUE); sv_bless(perl_obj, perl_obj_stash); // fill in the data fields link->cpp_object = cpp_obj; link->perl_object = (SV*)underlying_hash; link->can_delete_cpp_object = must_not_delete ? false : true; link->perl_class_name = perl_class_name; // link the data via '~' magic // (we link to the underlying hash and not to the reference itself) sv_magic((SV*)underlying_hash, NULL, PERL_MAGIC_ext, (const char*)link, 0); // cheat by storing data instead of a string // check this object DUMPME(1,perl_obj); return perl_obj; }
static SV * new_gdk_bitmap (GdkBitmap * bitmap, gboolean noinc) { if (!bitmap) return &PL_sv_undef; return sv_bless (gperl_new_object (G_OBJECT (bitmap), noinc), gv_stashpv ("Gtk2::Gdk::Bitmap", TRUE)); }
void p5_rebless_object(PerlInterpreter *my_perl, SV *obj) { SV * const inst = SvRV(obj); SV * const inst_ptr = newRV_noinc(inst); HV *stash = gv_stashpv("Perl6::Object", 0); if (stash == NULL) croak("Perl6::Object not found!? Forgot to call init_callbacks?"); (void)sv_bless(inst_ptr, stash); }
SV* THX_MopMcV_construct_instance(pTHX_ SV* metaclass, SV* repr) { // TODO: // This should handle all the attributes // and constructing things properly, which // should also include running all BUILD // methods. // - SL return sv_bless(repr, (HV*) SvRV(metaclass)); }
static void push_thread(pTHX, mthread* thread) { { dSP; SV* to_push = newRV_noinc(newSVuv(thread->id)); sv_bless(to_push, gv_stashpv("threads::lite::tid", FALSE)); XPUSHs(to_push); PUTBACK; } }
/** * NI_ip_add_num(): add integer to object and get new object. * @ipo: Net::IP::XS object. * @num: integer to add to object (as a string). */ SV * NI_ip_add_num(SV *ipo, const char *num) { int version; unsigned long num_ulong; char *endptr; n128_t num_n128; char buf[(2 * (MAX_IPV6_STR_LEN - 1)) + 4]; int res; HV *stash; HV *hash; SV *ref; int size; version = NI_hv_get_iv(ipo, "ipversion", 9); if (version == 4) { endptr = NULL; num_ulong = strtoul(num, &endptr, 10); if (STRTOUL_FAILED(num_ulong, num, endptr)) { return 0; } if (num_ulong > 0xFFFFFFFF) { return 0; } res = NI_ip_add_num_ipv4(ipo, num_ulong, buf); if (!res) { return 0; } } else if (version == 6) { res = n128_set_str_decimal(&num_n128, num, strlen(num)); if (!res) { return 0; } res = NI_ip_add_num_ipv6(ipo, &num_n128, buf); if (!res) { return 0; } } else { return 0; } hash = newHV(); ref = newRV_noinc((SV*) hash); stash = gv_stashpv("Net::IP::XS", 1); sv_bless(ref, stash); res = NI_set(ref, buf, version); if (!res) { return NULL; } return ref; }
/* * Return a new Catalog object - only accepts an integer catalog value. * Use this purely for speed when creating Catalog objects from other XS code. * All other Catalog object creation should be done with the perl new() method. */ SV* new_catalog(uint32_t cat) { SV *iv, *ref; iv = newSVuv(cat); ref = newRV_noinc(iv); sv_bless(ref, Sun_Solaris_Exacct_Catalog_stash); SvREADONLY_on(iv); return (ref); }
static SV *new_Token(pTHX_ Token *token) { HV *hash = (HV*)new_Hash(); (void)hv_stores(hash, "stype", set(new_Int(token->stype))); (void)hv_stores(hash, "type", set(new_Int(token->info.type))); (void)hv_stores(hash, "kind", set(new_Int(token->info.kind))); (void)hv_stores(hash, "line", set(new_Int(token->finfo.start_line_num))); (void)hv_stores(hash, "has_warnings", set(new_Int(token->info.has_warnings))); (void)hv_stores(hash, "name", set(new_String(token->info.name, strlen(token->info.name)))); (void)hv_stores(hash, "data", set(new_String(token->data.c_str(), strlen(token->data.c_str())))); HV *stash = (HV *)gv_stashpv("Compiler::Lexer::Token", sizeof("Compiler::Lexer::Token") + 1); return sv_bless(new_Ref(hash), stash); }
/* * Create a new ::Object by wrapping an ea_object_t in a perl SV. This is used * to wrap exacct records that have been read from a file, or packed records * that have been inflated. */ SV * new_xs_ea_object(ea_object_t *ea_obj) { xs_ea_object_t *xs_obj; SV *sv_obj; /* Allocate space - use perl allocator. */ New(0, xs_obj, 1, xs_ea_object_t); PERL_ASSERT(xs_obj != NULL); xs_obj->ea_obj = ea_obj; xs_obj->perl_obj = NULL; sv_obj = NEWSV(0, 0); PERL_ASSERT(sv_obj != NULL); /* * Initialise according to the type of the passed exacct object, * and bless the perl object into the appropriate class. */ if (ea_obj->eo_type == EO_ITEM) { if ((ea_obj->eo_catalog & EXT_TYPE_MASK) == EXT_EXACCT_OBJECT) { INIT_EMBED_ITEM_FLAGS(xs_obj); } else { INIT_PLAIN_ITEM_FLAGS(xs_obj); } sv_setiv(newSVrv(sv_obj, NULL), PTR2IV(xs_obj)); sv_bless(sv_obj, Sun_Solaris_Exacct_Object_Item_stash); } else { INIT_GROUP_FLAGS(xs_obj); sv_setiv(newSVrv(sv_obj, NULL), PTR2IV(xs_obj)); sv_bless(sv_obj, Sun_Solaris_Exacct_Object_Group_stash); } /* * We are passing back a pointer masquerading as a perl IV, * so make sure it can't be modified. */ SvREADONLY_on(SvRV(sv_obj)); return (sv_obj); }
/** * NI_binadd(): get new object from the sum of two IP addresses. * @ipo1: first Net::IP::XS object. * @ipo2: second Net::IP::XS object. */ SV * NI_binadd(SV *ipo1, SV *ipo2) { const char *binip1; const char *binip2; int version; char binbuf[130]; char buf[45]; int res; HV *stash; HV *hash; SV *ref; int iplen; binip1 = NI_hv_get_pv(ipo1, "binip", 5); if (!binip1) { binip1 = ""; } binip2 = NI_hv_get_pv(ipo2, "binip", 5); if (!binip2) { binip2 = ""; } res = NI_ip_binadd(binip1, binip2, binbuf, IPV6_BITSTR_LEN); if (!res) { NI_copy_Error_Errno(ipo1); return NULL; } version = NI_hv_get_iv(ipo1, "ipversion", 9); iplen = NI_iplengths(version); binbuf[iplen] = '\0'; buf[0] = '\0'; res = NI_ip_bintoip(binbuf, version, buf); if (!res) { return NULL; } hash = newHV(); ref = newRV_noinc((SV*) hash); stash = gv_stashpv("Net::IP::XS", 1); sv_bless(ref, stash); res = NI_set(ref, buf, version); if (!res) { return NULL; } return ref; }
void set_up_debug_sv(const char* name) { SV* tie_obj; HV* tie_obj_stash; // create an sv and make it a reference to another (new and empty) sv tie_obj = newSV(0); newSVrv(tie_obj, NULL); // bless the reference into the name'd class tie_obj_stash = gv_stashpv(name, TRUE); sv_bless(tie_obj, tie_obj_stash); // tie the blessed object to the name'd scalar sv_magic(get_sv(name, 1), tie_obj, PERL_MAGIC_tiedscalar, NULL, 0); }
static void tie_it(pTHX_ const char name, UV flag, HV *const stash) { GV *const gv = gv_fetchpvn(&name, 1, GV_ADDMULTI|GV_NOTQUAL, SVt_PVHV); HV *const hv = GvHV(gv); SV *rv = newSV_type(SVt_RV); SvRV_set(rv, newSVuv(flag)); SvROK_on(rv); sv_bless(rv, stash); sv_unmagic((SV *)hv, PERL_MAGIC_tied); sv_magic((SV *)hv, rv, PERL_MAGIC_tied, NULL, 0); SvREFCNT_dec(rv); /* As sv_magic increased it by one. */ }
static void * create_event_common(lcb_io_opt_t cbcio, int type) { plcb_EVENT *cevent; plcb_IOPROCS *async; SV *initproc = NULL, *tmprv = NULL; async = (plcb_IOPROCS*) cbcio->v.v0.cookie; Newxz(cevent, 1, plcb_EVENT); cevent->pl_event = newAV(); cevent->rv_event = newRV_noinc((SV*)cevent->pl_event); cevent->evtype = type; cevent->fd = -1; sv_bless(cevent->rv_event, gv_stashpv(PLCB_EVENT_CLASS, GV_ADD)); av_store(cevent->pl_event, PLCB_EVIDX_OPAQUE, newSViv(PTR2IV(cevent))); av_store(cevent->pl_event, PLCB_EVIDX_FD, newSViv(-1)); av_store(cevent->pl_event, PLCB_EVIDX_TYPE, newSViv(type)); av_store(cevent->pl_event, PLCB_EVIDX_WATCHFLAGS, newSViv(0)); tmprv = newRV_inc(*av_fetch(cevent->pl_event, PLCB_EVIDX_OPAQUE, 0)); sv_bless(tmprv, gv_stashpv("Couchbase::IO::_CEvent", GV_ADD)); SvREFCNT_dec(tmprv); if (type == PLCB_EVTYPE_IO) { initproc = async->cv_evinit; } else { initproc = async->cv_tminit; } if (initproc) { cb_args_noret(initproc, 0, 2, async->userdata, cevent->rv_event); } return cevent; }
void p5_rebless_object(PerlInterpreter *my_perl, SV *obj, char *package, IV i) { PERL_SET_CONTEXT(my_perl); { SV * const inst = SvRV(obj); HV *stash = gv_stashpv(package, GV_ADD); if (stash == NULL) croak("Perl6::Object not found!? Forgot to call init_callbacks?"); (void)sv_bless(obj, stash); _perl6_magic priv; /* set up magic */ priv.key = PERL6_MAGIC_KEY; priv.index = i; sv_magicext(inst, inst, PERL_MAGIC_ext, &p5_inline_mg_vtbl, (char *) &priv, sizeof(priv)); } }
MP_INLINE SV *modperl_newSVsv_obj(pTHX_ SV *stashsv, SV *obj) { SV *newobj; if (!obj) { obj = stashsv; stashsv = (SV *)NULL; } newobj = newSVsv(obj); if (stashsv) { HV *stash = gv_stashsv(stashsv, TRUE); return sv_bless(newobj, stash); } return newobj; }
SV * g_hash_table_to_hashref_property(GHashTable *hash) { HV *hv; HV *stash; SV *tie; hv = newHV(); tie = newRV_noinc((SV*)newHV()); stash = gv_stashpv("Amanda::Config::FoldingHash", GV_ADD); sv_bless(tie, stash); hv_magic(hv, (GV*)tie, PERL_MAGIC_tied); hv = (HV *)sv_2mortal((SV *)hv); g_hash_table_foreach(hash, foreach_fn_property, hv); return newRV((SV *)hv); }
static void Encode_XSEncoding(pTHX_ encode_t *enc) { dSP; HV *stash = gv_stashpv("Encode::XS", TRUE); SV *sv = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash); int i = 0; PUSHMARK(sp); XPUSHs(sv); while (enc->name[i]) { const char *name = enc->name[i++]; XPUSHs(sv_2mortal(newSVpvn(name,strlen(name)))); } PUTBACK; call_pv("Encode::define_encoding",G_DISCARD); SvREFCNT_dec(sv); }
void store_self(pTHX, mthread* thread) { SV *thread_sv, *self; AV* message_cache; thread_sv = newSV_type(SVt_PV); SvPVX(thread_sv) = (char*) thread; SvCUR(thread_sv) = sizeof(mthread); SvLEN(thread_sv) = 0; SvPOK_only(thread_sv); SvREADONLY_on(thread_sv); hv_store(PL_modglobal, "threads::lite::thread", 21, thread_sv, 0); self = newRV_noinc(newSVuv(thread->id)); sv_bless(self, gv_stashpv("threads::lite::tid", TRUE)); hv_store(PL_modglobal, "threads::lite::self", 19, self, 0); message_cache = newAV(); hv_store(PL_modglobal, "threads::lite::message_cache", 28, (SV*)message_cache, 0); thread->cache = message_cache; }
static void create_callback (GtkCellLayoutDataFunc func, gpointer data, GtkDestroyNotify destroy, SV **code_return, SV **data_return) { HV *stash; SV *code_sv, *data_sv; Gtk2PerlCellLayoutDataFunc *wrapper; wrapper = g_new0 (Gtk2PerlCellLayoutDataFunc, 1); wrapper->func = func; wrapper->data = data; wrapper->destroy = destroy; data_sv = newSViv (PTR2IV (wrapper)); stash = gv_stashpv ("Gtk2::CellLayout::DataFunc", TRUE); code_sv = sv_bless (newRV (data_sv), stash); *code_return = code_sv; *data_return = data_sv; }
SV * newSVGdkEvent(GdkEvent * e) { HV * h; GdkEvent * e2; SV * r; int n; if (!e) return newSVsv(&PL_sv_undef); h = newHV(); /*r = newSVMiscRef(e, "Gtk::Gdk::Event", &n);*/ /*h = (HV*)SvRV(r);*/ r = newRV((SV*)h); SvREFCNT_dec(h); sv_bless(r, gv_stashpv("Gtk::Gdk::Event", FALSE)); e2 = gdk_event_copy(e); hv_store(h, "_ptr", 4, newSViv((int)e2), 0); /*printf("Turning GdkEvent %d, type %d, into SV %d, ptr %d\n", e, e->type, r, e2);*/ hv_store(h, "type", 4, newSVGdkEventType(e->type), 0); hv_store(h, "window", 6, newSVGdkWindow(e->any.window), 0); switch (e->type) { case GDK_EXPOSE: hv_store(h, "area", 4, newSVGdkRectangle(&e->expose.area), 0); hv_store(h, "count", 5, newSViv(e->expose.count), 0); break; case GDK_MOTION_NOTIFY: hv_store(h, "is_hint", 7, newSViv(e->motion.is_hint), 0); hv_store(h, "x", 1, newSVnv(e->motion.x), 0); hv_store(h, "y", 1, newSVnv(e->motion.y), 0); hv_store(h, "pressure", 8, newSVnv(e->motion.pressure), 0); hv_store(h, "xtilt", 5, newSVnv(e->motion.xtilt), 0); hv_store(h, "ytilt", 5, newSVnv(e->motion.ytilt), 0); hv_store(h, "time", 4, newSViv(e->motion.time), 0); hv_store(h, "state", 5, newSViv(e->motion.state), 0); hv_store(h, "source", 6, newSVGdkInputSource(e->motion.source), 0); hv_store(h, "deviceid", 8, newSViv(e->motion.deviceid), 0); break; case GDK_BUTTON_PRESS: case GDK_2BUTTON_PRESS: case GDK_3BUTTON_PRESS: case GDK_BUTTON_RELEASE: hv_store(h, "x", 1, newSViv(e->button.x), 0); hv_store(h, "y", 1, newSViv(e->button.y), 0); hv_store(h, "time", 4, newSViv(e->button.time), 0); hv_store(h, "pressure", 8, newSVnv(e->motion.pressure), 0); hv_store(h, "xtilt", 5, newSVnv(e->motion.xtilt), 0); hv_store(h, "ytilt", 5, newSVnv(e->motion.ytilt), 0); hv_store(h, "state", 5, newSViv(e->button.state), 0); hv_store(h, "button", 6, newSViv(e->button.button), 0); hv_store(h, "source", 6, newSVGdkInputSource(e->motion.source), 0); hv_store(h, "deviceid", 8, newSViv(e->motion.deviceid), 0); break; case GDK_KEY_PRESS: case GDK_KEY_RELEASE: hv_store(h, "time", 4, newSViv(e->key.time), 0); hv_store(h, "state", 5, newSViv(e->key.state), 0); hv_store(h, "keyval", 6, newSViv(e->key.keyval), 0); break; case GDK_FOCUS_CHANGE: hv_store(h, "in", 2, newSViv(e->focus_change.in), 0); break; case GDK_ENTER_NOTIFY: case GDK_LEAVE_NOTIFY: hv_store(h, "window", 6, newSVGdkWindow(e->crossing.window), 0); hv_store(h, "subwindow", 9, newSVGdkWindow(e->crossing.subwindow), 0); hv_store(h, "detail", 6, newSVGdkNotifyType(e->crossing.detail), 0); break; case GDK_CONFIGURE: hv_store(h, "x", 1, newSViv(e->configure.x), 0); hv_store(h, "y", 1, newSViv(e->configure.y), 0); hv_store(h, "width", 5, newSViv(e->configure.width), 0); hv_store(h, "height", 6, newSViv(e->configure.height), 0); break; case GDK_PROPERTY_NOTIFY: hv_store(h, "time", 4, newSViv(e->property.time), 0); hv_store(h, "state", 5, newSViv(e->property.state), 0); hv_store(h, "atom", 4, newSVGdkAtom(e->property.atom), 0); break; case GDK_SELECTION_CLEAR: case GDK_SELECTION_REQUEST: case GDK_SELECTION_NOTIFY: hv_store(h, "requestor", 9, newSViv(e->selection.requestor), 0); hv_store(h, "time", 4, newSViv(e->selection.time), 0); hv_store(h, "selection", 9, newSVGdkAtom(e->selection.selection), 0); hv_store(h, "property", 8, newSVGdkAtom(e->selection.property), 0); break; case GDK_PROXIMITY_IN: case GDK_PROXIMITY_OUT: hv_store(h, "time", 4, newSViv(e->proximity.time), 0); hv_store(h, "source", 6, newSVGdkInputSource(e->motion.source), 0); hv_store(h, "deviceid", 8, newSViv(e->motion.deviceid), 0); break; } return r; }
static SV *bless(pTHX_ HV *self, const char *classname) { HV *stash = (HV *)gv_stashpv(classname, strlen(classname) + 1); return sv_bless(new_Ref(self), stash); }
int perl_trapd_handler( netsnmp_pdu *pdu, netsnmp_transport *transport, netsnmp_trapd_handler *handler) { trapd_cb_data *cb_data; SV *pcallback; netsnmp_variable_list *vb; netsnmp_oid *o; SV *arg; SV *rarg; SV **tmparray; int i, c = 0; u_char *outbuf; size_t ob_len = 0, oo_len = 0; AV *varbinds; HV *pduinfo; dSP; ENTER; SAVETMPS; if (!pdu || !handler) return 0; /* nuke v1 PDUs */ if (pdu->command == SNMP_MSG_TRAP) pdu = convert_v1pdu_to_v2(pdu); cb_data = handler->handler_data; if (!cb_data || !cb_data->perl_cb) return 0; pcallback = cb_data->perl_cb; /* get PDU related info */ pduinfo = newHV(); #define STOREPDU(n, v) hv_store(pduinfo, n, strlen(n), v, 0) #define STOREPDUi(n, v) STOREPDU(n, newSViv(v)) #define STOREPDUs(n, v) STOREPDU(n, newSVpv(v, 0)) STOREPDUi("version", pdu->version); STOREPDUs("notificationtype", ((pdu->command == SNMP_MSG_INFORM) ? "INFORM":"TRAP")); STOREPDUi("requestid", pdu->reqid); STOREPDUi("messageid", pdu->msgid); STOREPDUi("transactionid", pdu->transid); STOREPDUi("errorstatus", pdu->errstat); STOREPDUi("errorindex", pdu->errindex); if (pdu->version == 3) { STOREPDUi("securitymodel", pdu->securityModel); STOREPDUi("securitylevel", pdu->securityLevel); STOREPDU("contextName", newSVpv(pdu->contextName, pdu->contextNameLen)); STOREPDU("contextEngineID", newSVpv(pdu->contextEngineID, pdu->contextEngineIDLen)); STOREPDU("securityEngineID", newSVpv(pdu->securityEngineID, pdu->securityEngineIDLen)); STOREPDU("securityName", newSVpv(pdu->securityName, pdu->securityNameLen)); } else { STOREPDU("community", newSVpv(pdu->community, pdu->community_len)); } if (transport && transport->f_fmtaddr) { char *tstr = transport->f_fmtaddr(transport, pdu->transport_data, pdu->transport_data_length); STOREPDUs("receivedfrom", tstr); free(tstr); } /* * collect OID objects in a temp array first */ /* get VARBIND related info */ i = count_varbinds(pdu->variables); tmparray = malloc(sizeof(*tmparray) * i); for(vb = pdu->variables; vb; vb = vb->next_variable) { /* get the oid */ o = SNMP_MALLOC_TYPEDEF(netsnmp_oid); o->name = o->namebuf; o->len = vb->name_length; memcpy(o->name, vb->name, vb->name_length * sizeof(oid)); #undef CALL_EXTERNAL_OID_NEW #ifdef CALL_EXTERNAL_OID_NEW PUSHMARK(sp); rarg = sv_2mortal(newSViv((IV) 0)); arg = sv_2mortal(newSVrv(rarg, "netsnmp_oidPtr")); sv_setiv(arg, (IV) o); XPUSHs(rarg); PUTBACK; i = perl_call_pv("NetSNMP::OID::newwithptr", G_SCALAR); SPAGAIN; if (i != 1) { snmp_log(LOG_ERR, "unhandled OID error.\n"); /* ack XXX */ } /* get the value */ tmparray[c++] = POPs; SvREFCNT_inc(tmparray[c-1]); PUTBACK; #else /* build it and bless ourselves */ { HV *hv = newHV(); SV *rv = newRV_noinc((SV *) hv); SV *rvsub = newRV_noinc((SV *) newSViv((UV) o)); SV *sv; rvsub = sv_bless(rvsub, gv_stashpv("netsnmp_oidPtr", 1)); hv_store(hv, "oidptr", 6, rvsub, 0); rv = sv_bless(rv, gv_stashpv("NetSNMP::OID", 1)); tmparray[c++] = rv; } #endif /* build oid ourselves */ } /* * build the varbind lists */ varbinds = newAV(); for(vb = pdu->variables, i = 0; vb; vb = vb->next_variable, i++) { /* push the oid */ AV *vba; vba = newAV(); /* get the value */ outbuf = NULL; ob_len = 0; oo_len = 0; sprint_realloc_by_type(&outbuf, &ob_len, &oo_len, 1, vb, 0, 0, 0); av_push(vba,tmparray[i]); av_push(vba,newSVpvn(outbuf, oo_len)); free(outbuf); av_push(vba,newSViv(vb->type)); av_push(varbinds, (SV *) newRV_noinc((SV *) vba)); } PUSHMARK(sp); /* store the collected information on the stack */ XPUSHs(sv_2mortal(newRV_noinc((SV*) pduinfo))); XPUSHs(sv_2mortal(newRV_noinc((SV*) varbinds))); /* put the stack back in order */ PUTBACK; /* actually call the callback function */ if (SvTYPE(pcallback) == SVt_PVCV) { perl_call_sv(pcallback, G_DISCARD); /* XXX: it discards the results, which isn't right */ } else if (SvROK(pcallback) && SvTYPE(SvRV(pcallback)) == SVt_PVCV) { /* reference to code */ perl_call_sv(SvRV(pcallback), G_DISCARD); } else { snmp_log(LOG_ERR, " tried to call a perl function but failed to understand its type: (ref = %x, svrok: %lu, SVTYPE: %lu)\n", (uintptr_t)pcallback, SvROK(pcallback), SvTYPE(pcallback)); } #ifdef DUMPIT fprintf(stderr, "DUMPDUMPDUMPDUMPDUMPDUMP\n"); sv_dump(pduinfo); fprintf(stderr, "--------------------\n"); sv_dump(varbinds); #endif /* svREFCNT_dec((SV *) pduinfo); */ #ifdef NOT_THIS { SV *vba; while(vba = av_pop(varbinds)) { av_undef((AV *) vba); } } av_undef(varbinds); #endif free(tmparray); /* Not needed because of the G_DISCARD flag (I think) */ /* SPAGAIN; */ /* PUTBACK; */ #ifndef __x86_64__ FREETMPS; /* FIXME: known to cause a segfault on x86-64 */ #endif LEAVE; return NETSNMPTRAPD_HANDLER_OK; }
static ngx_int_t ngx_http_perl_call_handler(pTHX_ ngx_http_request_t *r, HV *nginx, SV *sub, SV **args, ngx_str_t *handler, ngx_str_t *rv) { SV *sv; int n, status; char *line; STRLEN len, n_a; ngx_str_t err; ngx_uint_t i; ngx_connection_t *c; dSP; status = 0; ENTER; SAVETMPS; PUSHMARK(sp); sv = sv_2mortal(sv_bless(newRV_noinc(newSViv(PTR2IV(r))), nginx)); XPUSHs(sv); if (args) { EXTEND(sp, (intptr_t) args[0]); for (i = 1; i <= (ngx_uint_t) args[0]; i++) { PUSHs(sv_2mortal(args[i])); } } PUTBACK; c = r->connection; n = call_sv(sub, G_EVAL); SPAGAIN; if (c->destroyed) { PUTBACK; FREETMPS; LEAVE; return NGX_DONE; } if (n) { if (rv == NULL) { status = POPi; ngx_log_debug1(NGX_LOG_DEBUG_HTTP, c->log, 0, "call_sv: %d", status); } else { line = SvPVx(POPs, n_a); rv->len = n_a; rv->data = ngx_pnalloc(r->pool, n_a); if (rv->data == NULL) { return NGX_ERROR; } ngx_memcpy(rv->data, line, n_a); } } PUTBACK; FREETMPS; LEAVE; /* check $@ */ if (SvTRUE(ERRSV)) { err.data = (u_char *) SvPV(ERRSV, len); for (len--; err.data[len] == LF || err.data[len] == CR; len--) { /* void */ } err.len = len + 1; ngx_log_error(NGX_LOG_ERR, c->log, 0, "call_sv(\"%V\") failed: \"%V\"", handler, &err); if (rv) { return NGX_ERROR; } return NGX_HTTP_INTERNAL_SERVER_ERROR; } if (n != 1) { ngx_log_error(NGX_LOG_ALERT, c->log, 0, "call_sv(\"%V\") returned %d results", handler, n); status = NGX_OK; } if (rv) { return NGX_OK; } return (ngx_int_t) status; }
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)); } }