#include "JS.h"
extern JSClass perlpackage_class;
static const char *PerlSubPkg = NAMESPACE"PerlSub";
static JSBool perlsub_call(JSContext *, DEFJSFSARGS_);
static JSBool perlsub_construct(JSContext *, DEFJSFSARGS_);
static JSClass perlsub_class = {
"PerlSub", JSCLASS_PRIVATE_IS_PERL,
JS_PropertyStub, JS_PropertyStub, JS_PropertyStub, PJS_SetterPropStub,
JS_EnumerateStub, JS_ResolveStub, JS_ConvertStub, PJS_unrootJSVis,
NULL,
NULL,
perlsub_call,
perlsub_construct,
NULL,
NULL,
NULL,
NULL
};
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;
}
JSObject*
PJS_NewPerlSub(
pTHX_
JSContext *cx,
JSObject *parent,
SV *cvref
) {
JSObject *newobj = PJS_CreateJSVis(
aTHX_ cx,
JS_NewObject(cx, &perlsub_class, NULL, parent),
cvref
);
if(newobj) {
CV *cv = (CV *)SvRV(cvref);
const char *fname = CvANON(cv) ? "(anonymous)" : GvENAME(CvGV(cv));
JSString *jstr = JS_InternString(cx, fname);
if(!jstr || !JS_DefineProperty(cx, newobj, "name",
STRING_TO_JSVAL(jstr),
NULL, NULL,
JSPROP_READONLY | JSPROP_PERMANENT)
) {
PJS_unrootJSVis(cx, newobj);
newobj = NULL;
}
}
return newobj;
}
/* The public JS side constructor */
static JSBool
PerlSub(
JSContext *cx,
DEFJSFSARGS_
) {
dTHX;
DECJSFSARGS;
// char *tmp;
SV *cvref;
JSBool ok = JS_FALSE;
SV *source;
/* If the path fails, the object will be finalized, so its needs the
* private setted */
if(!obj) obj = JS_NewObject(cx, &perlsub_class, NULL, NULL);
JS_SetPrivate(cx, obj, (void *)newRV(&PL_sv_undef));
ENTER; SAVETMPS;
if(argc != 1) {
JS_ReportError(cx, "PerlSub constructor requires more arguments");
return JS_FALSE;
}
if((source = PJS_JSString2SV(aTHX_ cx, JS_ValueToString(cx, argv[0]))) &&
(cvref = PJS_CallPerlMethod(aTHX_ cx,
"_const_sub",
sv_2mortal(newSVpv(PerlSubPkg, 0)),
sv_2mortal(source),
NULL)))
ok = PJS_CreateJSVis(aTHX_ cx, obj, cvref) != NULL;
if(ok) PJS_SET_RVAL(cx, OBJECT_TO_JSVAL(obj));
FREETMPS; LEAVE;
return ok;
}
JSObject*
PJS_InitPerlSubClass(
pTHX_
JSContext *cx,
JSObject *global
) {
CV *pcv = get_cv(NAMESPACE"PerlSub::prototype", 0);
JSObject *proto;
if(pcv && (CvROOT(pcv) || CvXSUB(pcv))) {
proto = JS_InitClass(
cx,
global,
PJS_GetPackageObject(aTHX_ cx, PerlSubPkg),
&perlsub_class,
PerlSub, 1,
NULL, NULL,
NULL, NULL
);
return PJS_CreateJSVis(aTHX_ cx, proto,
sv_2mortal(newRV_inc((SV *)pcv)));
}
croak("Can't locate PerlSub::prototype");
return NULL;
}