From 7ac6f89e90a7f1e2c36bde0462476c4fb09f02d4 Mon Sep 17 00:00:00 2001 From: "pavel%gingerall.cz" Date: Tue, 7 Nov 2000 15:24:49 +0000 Subject: [PATCH] - jsperl.c compiled with js programm, not with libjs - better JS value tie methods - memory leaks fixed - support of digging native js error from exception --- js/src/Makefile.ref | 6 +- js/src/perlconnect/JS.pm | 8 +- js/src/perlconnect/JS.xs | 101 +++++++++++++++----- js/src/perlconnect/Makefile.PL | 55 +++++++++-- js/src/perlconnect/jsperl.c | 169 +++++++++++++++++++++------------ js/src/perlconnect/jsperl.h | 2 +- js/src/perlconnect/test.pl | 108 ++++++++++----------- js/src/perlconnect/typemap | 5 +- 8 files changed, 296 insertions(+), 158 deletions(-) diff --git a/js/src/Makefile.ref b/js/src/Makefile.ref index c4a06d7bc6f..dd02f846b88 100644 --- a/js/src/Makefile.ref +++ b/js/src/Makefile.ref @@ -93,7 +93,8 @@ PERLLDFLAGS := $(shell perl -MExtUtils::Embed -e ldopts) PERLLDFLAGS := $(subst -rdynamic,-export-dynamic,$(PERLLDFLAGS)) CFLAGS += $(PERLCFLAGS) -LDFLAGS += $(PERLLDFLAGS) +#LDFLAGS += $(PERLLDFLAGS) #PH removed this assgnment +INCLUDES += -I. #needed for perlconnect/jsperl.c endif # @@ -267,6 +268,9 @@ else LIBRARY = $(OBJDIR)/libjs.a SHARED_LIBRARY = $(OBJDIR)/libjs.$(SO_SUFFIX) PROGRAM = $(OBJDIR)/js +ifdef JS_PERLCONNECT +PROG_LIBS += $(PERLLDFLAGS) +endif endif include rules.mk diff --git a/js/src/perlconnect/JS.pm b/js/src/perlconnect/JS.pm index 81ab5b7a2af..319abf4be69 100644 --- a/js/src/perlconnect/JS.pm +++ b/js/src/perlconnect/JS.pm @@ -109,10 +109,10 @@ sub DESTROY #7/31/98 4:54PM package JS::Context; use vars qw($AUTOLOAD $DEBUG); -sub AUTOLOAD #7/28/98 8:24PM -{ - print "\nJS::Context::AUTOLOAD: $AUTOLOAD, not implemented yet\n" if $DEBUG; -} ##AUTOLOAD +# sub AUTOLOAD #7/28/98 8:24PM +# { +# print "\nJS::Context::AUTOLOAD: $AUTOLOAD, not implemented yet\n" if $DEBUG; +# } ##AUTOLOAD sub new #7/31/98 3:39PM { diff --git a/js/src/perlconnect/JS.xs b/js/src/perlconnect/JS.xs index f45c253b88c..d4b681f68f6 100644 --- a/js/src/perlconnect/JS.xs +++ b/js/src/perlconnect/JS.xs @@ -54,12 +54,17 @@ } #endif -#include "../jsapi.h" +#include #include "jsperlpvt.h" #include /* __REMOVE__ */ -/* #include */ +/* #include */ + +/* this is internal js structure needed in errorFromPrivate */ +typedef struct JSExnPrivate { + JSErrorReport *errorReport; +} JSExnPrivate; static JSClass global_class = { @@ -143,7 +148,9 @@ PCB_ErrorReporter(JSContext *cx, const char *message, JSErrorReport *report) PUSHMARK(SP); XPUSHs(sv_2mortal(newSVpv((char*)message, 0))); if ( report ) { - XPUSHs(sv_2mortal(newSVpv((char*)report->filename, 0))); + if ( report->filename ) { + XPUSHs(sv_2mortal(newSVpv((char*)report->filename, 0))); + } XPUSHs(sv_2mortal(newSViv(report->lineno))); if (report->linebuf) { XPUSHs(sv_2mortal(newSVpv((char*)report->linebuf, 0))); @@ -152,7 +159,6 @@ PCB_ErrorReporter(JSContext *cx, const char *message, JSErrorReport *report) } PUTBACK; perl_call_sv(report_proc, G_VOID | G_DISCARD); - } else { warn(message); } @@ -271,7 +277,9 @@ PCB_FreeContextItem(JSContext * cx) { objitem = next; } - SvREFCNT_dec(cxitem->errorReporter); + if (cxitem->errorReporter) { + SvREFCNT_dec(cxitem->errorReporter); + } if ( context_list == cxitem ) { context_list = cxitem->next; @@ -376,7 +384,6 @@ PCB_SetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval) { proc_sv = sv_newmortal(); sv_setpv(proc_sv, full_name); - value_sv = sv_newmortal(); JSVALToSV(cx, obj, *rval, &value_sv); /* start of perl call stuff */ ENTER; @@ -445,14 +452,12 @@ PCB_UniversalStub (JSContext *cx, JSObject *obj, uintN argc, croak("Couldn't find stub for object"); if (! (cbk = PCB_FindCallback(po, JS_GetFunctionName(fun)))) croak("Couldn't find perl callback"); - /* start of perl call stuff */ ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(po->pObject); /* self for perl object method */ for (i = 0; i < argc; i++) { - sv = sv_newmortal(); JSVALToSV(cx, obj, argv[i], &sv); XPUSHs(sv); } @@ -471,12 +476,13 @@ PCB_UniversalStub (JSContext *cx, JSObject *obj, uintN argc, } else { warn("sorry, but array results are not supported yet..."); } - PUTBACK; + PUTBACK; FREETMPS; LEAVE; - return(JS_TRUE); + /* this solution is not perfect, but usefull when nested call happens */ + return(! JS_IsExceptionPending(cx)); }; /* __PH__END */ @@ -553,7 +559,6 @@ JS_NewContext(rt, stacksize) { JSObject *obj; /* jsval v; comment out unused var __PH__*/ - /* Here we are creating the globals object ourselves. */ JSContext *cx; cx = JS_NewContext(rt, stacksize); cxitem = PCB_NewContextItem(); @@ -577,6 +582,10 @@ JS_DestroyContext(cx) /* warn("===> before context check\n"); */ if(SvREFCNT(ST(0)) == 1){ /* warn("===> really destroing context"); */ + if (JS_IsExceptionPending(cx)) { + JS_ClearPendingException(cx); + } + JS_SetErrorReporter(cx, NULL); JS_DestroyContext(cx); PCB_FreeContextItem(cx); } @@ -586,23 +595,28 @@ JS_DestroyContext(cx) MODULE = JS PACKAGE = JS::Context PREFIX = JS_ jsval -JS_eval(cx, bytes) +JS_eval(cx, bytes, ...) JSContext *cx char *bytes PREINIT: JSContextItem *cxitem; + char *filename = NULL; CODE: { jsval rval; + if (items > 2) { filename = SvPV(ST(2), PL_na); }; /* Call on the global object */ if(!JS_EvaluateScript(cx, JS_GetGlobalObject(cx), - bytes, strlen(bytes), "Perl", 0, &rval)){ + bytes, strlen(bytes), + filename ? filename : "Perl", + 0, &rval)){ cxitem = PCB_FindContextItem(cx); if (!cxitem || cxitem->dieFromErrors) croak("Perl eval failed"); XSRETURN_UNDEF; } RETVAL = rval; + //RETVAL = 1; } OUTPUT: RETVAL @@ -619,6 +633,46 @@ JS_setErrorReporter(cx, reporter) SvREFCNT_inc(reporter); if ( cxitem ) cxitem->errorReporter = reporter; +void +JS_unsetErrorReporter(cx) + JSContext *cx + PREINIT: + JSContextItem *cxitem; + CODE: + cxitem = PCB_FindContextItem(cx); + if ( cxitem ) { + if ( cxitem->errorReporter ) + SvREFCNT_dec(cxitem->errorReporter); + cxitem->errorReporter = NULL; + } + +int +JS_hasException(cx) + JSContext *cx + CODE: + RETVAL = ! JS_IsExceptionPending(cx); + OUTPUT: + RETVAL + +void +JS_reportError(cx, msg) + JSContext *cx + char *msg + CODE: + JS_ReportError(cx, msg); + +void +JS_errorFromPrivate(cx, msg, ex) + JSContext *cx + char *msg + JSObject *ex + PREINIT: + JSErrorReport *rep; + CODE: + rep = (JSErrorReport*) JS_GetPrivate(cx, ex); + if (rep) + PCB_ErrorReporter(cx, msg, ((JSExnPrivate*)rep)->errorReport); + void JS_setDieFromErrors(cx, value) JSContext *cx @@ -696,7 +750,7 @@ JS_TIEHASH(class, obj) PREINIT: JSContext* cx; CODE: - RETVAL = obj; + RETVAL = SvREFCNT_inc(obj); OUTPUT: RETVAL @@ -707,7 +761,7 @@ JS_TIEARRAY(class, obj) PREINIT: JSContext* cx; CODE: - RETVAL = obj; + RETVAL = SvREFCNT_inc(obj); OUTPUT: RETVAL @@ -721,7 +775,7 @@ JS_FETCH(obj, key) MAGIC *magic; CODE: { - /* printf("in FETCH\n"); */ + /* printf("+++++++++> FETCH\n"); */ magic = mg_find(SvRV(ST(0)), '~'); if (magic) { cx = (JSContext *)SvIV(magic->mg_obj); @@ -742,13 +796,14 @@ JS_FETCHSIZE(obj) MAGIC *magic; CODE: { - /* printf("in FETCH\n"); */ + /* printf("+++++++++> FETCHSIZE: %d\n", ST(0)); */ magic = mg_find(SvRV(ST(0)), '~'); if (magic) { cx = (JSContext *)SvIV(magic->mg_obj); } else { warn("Tied object has no magic\n"); } + JS_IsArrayObject(cx, obj); JS_GetArrayLength(cx, obj, &RETVAL); } OUTPUT: @@ -762,15 +817,17 @@ JS_STORE(obj, key, value) PREINIT: JSContext* cx; MAGIC *magic; - CODE: { - /* printf("In STORE\n"); */ + /* printf("+++++++++> STORE\n"); */ magic = mg_find(SvRV(ST(0)), '~'); if (magic) { cx = (JSContext *)SvIV(magic->mg_obj); } else { warn("Tied object has no magic\n"); } + } + CODE: + { JS_SetProperty(cx, obj, key, &value); } @@ -783,7 +840,7 @@ JS_DELETE(obj, key) MAGIC *magic; CODE: { - /* printf("In DELETE\n"); */ + /* printf("+++++++++> DELETE\n"); */ magic = mg_find(SvRV(ST(0)), '~'); if (magic) { cx = (JSContext *)SvIV(magic->mg_obj); @@ -801,7 +858,7 @@ JS_CLEAR(obj) MAGIC *magic; CODE: { - /* printf("In CLEAR\n"); */ + /* printf("+++++++++> CLEAR\n"); */ magic = mg_find(SvRV(ST(0)), '~'); if (magic) { cx = (JSContext *)SvIV(magic->mg_obj); @@ -821,7 +878,7 @@ JS_EXISTS(obj, key) CODE: { jsval v; - /* printf("In EXISTS\n"); */ + /* printf("+++++++++> EXISTS\n"); */ magic = mg_find(SvRV(ST(0)), '~'); if (magic) { cx = (JSContext *)SvIV(magic->mg_obj); diff --git a/js/src/perlconnect/Makefile.PL b/js/src/perlconnect/Makefile.PL index cdc3649a321..6b84c4f602b 100644 --- a/js/src/perlconnect/Makefile.PL +++ b/js/src/perlconnect/Makefile.PL @@ -1,18 +1,54 @@ use ExtUtils::MakeMaker; -# we suppose running unix and files placed in perlconnect/ under -# js base; otherwise you have to hack the next line +use strict; +use Getopt::Std; -$jsbase = `pwd`; -chomp $jsbase; -$jsbase =~ s|/perlconnect||; +my (%foo, $jsdir, $inc, $libpath); +#m - build under mozilla tree +#d - specifies js build directory (with include/ and lib/ directories) +#c - build under charlie tree +getopts('mcd:', \%foo); -$inc = "-I$jsbase -I$jsbase/Linux_All_DBG.OBJ"; -$lib = "-L$jsbase/Linux_All_DBG.OBJ -ljs"; +$jsdir = $foo{d}; +$foo{'m'} = 1 unless $foo{c} || $foo{d}; #mozilla tree is the default -%extras = (); +if ($foo{c}) { + $inc = "-I$ENV{CHARLIE_HOME}/include"; + $libpath = "-L$ENV{CHARLIE_HOME}/lib"; +} + +if ($jsdir) { + $inc = "-I$jsdir/include"; + $libpath = "-L$jsdir/lib -ljs"; +} + +my $tmpmk = <<'eof'; +DEPTH=.. +include ../config.mk + +all: + @echo '$(OBJDIR)' +eof + +if ($foo{'m'}) { + if ($^O eq "MSWin32") { + $inc = "-I.. -I../Debug"; #I'm not sure + $libpath = "-L../Debug"; + } else { #suppose unix, never Mac, gmake + open FOO, ">tempmakefile"; + print FOO $tmpmk; + close FOO; + my $objdir = `gmake -f tempmakefile`; + unlink "tempmakefile"; + $inc = "-I.. -I../$objdir"; + $libpath = "-L../objdir"; + } +} + +my %extras = (); +my $define; if ($^O eq "MSWin32") { $define = "-DXP_PC"; @@ -21,11 +57,10 @@ if ($^O eq "MSWin32") { $define = '-DXP_UNIX'; } - WriteMakefile(NAME => 'JS', DEFINE => $define, INC => $inc, - LIBS => $lib, + LIBS => "$libpath -ljs", VERSION_FROM => 'JS.pm', %extras,); diff --git a/js/src/perlconnect/jsperl.c b/js/src/perlconnect/jsperl.c index 1d84b3406fa..eec5b1218d3 100644 --- a/js/src/perlconnect/jsperl.c +++ b/js/src/perlconnect/jsperl.c @@ -46,7 +46,7 @@ #include "perl.h" #include "XSUB.h" -#include "../jsapi.h" +#include #include /*---------------------------------------------------------------------------*/ @@ -58,7 +58,7 @@ /* Forward declarations */ static JSBool PerlConstruct(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *v); -static JSBool PerlFinilize(JSContext *cx, JSObject *obj); +static void PerlFinilize(JSContext *cx, JSObject *obj); static JSBool perl_eval(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval); static JSBool perl_call(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval); static JSBool perl_use(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval); @@ -78,7 +78,7 @@ static JSBool PVSetElement(JSContext *cx, JSObject *obj, jsint index, jsval v); static JSBool PVGetKey(JSContext *cx, JSObject *obj, char* name, jsval *rval); static JSBool PVSetKey(JSContext *cx, JSObject *obj, char* name, jsval v); static JSBool PVConvert(JSContext *cx, JSObject *obj, JSType type, jsval *v); -static JSBool PVFinalize(JSContext *cx, JSObject *obj); +static void PVFinalize(JSContext *cx, JSObject *obj); /* Exported functions */ JS_EXPORT_API(JSObject*) JS_InitPerlClass(JSContext *cx, JSObject *obj); JS_EXPORT_API(JSBool) JSVALToSV(JSContext *cx, JSObject *obj, jsval v, SV** sv); @@ -112,11 +112,11 @@ JSClass perlClass = { JS_EnumerateStub, JS_ResolveStub, JS_ConvertStub, PerlFinilize }; -JSFunctionSpec perlMethods[] = { - {"toString", PerlToString, 0}, - {"eval", perl_eval, 0}, - {"call", perl_call, 0}, - {"use", perl_use, 0}, +static JSFunctionSpec perlMethods[] = { + {"toString", (JSNative)PerlToString, 0}, + {"eval", (JSNative)perl_eval, 0}, + {"call", (JSNative)perl_call, 0}, + {"use", (JSNative)perl_use, 0}, { NULL, NULL,0 } }; @@ -129,7 +129,7 @@ JSClass perlModuleClass = { }; JSFunctionSpec perlModuleMethods[] = { - {"toString", PMToString, 0}, + {"toString", (JSNative)PMToString, 0}, { NULL, NULL,0 } }; @@ -142,7 +142,7 @@ JSClass perlValueClass = { }; JSFunctionSpec perlValueMethods[] = { - {"toString", PVToString, 0}, + {"toString", (JSNative)PVToString, 0}, { NULL, NULL, 0} }; @@ -213,14 +213,14 @@ PerlConstruct(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *v) } /* Destructor. Deallocates the interpreter */ -static JSBool +static void PerlFinilize(JSContext *cx, JSObject *obj) { PerlInterpreter *perl = JS_GetPrivate(cx, obj); perl_destruct(perl); perl_free(perl); - return JS_TRUE; + /* return JS_TRUE; */ } /* @@ -232,7 +232,7 @@ PerlFinilize(JSContext *cx, JSObject *obj) static JSBool PerlToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval){ SV* sv = perl_get_sv("JS::ver", FALSE); - *rval = STRING_TO_JSVAL(JS_NewStringCopyZ(cx, SvPV(sv, na))); + *rval = STRING_TO_JSVAL(JS_NewStringCopyZ(cx, SvPV(sv, PL_na))); return JS_TRUE; } @@ -292,7 +292,7 @@ perl_call(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval) /* Differetiate between direct and method-like call */ if((JS_TypeOfValue(cx, argv[-2]) == JSTYPE_FUNCTION) && strcmp("call", JS_GetFunctionName(JS_ValueToFunction(cx, argv[-2])))){ - fun_name = JS_GetFunctionName(JS_GetPrivate(cx, JSVAL_TO_OBJECT(argv[-2]))); + fun_name = (char*)JS_GetFunctionName(JS_GetPrivate(cx, JSVAL_TO_OBJECT(argv[-2]))); i=0; }else{ fun_name = JS_GetStringBytes(JS_ValueToString(cx, argv[0])); @@ -363,9 +363,9 @@ use(JSContext *cx, JSObject *obj, int argc, jsval *argv, const char* t){ static JSBool checkError(JSContext *cx) { - if(SvTRUE(GvSV(errgv))){ + if(SvTRUE(GvSV(PL_errgv))){ JS_ReportError(cx, "perl eval failed: %s", - SvPV(GvSV(errgv), na)); + 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; @@ -388,7 +388,7 @@ processReturn(JSContext *cx, JSObject *obj, jsval* rval) *rval = JSVAL_VOID; return JS_FALSE; }else if(!SvROK(js)){ - JS_ReportError(cx, "$js (%s) must be of reference type", SvPV(js,na)); + JS_ReportError(cx, "$js (%s) must be of reference type", SvPV(js,PL_na)); return JS_FALSE; } @@ -506,6 +506,9 @@ PMToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval){ Helped method. Retrieves the Perl reference stored in PerlValue object as private data. */ + +#include + static SV* PVGetRef(JSContext *cx, JSObject *obj) { @@ -537,24 +540,35 @@ PVCallStub (JSContext *cx, JSObject *obj, uintN argc, perl_object = PVGetRef(cx, obj); fun = JS_ValueToFunction(cx, argv[-2]); - name = JS_GetFunctionName(fun); + 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(); + //sv = sv_newmortal(); JSVALToSV(cx, obj, argv[i], &sv); + //sv_2mortal(sv); XPUSHs(sv); } PUTBACK; cnt = perl_call_sv((SV*)GvCV(gv), 0); - + + //SvREFCNT_dec(perl_object); + SPAGAIN; /* adjust stack for use of ST macro (see perlcall) */ SP -= cnt; @@ -834,22 +848,29 @@ PVConvert(JSContext *cx, JSObject *obj, JSType type, jsval *rval) Takes care of GC in Perl: we need to decrement Perl's reference count when PV goes out of scope. */ -static JSBool + +/* #include */ + +static void PVFinalize(JSContext *cx, JSObject *obj) { /* SV* sv = SvRV(PVGetRef(cx, obj)); */ - SV* sv = PVGetRef(cx, obj); - /* SV *sv = PVGetRef(cx, obj); - if ( SvROK(sv) ) sv = SvRV( sv ); _PH_ test*/ + SV *sv; - /* TODO: GC */ - if(SvREFCNT(sv)>0){ - /*fprintf(stderr, "Finilization: %d references left", SvREFCNT(sv));*/ - SvREFCNT_dec(sv); - /*fprintf(stderr, "Finilization: %d references left", SvREFCNT(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, "Finilization: %d references left", SvREFCNT(sv));*/ + SvREFCNT_dec(sv); + /*fprintf(stderr, "Finilization: %d references left", SvREFCNT(sv));*/ + } } - - return JS_TRUE; + /* return JS_TRUE; */ } /* @@ -864,16 +885,27 @@ 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 = sv_undef; + *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"); } @@ -881,24 +913,26 @@ JSVALToSV(JSContext *cx, JSObject *obj, jsval v, SV** sv) if(JSVAL_IS_OBJECT(v)){ JSObject *object = JSVAL_TO_OBJECT(v); if(JS_InstanceOf(cx, object, &perlValueClass, NULL)){ - /* newSVsv(SvRV(PVGetRef(cx, object))); //__PH__?? */ *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), newSViv(cx), '~', NULL, 0); + sv_magic(SvRV(*sv), 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), newSViv(cx), '~', NULL, 0); + sv_magic(SvRV(*sv), newSViv((IV)cx), '~', NULL, 0); + //printf("===> JSVALToSV: JS OBJECT\n"); } } }else{ warn("Type conversion is not supported"); - **sv = sv_undef; //__PH__?? + *sv = &PL_sv_undef; //__PH__?? return JS_FALSE; } } - return JS_TRUE; } @@ -909,37 +943,32 @@ JSVALToSV(JSContext *cx, JSObject *obj, jsval v, SV** sv) used by the Perl part of PerlConnect. */ - -#define _IS_UNDEF(a) (SvANY(a) == SvANY(&sv_undef)) +#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; - if(_IS_UNDEF(ref) || !SvRV(ref) || !SvROK(ref)) { - sv = ref; - }else{ + /* we'll use the dereferrenced value (ecpet for object) */ + if( SvROK(ref) ) { sv = SvRV(ref); + }else{ + sv = ref; } - /* printf("In SVToJSVAL value %s, type=%d\n", SvPV(sv, na), SvTYPE(sv)); */ - - /* object references are processed as objecs */ - if ( _IS_UNDEF(sv) ){ + /* printf("+++> In SVToJSVAL value %s, type=%d\n", SvPV(sv, PL_na), SvTYPE(sv)); */ + + if ( ! SvOK( ref ) ){ *rval = JSVAL_VOID; + /* printf("---> SVToJSVAL returnig VOID\n"); */ } else - if(SvIOK(sv)){ - *rval = INT_TO_JSVAL(SvIV(sv)); - } else - if(SvNOK(sv)){ - JS_NewDoubleValue(cx, SvNV(sv), rval); - } else - if(SvPOK(sv)){ - *rval = STRING_TO_JSVAL((JS_NewStringCopyZ(cx, SvPV(sv, na)))); - } else - if (1) /*(sv_isobject(ref))*/ { - JSObject *perlValue; - + if ( SV_BIND_TO_OBJECT(ref) ) { + JSObject *perlValue, *prototype; /*svtype type = SvTYPE(sv); switch(type){ case SVt_RV: name = "Perl Reference"; break; @@ -953,20 +982,38 @@ SVToJSVAL(JSContext *cx, JSObject *obj, SV *ref, jsval *rval) { return JS_FALSE; }*/ - /*printf("default\n");*/ + /* printf("---> SVToJSVAL returning object\n"); */ name = "Perl Value"; /* __PH__ */ SvREFCNT_inc(ref); + if (SvTYPE(sv) == SVt_PVAV) + prototype = JS_NewArrayObject(cx, 0, NULL); + else + prototype = NULL; perlValue = JS_DefineObject(cx, obj, "PerlValue", - &perlValueClass, NULL, JSPROP_ENUMERATE); + &perlValueClass, prototype, JSPROP_ENUMERATE); JS_SetPrivate(cx, perlValue, ref); JS_DefineFunctions(cx, perlValue, perlValueMethods); JS_DefineProperty(cx, perlValue, "type", name?STRING_TO_JSVAL(JS_NewStringCopyZ(cx, name)):JSVAL_VOID, NULL, NULL, JSPROP_PERMANENT|JSPROP_READONLY); *rval = OBJECT_TO_JSVAL(perlValue); + } else + if(SvIOK(sv)){ + *rval = INT_TO_JSVAL(SvIV(sv)); + /* printf("---> SVToJSVAL returnig INTEGER\n"); */ + } else + if(SvNOK(sv)){ + JS_NewDoubleValue(cx, SvNV(sv), rval); + /* printf("---> SVToJSVAL returnig DOUBLE\n"); */ + } else + if(SvPOK(sv)){ + *rval = STRING_TO_JSVAL((JS_NewStringCopyZ(cx, SvPV(sv, PL_na)))); + /* printf("---> SVToJSVAL returnig CHAR\n\n"); */ + } else { + *rval = JSVAL_VOID; /* shouldn't happen */ + /* printf("---> SVToJSVAL returning VOID (panic)\n"); */ } - return JS_TRUE; } diff --git a/js/src/perlconnect/jsperl.h b/js/src/perlconnect/jsperl.h index 8b13cbbf1f7..27b0ba1c38b 100644 --- a/js/src/perlconnect/jsperl.h +++ b/js/src/perlconnect/jsperl.h @@ -36,7 +36,7 @@ /* needs to include to enable the Perl object. See README.html for more */ /* documentation */ -#include "../jsapi.h" +#include /* This is the only function that must be called by an diff --git a/js/src/perlconnect/test.pl b/js/src/perlconnect/test.pl index 51f9fd46b29..8ec98b6317f 100644 --- a/js/src/perlconnect/test.pl +++ b/js/src/perlconnect/test.pl @@ -88,6 +88,18 @@ sub getValue { return $self->{ property }; } +sub getArray { + my $self = shift; + return [34, 35, 36, 37, 38]; +} + +sub getHash { + my $self = shift; + return { testkey1 => 'testvalue1', + testkey2 => 'testvalue2', + testkey3 => 'testvalue3', }; +} + ############################################################ # main part of the test script ############################################################ @@ -96,7 +108,7 @@ package main; use JS; BEGIN - { $| = 1; print "1..11\n"; } + { $| = 1; print "1..12\n"; } END { print "not ok 1\n" unless $loaded; } @@ -114,41 +126,41 @@ my $testc = 1; #testcounter # the simplest test $testc++; $jsval = $cx->eval('6;'); -print $jsval == 6 ? "ok $testc\n" : "not ok $testc\n"; +print $jsval == 6 ? "ok $testc\n" : "not ok $testc\n"; #2 ############################################################ #second very simple test $testc++; $jsval = $cx->eval('"hallo";'); -print $jsval eq "hallo" ? "ok $testc\n" : "not ok $testc\n"; +print $jsval eq "hallo" ? "ok $testc\n" : "not ok $testc\n"; #3 ############################################################ # third very simple test $testc++; $jsval = $cx->eval("1.23"); -print $jsval == 1.23 ? "ok $testc\n" : "not ok $testc\n"; +print $jsval == 1.23 ? "ok $testc\n" : "not ok $testc\n"; #4 ############################################################ #undef is little bit tricky $testc++; $jsval = $cx->eval('undefined'); -print ! defined $jsval ? "ok $testc\n" : "not ok $testc\n"; +print ! defined $jsval ? "ok $testc\n" : "not ok $testc\n"; #5 ############################################################ #can ve tie js objects? (generally to hash, Arrays to arrays too) $testc++; -$jsval = $cx->eval('foo = new Object(); foo.prop = 1; foo;'); +$jsval = $cx->eval('foo = new Object(); foo.prop = 11; foo;'); my %hash; #read js property tie %hash, 'JS::Object', $jsval; -print $hash{prop} == 1 ? "ok $testc\n" : "not ok $testc\n"; +print $hash{prop} == 11 ? "ok $testc\n" : "not ok $testc\n"; #6 ############################################################ -#set js propertry +#set js propertry $testc++; $hash{prop2} = 2; $jsval = $cx->eval('foo.prop2;'); -print $jsval == 2 ? "ok $testc\n" : "not ok $testc\n"; +print $jsval == 2 ? "ok $testc\n" : "not ok $testc\n"; #7 ############################################################ #tie array @@ -156,7 +168,7 @@ $testc++; my @arr; $jsval = $cx->eval('arr = new Array(); arr[0] = 0; arr[1] = 1; arr;'); tie @arr, "JS::Object", $jsval; -print ((($#arr == 1) && ($arr[1] == 1)) ? "ok $testc\n" : "not ok $testc\n"); +print ((($#arr == 1) && ($arr[1] == 1)) ? "ok $testc\n" : "not ok $testc\n");#8 ############################################################ # object delegation test @@ -164,80 +176,62 @@ $testc++; $cx->createObject(new Proxy("init_value"), "perlobj", { getObj => \&Proxy::getObj, getValue => \&Proxy::getValue, + getArray => \&Proxy::getArray, + getHash => \&Proxy::getHash, }); $jsval = $cx->eval("perlobj.getValue()"); -print $jsval eq "init_value" ? "ok $testc\n" : "not ok $testc\n"; +print $jsval eq "init_value" ? "ok $testc\n" : "not ok $testc\n"; #9 ############################################################ # perl object returned to js $testc++; $jsval = $cx->eval("po = perlobj.getObj(); po.new_meth()"); -print $jsval eq "Son::new_meth" ? "ok $testc\n" : "not ok $testc\n"; - +print $jsval eq "Son::new_meth" ? "ok $testc\n" : "not ok $testc\n"; #10 ############################################################ # and what about inherited methods? $testc++; $jsval = $cx->eval("po.old_meth()"); -print $jsval eq "Father::old_meth" ? "ok $testc\n" : "not ok $testc\n"; +print $jsval eq "Father::old_meth" ? "ok $testc\n" : "not ok $testc\n"; #11 + +############################################################ +# pass an array, check the element +$testc++; +$jsval = $cx->eval("parr = perlobj.getArray(); parr[2];"); +print $jsval == 36 ? "ok $testc\n" : "not ok $testc\n"; #12 + +############################################################ +# check the array length +$testc++; +$jsval = $cx->eval("parr.length"); +print $jsval == 5 ? "ok $testc\n" : "not ok $testc\n"; #13 + +############################################################ +# pass a hash, check the element +$testc++; +$jsval = $cx->eval("phash = perlobj.getHash(); phash.testkey1;"); +print $jsval eq 'testvalue1' ? "ok $testc\n" : "not ok $testc\n"; #14 ############################################################ # error test $testc++; my $line; +my $err; sub js_ErrorReporter { my ($msg, $file, $line, $linebuf, $token) = @_; - die "line $line"; + $err = "line $line $msg"; } $cx->setErrorReporter( \&js_ErrorReporter ); -eval { $cx->eval("x = 2 + 4;\nsecond line is wrong\n"); }; -print $@ =~ /^line 1/ ? "ok $testc\n" : "not ok $testc\n"; +$cx->eval("x = 2 + 4;\nx.method()\n"); +print $err =~ /^line 1/ ? "ok $testc\n" : "not ok $testc\n"; #15 ############################################################ # cleanup -# so far we have to undef context value, to make sure -# it is disposed before runtome +# so far we have to undef context value, to make sure, +# it is disposed before runtime undef $cx; undef $rt; __END__ -############################################################ -# the old disabled tests (should work) -############################################################ -use JS; -# create new JS context -($js = new JS()) or warn "new JS() failed"; -# eval for simple scalar cases -# int -($js->eval("100") == 100) or warn "Wrong value returned from eval()"; -# and string -($js->eval("'test string'") eq 'test string') or warn "Wrong value returned from eval()"; -# double TODO: double comparison? -($js->eval("1.25") == 1.25) or warn "Wrong value returned from eval()"; -# more complex eval: -# return an object -$obj = $js->eval(q/ - x = new Object(); - x.t='a'; - x; -/) or warn "eval failed"; -# tie this object to a hash -tie %hash, "JS::Object", $obj; -# try retrieving and manipulating values -$hash{foo} = 1200; -$_ = $hash{foo}; -($_ == 1200) or warn "Wrong value returned from hash"; -# -$hash{bar} = 'abcdef'; -$_ = $hash{bar}; -($_ eq 'abcdef') or warn "Wrong value returned from hash"; -# exists/delete -(exists $hash{bar}) or warn "\$hash{bar} should exist"; -delete $hash{bar}; -(!exists $hash{bar}) or warn "\$hash{bar} should be deleted"; -# exists/clear -(exists $hash{foo}) or warn "\$hash{foo} should exist"; -undef %hash; -(!exists $hash{foo}) or warn "\$hash{foo} should be deleted"; diff --git a/js/src/perlconnect/typemap b/js/src/perlconnect/typemap index 5709e294047..63340e1842c 100644 --- a/js/src/perlconnect/typemap +++ b/js/src/perlconnect/typemap @@ -47,8 +47,9 @@ JSObject * OBJECT OUTPUT jsval { - /* JSContext *cx = getContext(); */ - JSVALToSV(cx, JS_GetGlobalObject(cx), $var, &$arg); + SV *foo; + JSVALToSV(cx, JS_GetGlobalObject(cx), $var, &foo); + sv_setsv($arg, foo); } OBJECT