/* Called by context when a branch occurs */
JSBool PJS_branch_handler(JSContext *cx, JSScript *script) {
dSP;
PJS_Context *pcx;
SV *rv;
I32 rc = 0;
JSBool status = JS_TRUE;
pcx = PJS_GET_CONTEXT(cx);
if (pcx != NULL && pcx->branch_handler) {
ENTER ;
SAVETMPS ;
PUSHMARK(SP);
rc = perl_call_sv(SvRV(pcx->branch_handler), G_SCALAR | G_EVAL);
SPAGAIN;
rv = POPs;
if (!SvTRUE(rv)) {
status = JS_FALSE;
}
if (SvTRUE(ERRSV)) {
sv_setsv(ERRSV, &PL_sv_undef);
status = JS_FALSE;
}
PUTBACK;
FREETMPS;
LEAVE;
}
return status;
}
/* Universal call back for functions */
JSBool PJS_construct_perl_object(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *rval) {
PJS_Class *pcls;
PJS_Context *pcx;
JSFunction *jfunc = PJS_FUNC_SELF;
char *name;
if ((pcx = PJS_GET_CONTEXT(cx)) == NULL) {
JS_ReportError(cx, "Can't find context %d", cx);
return JS_FALSE;
}
name = (char *) JS_GetFunctionName(jfunc);
if ((pcls = PJS_GetClassByName(pcx, name)) == NULL) {
JS_ReportError(cx, "Can't find class %s", name);
return JS_FALSE;
}
/* Check if we are allowed to instanciate this class */
if (pcls->flags & PJS_CLASS_NO_INSTANCE) {
JS_ReportError(cx, "Class '%s' can't be instanciated", pcls->clasp->name);
return JS_FALSE;
}
if (SvROK(pcls->cons)) {
SV *rsv;
SV *pkg = newSVpv(pcls->pkg, 0);
if (perl_call_sv_with_jsvals_rsv(cx, obj, pcls->cons, pkg, argc, argv, &rsv) < 0) {
/* We must have thrown an exception */
return JS_FALSE;
}
JS_SetPrivate(cx, obj, (void *) rsv);
}
return JS_TRUE;
}
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);
}
JSBool PJS_invoke_perl_property_getter(JSContext *cx, JSObject *obj, jsval id, jsval *vp) {
dSP;
PJS_Context *pcx;
PJS_Class *pcls;
PJS_Property *pprop;
SV *caller;
char *name;
jsint slot;
U8 invocation_mode;
if (!(JSVAL_IS_INT(id) || JSVAL_IS_STRING(id))) {
return JS_TRUE;
}
if((pcx = PJS_GET_CONTEXT(cx)) == NULL) {
JS_ReportError(cx, "Can't find context %d", cx);
return JS_FALSE;
}
if (JS_TypeOfValue(cx, OBJECT_TO_JSVAL(obj)) == JSTYPE_OBJECT) {
/* Called as instsance */
JSClass *clasp = PJS_GET_CLASS(cx, obj);
name = (char *) clasp->name;
invocation_mode = 1;
}
else {
/* Called as static */
JSFunction *parent_jfunc = JS_ValueToFunction(cx, OBJECT_TO_JSVAL(obj));
if (parent_jfunc == NULL) {
JS_ReportError(cx, "Failed to extract class for static property getter");
return JS_FALSE;
}
name = (char *) JS_GetFunctionName(parent_jfunc);
invocation_mode = 0;
}
if ((pcls = PJS_GetClassByName(pcx, name)) == NULL) {
JS_ReportError(cx, "Can't find class '%s'", name);
return JS_FALSE;
}
if (invocation_mode) {
caller = (SV *) JS_GetPrivate(cx, obj);
}
else {
caller = newSVpv(pcls->pkg, 0);
}
if (JSVAL_IS_INT(id)) {
slot = JSVAL_TO_INT(id);
if ((pprop = PJS_get_property_by_id(pcls, (int8) slot)) == NULL) {
if (SvTRUE(pcls->property_getter)) {
if (perl_call_sv_with_jsvals(cx, obj, pcls->property_getter, caller, 1, &id, vp) < 0) {
return JS_FALSE;
}
return JS_TRUE;
}
JS_ReportError(cx, "Can't find property handler");
return JS_FALSE;
}
if (pprop->getter == NULL) {
JS_ReportError(cx, "Property is write-only");
return JS_FALSE;
}
if (perl_call_sv_with_jsvals(cx, obj, pprop->getter, caller, 0, NULL, vp) < 0) {
return JS_FALSE;
}
}
else if (JSVAL_IS_STRING(id) && SvTRUE(pcls->property_getter)) {
SV *sv = sv_newmortal();
#ifdef JS_C_STRINGS_ARE_UTF8
char *tmp = JS_smprintf("%hs", JS_GetStringChars(JSVAL_TO_STRING(id)));
sv_setpv(sv, tmp);
SvUTF8_on(sv);
free(tmp);
#else
sv_setpv(sv, JS_GetStringBytes(JSVAL_TO_STRING(id)));
#endif
if (PJS_get_method_by_name(pcls, SvPV_nolen(sv))) {
return JS_TRUE;
}
if (perl_call_sv_with_jsvals(cx, obj, pcls->property_getter, caller, 1, &id, vp) < 0) {
return JS_FALSE;
}
}
return JS_TRUE;
}
JSBool PJS_invoke_perl_object_method(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *rval) {
PJS_Context *pcx;
PJS_Class *pcls;
PJS_Function *pfunc;
JSFunction *jfunc = PJS_FUNC_SELF;
SV *caller;
char *name;
U8 invocation_mode;
if((pcx = PJS_GET_CONTEXT(cx)) == NULL) {
JS_ReportError(cx, "Can't find context %d", cx);
return JS_FALSE;
}
if (JS_TypeOfValue(cx, OBJECT_TO_JSVAL(obj)) == JSTYPE_OBJECT) {
/* Called as instsance */
JSClass *clasp = PJS_GET_CLASS(cx, obj);
name = (char *) clasp->name;
invocation_mode = 1;
}
else {
/* Called as static */
JSFunction *parent_jfunc = JS_ValueToFunction(cx, OBJECT_TO_JSVAL(obj));
if (parent_jfunc == NULL) {
JS_ReportError(cx, "Failed to extract class for static property getter");
return JS_FALSE;
}
name = (char *) JS_GetFunctionName(parent_jfunc);
invocation_mode = 0;
}
if (!(pcls = PJS_GetClassByName(pcx, name))) {
JS_ReportError(cx, "Can't find class '%s'", name);
return JS_FALSE;
}
name = (char *) JS_GetFunctionName(jfunc);
if((pfunc = PJS_get_method_by_name(pcls, name)) == NULL) {
JS_ReportError(cx, "Can't find method '%s' in '%s'", name, pcls->clasp->name);
return JS_FALSE;
}
if (invocation_mode) {
caller = (SV *) JS_GetPrivate(cx, obj);
}
else {
caller = newSVpv(pcls->pkg, 0);
}
/* XXX: the original invocation here has slightly different
retrun value handling. if the returned value is reference
same as priv, don't return it. While the case is not
covered by the tets */
if (perl_call_sv_with_jsvals(cx, obj, pfunc->callback,
caller, argc, argv, rval) < 0) {
return JS_FALSE;
}
return JS_TRUE;
}
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;
}
/* 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;
}
/* 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;
}
