int modperl_errsv(pTHX_ int status, request_rec *r, server_rec *s) { SV *sv = ERRSV; STRLEN n_a; if (SvTRUE(sv)) { if (sv_derived_from(sv, "APR::Error") && SvIVx(sv) == MODPERL_RC_EXIT) { /* ModPerl::Util::exit was called */ return OK; } #if 0 if (modperl_sv_is_http_code(ERRSV, &status)) { return status; } #endif if (r) { ap_log_rerror(APLOG_MARK, APLOG_ERR, 0, r, "%s", SvPV(sv, n_a)); } else { ap_log_error(APLOG_MARK, APLOG_ERR, 0, s, "%s", SvPV(sv, n_a)); } return status; } return status; }
void ffi_pl_perl_to_complex_float(SV *sv, float *ptr) { if(sv_isobject(sv) && sv_derived_from(sv, "Math::Complex")) { ptr[0] = decompose(sv, 0); ptr[1] = decompose(sv, 1); } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { AV *av = (AV*) SvRV(sv); SV **real_sv, **imag_sv; real_sv = av_fetch(av, 0, 0); imag_sv = av_fetch(av, 1, 0); ptr[0] = real_sv != NULL ? SvNV(*real_sv) : 0.0; ptr[1]= imag_sv != NULL ? SvNV(*imag_sv) : 0.0; } else if(SvOK(sv)) { ptr[0] = SvNV(sv); ptr[1] = 0.0; } else { ptr[0] = 0.0; ptr[1] = 0.0; } }
void ffi_pl_complex_float_to_perl(SV *sv, float *ptr) { if(SvOK(sv) && sv_isobject(sv) && sv_derived_from(sv, "Math::Complex")) { /* the complex variable is a Math::Complex object */ set(sv, sv_2mortal(newSVnv(ptr[0])), 0); set(sv, sv_2mortal(newSVnv(ptr[1])), 1); } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { /* the compex variable is already an array */ AV *av = (AV*) SvRV(sv); av_store(av, 0, newSVnv(ptr[0])); av_store(av, 1, newSVnv(ptr[1])); } else { /* the complex variable is something else and an array needs to be created */ SV *values[2]; AV *av; values[0] = newSVnv(ptr[0]); values[1] = newSVnv(ptr[1]); av = av_make(2, values); sv_setsv(sv, newRV_noinc((SV*)av)); } }
xmlNodePtr PmmSvNodeExt( SV* perlnode, int copy ) { xmlNodePtr retval = NULL; ProxyNodePtr proxy = NULL; if ( perlnode != NULL && perlnode != &PL_sv_undef ) { /* if ( sv_derived_from(perlnode, "XML::LibXML::Node") */ /* && SvPROXYNODE(perlnode) != NULL ) { */ /* retval = PmmNODE( SvPROXYNODE(perlnode) ) ; */ /* } */ xs_warn("PmmSvNodeExt: perlnode found\n" ); if ( sv_derived_from(perlnode, "XML::LibXML::Node") ) { proxy = SvPROXYNODE(perlnode); if ( proxy != NULL ) { xs_warn( "PmmSvNodeExt: is a xmlNodePtr structure\n" ); retval = PmmNODE( proxy ) ; } if ( retval != NULL && ((ProxyNodePtr)retval->_private) != proxy ) { xs_warn( "PmmSvNodeExt: no node in proxy node\n" ); PmmNODE( proxy ) = NULL; retval = NULL; } } #ifdef XML_LIBXML_GDOME_SUPPORT else if ( sv_derived_from( perlnode, "XML::GDOME::Node" ) ) { GdomeNode* gnode = (GdomeNode*)SvIV((SV*)SvRV( perlnode )); if ( gnode == NULL ) { warn( "no XML::GDOME data found (datastructure empty)" ); } else { retval = gdome_xml_n_get_xmlNode( gnode ); if ( retval == NULL ) { xs_warn( "PmmSvNodeExt: no XML::LibXML node found in GDOME object\n" ); } else if ( copy == 1 ) { retval = PmmCloneNode( retval, 1 ); } } } #endif } return retval; }
/* Convert a bigint to a signed integer, or croak trying. * * @param bigint: the perl object to convert * @returns: signed integer */ static gint64 bigint2int64(SV *bigint) { SV *sv; char *str; guint64 absval; gboolean negative = FALSE; int count; dSP; /* first, see if it's a BigInt */ if (!sv_isobject(bigint) || !sv_derived_from(bigint, "Math::BigInt")) croak("Expected an integer or a Math::BigInt; cannot convert"); ENTER; SAVETMPS; /* get the value: * strtoull($bigint->bstr()) */ PUSHMARK(SP); XPUSHs(bigint); PUTBACK; count = call_method("Math::BigInt::bstr", G_SCALAR); SPAGAIN; if (count != 1) croak("Expected a result from Math::BigInt::bstr"); sv = POPs; str = SvPV_nolen(sv); if (!str) croak("Math::BigInt::bstr did not return a string"); if (str[0] == '-') { negative = TRUE; str++; } errno = 0; absval = g_ascii_strtoull(str, NULL, 0); /* (the last branch of this || depends on G_MININT64 = -G_MAXINT64-1) */ if ((absval == G_MAXUINT64 && errno == ERANGE) || (!negative && absval > (guint64)(G_MAXINT64)) || (negative && absval > (guint64)(G_MAXINT64)+1)) croak("Expected a signed 64-bit value or smaller; value '%s' out of range", str); if (errno) croak("Math::BigInt->bstr returned invalid number '%s'", str); PUTBACK; FREETMPS; LEAVE; if (negative) return -absval; return absval; }
/* * Checks whether the passed SV is a valid VDB object: * - not null * - not undef * - an object * - derived from OpenSIPS::VDB */ int checkobj(SV* obj) { if (obj != NULL) { if (obj != &PL_sv_undef) { if (sv_isobject(obj)) { if (sv_derived_from(obj, PERL_VDB_BASECLASS)) { return 1; } } } } return 0; }
cfish_Obj* LUCY_Doc_Extract_IMP(lucy_Doc *self, cfish_String *field) { lucy_DocIVARS *const ivars = lucy_Doc_IVARS(self); cfish_Obj *retval = NULL; SV **sv_ptr = hv_fetch((HV*)ivars->fields, CFISH_Str_Get_Ptr8(field), CFISH_Str_Get_Size(field), 0); if (sv_ptr && XSBind_sv_defined(*sv_ptr)) { SV *const sv = *sv_ptr; if (sv_isobject(sv) && sv_derived_from(sv, "Clownfish::Obj")) { IV tmp = SvIV(SvRV(sv)); retval = CFISH_INCREF(INT2PTR(cfish_Obj*, tmp)); }
lucy_Obj* lucy_Doc_extract(lucy_Doc *self, lucy_CharBuf *field, lucy_ViewCharBuf *target) { lucy_Obj *retval = NULL; SV **sv_ptr = hv_fetch((HV*)self->fields, (char*)Lucy_CB_Get_Ptr8(field), Lucy_CB_Get_Size(field), 0); if (sv_ptr && XSBind_sv_defined(*sv_ptr)) { SV *const sv = *sv_ptr; if (sv_isobject(sv) && sv_derived_from(sv, "Clownfish::Obj")) { IV tmp = SvIV(SvRV(sv)); retval = INT2PTR(lucy_Obj*, tmp); }
cfish_Obj* XSBind_new_blank_obj(SV *either_sv) { cfish_VTable *vtable; // Get a VTable. if (sv_isobject(either_sv) && sv_derived_from(either_sv, "Clownfish::Obj") ) { // Use the supplied object's VTable. IV iv_ptr = SvIV(SvRV(either_sv)); cfish_Obj *self = INT2PTR(cfish_Obj*, iv_ptr); vtable = self->vtable; }
request_rec *modperl_xs_sv2request_rec(pTHX_ SV *in, char *classname, CV *cv) { SV *sv = (SV *)NULL; MAGIC *mg; if (SvROK(in)) { SV *rv = (SV*)SvRV(in); switch (SvTYPE(rv)) { case SVt_PVMG: sv = rv; break; case SVt_PVHV: sv = modperl_hv_request_find(aTHX_ in, classname, cv); break; default: Perl_croak(aTHX_ "panic: unsupported request_rec type %d", (int)SvTYPE(rv)); } } /* might be Apache2::ServerRec::warn method */ if (!sv && !(classname && SvPOK(in) && !strEQ(classname, SvPVX(in)))) { request_rec *r = NULL; (void)modperl_tls_get_request_rec(&r); if (!r) { Perl_croak(aTHX_ "Apache2->%s called without setting Apache2->request!", cv ? GvNAME(CvGV(cv)) : "unknown"); } return r; } /* there could be pool magic attached to custom $r object, so make * sure that mg->mg_ptr is set */ if ((mg = mg_find(sv, PERL_MAGIC_ext)) && mg->mg_ptr) { return (request_rec *)mg->mg_ptr; } else { if (classname && !sv_derived_from(in, classname)) { /* XXX: find something faster than sv_derived_from */ return NULL; } return INT2PTR(request_rec *, SvIV(sv)); } return NULL; }
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; }
PyObject* PerlPyObject_pyo_or_null(SV* sv) { MAGIC *mg; dCTXP; ASSERT_LOCK_PERL; if (SvROK(sv) && sv_derived_from(sv, "Python::Object")) { sv = SvRV(sv); mg = mg_find(sv, '~'); if (SvIOK(sv) && mg && mg->mg_virtual == &vtbl_free_pyo) { IV ival = SvIV(sv); return INT2PTR(PyObject *, ival); }
static CORBA_boolean put_objref (GIOPSendBuffer *buf, CORBA_TypeCode tc, SV *sv) { CORBA_Object obj; if (!SvOK(sv)) obj = CORBA_OBJECT_NIL; else { if (!sv_derived_from(sv, "CORBA::Object")) { warn("not an object reference"); return CORBA_FALSE; } obj = (CORBA_Object)SvIV((SV *)SvRV(sv)); } ORBit_marshal_object (buf, obj); return CORBA_TRUE; }
void propagate_errsv() { STRLEN n_a; dCTXP; ASSERT_LOCK_BOTH; if (SvROK(ERRSV) && sv_derived_from(ERRSV, "Python::Err")) { IV tmp = SvIV((SV*)SvRV(ERRSV)); PerlPyErr *py_err = INT2PTR(PerlPyErr *,tmp); /* We want to keep the Exception object valid also after restore, * so increment reference counts first. */ Py_XINCREF(py_err->type); Py_XINCREF(py_err->value); Py_XINCREF(py_err->traceback); PyErr_Restore(py_err->type, py_err->value, py_err->traceback); }
lucy_Err* lucy_Err_trap(Cfish_Err_Attempt_t routine, void *context) { lucy_Err *error = NULL; SV *routine_sv = newSViv(PTR2IV(routine)); SV *context_sv = newSViv(PTR2IV(context)); dSP; ENTER; SAVETMPS; PUSHMARK(SP); EXTEND(SP, 2); PUSHs(sv_2mortal(routine_sv)); PUSHs(sv_2mortal(context_sv)); PUTBACK; int count = call_sv(attempt_xsub, G_EVAL | G_DISCARD); if (count != 0) { lucy_CharBuf *mess = lucy_CB_newf("'attempt' returned too many values: %i32", (int32_t)count); error = lucy_Err_new(mess); } else { SV *dollar_at = get_sv("@", FALSE); if (SvTRUE(dollar_at)) { if (sv_isobject(dollar_at) && sv_derived_from(dollar_at,"Clownfish::Err") ) { IV error_iv = SvIV(SvRV(dollar_at)); error = INT2PTR(lucy_Err*, error_iv); CFISH_INCREF(error); } else { STRLEN len; char *ptr = SvPVutf8(dollar_at, len); lucy_CharBuf *mess = lucy_CB_new_from_trusted_utf8(ptr, len); error = lucy_Err_new(mess); } }
gpointer c_obj_from_sv( SV *sv, const char *derived_from) { SV *referent; IV tmp; if (!sv) return NULL; if (!SvOK(sv)) return NULL; /* Peel back the layers. The sv should be a blessed reference to a PV, * and we check the class against derived_from to ensure we have the right * stuff. */ if (!sv_isobject(sv) || !sv_derived_from(sv, derived_from)) { croak("Value is not an object of type %s", derived_from); return NULL; } referent = (SV *)SvRV(sv); tmp = SvIV(referent); return INT2PTR(gpointer, tmp); }
int perlresult2dbres(SV *perlres, db1_res_t **r) { SV *colarrayref = NULL; AV *colarray = NULL; SV *acol = NULL; int colcount = 0; SV *rowarrayref = NULL; AV *rowarray = NULL; int rowcount = 0; SV *arowref = NULL; AV *arow = NULL; int arowlen = 0; SV *aelement = NULL; SV *atypesv = 0; int atype = 0; SV *aval = NULL; char *charbuf; char *currentstring; int i, j; int retval = 0; STRLEN len; SV *d1; /* helper variables */ /*db_val_t cur_val;*/ /* Abbreviation in "switch" below. The currently modified db result value. */ if (!(SvROK(perlres) && (sv_derived_from(perlres, "Kamailio::VDB::Result")))) { goto error; } /* Memory allocation for C side result structure */ *r = (db1_res_t *)pkg_malloc(sizeof(db1_res_t)); if (!(*r)) { LM_ERR("no pkg memory left\n"); return -1; } memset(*r, 0, sizeof(db1_res_t)); /* Fetch column definitions */ colarrayref = perlvdb_perlmethod(perlres, PERL_VDB_COLDEFSMETHOD, NULL, NULL, NULL, NULL); if (!(SvROK(colarrayref))) goto error; colarray = (AV *)SvRV(colarrayref); if (!(SvTYPE(colarray) == SVt_PVAV)) goto error; colcount = av_len(colarray) + 1; /* Allocate col def memory */ (*r)->col.n = colcount; (*r)->col.types = (db_type_t*)pkg_malloc(colcount*sizeof(db_type_t)); (*r)->col.names = (db_key_t*)pkg_malloc(colcount*sizeof(db_key_t)); /* reverse direction, as elements are removed by "SvREFCNT_dec" */ for (i = colcount-1; i >= 0; i--) { acol = *av_fetch(colarray, i, 0); d1 = perlvdb_perlmethod(acol, PERL_VDB_TYPEMETHOD, NULL, NULL, NULL, NULL); if (!SvIOK(d1)) goto error; (*r)->col.types[i] = SvIV(d1); SvREFCNT_dec(d1); d1 = perlvdb_perlmethod(acol, PERL_VDB_NAMEMETHOD, NULL, NULL, NULL, NULL); if (!SvPOK(d1)) goto error; currentstring = SvPV(d1, len); charbuf = pkg_malloc(len+1); strncpy(charbuf, currentstring, len+1); (*r)->col.names[i]->s = charbuf; (*r)->col.names[i]->len = strlen(charbuf); SvREFCNT_dec(d1); } rowarrayref = perlvdb_perlmethod(perlres, PERL_VDB_ROWSMETHOD, NULL, NULL, NULL, NULL); if (!(SvROK(rowarrayref))) { /* Empty result set */ (*r)->n = 0; (*r)->res_rows = 0; (*r)->last_row = 0; goto end; } rowarray = (AV *)SvRV(rowarrayref); if (!(SvTYPE(rowarray) == SVt_PVAV)) goto error; rowcount = av_len(rowarray) + 1; (*r)->n = rowcount; (*r)->res_rows = rowcount; (*r)->last_row = rowcount; (*r)->rows = (db_row_t *)pkg_malloc(rowcount*sizeof(db_row_t)); for (i = 0; i < rowcount; i++) { arowref = *av_fetch(rowarray, 0, 0); if (!SvROK(arowref)) goto error; arow = (AV *)SvRV(arowref); if (!(SvTYPE(colarray) == SVt_PVAV)) goto error; arowlen = av_len(arow) + 1; (*r)->rows[i].n = arowlen; (*r)->rows[i].values = (db_val_t *)pkg_malloc(arowlen*sizeof(db_val_t)); for (j = 0; j < arowlen; j++) { aelement = *av_fetch(arow, j, 0); #define cur_val (((*r)->rows)[i].values)[j] /*cur_val = (((*r)->rows)[i].values)[j];*/ /* cur_val is just an "abbreviation" */ if (!(sv_isobject(aelement) && sv_derived_from(aelement, PERL_CLASS_VALUE))) { cur_val.nul = 1; continue; } atype = SvIV(atypesv = perlvdb_perlmethod(aelement, PERL_VDB_TYPEMETHOD, NULL, NULL, NULL, NULL)); aval = perlvdb_perlmethod(aelement, PERL_VDB_DATAMETHOD, NULL, NULL, NULL, NULL); (*r)->rows[i].values[j].type = atype; if (!SvOK(aval)) { cur_val.nul = 1; } else { switch (atype) { case DB1_INT: cur_val.val.int_val = SvIV(aval); cur_val.nul = 0; break; case DB1_DOUBLE: cur_val.val.double_val = SvNV(aval); cur_val.nul = 0; break; case DB1_STRING: case DB1_STR: /* We dont support DB1_STR for now. * Set DB1_STRING instead */ cur_val.type = DB1_STRING; currentstring = SvPV(aval, len); charbuf = pkg_malloc(len+1); strncpy(charbuf, currentstring, len+1); cur_val.val.string_val = charbuf; cur_val.nul = 0; break; case DB1_DATETIME: cur_val.val.time_val = (time_t)SvIV(aval); cur_val.nul = 0; break; case DB1_BLOB: currentstring = SvPV(aval, len); charbuf = pkg_malloc(len+1); strncpy(charbuf, currentstring, len+1); cur_val.val.blob_val.s = charbuf; cur_val.val.blob_val.len = len; cur_val.nul = 0; break; case DB1_BITMAP: cur_val.val.bitmap_val = SvIV(aval); cur_val.nul = 0; break; default: LM_CRIT("cannot handle this data type.\n"); return -1; break; } } SvREFCNT_dec(atypesv); SvREFCNT_dec(aval); } } end: av_undef(colarray); av_undef(rowarray); return retval; error: LM_CRIT("broken result set. Exiting, leaving Kamailio in unknown state.\n"); return -1; }
int perlresult2dbres(SV *perlres, db_res_t **r) { HV * result = NULL; SV *colarrayref = NULL; AV *colarray = NULL; SV *acol = NULL; int colcount = 0; SV *rowarrayref = NULL; AV *rowarray = NULL; int rowcount = 0; SV *arowref = NULL; AV *arow = NULL; int arowlen = 0; SV *aelement = NULL; SV *atypesv = 0; int atype = 0; SV *aval = NULL; char *charbuf; char *currentstring; int i, j; int retval = 0; STRLEN len; SV *d1; /* helper variables */ /*db_val_t cur_val;*/ /* Abbreviation in "switch" below. The currently modified db result value. */ if (!(SvROK(perlres) && (sv_derived_from(perlres, "OpenSIPS::VDB::Result")))) { goto error; } result = (HV*)SvRV(perlres); /* Memory allocation for C side result structure */ *r = db_new_result(); /* Fetch column definitions */ colarrayref = *hv_fetchs(result, PERL_VDB_COLDEFSMETHOD, 0); /* colarrayref = perlvdb_perlmethod(perlres, PERL_VDB_COLDEFSMETHOD, NULL, NULL, NULL, NULL); */ if (!(SvROK(colarrayref))) goto error; colarray = (AV *)SvRV(colarrayref); /* SvREFCNT_dec(colarray); */ if (!(SvTYPE(colarray) == SVt_PVAV)) goto error; colcount = av_len(colarray) + 1; RES_COL_N(*r) = colcount; db_allocate_columns(*r, colcount); /* reverse direction, as elements are removed by "SvREFCNT_dec" */ for (i = colcount-1; i >= 0; i--) { acol = *av_fetch(colarray, i, 0); d1 = perlvdb_perlmethod(acol, PERL_VDB_TYPEMETHOD, NULL, NULL, NULL, NULL); if (!SvIOK(d1)) goto error; (*r)->col.types[i] = SvIV(d1); SvREFCNT_dec(d1); d1 = perlvdb_perlmethod(acol, PERL_VDB_NAMEMETHOD, NULL, NULL, NULL, NULL); if (!SvPOK(d1)) goto error; currentstring = SvPV(d1, len); charbuf = pkg_malloc(len+1); /* Column names buffers are freed in the perlvdb free function */ strncpy(charbuf, currentstring, len+1); (*r)->col.names[i]->s = charbuf; (*r)->col.names[i]->len = strlen(charbuf); SvREFCNT_dec(d1); } if(hv_exists(result, "rows", 4)){ rowarrayref =(SV*) hv_fetchs(result, "rows", 0); }else{ (*r)->n = 0; (*r)->res_rows = 0; (*r)->last_row = 0; goto end; } if(rowarrayref){ rowarrayref = *((SV**)rowarrayref); }else{ (*r)->n = 0; (*r)->res_rows = 0; (*r)->last_row = 0; goto end; } if (!(SvROK(rowarrayref))) { /* Empty result set */ (*r)->n = 0; (*r)->res_rows = 0; (*r)->last_row = 0; goto end; } rowarray = (AV *)SvRV(rowarrayref); if (!(SvTYPE(rowarray) == SVt_PVAV)) goto error; rowcount = av_len(rowarray) + 1; (*r)->n = rowcount; (*r)->res_rows = rowcount; (*r)->last_row = rowcount; db_allocate_rows(*r, rowcount); /* (rows * (sizeof(db_row_t) + sizeof(db_val_t) * RES_COL_N(_res)) */ /* LM_DBG("We got %d rows each row requres %d bytes because the row struct is %d and" "the values in that row take up %d. That is %d values each size is %d\n", rowcount, sizeof(db_row_t) + sizeof(db_val_t) * RES_COL_N(*r), sizeof(db_row_t), sizeof(db_val_t) * RES_COL_N(*r), RES_COL_N(*r), sizeof(db_val_t)); */ for (i = 0; i < rowcount; i++) { arowref = *av_fetch(rowarray, i, 0); if (!SvROK(arowref)) goto error; arow = (AV *)SvRV(arowref); if (!(SvTYPE(colarray) == SVt_PVAV)) goto error; arowlen = av_len(arow) + 1; (*r)->rows[i].n = arowlen; for (j = 0; j < arowlen; j++) { aelement = *av_fetch(arow, j, 0); #define cur_val (((*r)->rows)[i].values)[j] /*cur_val = (((*r)->rows)[i].values)[j];*/ /* cur_val is just an "abbreviation" */ if (!(sv_isobject(aelement) && sv_derived_from(aelement, PERL_CLASS_VALUE))) { cur_val.nul = 1; continue; } atypesv = *hv_fetchs((HV*)SvRV(aelement),PERL_VDB_TYPEMETHOD,0); /*aelement->{type} */ atype = SvIV(atypesv); /*atypesv = perlvdb_perlmethod(aelement, PERL_VDB_TYPEMETHOD, NULL, NULL, NULL, NULL);*/ aval = perlvdb_perlmethod(aelement, PERL_VDB_DATAMETHOD, NULL, NULL, NULL, NULL); (*r)->rows[i].values[j].type = atype; /* SvREFCNT_dec(atypesv); */ if (!SvOK(aval)) { cur_val.nul = 1; } else { switch (atype) { case DB_INT: cur_val.val.int_val = SvIV(aval); cur_val.nul = 0; break; case DB_DOUBLE: cur_val.val.double_val = SvNV(aval); cur_val.nul = 0; break; case DB_STRING: case DB_STR: /* We dont support DB_STR for now. * Set DB_STRING instead */ cur_val.type = DB_STRING; currentstring = SvPV(aval, len); charbuf = pkg_malloc(len+1); strncpy(charbuf, currentstring, len+1); cur_val.val.string_val = charbuf; cur_val.nul = 0; break; case DB_DATETIME: cur_val.val.time_val = (time_t)SvIV(aval); cur_val.nul = 0; break; case DB_BLOB: currentstring = SvPV(aval, len); charbuf = pkg_malloc(len+1); strncpy(charbuf, currentstring, len+1); cur_val.val.blob_val.s = charbuf; cur_val.val.blob_val.len = len; cur_val.nul = 0; break; case DB_BITMAP: cur_val.val.bitmap_val = SvIV(aval); cur_val.nul = 0; break; default: LM_CRIT("cannot handle this data type.\n"); return -1; break; } } SvREFCNT_dec(aval); } } end: return retval; error: LM_CRIT("broken result set. Exiting, leaving OpenSIPS in unknown state.\n"); return -1; }
static gpointer sv_to_struct (GITransfer transfer, GIBaseInfo * info, GIInfoType info_type, SV * sv) { HV *hv; gsize size = 0; GITransfer field_transfer; gpointer pointer = NULL; dwarn ("sv = %p\n", sv); if (!gperl_sv_is_defined (sv)) return NULL; if (is_struct_disguised (info)) { gchar *package; dwarn (" disguised struct\n"); package = get_struct_package (info); g_assert (package); if (!gperl_sv_is_ref (sv) || !sv_derived_from (sv, package)) ccroak ("Cannot convert scalar %p to an object of type %s", sv, package); g_free (package); return INT2PTR (void *, SvIV ((SV *) SvRV (sv))); } if (!gperl_sv_is_hash_ref (sv)) ccroak ("need a hash ref to convert to struct of type %s", g_base_info_get_name (info)); hv = (HV *) SvRV (sv); switch (info_type) { case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: size = g_struct_info_get_size ((GIStructInfo *) info); break; case GI_INFO_TYPE_UNION: size = g_union_info_get_size ((GIStructInfo *) info); break; default: g_assert_not_reached (); } dwarn (" size = %"G_GSIZE_FORMAT"\n", size); field_transfer = GI_TRANSFER_NOTHING; dwarn (" transfer = %d\n", transfer); switch (transfer) { case GI_TRANSFER_EVERYTHING: field_transfer = GI_TRANSFER_EVERYTHING; /* fall through */ case GI_TRANSFER_CONTAINER: /* FIXME: What if there's a special allocator for the record? * Like GSlice? */ pointer = g_malloc0 (size); break; default: pointer = gperl_alloc_temp (size); break; } switch (info_type) { case GI_INFO_TYPE_BOXED: case GI_INFO_TYPE_STRUCT: { gint i, n_fields = g_struct_info_get_n_fields ((GIStructInfo *) info); for (i = 0; i < n_fields; i++) { GIFieldInfo *field_info; const gchar *field_name; SV **svp; field_info = g_struct_info_get_field ( (GIStructInfo *) info, i); /* FIXME: Check GIFieldInfoFlags. */ field_name = g_base_info_get_name ( (GIBaseInfo *) field_info); dwarn (" field %d (%s)\n", i, field_name); svp = hv_fetch (hv, field_name, strlen (field_name), 0); if (svp && gperl_sv_is_defined (*svp)) { set_field (field_info, pointer, field_transfer, *svp); } g_base_info_unref ((GIBaseInfo *) field_info); } break; } case GI_INFO_TYPE_UNION: ccroak ("%s: unions not handled yet", G_STRFUNC); default: ccroak ("%s: unhandled info type %d", G_STRFUNC, info_type); } return pointer; }
SV * porbit_put_exception (GIOPSendBuffer *buf, CORBA_TypeCode tc, SV *sv, CORBA_ExcDescriptionSeq *exceptions) { CORBA_unsigned_long i, len; HV *hv; char *repoid; if (sv_derived_from(sv, "CORBA::UserException")) { repoid = porbit_exception_repoid (sv); if (!repoid) { warn ("Cannot get repository ID for exception"); return porbit_system_except ("IDL:omg.org/CORBA/INTERNAL:1.0", 0, CORBA_COMPLETED_MAYBE); } if (!tc && exceptions) { for (i=0; i<exceptions->_length; i++) { if (strcmp (exceptions->_buffer[i].id, repoid) == 0) { tc = exceptions->_buffer[i].type; break; } } } if (!tc) { warn ("Attempt to throw invalid user exception"); g_free (repoid); return porbit_system_except ("IDL:omg.org/CORBA/UNKNOWN:1.0", 0, CORBA_COMPLETED_MAYBE); } } else if (sv_derived_from(sv, "CORBA::SystemException")) { tc = &sysex_typecode; repoid = porbit_exception_repoid (sv); if (!repoid) { warn ("Cannot get repository ID for CORBA exception"); return porbit_system_except ("IDL:omg.org/CORBA/INTERNAL:1.0", 0, CORBA_COMPLETED_MAYBE); } } else { warn ("Thrown CORBA exception must derive from CORBA::UserException or CORBA::SystemException"); return porbit_system_except ("IDL:omg.org/CORBA/UNKNOWN:1.0", 0, CORBA_COMPLETED_MAYBE); } len = strlen (repoid) + 1; buf_putn (buf, &len, sizeof (len)); giop_send_buffer_append_mem_indirect (buf, repoid, len); g_free (repoid); if (tc->sub_parts != 0) { if (!SvROK(sv) || (SvTYPE(SvRV(sv)) != SVt_PVHV)) { warn ("CORBA exception must be hash reference"); return porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0", 0, CORBA_COMPLETED_MAYBE); } hv = (HV *)SvRV(sv); for (i = 0; i < tc->sub_parts; i++) { SV **valp = hv_fetch (hv, (char *)tc->subnames[i], strlen(tc->subnames[i]), 0); if (!valp && (PL_dowarn & G_WARN_ON)) warn ("Uninitialized CORBA exception member '%s'", tc->subnames[i]); if (!porbit_put_sv (buf, tc->subtypes[i], valp ? *valp : &PL_sv_undef)) return porbit_system_except ("IDL:omg.org/CORBA/MARSHAL:1.0", 0, CORBA_COMPLETED_MAYBE); } } return NULL; }
HV * plu_table_obj_to_hash(pTHX_ plu_table_t *THIS, int recursive) { PLU_dSTACKASSERT; int table_stack_offset; lua_State *L; char *keystr; size_t keylen; char tmp[32]; SV *value_sv; int dopop; HV *RETVAL; L = THIS->L; PLU_ENTER_STACKASSERT(L); PLU_TABLE_PUSH_TO_STACK(*THIS); RETVAL = newHV(); sv_2mortal((SV *)RETVAL); table_stack_offset = lua_gettop(L); lua_pushnil(L); /* first key */ while (lua_next(L, table_stack_offset) != 0) { /* uses 'key' (at index -2) and 'value' (at index -1) */ /* Prepare key */ switch (lua_type(L, -2)) { case LUA_TSTRING: keystr = (char *)lua_tolstring(L, -2, &keylen); break; case LUA_TNUMBER: case LUA_TBOOLEAN: { lua_Number n = lua_tonumber(L, -2); sprintf(tmp, LUA_NUMBER_FMT, n); keylen = strlen(tmp); keystr = &tmp[0]; break; } default: croak("Unsupported Lua type '%s' for Perl hash keys", lua_typename(L, lua_type(L, 02))); } /* Prepare value */ value_sv = plu_luaval_to_perl(aTHX_ L, -1, &dopop); if (recursive && SvROK(value_sv) && sv_derived_from(value_sv, "PLua::Table")) { HV *tmph; tmph = plu_table_obj_to_hash(aTHX_ (plu_table_t *)SvIV(SvRV(value_sv)), recursive); SvREFCNT_dec(value_sv); value_sv = newRV_inc((SV *)tmph); } (void)hv_store(RETVAL, keystr, keylen, value_sv, 0); /* removes 'value' if not already done; keeps 'key' for next iteration */ if (dopop) lua_pop(L, 1); } lua_pop(L, 1); PLU_LEAVE_STACKASSERT(L); return RETVAL; }
AV * plu_table_obj_to_array(pTHX_ plu_table_t *THIS, int recursive) { PLU_dSTACKASSERT; int table_stack_offset; lua_State *L; char *keystr; size_t keylen; SV *value_sv; int dopop; AV *RETVAL; I32 aryidx; L = THIS->L; PLU_ENTER_STACKASSERT(L); PLU_TABLE_PUSH_TO_STACK(*THIS); RETVAL = newAV(); sv_2mortal((SV *)RETVAL); table_stack_offset = lua_gettop(L); lua_pushnil(L); /* first key */ while (lua_next(L, table_stack_offset) != 0) { /* uses 'key' (at index -2) and 'value' (at index -1) */ /* Prepare key - cast to int if need be */ switch (lua_type(L, -2)) { case LUA_TSTRING: { SV *tmpsv; keystr = (char *)lua_tolstring(L, -2, &keylen); /* Using SV is not efficient, but may cause the perl warnings we want. * That in turn may cause Perl code to be run that can throw exceptions. * So we need to mortalize. Grmpf. */ tmpsv = newSVpvn(keystr, (STRLEN)keylen); sv_2mortal(tmpsv); aryidx = (I32)SvIV(tmpsv); SvREFCNT_dec(tmpsv); break; } case LUA_TNUMBER: { lua_Number n = lua_tonumber(L, -2); /* Don't change its type with lua_tointeger! */ aryidx = (I32)n; /* FIXME should this warn for actual truncation? */ break; } case LUA_TBOOLEAN: aryidx = lua_toboolean(L, -2); break; default: croak("Unsupported Lua type '%s' for Perl array indexes", lua_typename(L, lua_type(L, 02))); } /* Prepare value */ value_sv = plu_luaval_to_perl(aTHX_ L, -1, &dopop); if (recursive && SvROK(value_sv) && sv_derived_from(value_sv, "PLua::Table")) { AV *tmpa; tmpa = plu_table_obj_to_array(aTHX_ (plu_table_t *)SvIV(SvRV(value_sv)), recursive); SvREFCNT_dec(value_sv); value_sv = newRV_inc((SV *)tmpa); } (void)av_store(RETVAL, aryidx, value_sv); /* removes 'value' if not already done; keeps 'key' for next iteration */ if (dopop) lua_pop(L, 1); } lua_pop(L, 1); PLU_LEAVE_STACKASSERT(L); return RETVAL; }
static void tn_encode(SV *data, struct tn_buffer *buf) { size_t init_length = tn_buffer_length(buf) + 1; /* Null */ if(!SvOK(data)) { tn_buffer_puts(buf, "0:~", 3); return; } /* Boolean */ else if(sv_isobject(data) && sv_derived_from(data, "boolean")) { tn_buffer_putc(buf, tn_type_bool); if(SvTRUE(data)) { tn_buffer_puts(buf, "4:true", 6); } else { tn_buffer_puts(buf, "5:false", 7); } return; } /* Integer */ else if(SvIOK(data)) { /* The evaluatioin order of arguments isn't defined, so * stringify before calling tn_buffer_puts(). */ SvPV_nolen(data); tn_buffer_putc(buf, tn_type_integer); tn_buffer_puts(buf, SvPVX(data), SvCUR(data)); } /* Floating point */ else if(SvNOK(data)) { /* The evaluatioin order of arguments isn't defined, so * stringify before calling tn_buffer_puts(). */ SvPV_nolen(data); tn_buffer_putc(buf, tn_type_float); tn_buffer_puts(buf, SvPVX(data), SvCUR(data)); } /* String */ else if(SvPOK(data)) { tn_buffer_putc(buf, tn_type_bytestring); tn_buffer_puts(buf, SvPVX(data), SvCUR(data)); } /* Reference (Hash/Array) */ else if(SvROK(data)) { data = SvRV(data); switch(SvTYPE(data)) { case SVt_PVAV: tn_buffer_putc(buf, tn_type_array); tn_encode_array(data, buf); break; case SVt_PVHV: tn_buffer_putc(buf, tn_type_hash); tn_encode_hash(data, buf); break; default: croak("encountered %s (%s), but TNetstrings can only represent references to arrays or hashes", SvPV_nolen(data), sv_reftype(data, 0)); } } else { croak("support for type (%s, %s) not implemented, please file a bug", sv_reftype(data, 0), SvPV_nolen(data)); } tn_buffer_putc(buf, ':'); tn_buffer_puti(buf, tn_buffer_length(buf) - init_length - 1); }
/* Wrap a JS value to export into perl * Returns a new SV, REFCNT_dec is caller's responsability */ JSBool PJS_ReflectJS2Perl( pTHX_ JSContext *cx, jsval value, SV** sv, int full ) { if(JSVAL_IS_PRIMITIVE(value)) { *sv = PrimJSVALToSV(aTHX_ cx, value); if(*sv) return JS_TRUE; } else if(JSVAL_IS_OBJECT(value)) { PJS_Context *pcx = PJS_GET_CONTEXT(cx); JSObject *object = JSVAL_TO_OBJECT(value); JSClass *clasp = PJS_GET_CLASS(cx, object); const char *classname = clasp->name; JSObject *passport; SV *wrapper; SV *box; char hkey[32]; jsval temp = JSVAL_VOID; snprintf(hkey, 32, "%p", (void *)object); PJS_DEBUG2("Wrapping a %s(%s)\n", classname, hkey); if(PJS_getFlag(pcx, "ConvertRegExp") && strEQ(classname, "RegExp")) { jsval src; char *str; if(JS_CallFunctionName(cx, object, "toSource", 0, NULL, &src) && (str = JS_GetStringBytes(JS_ValueToString(cx, src))) ) { dSP; SV *tmp = newSVpvf("qr%s", str); eval_sv(tmp, G_SCALAR); sv_free(tmp); // Don't leak SPAGAIN; tmp = POPs; PUTBACK; if(!SvTRUE(ERRSV)) { *sv = SvREFCNT_inc_simple_NN(tmp); return JS_TRUE; } } return JS_FALSE; } if(IS_PERL_CLASS(clasp)) { /* IS_PERL_CLASS means actual perl object is there */ SV *priv = (SV *)JS_GetPrivate(cx, object); if(priv && SvOK(priv) && SvROK(priv)) { *sv = SvREFCNT_inc_simple_NN(priv); return JS_TRUE; } croak("A private %s?!\n", classname); return JS_FALSE; } /* Common JSObject case */ /* Check registered perl visitors */ JS_LookupProperty(cx, pcx->pvisitors, hkey, &temp); if(temp != JSVAL_VOID) { /* Already registered, so exits a reference in perl space * _must_ hold a PASSPORT */ assert(JSVAL_TO_OBJECT(temp) == object); box = PJS_GetPassport(aTHX_ cx, object); SvREFCNT_inc_void_NN(box); /* In perl should be one more */ PJS_DEBUG1("Cached!: %s\n", hkey); } else { /* Check if with a PASSPORT */ JS_LookupPropertyWithFlags(cx, object, PJS_PASSPORT_PROP, 0, &temp); if(JSVAL_IS_OBJECT(temp) && (passport = JSVAL_TO_OBJECT(temp)) && PJS_GET_CLASS(cx, passport) == &passport_class && JS_GetReservedSlot(cx, passport, 0, &temp) && object == (JSObject *)JSVAL_TO_PRIVATE(temp) ) { /* Yes, reentering perl */ box = (SV *)JS_GetPrivate(cx, passport); /* Here we don't increment refcount, the ownership in passport is * transferred to perl land. */ PJS_DEBUG1("Reenter: %s\n", hkey); } else { /* No, first time, must wrap the object */ SV *boxref; const char *package; SV *robj = newSV(0); SV *rjsv = newSV(0); if (JS_ObjectIsFunction(cx, object)) package = PJS_FUNCTION_PACKAGE; else if(JS_IsArrayObject(cx, object)) package = PJS_ARRAY_PACKAGE; else if(strEQ(classname, PJS_PACKAGE_CLASS_NAME)) package = PJS_STASH_PACKAGE; #if JS_HAS_XML_SUPPORT else if(strEQ(classname, "XML")) package = PJS_XMLOBJ_PACKAGE; #endif else if(strEQ(classname, "Error")) package = PJS_ERROR_PACKAGE; else { SV **sv = hv_fetch(get_hv(NAMESPACE"ClassMap", 1), classname, strlen(classname), 0); if(sv) package = SvPV_nolen(*sv); else package = PJS_OBJECT_PACKAGE; } sv_setref_pv(robj, PJS_RAW_OBJECT, (void*)object); sv_setref_iv(rjsv, PJS_RAW_JSVAL, (IV)value); boxref = PJS_CallPerlMethod(aTHX_ cx, "__new", sv_2mortal(newSVpv(package, 0)), // package sv_2mortal(robj), // content sv_2mortal(rjsv), // jsval NULL ); if(!boxref) return JS_FALSE; if(!SvOK(boxref) || !sv_derived_from(boxref, PJS_BOXED_PACKAGE)) croak("PJS_Assert: Contructor must return a "NAMESPACE"Boxed"); /* Create a new PASSPORT */ passport = JS_NewObject(cx, &passport_class, NULL, object); if(!passport || !JS_DefineProperty(cx, object, PJS_PASSPORT_PROP, OBJECT_TO_JSVAL(passport), NULL, NULL, JSPROP_READONLY | JSPROP_PERMANENT)) return JS_FALSE; box = SvRV(boxref); /* boxref is mortal, so we need to increment its rc, at end of * scope, PASSPORT owns created box */ JS_SetPrivate(cx, passport, (void *)SvREFCNT_inc_simple_NN(box)); JS_SetReservedSlot(cx, passport, 0, PRIVATE_TO_JSVAL(object)); PJS_DEBUG2("New boxed: %s brc: %d\n", hkey, SvREFCNT(box)); } /* Root object adding it to pvisitors list, will be unrooted by * jsc_free_root at Boxed DESTROY time */ JS_DefineProperty(cx, pcx->pvisitors, hkey, value, NULL, NULL, 0); } /* Here the RC of box in PASSPORT reflects wrapper's ownership */ if(full && PJS_getFlag(pcx, "AutoTie") && (strEQ(classname, "Object") || strEQ(classname, "Array")) ) { /* Return tied */ AV *avbox = (AV *)SvRV(box); SV **last; SV *tied; SV *tier; if(strEQ(classname, "Array")) { last = av_fetch(avbox, 6, 1); if(last && SvOK(*last) && SvROK(*last)) { // Cached *sv = newSVsv(*last); sv_free(box); /* Hard copy 'sv' owns the reference */ return JS_TRUE; } tied = (SV *)newAV(); } else { // Object last = av_fetch(avbox, 5, 1); if(last && SvOK(*last) && SvROK(*last)) { // Cached *sv = newSVsv(*last); sv_free(box); /* Hard copy 'sv' owns the reference */ return JS_TRUE; } tied = (SV *)newHV(); } /* hv_magic below own a reference to box, we use an explicit path, * to make clear that to perl land only one reference is given */ tier = newRV_inc(box); hv_magic((HV *)tied, (GV *)tier, PERL_MAGIC_tied); sv_free(tier); wrapper = newRV_noinc(tied); /* Don't leak the hidden tied variable */ /* Save in cache a weaken copy, the cache itself dosn't hold a reference */ sv_setsv(*last, wrapper); sv_rvweaken(*last); PJS_DEBUG1("Return tied for %s\n", SvPV_nolen(tier)); } else { wrapper = newRV_noinc(box); /* Transfer ownership to wrapper */ #if PERL_VERSION < 9 sv_bless(wrapper, SvSTASH(box)); #endif } *sv = wrapper; return JS_TRUE; } return JS_FALSE; }
/* Convert bigint to an unsigned integer, or croak trying. * * @param bigint: the perl object to convert * @returns: unsigned integer */ static guint64 bigint2uint64(SV *bigint) { SV *sv; char *str; guint64 rv; int count; dSP; /* first, see if it's a BigInt */ if (!sv_isobject(bigint) || !sv_derived_from(bigint, "Math::BigInt")) croak("Expected an integer or a Math::BigInt; cannot convert"); ENTER; SAVETMPS; /* make sure the bigint is positive: * croak(..) unless $bigint->sign() eq "+"; */ PUSHMARK(SP); XPUSHs(bigint); PUTBACK; count = call_method("Math::BigInt::sign", G_SCALAR); SPAGAIN; if (count != 1) croak("Expected a result from Math::BigInt::sign"); sv = POPs; str = SvPV_nolen(sv); if (!str) croak("Math::BigInt::sign did not return a string"); if (strcmp(str, "+") != 0) croak("Expected a positive number; value out of range"); /* get the value: * strtoull($bigint->bstr()) */ PUSHMARK(SP); XPUSHs(bigint); PUTBACK; count = call_method("Math::BigInt::bstr", G_SCALAR); SPAGAIN; if (count != 1) croak("Expected a result from Math::BigInt::bstr"); sv = POPs; str = SvPV_nolen(sv); if (!str) croak("Math::BigInt::bstr did not return a string"); errno = 0; rv = g_ascii_strtoull(str, NULL, 0); if (rv == G_MAXUINT64 && errno == ERANGE) croak("Expected an unsigned 64-bit value or smaller; value '%s' out of range", str); if (errno) croak("Math::BigInt->bstr returned invalid number '%s'", str); PUTBACK; FREETMPS; LEAVE; return rv; }
/* Converts perl values to equivalent JS values */ JSBool PJS_ReflectPerl2JS( pTHX_ JSContext *cx, JSObject *pobj, SV *ref, jsval *rval ) { PJS_Context *pcx = PJS_GET_CONTEXT(cx); JSObject *newobj = NULL; if(++pcx->svconv % 2000 == 0) { JSErrorReporter older; ENTER; SAVETMPS; /* Scope for finalizers */ older = JS_SetErrorReporter(cx, NULL); if(pcx->svconv > 10000) { JS_GC(cx); pcx->svconv = 0; } else JS_MaybeGC(cx); JS_SetErrorReporter(cx, older); FREETMPS; LEAVE; } if(SvROK(ref)) { MAGIC *mg; /* First check old jsvisitors */ if((newobj = PJS_IsPerlVisitor(aTHX_ pcx, SvRV(ref)))) { PJS_DEBUG("Old jsvisitor returns\n"); *rval = OBJECT_TO_JSVAL(newobj); return JS_TRUE; } if(SvMAGICAL(SvRV(ref)) && (mg = mg_find(SvRV(ref), PERL_MAGIC_tied)) && mg->mg_obj && sv_derived_from(mg->mg_obj, PJS_BOXED_PACKAGE)) { PJS_DEBUG1("A magical ref %s, shortcircuit!\n", SvPV_nolen((SV*)mg->mg_obj)); ref = mg->mg_obj; } if(sv_derived_from(ref, PJS_BOXED_PACKAGE)) { SV **fref = av_fetch((AV *)SvRV(SvRV(ref)), 2, 0); assert(sv_derived_from(*fref, PJS_RAW_JSVAL)); *rval = (jsval)SvIV(SvRV(*fref)); return JS_TRUE; } if(sv_derived_from(ref, PJS_BOOLEAN)) { *rval = SvTRUE(SvRV(ref)) ? JSVAL_TRUE : JSVAL_FALSE; return JS_TRUE; } if(sv_isobject(ref)) { newobj = PJS_NewPerlObject(aTHX_ cx, pobj, ref); if(newobj) { *rval = OBJECT_TO_JSVAL(newobj); return JS_TRUE; } return JS_FALSE; } } SvGETMAGIC(ref); if(!SvOK(ref)) /* undef */ *rval = JSVAL_VOID; else if(SvIOK(ref) || SvIOKp(ref)) { if(SvIV(ref) <= JSVAL_INT_MAX) *rval = INT_TO_JSVAL(SvIV(ref)); else JS_NewDoubleValue(cx, (double) SvIV(ref), rval); } else if(SvNOK(ref)) JS_NewDoubleValue(cx, SvNV(ref), rval); else if(SvPOK(ref) || SvPOKp(ref)) { STRLEN len; char *str; SV *temp=NULL; if(SvREADONLY(ref)) { temp = newSVsv(ref); str = PJS_SvPV(temp, len); } else str = PJS_SvPV(ref, len); JSString *jstr = ((int)len >= 0) ? JS_NewStringCopyN(cx, str, len) : JS_NewUCStringCopyN(cx, (jschar *)str, -(int)len); sv_free(temp); if(!jstr) return JS_FALSE; *rval = STRING_TO_JSVAL(jstr); } else if(SvROK(ref)) { /* Plain reference */ I32 type = SvTYPE(SvRV(ref)); if(type == SVt_PVHV) newobj = PJS_NewPerlHash(aTHX_ cx, pobj, ref); else if(type == SVt_PVAV) newobj = PJS_NewPerlArray(aTHX_ cx, pobj, ref); else if(type == SVt_PVCV) newobj = PJS_NewPerlSub(aTHX_ cx, pobj, ref); else newobj = PJS_NewPerlScalar(aTHX_ cx, pobj, ref); if(!newobj) return JS_FALSE; *rval = OBJECT_TO_JSVAL(newobj); } else { warn("I have no idea what perl send us (it's of type %i), I'll pretend it's undef", SvTYPE(ref)); *rval = JSVAL_VOID; } return JS_TRUE; }