static JSBool
perlsub_call(
JSContext *cx,
DEFJSFSARGS_
) {
dTHX;
DECJSFSARGS;
JSObject *func = JSVAL_TO_OBJECT(JS_ARGV_CALLEE(argv));
SV *callee = (SV *)JS_GetPrivate(cx, func);
JSObject *This = JSVAL_TO_OBJECT(argv[-1]);
JSClass *clasp = PJS_GET_CLASS(cx, This);
SV *caller;
JSBool wanta, isclass = JS_FALSE;
if(!JS_GetProperty(cx, func, "$wantarray", rval) ||
!JS_ValueToBoolean(cx, *rval, &wanta))
return JS_FALSE;
PJS_DEBUG1("In PSC: obj is %s\n", PJS_GET_CLASS(cx, obj)->name);
if(clasp == &perlpackage_class) {
if(!JS_GetProperty(cx, This, "$__im_a_class", rval) ||
!JS_ValueToBoolean(cx, *rval, &isclass))
return JS_FALSE;
}
if(isclass ||
( clasp == &perlsub_class /* Constructors has a Stash in __proto__ */
&& (func = JS_GetPrototype(cx, This))
&& PJS_GET_CLASS(cx, func) == &perlpackage_class)
) { // Caller is a stash, make a static call
char *pkgname = PJS_GetPackageName(aTHX_ cx, This);
if(!pkgname) return JS_FALSE;
caller = newSVpv(pkgname, 0);
PJS_DEBUG1("Caller is a stash: %s\n", pkgname);
#if JS_VERSION >= 185
Safefree(pkgname);
#endif
}
else if(IS_PERL_CLASS(clasp) &&
sv_isobject(caller = (SV *)JS_GetPrivate(cx, This))
) { // Caller is a perl object
SvREFCNT_inc_void_NN(caller);
PJS_DEBUG1("Caller is an object: %s\n", SvPV_nolen(caller));
}
else {
caller = NULL;
PJS_DEBUG1("Caller is %s\n", clasp->name);
}
return PJS_Call_sv_with_jsvals(aTHX_ cx, obj, callee, caller, argc, argv,
rval, wanta ? G_ARRAY : G_SCALAR);
}
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;
}
JSBool
perlsub_as_constructor(
JSContext *cx,
JSObject *obj,
pjsid id,
DEFSTRICT_
jsval *vp
) {
// dTHX;
const char *key;
if(!PJSID_IS(STRING, id)) {
return JS_TRUE;
}
#if JS_VERSION < 185
key = JS_GetStringBytes(PJSID_TO(STRING, id));
#else
JSAutoByteString bytes(cx, PJSID_TO(STRING, id));
key = bytes.ptr();
#endif
if(strEQ(key, "constructor")) {
JSObject *constructor;
if(JSVAL_IS_OBJECT(*vp) && (constructor = JSVAL_TO_OBJECT(*vp)) &&
PJS_GET_CLASS(cx, constructor) == &perlsub_class) {
/* TODO: Change the constructor 'name' */
jsval temp;
JSObject *stash = JS_GetPrototype(cx, obj);
JS_SetPrototype(cx, stash, JS_GetPrototype(cx, constructor));
JS_SetPrototype(cx, constructor, stash);
JS_DefineProperty(cx, constructor, "prototype", OBJECT_TO_JSVAL(obj),
NULL, NULL, 0);
JS_LookupProperty(cx, obj, "__PACKAGE__", &temp);
// warn("Constructor set for %s\n", JS_GetStringBytes(JSVAL_TO_STRING(temp)));
return JS_TRUE;
} else {
JS_ReportError(cx, "Invalid constructor type");
return JS_FALSE;
}
} else
warn ("Opps: setting %s?\n", key);
return JS_TRUE;
}
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;
}
/* 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;
}
