The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#include "JavaScript.h"

#include "PJS_Call.h"
#include "PJS_Context.h"

JSBool checkSeen( JSContext *cx, JSObject *seen, SV *ref, jsval *rval ) {
    /* a string rep of a pointer to the object */
    char hkey[32];
    int klen = snprintf(hkey, 32, "%p", ref);

    jsval seen_value;
    if ( JS_GetProperty(cx, seen, hkey, &seen_value) == JS_FALSE )
        return JS_FALSE;

    if (!( JSVAL_IS_NULL(seen_value) || JSVAL_IS_VOID(seen_value))) {
        /* seen this before */
        *rval = seen_value;
        return JS_TRUE;
    }

    return JS_FALSE;
}

JSBool setSeen( JSContext *cx, JSObject *seen, SV *ref, jsval rval ) {
    /* a string rep of a pointer to the object */
    char hkey[32];
    int klen = snprintf(hkey, 32, "%p", ref);
    return JS_DefineProperty(cx, seen, hkey, rval, NULL, NULL, JSPROP_ENUMERATE);
}

/* Converts perl values to equivalent JavaScript values */
JSBool PJS_ConvertPerlToJSType(JSContext *cx, JSObject *seen, JSObject *obj, SV *ref, jsval *rval) {
    int destroy_seen = 0; /* TODO - do we _need_ to clean up after us? */
    
    if (sv_isobject(ref) && strcmp(HvNAME(SvSTASH(SvRV(ref))), PJS_BOXED_PACKAGE) == 0) {
        /* XXX: test this more */
        ref = *av_fetch((AV *) SvRV(SvRV(ref)), 0, 0);
    }

    if (sv_isobject(ref)) { /* blessed */
        PJS_Context *pcx;
        PJS_Class *pjsc;
        JSObject *newobj;
        HV *stash = SvSTASH(SvRV(ref));
        char *name = HvNAME(stash);

        if (strcmp(name, PJS_FUNCTION_PACKAGE) == 0) {
            JSFunction *func = INT2PTR(JSFunction *, SvIV((SV *) SvRV(PJS_call_perl_method("content", ref, NULL))));
            JSObject *obj = JS_GetFunctionObject(func);
            *rval = OBJECT_TO_JSVAL(obj);
            return JS_TRUE;
        }
        
	if (strcmp(name, PJS_GENERATOR_PACKAGE) == 0) {
	  JSObject *obj = INT2PTR(JSObject *, SvIV((SV *) SvRV(PJS_call_perl_method("content", ref, NULL))));
	  *rval = OBJECT_TO_JSVAL(obj);
	  return JS_TRUE;
	}

        /* ugly hack, this needs to be nicer */
        if((pcx = PJS_GET_CONTEXT(cx)) == NULL) {
            *rval = JSVAL_VOID;
            return JS_FALSE;
        }
                
        if((pjsc = PJS_GetClassByPackage(pcx, name)) == NULL) {
            *rval = JSVAL_VOID;
            return JS_FALSE;
        }
        
        SvREFCNT_inc(ref);
        
        newobj = JS_NewObject(cx, pjsc->clasp, NULL, obj);
        
        JS_SetPrivate(cx, newobj, (void *) ref);
        
        *rval = OBJECT_TO_JSVAL(newobj);
        
        return JS_TRUE;
    }

    if (!SvOK(ref)) {
        /* Returned value is undefined */
        *rval = JSVAL_VOID;
    }
    else if (SvIOK(ref)) {
        /* Returned value is an integer */
        if (SvIV(ref) <= JSVAL_INT_MAX) {
            *rval = INT_TO_JSVAL(SvIV(ref));
        } else {
            JS_NewDoubleValue(cx, (double) SvIV(ref), rval);
        }
    }
    else if (SvNOK(ref)) {
        JS_NewDoubleValue(cx, SvNV(ref), rval);
    }
    else if(SvPOK(ref)) {
        /* Returned value is a string */
        char *str;
        STRLEN len;

#ifdef JS_C_STRINGS_ARE_UTF8
        str = SvPVutf8(ref, len);
#else
        str = SvPVbyte(ref, len);
#endif
        *rval = STRING_TO_JSVAL(JS_NewStringCopyN(cx, str, len));
    }
    else if(SvROK(ref)) { /* reference */
        I32 type;

        if (!seen) {
            seen = JS_NewObject(cx, NULL, NULL, NULL);
            if(seen == NULL)
                croak("Failed to create new JavaScript object");
            destroy_seen = 1;
        }
        

        type = SvTYPE(SvRV(ref));

        /* Most likely it's an hash that is returned */
        if(type == SVt_PVHV) {
            JSObject *new_obj;
            HV *hv = (HV *) SvRV(ref);
            I32 items;
            HE *key;
            char *keyname;
            SV *keysv;
            STRLEN keylen;
            SV *keyval;
            jsval elem;
            
            if ( checkSeen( cx, seen, (SV*)hv, rval ) == JS_TRUE )
                return JS_TRUE;

            new_obj = JS_NewObject(cx, NULL, NULL, NULL);
            if(new_obj == NULL)
                croak("Failed to create new JavaScript object");

            setSeen( cx, seen, (SV*)hv, OBJECT_TO_JSVAL(new_obj) );

            /* Assign properties, lets iterate over the hash */
            items = hv_iterinit(hv);
            
            while((key = hv_iternext(hv)) != NULL) {
                /* although most hash keys are stored as char*, it's _way_
                   easier from a logic point of view to convert the bytes
                   to an SV (so we know the charset) and then back again.
                   TODO - we should only do this if we need to change the
                   encoding of the key. */

                /* if the key is an SV, this will return a *SV, otherwise null */
                keysv = HeSVKEY( key );
                if (keysv) {
                    /* great. Do nothing. */
                    warn ("here - got SV key %p", keysv);
#ifdef JS_C_STRINGS_ARE_UTF8
                    keyname = SvPVutf8(keysv, SvLEN( keysv ) );
#else
                    keyname = SvPVbyte(keysv, SvLEN( keysv ) );
#endif

                } else {
                    /* otherwise, just a pv key */
                    keyname = HeKEY( key );
#ifdef JS_C_STRINGS_ARE_UTF8
                    if (!HeKUTF8( key )) {
                        /* key is bytes, we want utf8. */
                        keysv = newSV(0);
                        sv_setpv( keysv, keyname );
                        keyname = SvPVutf8(keysv, SvLEN( keysv ) );
                        sv_2mortal( keysv );
                    }
#else
                    if (HeKUTF8( key )) {
                        /* key is utf8, we want bytes. */
                        keysv = newSV(0);
                        sv_setpv( keysv, keyname );
                        SvUTF8_on(keysv);
                        keyname = SvPVbyte(keysv, SvLEN( keysv ) );
                        sv_2mortal( keysv );
                    }
#endif
                }

                keyval = (SV *) hv_iterval(hv, key);
                if (PJS_ConvertPerlToJSType(cx, seen, obj, keyval, &elem) == JS_FALSE) {
                    *rval = JSVAL_VOID;
                    return JS_FALSE;
                }
                
                if (JS_DefineProperty(cx, new_obj, keyname, elem, NULL, NULL, JSPROP_ENUMERATE) == JS_FALSE) {
                    warn("Failed to defined property %%", keyname);
                }
            }
                
            *rval = OBJECT_TO_JSVAL(new_obj);
        } else if(type == SVt_PVAV) {
            jsint av_length;
            jsint cnt;
            jsval *elems;
            JSObject *arr_obj;
            /* Then it's probablly an array */
            AV *av = (AV *) SvRV(ref);

            if ( checkSeen( cx, seen, (SV*)av, rval ) == JS_TRUE )
                return JS_TRUE;

            arr_obj = JS_NewArrayObject(cx, 0, NULL);

            setSeen( cx, seen, (SV*)av, OBJECT_TO_JSVAL(arr_obj) );

            av_length = av_len(av);
            for(cnt = 0; cnt <= av_length; cnt++) {
                jsval value;
                if (PJS_ConvertPerlToJSType(cx, seen, obj, *(av_fetch(av, cnt, 0)), &value) == JS_FALSE) {
                    *rval = JSVAL_VOID;
                    return JS_FALSE;
                }
                JS_DefineElement(cx, arr_obj, cnt, value, NULL, NULL, JSPROP_ENUMERATE );
            }
            
            *rval = OBJECT_TO_JSVAL(arr_obj);
        }
        else if(type == SVt_PVGV) {
            *rval = PRIVATE_TO_JSVAL(ref);
        }
        else if(type == SVt_PV || type == SVt_IV || type == SVt_NV || type == SVt_RV) {
            /* Not very likely to return a reference to a primitive type, but we need to support that aswell */
            warn("returning references to primitive types is not supported yet");   
        }
        else if(type == SVt_PVCV) {
            JSObject *newobj = PJS_NewPerlSubObject(cx, obj, ref);            
            *rval = OBJECT_TO_JSVAL(newobj);
        }
        else {
            warn("JavaScript.pm not handling this yet");
            *rval = JSVAL_VOID;
            return JS_FALSE;
        }

    }
    else {
        warn("I have no idea what ref is (it's of type %i), I'll pretend it's null", SvTYPE(ref));
        *rval = JSVAL_VOID;
    }
    

    return JS_TRUE;
}
/* Converts a JavaScript value to equivalent Perl value */
JSBool JSVALToSV(JSContext *cx, HV *seen, jsval v, SV** sv) {
    if (JSVAL_IS_PRIMITIVE(v)) {
        if (JSVAL_IS_NULL(v) || JSVAL_IS_VOID(v)){
            *sv = &PL_sv_undef;
        }
        else if (JSVAL_IS_INT(v)) {
            sv_setiv(*sv, JSVAL_TO_INT(v));
        }
        else if (JSVAL_IS_DOUBLE(v)) {
            sv_setnv(*sv, *JSVAL_TO_DOUBLE(v));
        }
        else if (JSVAL_IS_STRING(v)) {
            /* XXX: review this, JS_GetStringBytes twice causing assertaion failure */
#ifdef JS_C_STRINGS_ARE_UTF8
            char *tmp = JS_smprintf("%hs", JS_GetStringChars(JSVAL_TO_STRING(v)));
            sv_setpv(*sv, tmp);
            SvUTF8_on(*sv);
            free(tmp);
#else
            sv_setpv(*sv, JS_GetStringBytes(JSVAL_TO_STRING(v)));
#endif         
        }
        else if (JSVAL_IS_BOOLEAN(v)) {
            if (JSVAL_TO_BOOLEAN(v)) {
                *sv = &PL_sv_yes;
            }
            else {
            *sv = &PL_sv_no;
            }
        }
        else {
            croak("Unknown primitive type");
        }
    }
    else {
        if (JSVAL_IS_OBJECT(v)) {
            JSObject *object = JSVAL_TO_OBJECT(v);
            int destroy_hv;
            SV **used;
            char hkey[32];
            int klen;
            
            /* stringify object with a default value for now, such as
               String.  We might want to actually tie the object in the
               future, so the additional properties won't go away */
            {
                jsval dvalue;
                if (OBJ_DEFAULT_VALUE(cx, object, JSTYPE_OBJECT, &dvalue) &&
                    JSVAL_IS_STRING(dvalue)) {
                    sv_setpv(*sv, JS_GetStringBytes(JSVAL_TO_STRING(dvalue)));
                    return JS_TRUE;
                }
            }

#ifdef JS_ENABLE_E4X
            if (OBJECT_IS_XML(cx,object)) {
                    /* We can't use private functions so let's call the toString method on the object */
                    jsval tv;
                    JSString *xmlstring;
                    JS_CallFunctionName(cx, object, "toXMLString", 0, NULL, &tv);
                    xmlstring = JS_ValueToString(cx,tv);
                    sv_setpv(*sv, JS_GetStringBytes(xmlstring));
                    SvUTF8_on(*sv);
                    return JS_TRUE;
            } 
            else if (JS_ObjectIsFunction(cx, object)) {
#else
            if (JS_ObjectIsFunction(cx, object)) {
#endif               
                JSFunction *jsfun = JS_ValueToFunction(cx, v);
                SV *pcx = sv_2mortal(newSViv(PTR2IV(PJS_GET_CONTEXT(cx))));
                SV *content = sv_2mortal(newRV_noinc(newSViv(PTR2IV(jsfun))));
                jsval *x;
                
                Newz(1, x, 1, jsval);
                if (x == NULL) {
                    croak("Failed to allocate memory for jsval");
                }
                *x = v;
                JS_AddRoot(cx, (void *)x);

                sv_setsv(*sv, PJS_call_perl_method("new",
                                                   newSVpv(PJS_FUNCTION_PACKAGE, 0),
                                                   content, pcx,
                                                   sv_2mortal(newSViv(PTR2IV(x))), NULL));
                return JS_TRUE;
            }
	    else if (!strcmp(JS_GET_CLASS(cx,object)->name, "RegExp")) {
	      jsval src;

	      if ( JS_GetProperty(cx, object, "source", &src) == JS_TRUE ) {
		dSP;
		ENTER;
		SAVETMPS;
		PUSHMARK(SP);
		SV *arg = sv_newmortal();	      
		sv_setpv(arg, JS_GetStringBytes(JS_ValueToString(cx, src)));		
		XPUSHs(arg);
		PUTBACK;
		call_pv("JavaScript::_compile_string_re", G_SCALAR);
		SPAGAIN;
		sv_setsv(*sv, POPs);
		PUTBACK;
		FREETMPS;
		LEAVE;
		return JS_TRUE;
	      }

	      return JS_FALSE;
	    }
            else if (OBJ_IS_NATIVE(object) &&
                     (OBJ_GET_CLASS(cx, object)->flags & JSCLASS_HAS_PRIVATE) &&
                     (strcmp(OBJ_GET_CLASS(cx, object)->name, "Error") != 0) &&
		     (strcmp(OBJ_GET_CLASS(cx, object)->name, "Generator") != 0)
		     ) {
                /* Object with a private means the actual perl object is there */
                /* This is kludgy because function is also object with private,
                   we need to turn this to use hidden property on object */
                SV *priv = (SV *)JS_GetPrivate(cx, object);
                if (priv && SvROK(priv)) {
                    sv_setsv(*sv, priv);
                    return JS_TRUE;
                }
            }
	    else if (OBJ_IS_NATIVE(object) &&
		     (OBJ_GET_CLASS(cx, object)->flags & JSCLASS_HAS_PRIVATE) &&
		     (strcmp(OBJ_GET_CLASS(cx, object)->name, "Generator") == 0)
		     ){
	      SV *content = sv_2mortal(newRV_noinc(newSViv(PTR2IV(object))));
	      SV *pcx = sv_2mortal(newSViv(PTR2IV(PJS_GET_CONTEXT(cx))));
	      jsval *x;
               
	      Newz(1, x, 1, jsval);
	      if (x == NULL) {
		croak("Failed to allocate memory for jsval");
	      }
	      *x = v;
	      JS_AddRoot(cx, (void *)x);

	      sv_setsv(*sv, PJS_call_perl_method("new",
						 newSVpv(PJS_GENERATOR_PACKAGE, 0),
						 content, pcx,
						 sv_2mortal(newSViv(PTR2IV(x))), NULL));
	      return JS_TRUE;	      
	    }

            destroy_hv = 0;
            if (!seen) {
                seen = newHV();
                destroy_hv = 1;
            }
            
            klen = snprintf(hkey, 32, "%p", object);
            if ((used = hv_fetch(seen, hkey, klen, 0)) != NULL) {
                sv_setsv(*sv, *used);
                return JS_TRUE;
            } else if(JS_IsArrayObject(cx, object)) {
                SV *arr_sv;
                
                arr_sv = JSARRToSV(cx, seen, object);
                
                sv_setsv(*sv, arr_sv);
            } else {
                SV *hash_sv;
                
                hash_sv = JSHASHToSV(cx, seen, object);
                sv_setsv(*sv, hash_sv);
            }
            
            if (destroy_hv) {
              SvREFCNT_dec(seen);
            }
        }
        else {
            croak("Not an object nor a primitive");
        }
    }
    
    
    return JS_TRUE;
}

/* Converts an JavaScript array object to an Perl array reference */
SV *JSARRToSV(JSContext *cx, HV *seen, JSObject *object) {
    jsuint jsarrlen;
    jsuint index;
    jsval elem;
    
    AV *av = newAV();
    SV *sv = sv_2mortal(newRV_noinc((SV *) av));

    char hkey[32];
    int klen = snprintf(hkey, 32, "%p", object);

    hv_store(seen, hkey, klen, sv, 0);
    SvREFCNT_inc(sv);

    JS_GetArrayLength(cx, object, &jsarrlen);
    for(index = 0; index < jsarrlen; index++) {
        SV *elem_sv;

        JS_GetElement(cx, object, index, &elem);        
        elem_sv = newSV(0);
        
        JSVALToSV(cx, seen, elem, &elem_sv);
        av_push(av, elem_sv);
    }

    return sv;
}

/* Converts a JavaScript object (not array) to a anonymous perl hash reference */
SV *JSHASHToSV(JSContext *cx, HV *seen, JSObject *object) {
    JSIdArray *prop_arr = JS_Enumerate(cx, object);
    int idx;

    HV *hv = newHV();
    SV *sv = sv_2mortal(newRV_noinc((SV *) hv));
    
    char hkey[32];
    int klen = snprintf(hkey, 32, "%p", object);
    hv_store(seen, hkey, klen, sv, 0);
    SvREFCNT_inc(sv);
    
    for(idx = 0; idx < prop_arr->length; idx++) {
        jsval key;
        
        JS_IdToValue(cx, (prop_arr->vector)[idx], &key);
        
        if(JSVAL_IS_STRING(key)) {
            jsval value;
            SV *val_sv;
            
            SV *js_key_sv = sv_newmortal();
            char *js_key = JS_GetStringBytes(JSVAL_TO_STRING(key));
            sv_setpv(js_key_sv, js_key);

#ifdef JS_C_STRINGS_ARE_UTF8
            /* char *js_key = JS_smprintf("%hs", JS_GetStringChars(JSVAL_TO_STRING(v))); */
            SvUTF8_on(js_key_sv);
#endif

            if ( JS_GetProperty(cx, object, js_key, &value) == JS_FALSE ) {
                /* we're enumerating the properties of an object. This returns
                   false if there's no such property. Urk. */
                croak("this can't happen.");
            }
            
            val_sv = newSV(0);
            JSVALToSV(cx, seen, value, &val_sv);
            hv_store_ent(hv, js_key_sv, val_sv, 0);
        }
        else {
            croak("can't coerce object key into a hash");
        }
    }
 
    JS_DestroyIdArray(cx, prop_arr);
  
    return sv;
}