PJS_PerlSub.c

#include "XSUB.h"

#include "JavaScript_Env.h"

#include "PJS_Context.h"
#include "PJS_Class.h"
#include "PJS_PerlSub.h"

static PJS_PerlSub * PJS_NewPerlSub();
static void perlsub_finalize(JSContext *cx, JSObject *obj);
static JSBool perlsub_call(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *rval);
static JSBool perlsub_apply(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *rval);

static const char *PerlSubPkg = "JavaScript::PerlSub";

static JSClass perlsub_class = {
    "PerlSub", JSCLASS_HAS_PRIVATE,
    JS_PropertyStub, JS_PropertyStub,
    JS_PropertyStub, JS_PropertyStub,
    JS_EnumerateStub, JS_ResolveStub,
    JS_ConvertStub, perlsub_finalize,
    NULL,
    NULL,
    perlsub_call,
    NULL,
    NULL,
    NULL,
    NULL,
    NULL
};

static JSPropertySpec perlsub_props[] = {
    {0, 0, 0, 0, 0}
};

static JSFunctionSpec perlsub_methods[] = {
  {"apply", perlsub_apply, 2, 0, 0},
  {0, 0, 0, 0 ,0}
};

PJS_PerlSub * PJS_NewPerlSub() {
    dTHX;
    PJS_PerlSub *obj;
    
    Newz(1, obj, 1, PJS_PerlSub);
    obj->cv = NULL;
    
    return obj;
}

JSObject * PJS_NewPerlSubObject(JSContext *cx, JSObject *parent, SV *ref) {
    dTHX;
    JSObject *obj = JS_NewObject(cx, &perlsub_class, NULL, parent);
    PJS_PerlSub *sub = PJS_NewPerlSub();
    sub->cv = SvREFCNT_inc(ref);
    SV *sv = newSV(0);
    sv_setref_pv(sv, "JavaScript::PerlSub", (void*) sub);
    JS_SetPrivate(cx, obj, (void *) sv); 
    
    return obj;
    
}

JSObject *PJS_InitPerlSubClass(PJS_Context *pcx, JSObject *global) {
    dTHX;
    PJS_Class *cls;
    
    Newz(1, cls, 1, PJS_Class);
    
    cls->pkg  = savepv(PerlSubPkg);
    cls->clasp = &perlsub_class;
    
    cls->proto = JS_InitClass(
        pcx->cx, global, NULL, &perlsub_class, NULL, 0, 
        perlsub_props, perlsub_methods,
        NULL, NULL
    );
    
    PJS_store_class(pcx, cls);
    
    return cls->proto;
}

static void perlsub_finalize(JSContext *cx, JSObject *obj) {
    dTHX;
    SV *self = (SV *) JS_GetPrivate(cx, obj);
    if (self) {
        IV tmp = SvIV((SV *) SvRV((SV *) self));
        PJS_PerlSub *sub = INT2PTR(PJS_PerlSub *, tmp);
        SvREFCNT_dec(sub->cv);
        SvREFCNT_dec(self);
    }
}

static JSBool perlsub_apply(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *rval) {
  dTHX;

  jsuint jsarrlen;
  jsuint index;
  jsval *arg_list;
  jsval elem;

  JSObject *object = JSVAL_TO_OBJECT(argv[1]);

  /* flatten the array, as perl wants $this, arg1, arg2, arg3, etc... */
  JS_GetArrayLength(cx, object, &jsarrlen);
  Newz(1, arg_list, jsarrlen + 1, jsval);
  arg_list[0] = argv[0];
  for ( index = 0; index < jsarrlen; index++ ) {
    JS_GetElement(cx, object, index, &elem);
    arg_list[index+1] = elem;
  }

  SV *fn = (SV *) JS_GetPrivate(cx, (JSObject *) obj);
  if (fn != NULL) {
    IV tmp = SvIV((SV *) SvRV((SV *) fn));
    PJS_PerlSub *sub = INT2PTR(PJS_PerlSub *, tmp);
    if (perl_call_sv_with_jsvals(cx, obj, sub->cv, NULL, jsarrlen+1, arg_list, rval) < 0) {
      return JS_FALSE;
    }
    
    return JS_TRUE;
  }
    
    return JS_FALSE;
}

static JSBool perlsub_call(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *rval) {
    dTHX;
    SV *self = (SV *) JS_GetPrivate(cx, (JSObject *) argv[-2]);
    if (self != NULL) {
        IV tmp = SvIV((SV *) SvRV((SV *) self));
        PJS_PerlSub *sub = INT2PTR(PJS_PerlSub *, tmp);
        if (perl_call_sv_with_jsvals(cx, obj, sub->cv, NULL, argc, argv, rval) < 0 || JS_IsExceptionPending(cx)) {
            return JS_FALSE;
        }
        
        return JS_TRUE;
    }
    
    return JS_FALSE;
}