зеркало из https://github.com/mozilla/pjs.git
- 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
This commit is contained in:
pavel%gingerall.cz
Родитель
4541fc4878
Коммит
7ac6f89e90
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
{
|
||||
|
|
|
|||
|
|
@ -54,12 +54,17 @@
|
|||
}
|
||||
#endif
|
||||
|
||||
#include "../jsapi.h"
|
||||
#include <jsapi.h>
|
||||
#include "jsperlpvt.h"
|
||||
#include <malloc.h>
|
||||
|
||||
/* __REMOVE__ */
|
||||
/* #include <stdio.h> */
|
||||
/* #include <stdio.h> */
|
||||
|
||||
/* 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);
|
||||
|
|
|
|||
|
|
@ -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,);
|
||||
|
||||
|
|
|
|||
|
|
@ -46,7 +46,7 @@
|
|||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "../jsapi.h"
|
||||
#include <jsapi.h>
|
||||
#include <string.h>
|
||||
|
||||
/*---------------------------------------------------------------------------*/
|
||||
|
|
@ -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 <stdio.h>
|
||||
|
||||
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 <stdio.h> */
|
||||
|
||||
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;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
/* needs to include to enable the Perl object. See README.html for more */
|
||||
/* documentation */
|
||||
|
||||
#include "../jsapi.h"
|
||||
#include <jsapi.h>
|
||||
|
||||
/*
|
||||
This is the only function that must be called by an
|
||||
|
|
|
|||
|
|
@ -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";
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Загрузка…
Ссылка в новой задаче