jsperl.c

caffeine-monkey java实现的js模拟引擎

    int i;

    if (!evalStr)
        return JS_FALSE;

    strcpy(evalStr, t?t:"");

    for(i=0;i<argc;i++){
        char *arg = JS_GetStringBytes(JS_ValueToString(cx, argv[i])), *tmp, old[256];

        /* call use() on every parameter */
        strcpy(old, evalStr);
	JS_free(cx, evalStr);
        tmp = JS_malloc(cx, strlen(old)+strlen(arg)+6);
        if (!tmp)
            return JS_FALSE;
        sprintf(tmp, "%suse %s;", old, arg);
        evalStr = tmp;
    }

    perl_eval_sv(newSVpv(evalStr, 0), G_KEEPERR);

    checkError(cx);
    JS_free(cx, evalStr);
    return JS_TRUE;
}

/*
    Looks at $@ to see if there was an error. Used by
    perl_eval, perl_call, etc.
*/
static JSBool
checkError(JSContext *cx)
{
    if(SvTRUE(GvSV(PL_errgv))){ 
        JS_ReportError(cx, "perl eval failed: %s",
            SvPV(GvSV(PL_errgv), PL_na));
        /* clear error status. there should be a way to do this faster */
        perl_eval_sv(newSVpv("undef $@;", 0), G_KEEPERR);
        return JS_FALSE;
    }
    return JS_TRUE;
}

/*
    Take the value of $JS::js and convert it to a jsval. It is stored
    in *rval. perl_eval and perl_call use $JS::js to store return results.
*/
static JSBool
processReturn(JSContext *cx, JSObject *obj, jsval* rval)
{
    SV  *js;

    js = perl_get_sv("JS::js", FALSE);

    if(!js || !SvOK(js)){
        *rval = JSVAL_VOID;
        /* XXX isn't this wrong? */
        return JS_FALSE;
    }
    if(!SvROK(js)){
        JS_ReportError(cx, "$js (%s) must be of reference type", SvPV(js,PL_na));
        return JS_FALSE;
    }

    checkError(cx);

    return SVToJSVAL(cx, obj, js, rval);
}

/*
    Implements namespace-like syntax that maps Perl packages to
    JS objects. One can say
        p = new Perl('Foo::Bar')
    and then call
        a = p.Foo.Bar.f()
    or access variables exported from those packages like this:
        a = p.Foo.Bar["$var"]
    this syntax will also work:
        a = p.Foo.Bar.$var
    but if you want to access non-scalar values, you must use the subscript syntax:
        p.Foo.Bar["@arr"]
    and
        p.Foo.Bar["%hash"]
*/
static JSBool
PMGetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
{
    char *last = JS_GetStringBytes(JS_ValueToString(cx, name)), *path, package[256];
    char *args[] = {NULL, NULL};
    char *predefined_methods[] = {"toString", "eval", "call", "use", "path"};
    int count;
    SV  *js;
    jsval v;
    int i;

    for(i=0;i<sizeof(predefined_methods)/sizeof(char*);i++){
        if(!strcmp(predefined_methods[i], last)){
            return JS_TRUE;
        }
    }

    JS_GetProperty(cx, obj, "path", &v);
    path = JS_GetStringBytes(JS_ValueToString(cx, v));
    sprintf(package, "%s::%s", path, last);
    args[0] = package;

    count = perl_call_argv("JS::perl_resolve", G_KEEPERR|G_SCALAR|G_EVAL|G_DISCARD, args);
    if(count!=0){
        JS_ReportError(cx, "Implementation error: count=%d, must be 0!\n", count);
        return JS_FALSE;
    }

    checkError(cx);

    js = perl_get_sv("JS::js", FALSE);

    if(js && SvOK(js)){
        if(SvROK(js)){
            SVToJSVAL(cx, obj, js, rval);
        }else{
            /* defined function */
            if(SvIV(js) == 1){
                JSFunction *f = JS_NewFunction(cx, (JSNative)perl_call, 0, 0, NULL, package);
                if (!f) {
                    return JS_FALSE;
                }
                *rval = OBJECT_TO_JSVAL(JS_GetFunctionObject(f));
            }else
            if(SvIV(js) == 2){
                JSObject *module;
                JSString *packageString;
                module = JS_NewObject(cx, &perlModuleClass, NULL, obj);
                packageString = JS_NewStringCopyZ(cx,package);
                if (!module || !packageString) {
                    return JS_FALSE;
                }
                v = (js && SvTRUE(js))?STRING_TO_JSVAL(packageString):JSVAL_VOID;
                JS_SetProperty(cx, module, "path", &v);
                *rval = OBJECT_TO_JSVAL(module);
            }else{
                JS_ReportError(cx, "Symbol %s is not defined", package);
                *rval = JSVAL_VOID;
            }
        }
        return JS_TRUE;
    }else{
        JS_ReportError(cx, "failure");
        return JS_FALSE;
    }
}

/*
    Gets called when a Perl value gets assigned to like this:
        p.Foo.Bar["$var"] = 100
*/
static JSBool
PMSetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
{
    /* TODO: just call SVToJSVAL() and make the assignment. */
    return JS_TRUE;
}

/*
    toString() for PerlModule. Prints the path the module represents.
    Note that the path doesn't necessarily have to be valid. We don't
    have a way to check that until we call a function from that package.
    TODO: In 5.005 exists Foo::{Bar::} checks is Foo::{Bar::} exists.
    We can use this to validate package names.
*/
static JSBool
PMToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval){
    char str[256];
    JSString *s, *newString;
    jsval v;

    JS_GetProperty(cx, obj,  "path", &v);
    s = JSVAL_TO_STRING(v);
    sprintf(str, "[PerlModule %s]", JS_GetStringBytes(s));
    newString = JS_NewStringCopyZ(cx, str);
    if (!newString)
        return JS_FALSE;
    *rval = STRING_TO_JSVAL(newString);
    return JS_TRUE;
}

/*
    Helped method. Retrieves the Perl reference stored
    in PerlValue object as private data.
*/

#include <stdio.h>

static SV*
PVGetRef(JSContext *cx, JSObject *obj)
{
    SV* ref;

    ref = (SV*)JS_GetInstancePrivate(cx, obj, &perlValueClass, NULL);

    if(!ref || !SvOK(ref) || !SvROK(ref)){
        JS_ReportError(cx, "Can't extract ref");
        return NULL;
    }
    return ref;
}

static JSBool
PVCallStub (JSContext *cx, JSObject *obj, uintN argc, 
            jsval *argv, jsval *rval) {
    JSFunction *fun;
    int i, cnt;
    I32 ax;
    SV *sv, *perl_object;
    GV *gv;
    HV *stash;
    char *name;

    dSP;

    fun = JS_ValueToFunction(cx, argv[-2]);
    perl_object = PVGetRef(cx, obj);

    fun = JS_ValueToFunction(cx, argv[-2]);
    name = (char*) JS_GetFunctionName(fun);

    stash = SvSTASH(SvRV(perl_object));
    gv = gv_fetchmeth(stash, name, strlen(name), 0);
    /* cnt = perl_call_pv(method_name, 0); */
    /* start of perl call stuff */
    if (! gv) {
        char msg[256];
        sprintf(msg, "Method ``%s'' not defined", name);
        JS_ReportError(cx, msg);
        return JS_FALSE;
    }

    ENTER;
    SAVETMPS;
    PUSHMARK(SP);
    //SvREFCNT_inc(perl_object);
    XPUSHs(perl_object); /* self for perl object method */
    for (i = 0; i < argc; i++) {
        //sv = sv_newmortal();
        JSVALToSV(cx, obj, argv[i], &sv);
        //sv_2mortal(sv);
        XPUSHs(sv);
    }
    PUTBACK;

    cnt = perl_call_sv((SV*)GvCV(gv), G_ARRAY | G_KEEPERR | G_EVAL);

    //SvREFCNT_dec(perl_object);

    SPAGAIN;
    /* adjust stack for use of ST macro (see perlcall) */
    SP -= cnt;
    ax = (SP - PL_stack_base) + 1;

    /* read value(s) */
    if (cnt == 1) {
        SVToJSVAL(cx, obj, ST(0), rval);
    } else {
        JSObject *jsarr;
        jsval val;
        int i;
        jsarr = JS_NewArrayObject(cx, 0, NULL);
        for (i = 0; i < cnt; i++) {
            SVToJSVAL(cx, JS_GetGlobalObject(cx), ST(i), &val);
            JS_DefineElement(cx, jsarr, i, val, NULL, NULL, 0);
        }
        *rval = OBJECT_TO_JSVAL(jsarr);
    }
    PUTBACK;

    FREETMPS;
    LEAVE;

    //return(JS_TRUE);
    return checkError(cx);
}

/*
    Retrieve property from PerlValue object by its name. Tries
    to look at the PerlValue object both as a hash and array.
    If the index is numerical, then it looks at the array part
    first. *rval contains the result.
*/
/* __PH__
    ...but. PVGetproperty now firstly looks for method in given 
    object package. If such method if found, then is returned 
    universal method stub. Sideeffect of this behavior is, that
    method are looked first before properties of the same name.

    Second problem is security. In this way any perl method could 
    be called. We pay security leak for this. May be we could 
    support some Perl exporting process (via some package global 
    array).
*/
static JSBool
PVGetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
{
    char* str;

    /* __PH__ array properties should be served first */
    if(JSVAL_IS_INT(name)){
        int32 ip;

        JS_ValueToInt32(cx, name, &ip);
        PVGetElement(cx, obj, ip, rval);
        if(*rval!=JSVAL_VOID){
            return JS_TRUE;
        }
    }

    str = JS_GetStringBytes(JS_ValueToString(cx, name));

    /* __PH__ may, be */
    if(!strcmp(str, "length")){
        SV* sv = SvRV(PVGetRef(cx, obj));

        if(SvTYPE(sv)==SVt_PVAV){
            *rval = INT_TO_JSVAL(av_len((AV*)sv)+1);
            return JS_TRUE;
        }else
        if(SvTYPE(sv)==SVt_PVHV){
            *rval = INT_TO_JSVAL(av_len((AV*)sv)+1);
            return JS_TRUE;
        }else{
            *rval = INT_TO_JSVAL(0);
            return JS_TRUE;
        }
    }else{
        int i;
        /* __PH__ predefined methods NUST win */
        for(i=0; i < sizeof(predefined_methods)/sizeof(char*); i++){
            if(!strcmp(predefined_methods[i], str)){
                return JS_TRUE;
            }
        }

        /* __PH__ properties in hash should be served at last (possibly) */
        PVGetKey(cx, obj, str, rval);
        if (*rval!=JSVAL_VOID) {
            return JS_TRUE;
        } else {
#if 0
            char* str = JS_GetStringBytes(JS_ValueToString(cx, name));
            JS_ReportError(cx, "Perl: can't get property '%s'", str);
            return JS_FALSE;
#else
            /* when Volodya does another job, we may experiment :-) */
            char* str = JS_GetStringBytes(JS_ValueToString(cx, name));
            /* great, but who will dispose it? (GC of JS??) */
            JSFunction *fun = JS_NewFunction(cx, PVCallStub, 0, 0, NULL, str);
            *rval = OBJECT_TO_JSVAL(JS_GetFunctionObject(fun));
            return(JS_TRUE);
#endif
        }
    }
    return JS_TRUE;
}

/*
    Set property of PerlValue object. Like GetProperty is looks at
    both array and hash components.
*/