static void modify_event_perl(PLCBA_t *async, PLCBA_c_event *cevent, PLCBA_evaction_t action, short flags) { SV **tmpsv; tmpsv = av_fetch(cevent->pl_event, PLCBA_EVIDX_FD, 1); if (SvIOK(*tmpsv)) { if (SvIV(*tmpsv) != cevent->fd) { /*file descriptor mismatch!*/ av_delete(cevent->pl_event, PLCBA_EVIDX_DUPFH, G_DISCARD); } } else { sv_setiv(*tmpsv, cevent->fd); } plcb_call_sv_with_args_noret(async->cv_evmod, 1, 3, newRV_inc( (SV*)(cevent->pl_event)), newSViv(action), newSViv(flags)); /*set the current flags*/ if (action != PLCBA_EVACTION_SUSPEND && action != PLCBA_EVACTION_RESUME) { sv_setiv( *(av_fetch(cevent->pl_event, PLCBA_EVIDX_WATCHFLAGS, 1)), flags); } /*set the current state*/ sv_setiv( *(av_fetch(cevent->pl_event, PLCBA_EVIDX_STATEFLAGS, 1)), cevent->state); }
SV * PLCBA_construct(const char *pkg, AV *options) { PLCBA_t *async; char *host, *username, *password, *bucket; libcouchbase_t instance; SV *blessed_obj; Newxz(async, 1, PLCBA_t); extract_async_options(async, options); plcb_ctor_conversion_opts(&async->base, options); plcb_ctor_cbc_opts(options, &host, &username, &password, &bucket); instance = libcouchbase_create(host, username, password, bucket, plcba_make_io_opts(async)); if(!instance) { die("Couldn't create instance!"); } plcb_ctor_init_common(&async->base, instance, options); plcba_setup_callbacks(async); async->base_rv = newRV_inc(newSViv(PTR2IV(&(async->base)))); blessed_obj = newSV(0); sv_setiv(newSVrv(blessed_obj, pkg), PTR2IV(async)); return blessed_obj; }
SV* newPerlPyObject_noinc(PyObject *pyo) { SV* rv; SV* sv; MAGIC *mg; dCTXP; ASSERT_LOCK_PERL; if (!pyo) croak("Missing pyo reference argument"); rv = newSV(0); sv = newSVrv(rv, "Python::Object"); sv_setiv(sv, (IV)pyo); sv_magic(sv, 0, '~', 0, 0); mg = mg_find(sv, '~'); if (!mg) { SvREFCNT_dec(rv); croak("Can't assign magic to Python::Object"); } mg->mg_virtual = &vtbl_free_pyo; SvREADONLY(sv); #ifdef REF_TRACE printf("Bind pyo %p\n", pyo); #endif ASSERT_LOCK_PERL; return rv; }
static void S_lazy_init_host_obj(kino_Obj *self) { SV *inner_obj = newSV(0); SvOBJECT_on(inner_obj); PL_sv_objcount++; SvUPGRADE(inner_obj, SVt_PVMG); sv_setiv(inner_obj, PTR2IV(self)); // Connect class association. kino_CharBuf *class_name = Kino_VTable_Get_Name(self->vtable); HV *stash = gv_stashpvn((char*)Kino_CB_Get_Ptr8(class_name), Kino_CB_Get_Size(class_name), TRUE); SvSTASH_set(inner_obj, (HV*)SvREFCNT_inc(stash)); /* Up till now we've been keeping track of the refcount in * self->ref.count. We're replacing ref.count with ref.host_obj, which * will assume responsibility for maintaining the refcount. ref.host_obj * starts off with a refcount of 1, so we need to transfer any refcounts * in excess of that. */ size_t old_refcount = self->ref.count; self->ref.host_obj = inner_obj; while (old_refcount > 1) { SvREFCNT_inc_simple_void_NN(inner_obj); old_refcount--; } }
static void modify_event_perl(plcb_IOPROCS *async, plcb_EVENT *cevent, short flags) { SV **tmpsv; tmpsv = av_fetch(cevent->pl_event, PLCB_EVIDX_FD, 1); if (SvIOK(*tmpsv)) { SvIVX(*tmpsv) = cevent->fd; } else { sv_setiv(*tmpsv, cevent->fd); } SvIVX(async->flags_sv) = flags; /* Figure out the proper masks */ SvIVX(async->sched_r_sv) = flags & LCB_READ_EVENT && (cevent->flags & LCB_READ_EVENT) == 0; SvIVX(async->sched_w_sv) = flags & LCB_WRITE_EVENT && (cevent->flags & LCB_WRITE_EVENT) == 0; SvIVX(async->stop_r_sv) = (flags & LCB_READ_EVENT) == 0 && cevent->flags & LCB_READ_EVENT; SvIVX(async->stop_w_sv) = (flags & LCB_WRITE_EVENT) == 0 && cevent->flags & LCB_WRITE_EVENT; cb_args_noret(async->cv_evmod, 0, 7, async->userdata, cevent->rv_event, async->flags_sv, async->sched_r_sv, async->sched_w_sv, async->stop_r_sv, async->stop_w_sv); cevent->flags = flags; tmpsv = av_fetch(cevent->pl_event, PLCB_EVIDX_WATCHFLAGS, 1); SvIVX(*tmpsv) = cevent->flags; }
static void init_help_consts (void) { /* Export our constants as global variables. */ const struct { const char *name; int value; } consts[] = { { "GNM_FUNC_HELP_NAME", GNM_FUNC_HELP_NAME }, { "GNM_FUNC_HELP_ARG", GNM_FUNC_HELP_ARG }, { "GNM_FUNC_HELP_DESCRIPTION", GNM_FUNC_HELP_DESCRIPTION }, { "GNM_FUNC_HELP_NOTE", GNM_FUNC_HELP_NOTE }, { "GNM_FUNC_HELP_EXAMPLES", GNM_FUNC_HELP_EXAMPLES }, { "GNM_FUNC_HELP_SEEALSO", GNM_FUNC_HELP_SEEALSO }, { "GNM_FUNC_HELP_EXTREF", GNM_FUNC_HELP_EXTREF }, { "GNM_FUNC_HELP_EXCEL", GNM_FUNC_HELP_EXCEL }, { "GNM_FUNC_HELP_ODF", GNM_FUNC_HELP_ODF } }; unsigned ui; for (ui = 0; ui < G_N_ELEMENTS (consts); ui++) { SV* x = get_sv (consts[ui].name, TRUE); sv_setiv (x, consts[ui].value); } }
static int xsDecode(HV* hv, AV* av, SV* src, bool useIO) { csv_t csv; int result; SetupCsv(&csv, hv); if ((csv.useIO = useIO)) { csv.tmp = NULL; csv.size = 0; } else { STRLEN size; csv.tmp = src; csv.bptr = SvPV(src, size); csv.size = size; } result = Decode(&csv, src, av); if (result && csv.types) { I32 i, len = av_len(av); SV** svp; for (i = 0; i <= len && i <= csv.types_len; i++) { if ((svp = av_fetch(av, i, 0)) && *svp && SvOK(*svp)) { switch (csv.types[i]) { case CSV_XS_TYPE_IV: sv_setiv(*svp, SvIV(*svp)); break; case CSV_XS_TYPE_NV: sv_setnv(*svp, SvIV(*svp)); break; } } } } return result; }
ngx_int_t ngx_http_psgi_perl_init_worker(ngx_cycle_t *cycle) { ngx_http_psgi_main_conf_t *psgimcf = ngx_http_cycle_get_module_main_conf(cycle, ngx_http_psgi_module); ngx_log_debug1(NGX_LOG_DEBUG_HTTP, cycle->log, 0, "Init Perl interpreter in worker %d", ngx_pid); if (psgimcf) { dTHXa(psgimcf->perl); PERL_SET_CONTEXT(psgimcf->perl); /* FIXME: It looks very wrong. * Has new worker it's own Perl instance? * I think I should perl_clone() or something like that * Also $0 (script path) should be set somewhere. * I don't think it's right place for it. It should be done somewhere in local conf init stuff * Or, if many handlers share single Perl interpreter - before each handler call * * TODO * Test PID and related stuff * Test what happens if user try to change * Test what happens if user does 'fork' inside PSGI app */ sv_setiv(GvSV(gv_fetchpv("$$", TRUE, SVt_PV)), (I32) ngx_pid); } else { ngx_log_error(NGX_LOG_ALERT, cycle->log, 0, "PSGI panic: no main configuration supplied for init worker %d", ngx_pid); return NGX_ERROR; } return NGX_OK; }
SV* P_newSVqv2(pTHX_ int i, const char* (*func)(int i,int* len)){ int len; const char* s=(*func)(i,&len); SV* m=newSVpv(s,len); sv_setiv(m,i); SvPOK_on(m); return m; }
void decode_tinyint(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { if (UNLIKELY(len != 1)) croak("decode_tinyint: len != 1"); int8_t number = *input; sv_setiv(output, number); }
int IntToScalar(PERL_CALL SV *string, int val) { if(!string) return 0; sv_setiv(string, val); return 1; }
/* * 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); }
void decode_int(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { union { unsigned char bytes[4]; int32_t i; } bytes_or_int; if (UNLIKELY(len != 4)) croak("decode_int: len != 4"); memcpy(bytes_or_int.bytes, input, 4); bswap4(bytes_or_int.bytes); sv_setiv(output, bytes_or_int.i); }
void decode_bigint(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { union { unsigned char bytes[8]; int64_t bigint; } bytes_or_bigint; if (UNLIKELY(len != 8)) croak("decode_bigint: len != 8"); memcpy(bytes_or_bigint.bytes, input, 8); bswap8(bytes_or_bigint.bytes); sv_setiv(output, bytes_or_bigint.bigint); }
void decode_smallint(pTHX_ unsigned char *input, STRLEN len, struct cc_type *type, SV *output) { union { unsigned char bytes[2]; int16_t i; } bytes_or_smallint; if (UNLIKELY(len != 2)) croak("decode_smallint: len != 2"); memcpy(bytes_or_smallint.bytes, input, 2); bswap2(bytes_or_smallint.bytes); sv_setiv(output, bytes_or_smallint.i); }
static ngx_int_t ngx_http_perl_init_worker(ngx_cycle_t *cycle) { ngx_http_perl_main_conf_t *pmcf; pmcf = ngx_http_cycle_get_module_main_conf(cycle, ngx_http_perl_module); if (pmcf) { dTHXa(pmcf->perl); PERL_SET_CONTEXT(pmcf->perl); /* set worker's $$ */ sv_setiv(GvSV(gv_fetchpv("$", TRUE, SVt_PV)), (I32) ngx_pid); } return NGX_OK; }
void Perl_av_extend(pTHX_ AV *av, SSize_t key) { MAGIC *mg; PERL_ARGS_ASSERT_AV_EXTEND; assert(SvTYPE(av) == SVt_PVAV); mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (UNLIKELY(mg)) { SV *arg1 = sv_newmortal(); sv_setiv(arg1, (IV)(key + 1)); Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, arg1); return; } av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); }
SV * ithread_to_SV(pTHX_ SV *obj, ithread *thread, char *classname, bool inc) { SV *sv; MAGIC *mg; if (inc) { MUTEX_LOCK(&thread->mutex); thread->count++; MUTEX_UNLOCK(&thread->mutex); } if (!obj) obj = newSV(0); sv = newSVrv(obj,classname); sv_setiv(sv,PTR2IV(thread)); mg = sv_magicext(sv,Nullsv,PERL_MAGIC_shared_scalar,&ithread_vtbl,(char *)thread,0); mg->mg_flags |= MGf_DUP; SvREADONLY_on(sv); return obj; }
PJS_EXTERN SV * PJS_CallPerlMethod( pTHX_ JSContext *cx, const char *method, ... ) { dSP; va_list ap; SV *arg, *ret; PJS_Context *pcx = PJS_GET_CONTEXT(cx); ENTER; SAVETMPS; PUSHMARK(SP); sv_setiv(save_scalar(PJS_Context_SV), PTR2IV(pcx)); va_start(ap, method); while( (arg = va_arg(ap, SV*)) ) XPUSHs(arg); va_end(ap); PUTBACK; call_method(method, G_SCALAR | G_EVAL); ret = newSVsv(*PL_stack_sp--); FREETMPS; LEAVE; if (SvTRUE(ERRSV)) { sv_free(ret); // Don't want leaks propagate2JS(aTHX_ pcx, NULL); return NULL; } return sv_2mortal(ret); }
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; }
PJS_EXTERN JSBool PJS_Call_sv_with_jsvals_rsv( pTHX_ JSContext *cx, JSObject *obj, SV *code, SV *caller, /* Will be disposed inside */ uintN argc, jsval *argv, SV **rsv, I32 flag ) { dSP; JSBool ok = JS_TRUE; uintN arg; I32 rcount = caller ? 1 : 0; PJS_Context *pcx = PJS_GET_CONTEXT(cx); if(SvROK(code) && SvTYPE(SvRV(code)) == SVt_PVCV) { ENTER; SAVETMPS; PUSHMARK(SP) ; sv_setiv(save_scalar(PJS_Context_SV), PTR2IV(pcx)); EXTEND(SP, argc + rcount); PUTBACK; /* From here we are working with the global stack, * a) at PUSH time we can fail, so we need to abort the call * b) Want to avoid copying local <=> global SP at every single PUSH * * Before 'call_sv', rcount is the number of SVs pushed so far */ if(caller) *++PL_stack_sp = sv_2mortal(caller); if(argv && !(flag & G_NOARGS)) { /* HACK: We use G_NOARGS as a guard against use argv[-1] to get This. * Needed for the use in PJS_invoke_perl_property_setter where given * argc is faked */ SV *This; ok = PJS_ReflectJS2Perl(aTHX_ cx, argv[-1], &This, 0); if(ok) sv_setsv(save_scalar(PJS_This), sv_2mortal(This)); else goto forget; } else flag &= ~G_NOARGS; for(arg = 0; arg < argc; arg++) { SV *sv; ok = PJS_ReflectJS2Perl(aTHX_ cx, argv[arg], &sv, 1); if(!ok) { rcount += arg; goto forget; } *++PL_stack_sp = sv_2mortal(sv); } rcount = call_sv(code, flag | G_EVAL); if(rsv) { if(flag == G_SCALAR || rcount == 1) *rsv = SvREFCNT_inc_simple_NN(*PL_stack_sp); else *rsv = newRV((SV *)av_make(rcount, PL_stack_sp-rcount+1)); SAVEMORTALIZESV(*rsv); } forget: PL_stack_sp -= rcount; FREETMPS; LEAVE; if(ok && SvTRUE(ERRSV)) { propagate2JS(aTHX_ pcx, obj); ok = JS_FALSE; } } else croak("Not a coderef"); return ok; }
/**************************** * SV* Py2Pl(PyObject *obj) * * Converts arbitrary Python data structures to Perl data structures * Note on references: does not Py_DECREF(obj). * * Modifications by Eric Wilhelm 2004-07-11 marked as elw * ****************************/ SV *Py2Pl(PyObject * const obj) { /* elw: see what python says things are */ #if PY_MAJOR_VERSION >= 3 int const is_string = PyBytes_Check(obj) || PyUnicode_Check(obj); #else int const is_string = PyString_Check(obj) || PyUnicode_Check(obj); #endif #ifdef I_PY_DEBUG PyObject *this_type = PyObject_Type(obj); /* new reference */ PyObject *t_string = PyObject_Str(this_type); /* new reference */ #if PY_MAJOR_VERSION >= 3 PyObject *type_str_bytes = PyUnicode_AsUTF8String(t_string); /* new reference */ char *type_str = PyBytes_AsString(type_str_bytes); #else char *type_str = PyString_AsString(t_string); #endif Printf(("type is %s\n", type_str)); printf("Py2Pl object:\n\t"); PyObject_Print(obj, stdout, Py_PRINT_RAW); printf("\ntype:\n\t"); PyObject_Print(this_type, stdout, Py_PRINT_RAW); printf("\n"); Printf(("String check: %i\n", is_string)); Printf(("Number check: %i\n", PyNumber_Check(obj))); Printf(("Int check: %i\n", PyInt_Check(obj))); Printf(("Long check: %i\n", PyLong_Check(obj))); Printf(("Float check: %i\n", PyFloat_Check(obj))); Printf(("Type check: %i\n", PyType_Check(obj))); #if PY_MAJOR_VERSION < 3 Printf(("Class check: %i\n", PyClass_Check(obj))); Printf(("Instance check: %i\n", PyInstance_Check(obj))); #endif Printf(("Dict check: %i\n", PyDict_Check(obj))); Printf(("Mapping check: %i\n", PyMapping_Check(obj))); Printf(("Sequence check: %i\n", PySequence_Check(obj))); Printf(("Iter check: %i\n", PyIter_Check(obj))); Printf(("Function check: %i\n", PyFunction_Check(obj))); Printf(("Module check: %i\n", PyModule_Check(obj))); Printf(("Method check: %i\n", PyMethod_Check(obj))); #if PY_MAJOR_VERSION < 3 if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE)) printf("heaptype true\n"); if ((obj->ob_type->tp_flags & Py_TPFLAGS_HAVE_CLASS)) printf("has class\n"); #else Py_DECREF(type_str_bytes); #endif Py_DECREF(t_string); Py_DECREF(this_type); #endif /* elw: this needs to be early */ /* None (like undef) */ if (!obj || obj == Py_None) { Printf(("Py2Pl: Py_None\n")); return &PL_sv_undef; } else #ifdef EXPOSE_PERL /* unwrap Perl objects */ if (PerlObjObject_Check(obj)) { Printf(("Py2Pl: Obj_object\n")); return ((PerlObj_object *) obj)->obj; } /* unwrap Perl code refs */ else if (PerlSubObject_Check(obj)) { Printf(("Py2Pl: Sub_object\n")); SV * ref = ((PerlSub_object *) obj)->ref; if (! ref) { /* probably an inherited method */ if (! ((PerlSub_object *) obj)->obj) croak("Error: could not find a code reference or object method for PerlSub"); SV * const sub_obj = (SV*)SvRV(((PerlSub_object *) obj)->obj); HV * const pkg = SvSTASH(sub_obj); #if PY_MAJOR_VERSION >= 3 char * const sub = PyBytes_AsString(((PerlSub_object *) obj)->sub); #else PyObject *obj_sub_str = PyObject_Str(((PerlSub_object *) obj)->sub); /* new ref. */ char * const sub = PyString_AsString(obj_sub_str); #endif GV * const gv = Perl_gv_fetchmethod_autoload(aTHX_ pkg, sub, TRUE); if (gv && isGV(gv)) { ref = (SV *)GvCV(gv); } #if PY_MAJOR_VERSION < 3 Py_DECREF(obj_sub_str); #endif } return newRV_inc((SV *) ref); } else #endif /* wrap an instance of a Python class */ /* elw: here we need to make these look like instances: */ if ((obj->ob_type->tp_flags & Py_TPFLAGS_HEAPTYPE) #if PY_MAJOR_VERSION < 3 || PyInstance_Check(obj) #endif ) { /* This is a Python class instance -- bless it into an * Inline::Python::Object. If we're being called from an * Inline::Python class, it will be re-blessed into whatever * class that is. */ SV * const inst_ptr = newSViv(0); SV * const inst = newSVrv(inst_ptr, "Inline::Python::Object");; _inline_magic priv; /* set up magic */ priv.key = INLINE_MAGIC_KEY; sv_magic(inst, inst, PERL_MAGIC_ext, (char *) &priv, sizeof(priv)); MAGIC * const mg = mg_find(inst, PERL_MAGIC_ext); mg->mg_virtual = &inline_mg_vtbl; sv_setiv(inst, (IV) obj); /*SvREADONLY_on(inst); */ /* to uncomment this means I can't re-bless it */ Py_INCREF(obj); Printf(("Py2Pl: Instance. Obj: %p, inst_ptr: %p\n", obj, inst_ptr)); sv_2mortal(inst_ptr); return inst_ptr; } /* a tuple or a list */ else if (PySequence_Check(obj) && !is_string) { AV * const retval = newAV(); int i; int const sz = PySequence_Length(obj); Printf(("sequence (%i)\n", sz)); for (i = 0; i < sz; i++) { PyObject * const tmp = PySequence_GetItem(obj, i); /* new reference */ SV * const next = Py2Pl(tmp); av_push(retval, next); if (sv_isobject(next)) // needed because objects get mortalized in Py2Pl SvREFCNT_inc(next); Py_DECREF(tmp); } if (PyTuple_Check(obj)) { _inline_magic priv; priv.key = TUPLE_MAGIC_KEY; sv_magic((SV * const)retval, (SV * const)NULL, PERL_MAGIC_ext, (char *) &priv, sizeof(priv)); } return newRV_noinc((SV *) retval); } /* a dictionary or fake Mapping object */ /* elw: PyMapping_Check() now returns true for strings */ else if (! is_string && PyMapping_Check(obj)) { HV * const retval = newHV(); int i; int const sz = PyMapping_Length(obj); PyObject * const keys = PyMapping_Keys(obj); /* new reference */ PyObject * const vals = PyMapping_Values(obj); /* new reference */ Printf(("Py2Pl: dict/map\n")); Printf(("mapping (%i)\n", sz)); for (i = 0; i < sz; i++) { PyObject * const key = PySequence_GetItem(keys, i), /* new reference */ * const val = PySequence_GetItem(vals, i); /* new reference */ SV * const sv_val = Py2Pl(val); char * key_val; if (PyUnicode_Check(key)) { PyObject * const utf8_string = PyUnicode_AsUTF8String(key); /* new reference */ #if PY_MAJOR_VERSION >= 3 key_val = PyBytes_AsString(utf8_string); SV * const utf8_key = newSVpv(key_val, PyBytes_Size(utf8_string)); #else key_val = PyString_AsString(utf8_string); SV * const utf8_key = newSVpv(key_val, PyString_Size(utf8_string)); #endif SvUTF8_on(utf8_key); hv_store_ent(retval, utf8_key, sv_val, 0); Py_DECREF(utf8_string); } else { PyObject * s = NULL; #if PY_MAJOR_VERSION >= 3 PyObject * s_bytes = NULL; if (PyBytes_Check(key)) { key_val = PyBytes_AsString(key); #else if (PyString_Check(key)) { key_val = PyString_AsString(key); #endif } else { /* Warning -- encountered a non-string key value while converting a * Python dictionary into a Perl hash. Perl can only use strings as * key values. Using Python's string representation of the key as * Perl's key value. */ s = PyObject_Str(key); /* new reference */ #if PY_MAJOR_VERSION >= 3 s_bytes = PyUnicode_AsUTF8String(s); /* new reference */ key_val = PyBytes_AsString(s_bytes); #else key_val = PyString_AsString(s); #endif Py_DECREF(s); if (PL_dowarn) warn("Stringifying non-string hash key value: '%s'", key_val); } if (!key_val) { croak("Invalid key on key %i of mapping\n", i); } hv_store(retval, key_val, strlen(key_val), sv_val, 0); #if PY_MAJOR_VERSION >= 3 Py_XDECREF(s_bytes); #endif Py_XDECREF(s); } if (sv_isobject(sv_val)) // needed because objects get mortalized in Py2Pl SvREFCNT_inc(sv_val); Py_DECREF(key); Py_DECREF(val); } Py_DECREF(keys); Py_DECREF(vals); return newRV_noinc((SV *) retval); } /* a boolean */ else if (PyBool_Check(obj)) {
void Tcl_SetBooleanObj (Tcl_Obj *objPtr, int value) { dTHX; sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value != 0); }
SV* P_newSVqv(pTHX_ const char* s, int i){ SV* m=newSVpv(s,strlen(s)); sv_setiv(m,i); SvPOK_on(m); return m; }
void Tcl_SetIntObj (Tcl_Obj *objPtr, int value) { dTHX; sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value); }
void Tcl_SetLongObj (Tcl_Obj *objPtr, long value) { dTHX; sv_setiv(ForceScalarLvalue(aTHX_ objPtr),value); }
SV* P_newSVqvn(pTHX_ const char* s, STRLEN len, int i){ SV* m=newSVpv(s,len); sv_setiv(m,i); SvPOK_on(m); return m; }
void ffi_pl_closure_call(ffi_cif *ffi_cif, void *result, void **arguments, void *user) { dSP; ffi_pl_closure *closure = (ffi_pl_closure*) user; ffi_pl_type_extra_closure *extra = &closure->type->extra[0].closure; int flags = extra->flags; int i; int count; SV *sv; SV **svp; if(!(flags & G_NOARGS)) { ENTER; SAVETMPS; } PUSHMARK(SP); if(!(flags & G_NOARGS)) { for(i=0; i< ffi_cif->nargs; i++) { if(extra->argument_types[i]->platypus_type == FFI_PL_NATIVE) { switch(extra->argument_types[i]->ffi_type->type) { case FFI_TYPE_VOID: break; case FFI_TYPE_UINT8: sv = sv_newmortal(); sv_setuv(sv, *((uint8_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_SINT8: sv = sv_newmortal(); sv_setiv(sv, *((int8_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_UINT16: sv = sv_newmortal(); sv_setuv(sv, *((uint16_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_SINT16: sv = sv_newmortal(); sv_setiv(sv, *((int16_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_UINT32: sv = sv_newmortal(); sv_setuv(sv, *((uint32_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_SINT32: sv = sv_newmortal(); sv_setiv(sv, *((int32_t*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_UINT64: sv = sv_newmortal(); #ifdef HAVE_IV_IS_64 sv_setuv(sv, *((uint64_t*)arguments[i])); #else sv_setu64(sv, *((uint64_t*)arguments[i])); #endif XPUSHs(sv); break; case FFI_TYPE_SINT64: sv = sv_newmortal(); #ifdef HAVE_IV_IS_64 sv_setiv(sv, *((int64_t*)arguments[i])); #else sv_seti64(sv, *((int64_t*)arguments[i])); #endif XPUSHs(sv); break; case FFI_TYPE_FLOAT: sv = sv_newmortal(); sv_setnv(sv, *((float*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_DOUBLE: sv = sv_newmortal(); sv_setnv(sv, *((double*)arguments[i])); XPUSHs(sv); break; case FFI_TYPE_POINTER: sv = sv_newmortal(); if( *((void**)arguments[i]) != NULL) sv_setiv(sv, PTR2IV( *((void**)arguments[i]) )); XPUSHs(sv); break; } } else if(extra->argument_types[i]->platypus_type == FFI_PL_STRING) { sv = sv_newmortal(); if( *((char**)arguments[i]) != NULL) { if(extra->argument_types[i]->extra[0].string.platypus_string_type == FFI_PL_STRING_FIXED) sv_setpvn(sv, *((char**)arguments[i]), extra->argument_types[i]->extra[0].string.size); else sv_setpv(sv, *((char**)arguments[i])); } XPUSHs(sv); } } PUTBACK; } svp = hv_fetch((HV *)SvRV((SV *)closure->coderef), "code", 4, 0); if (svp) count = call_sv(*svp, flags | G_EVAL); else count = 0; if(SvTRUE(ERRSV)) { #ifdef warn_sv warn_sv(ERRSV); #else warn("%s", SvPV_nolen(ERRSV)); #endif } if(!(flags & G_DISCARD)) { SPAGAIN; if(count != 1) sv = &PL_sv_undef; else sv = POPs; if(extra->return_type->platypus_type == FFI_PL_NATIVE) { switch(extra->return_type->ffi_type->type) { case FFI_TYPE_UINT8: #ifdef FFI_PL_PROBE_BIGENDIAN ((uint8_t*)result)[3] = SvUV(sv); #else *((uint8_t*)result) = SvUV(sv); #endif break; case FFI_TYPE_SINT8: #ifdef FFI_PL_PROBE_BIGENDIAN ((int8_t*)result)[3] = SvIV(sv); #else *((int8_t*)result) = SvIV(sv); #endif break; case FFI_TYPE_UINT16: #ifdef FFI_PL_PROBE_BIGENDIAN ((uint16_t*)result)[1] = SvUV(sv); #else *((uint16_t*)result) = SvUV(sv); #endif break; case FFI_TYPE_SINT16: #ifdef FFI_PL_PROBE_BIGENDIAN ((int16_t*)result)[1] = SvIV(sv); #else *((int16_t*)result) = SvIV(sv); #endif break; case FFI_TYPE_UINT32: *((uint32_t*)result) = SvUV(sv); break; case FFI_TYPE_SINT32: *((int32_t*)result) = SvIV(sv); break; case FFI_TYPE_UINT64: #ifdef HAVE_IV_IS_64 *((uint64_t*)result) = SvUV(sv); #else *((uint64_t*)result) = SvU64(sv); #endif break; case FFI_TYPE_SINT64: #ifdef HAVE_IV_IS_64 *((int64_t*)result) = SvIV(sv); #else *((int64_t*)result) = SvI64(sv); #endif break; case FFI_TYPE_FLOAT: *((float*)result) = SvNV(sv); break; case FFI_TYPE_DOUBLE: *((double*)result) = SvNV(sv); break; case FFI_TYPE_POINTER: *((void**)result) = SvOK(sv) ? INT2PTR(void*, SvIV(sv)) : NULL; break; } } PUTBACK; }
I32 magic_c_int_get(IV num, SV *sv) { MAGIC *mg = mg_find(sv, (int)'U'); sv_setiv(sv, *((int *)(SvIV(mg->mg_obj)))); return 1; }
/* * Call the function_name inside the module * Store all vps in hashes %RAD_CHECK %RAD_REPLY %RAD_REQUEST * */ static int do_perl(void *instance, REQUEST *request, char const *function_name) { rlm_perl_t *inst = instance; VALUE_PAIR *vp; int exitstatus=0, count; STRLEN n_a; HV *rad_reply_hv; HV *rad_check_hv; HV *rad_config_hv; HV *rad_request_hv; HV *rad_state_hv; #ifdef WITH_PROXY HV *rad_request_proxy_hv; HV *rad_request_proxy_reply_hv; #endif SV *rad_requestp_sv; /* * Radius has told us to call this function, but none * is defined. */ if (!function_name) return RLM_MODULE_FAIL; #ifdef USE_ITHREADS pthread_mutex_lock(&inst->clone_mutex); PerlInterpreter *interp; interp = rlm_perl_clone(inst->perl,inst->thread_key); { dTHXa(interp); PERL_SET_CONTEXT(interp); } pthread_mutex_unlock(&inst->clone_mutex); #else PERL_SET_CONTEXT(inst->perl); #endif { dSP; ENTER; SAVETMPS; rad_reply_hv = get_hv("RAD_REPLY", 1); rad_check_hv = get_hv("RAD_CHECK", 1); rad_config_hv = get_hv("RAD_CONFIG", 1); rad_request_hv = get_hv("RAD_REQUEST", 1); rad_state_hv = get_hv("RAD_STATE", 1); rad_requestp_sv = get_sv("RAD___REQUESTP", 1); perl_store_vps(request->packet, request, &request->packet->vps, rad_request_hv, "RAD_REQUEST", "request"); perl_store_vps(request->reply, request, &request->reply->vps, rad_reply_hv, "RAD_REPLY", "reply"); perl_store_vps(request, request, &request->config, rad_check_hv, "RAD_CHECK", "control"); perl_store_vps(request, request, &request->config, rad_config_hv, "RAD_CONFIG", "control"); perl_store_vps(request->state_ctx, request, &request->state, rad_state_hv, "RAD_STATE", "session-state"); #ifdef WITH_PROXY rad_request_proxy_hv = get_hv("RAD_REQUEST_PROXY",1); rad_request_proxy_reply_hv = get_hv("RAD_REQUEST_PROXY_REPLY",1); if (request->proxy != NULL) { perl_store_vps(request->proxy, request, &request->proxy->vps, rad_request_proxy_hv, "RAD_REQUEST_PROXY", "proxy-request"); } else { hv_undef(rad_request_proxy_hv); } if (request->proxy_reply != NULL) { perl_store_vps(request->proxy_reply, request, &request->proxy_reply->vps, rad_request_proxy_reply_hv, "RAD_REQUEST_PROXY_REPLY", "proxy-reply"); } else { hv_undef(rad_request_proxy_reply_hv); } #endif /* * Store pointer to request structure globally so xlat works * We mark it read-only for interpreter so end users will not be * in posession to change it and crash radiusd with bogus pointer */ SvREADONLY_off(rad_requestp_sv); sv_setiv(rad_requestp_sv, PTR2IV(request)); SvREADONLY_on(rad_requestp_sv); PUSHMARK(SP); /* * This way %RAD_xx can be pushed onto stack as sub parameters. * XPUSHs( newRV_noinc((SV *)rad_request_hv) ); * XPUSHs( newRV_noinc((SV *)rad_reply_hv) ); * XPUSHs( newRV_noinc((SV *)rad_check_hv) ); * PUTBACK; */ count = call_pv(function_name, G_SCALAR | G_EVAL | G_NOARGS); SPAGAIN; if (SvTRUE(ERRSV)) { RDEBUG("perl_embed:: module = %s , func = %s exit status= %s\n", inst->module, function_name, SvPV(ERRSV,n_a)); (void)POPs; count = 0; exitstatus = RLM_MODULE_FAIL; } if (count == 1) { exitstatus = POPi; if (exitstatus >= 100 || exitstatus < 0) { exitstatus = RLM_MODULE_FAIL; } } PUTBACK; FREETMPS; LEAVE; vp = NULL; get_hv_content(request->packet, request, rad_request_hv, &vp, "RAD_REQUEST", "request"); if (vp) { fr_pair_list_free(&request->packet->vps); request->packet->vps = vp; vp = NULL; /* * Update cached copies */ request->username = fr_pair_find_by_num(request->packet->vps, PW_USER_NAME, 0, TAG_ANY); request->password = fr_pair_find_by_num(request->packet->vps, PW_USER_PASSWORD, 0, TAG_ANY); if (!request->password) request->password = fr_pair_find_by_num(request->packet->vps, PW_CHAP_PASSWORD, 0, TAG_ANY); } get_hv_content(request->reply, request, rad_reply_hv, &vp, "RAD_REPLY", "reply"); if (vp) { fr_pair_list_free(&request->reply->vps); request->reply->vps = vp; vp = NULL; } get_hv_content(request, request, rad_check_hv, &vp, "RAD_CHECK", "control"); if (vp) { fr_pair_list_free(&request->config); request->config = vp; vp = NULL; } get_hv_content(request->state_ctx, request, rad_state_hv, &vp, "RAD_STATE", "session-state"); if (vp) { fr_pair_list_free(&request->state); request->state = vp; vp = NULL; } #ifdef WITH_PROXY if (request->proxy) { get_hv_content(request->proxy, request, rad_request_proxy_hv, &vp, "RAD_REQUEST_PROXY", "proxy-request"); if (vp) { fr_pair_list_free(&request->proxy->vps); request->proxy->vps = vp; vp = NULL; } } if (request->proxy_reply) { get_hv_content(request->proxy_reply, request, rad_request_proxy_reply_hv, &vp, "RAD_REQUEST_PROXY_REPLY", "proxy-reply"); if (vp) { fr_pair_list_free(&request->proxy_reply->vps); request->proxy_reply->vps = vp; vp = NULL; } } #endif } return exitstatus; }