jsperl.c

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

static JSBool
PVSetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
{
    char* str = JS_GetStringBytes(JS_ValueToString(cx, name));

    if(JSVAL_IS_INT(name)){
        int32 ip;

        JS_ValueToInt32(cx, name, &ip);
        if(PVSetElement(cx, obj, ip, *rval)) return JS_TRUE;
    }
    return PVSetKey(cx, obj, str, *rval);
}

/*
    Retrieve numerical property of a PerlValue object.
    If the object doesn't contain an array, or the
    property doesn't exist, NULL is returned.
*/
static JSBool
PVGetElement(JSContext *cx, JSObject *obj, jsint index, jsval *rval)
{
    SV *ref, **sv;
    AV *list;

    *rval = JSVAL_VOID;

    ref = PVGetRef(cx, obj);

    if(SvTYPE(SvRV(ref)) != SVt_PVAV){
        return JS_FALSE;
    }

    list = (AV*)SvRV(ref);

    if(!list){
        return JS_FALSE;
    }
    sv = av_fetch(list, (I32)index, 0);
    if(!sv){
        return JS_FALSE;
    }
    //return SVToJSVAL(cx, obj, newRV_inc(*sv), rval);
    return SVToJSVAL(cx, obj, *sv, rval);
}

/*
    Set a numeric property of a PerlValue object.
    If the object doesn't contain an array or the
    index doesn't exist, JS_FALSE is returned.
*/
static JSBool
PVSetElement(JSContext *cx, JSObject *obj, jsint index, jsval v)
{
    SV *ref, **sv, *s;
    AV *list;

    ref = PVGetRef(cx, obj);

    if(SvTYPE(SvRV(ref)) != SVt_PVAV){
        return JS_FALSE;
    }

    list = (AV*)SvRV(ref);

    if(!list) return JS_FALSE;
    JSVALToSV(cx, obj, v, &s);
    sv = av_store(list, (I32)index, s);
    if(!sv) return JS_FALSE;
    return JS_TRUE;
}

/*
    Retrieve property. If the object doesn't contain an hash, or the
    property doesn't exist, NULL is returned.
*/
static JSBool
PVGetKey(JSContext *cx, JSObject *obj, char* name, jsval *rval)
{
    SV *ref, **sv;
    HV *hash;

    *rval = JSVAL_VOID;
    ref = PVGetRef(cx, obj);

    if(SvTYPE(SvRV(ref)) != SVt_PVHV){
        return JS_FALSE;
    }

    hash = (HV*)SvRV(ref);

    if(!hash){
        return JS_FALSE;
    }
    sv = hv_fetch(hash, name, strlen(name), 0);
    if(!sv){
        return JS_FALSE;
    }
    return SVToJSVAL(cx, obj, newRV_inc(*sv), rval);
}

/*
    Get property of a PerlValue object.
    If the object doesn't contain a hash or the
    property doesn't exist, JS_FALSE is returned.
*/
static JSBool
PVSetKey(JSContext *cx, JSObject *obj, char* name, jsval v)
{
    SV *ref, **sv, *s;
    HV *hash;

    ref = PVGetRef(cx, obj);

    if(SvTYPE(SvRV(ref)) != SVt_PVHV){
        return JS_FALSE;
    }

    hash = (HV*)SvRV(ref);

    if(!hash) return JS_FALSE;
    JSVALToSV(cx, obj, v, &s);
    sv = hv_store(hash, name, strlen(name), s, 0);
    if(!sv) return JS_FALSE;
    else return JS_TRUE;
}

/*
    toString() method for PerlValue. For arrays uses array's methods.
    If this fails, the type of the value gets returned. TODO: It's actually
    better to use a Perl module like Data::Dumpvar.pm to print complex
    data structures recursively.
*/
static JSBool
PVToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval)
{
    SV* ref     = PVGetRef(cx, obj);
    SV* sv      = SvRV(ref);
    svtype type = SvTYPE(sv);
    /*jsval args[]= {STRING_TO_JSVAL(JS_NewStringCopyZ(cx, "JS::Object::toString")),
                            OBJECT_TO_JSVAL(obj)};*/
    jsval v;
    /*return perl_call(cx, obj, 2, args, rval);*/

    if (type==SVt_PVAV) {
        JSObject   *arrayObject = JS_NewArrayObject(cx,0,NULL);
        JSFunction *fun;

        JS_GetProperty(cx, arrayObject, "toString", &v);
        fun = JS_ValueToFunction(cx, v);
        return JS_CallFunction(cx, obj, fun, 0, NULL, rval);
    } 
    {
        char out[256];
        JSString *newString;
        JS_GetProperty(cx, obj, "type", &v);
        if(!JSVAL_IS_VOID(v))
            sprintf(out, "[%s]", JS_GetStringBytes(JSVAL_TO_STRING(v)));
        else
            strcpy(out, "[PerlValue]");
        newString = JS_NewStringCopyZ(cx, out);
        if (!newString)
            return JS_FALSE;
        *rval = STRING_TO_JSVAL(newString);
    }
    return JS_TRUE;
}

static JSBool
PVConvert (JSContext *cx, JSObject *obj, JSType type, jsval *rval)
{
    *rval = OBJECT_TO_JSVAL(obj);
    return JS_TRUE;
}

/*
    Takes care of GC in Perl: we need to decrement Perl's
    reference count when PV goes out of scope.
*/

/* #include <stdio.h> */

static void
PVFinalize (JSContext *cx, JSObject *obj)
{
    /* SV* sv = SvRV(PVGetRef(cx, obj)); */
    SV *sv;

    if ( obj ) {
        sv = PVGetRef(cx, obj);
        
        /* SV *sv = PVGetRef(cx, obj);
           if ( SvROK(sv) ) sv = SvRV( sv ); _PH_ test*/
        
        /* TODO: GC */
        if(sv && SvREFCNT(sv) > 0){
            /*fprintf(stderr, "Finalization: %d references left", SvREFCNT(sv));*/
            SvREFCNT_dec(sv);
            /*fprintf(stderr, "Finalization: %d references left", SvREFCNT(sv));*/
        }
    }
    /*    return JS_TRUE; */
}

/*
    Convert a jsval to a SV* (scalar value pointer).
    Used for parameter passing. This function is also
    used by the Perl part of PerlConnect.
*/

JSBool
JSVALToSV(JSContext *cx, JSObject *obj, jsval v, SV** sv)
{
    //*sv = &sv_undef; //__PH__??
    if(JSVAL_IS_PRIMITIVE(v)){
        if(JSVAL_IS_NULL(v) || JSVAL_IS_VOID(v)){
            *sv = &PL_sv_undef;
            //printf("===> JSVALToSV: VOID\n");
        }else
        if(JSVAL_IS_INT(v)){
            *sv = sv_newmortal();
            sv_setiv(*sv, JSVAL_TO_INT(v));
            //*sv = newSViv(JSVAL_TO_INT(v));
            //printf("===> JSVALToSV: INT\n");
        }else
        if(JSVAL_IS_DOUBLE(v)){
            *sv = sv_newmortal();
            sv_setnv(*sv, *JSVAL_TO_DOUBLE(v));
            //*sv = newSVnv(*JSVAL_TO_DOUBLE(v));
            //printf("===> JSVALToSV: DOUBLE\n");
        }else
        if(JSVAL_IS_STRING(v)){
            *sv = sv_newmortal();
            sv_setpv(*sv, JS_GetStringBytes(JSVAL_TO_STRING(v)));
            //*sv = newSViv(0);
            //sv_setpv(*sv, JS_GetStringBytes(JSVAL_TO_STRING(v)));
            //printf("===> JSVALToSV: CHAR\n");
        }else{
            warn("Unknown primitive type");
        }
    }else{
        if(JSVAL_IS_OBJECT(v)){
            JSObject *object = JSVAL_TO_OBJECT(v);
            if(JS_InstanceOf(cx, object, &perlValueClass, NULL)){
                *sv = PVGetRef(cx, object);
            }else{
                if(JS_IsArrayObject(cx, object)){
                    *sv = sv_newmortal();
                    sv_setref_pv(*sv, "JS::Object", (void*)object);
                    sv_magic(SvRV(*sv), sv_2mortal(newSViv((IV)cx)), 
                             '~', NULL, 0);
                    /* printf("===> JSVALToSV: ARRAY\n); */
                }else{
                    *sv = sv_newmortal();
                    sv_setref_pv(*sv, "JS::Object", (void*)object);
                    sv_magic(SvRV(*sv), sv_2mortal(newSViv((IV)cx)), 
                             '~', NULL, 0);
                    //printf("===> JSVALToSV: JS OBJECT\n");
                }
            }
        }else{
            warn("Type conversion is not supported");
            *sv = &PL_sv_undef;  //__PH__??
            return JS_FALSE;
        }
    }
    return JS_TRUE;
}

/*
    Converts a reference Perl value to a jsval. If ref points
    to an immediate value, the value itself is returned in rval.
    O.w. a PerlValue object is returned. This function is also
    used by the Perl part of PerlConnect.
*/

#define SV_BIND_TO_OBJECT(sv) (sv_isobject(sv) || (SvROK(sv) && (\
               SvTYPE(SvRV(sv)) == SVt_RV   ||\
               SvTYPE(SvRV(sv)) == SVt_PVAV ||\
               SvTYPE(SvRV(sv)) == SVt_PVHV ||\
               SvTYPE(SvRV(sv)) == SVt_PVCV\
            )))

JSBool
SVToJSVAL(JSContext *cx, JSObject *obj, SV *ref, jsval *rval) {
    SV *sv;
    char* name=NULL;
    JSBool ok = JS_TRUE;

    /* we'll use the dereferrenced value (excpet for object) */
    if( SvROK(ref) ) {
        sv = SvRV(ref);
    }else{
        sv = ref;
    }

    /* printf("+++> In SVToJSVAL value %s, type=%d\n", SvPV(sv, PL_na), SvTYPE(sv)); */

    if ( ! SvOK( ref ) ){
        *rval = JSVAL_VOID;
        /* printf("---> SVToJSVAL returning VOID\n"); */
    } else
    if ( SV_BIND_TO_OBJECT(ref) ) {
        JSObject *perlValue, *prototype = NULL;
        JSString *nameString;

        /*svtype type = SvTYPE(sv);
          switch(type){
          case SVt_RV:   name = "Perl Reference"; break;
          case SVt_PVAV: name = "Perl Array"; break;
          case SVt_PVHV: name = "Perl Hash"; break;
          case SVt_PVCV: name = "Perl Code Reference"; break;
          case SVt_PVMG: name = "Perl Magic"; break;
          default:
          warn("Unsupported type in SVToJSVAL: %d", type);
          *rval = JSVAL_VOID;
          return JS_FALSE;
          }*/
        
        /* printf("---> SVToJSVAL returning object\n"); */
        name = "Perl Value";
        /* __PH__ */
        SvREFCNT_inc(ref);

        if (SvTYPE(sv) == SVt_PVAV) {
            prototype = JS_NewArrayObject(cx, 0, NULL);
            if (!prototype)
                return JS_FALSE;
        }

        perlValue = JS_DefineObject(cx, obj, "PerlValue",
                                    &perlValueClass, prototype, 
                                    JSPROP_ENUMERATE);
        if (!perlValue)
            return JS_FALSE;
        JS_SetPrivate(cx, perlValue, ref);
        if (!JS_DefineFunctions(cx, perlValue, perlValueMethods))
            return JS_FALSE;
        if (name) {
            nameString = JS_NewStringCopyZ(cx, name);
            if (!nameString)
                return JS_FALSE;
        }
        if (!JS_DefineProperty(cx, perlValue, "type",
                               name?STRING_TO_JSVAL(nameString):JSVAL_VOID,
                               NULL, NULL, JSPROP_PERMANENT|JSPROP_READONLY))
            return JS_FALSE;
        *rval = OBJECT_TO_JSVAL(perlValue); 
    } else
    if(SvIOK(sv)){
        *rval = INT_TO_JSVAL(SvIV(sv));
        /* printf("---> SVToJSVAL returning INTEGER\n"); */
    } else
    if(SvNOK(sv)){
        ok = JS_NewDoubleValue(cx, SvNV(sv), rval);
        /* printf("---> SVToJSVAL returning DOUBLE\n"); */
    } else
    if(SvPOK(sv)){
        *rval = STRING_TO_JSVAL((JS_NewStringCopyZ(cx, SvPV(sv, PL_na))));
        /* printf("---> SVToJSVAL returning CHAR\n\n"); */
    } else {
        *rval = JSVAL_VOID; /* shouldn't happen */
        /* printf("---> SVToJSVAL returning VOID (panic)\n"); */
    }
    return ok;
}