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;
}
