зеркало из https://github.com/mozilla/gecko-dev.git
- fixes in original version of perlconnect (JSVALToSV SVToJSVAL etc.)
- object delegation (like JSCreateObject) Perl->JS - ParlValue handles PerlObject correctly - undef values handled correctly (in both directions) - JS arrays may be tied to perl arrays - error handlers supported on Perl side - no globals - several minor fixes
This commit is contained in:
pavel%gingerall.cz
Родитель
0c07208dc5
Коммит
fff3bf7638
|
|
@ -38,6 +38,132 @@
|
|||
# See README.html for more information about this module.
|
||||
############################################################################
|
||||
|
||||
package JS;
|
||||
$VERSION='0.03';
|
||||
require Exporter;
|
||||
use DynaLoader;
|
||||
@ISA = qw(Exporter DynaLoader);
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
sub boot #7/31/98 5:28PM
|
||||
{
|
||||
# this is to load the JS DLL at run-time
|
||||
bootstrap JS $VERSION;
|
||||
push @DynaLoader::dl_library_path, $ENV{'LD_LIBRARY_PATH'};
|
||||
} ##boot
|
||||
|
||||
sub new {
|
||||
my ($class, $maxbytes) = @_;
|
||||
my $self = new JS::Runtime($maxbytes);
|
||||
return $self;
|
||||
}
|
||||
|
||||
############################################################
|
||||
# JS::Runtime
|
||||
############################################################
|
||||
package JS::Runtime;
|
||||
use strict;
|
||||
use vars qw ($AUTOLOAD $DEBUG %CONTEXTS);
|
||||
|
||||
# we use %CONTEXT hash to remember all created contex.
|
||||
# reason of this is increase reference to context objects
|
||||
# and ensure corret order of destructor calls
|
||||
|
||||
sub AUTOLOAD #7/28/98 8:24PM
|
||||
{
|
||||
print "\nJS::Runtime::AUTOLOAD: $AUTOLOAD, not implemented yet\n" if $DEBUG;
|
||||
} ##AUTOLOAD
|
||||
|
||||
|
||||
# Constructor. Calls NewRuntime
|
||||
|
||||
sub new #7/31/98 3:39PM
|
||||
{
|
||||
warn "JS::Runtime::new\n" if $DEBUG;
|
||||
my($class, $maxbytes) = @_;
|
||||
my $self = JS::NewRuntime(scalar($maxbytes));
|
||||
return $self;
|
||||
} ##new
|
||||
|
||||
sub createContext {
|
||||
my ($self, $stacksize) = @_;
|
||||
#my $cx = $self->NewContext($stacksize);
|
||||
my $cx = JS::Context->new($self, $stacksize);
|
||||
# $CONTEXTS{$self} = [] unless exists $CONTEXTS{$self};
|
||||
# push @{$CONTEXTS{$self}}, $cx;
|
||||
return $cx;
|
||||
}
|
||||
|
||||
# Destructor for Runtimes
|
||||
sub DESTROY #7/31/98 4:54PM
|
||||
{
|
||||
my $self = shift;
|
||||
warn "JS::Runtime::DESTROY\n" if $DEBUG;
|
||||
JS::DestroyRuntime($self);
|
||||
} ##DESTROY
|
||||
|
||||
############################################################
|
||||
# JS::Context
|
||||
############################################################
|
||||
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 new #7/31/98 3:39PM
|
||||
{
|
||||
warn "JS::Context::new\n" if $DEBUG;
|
||||
my($class, $rt, $stacksize) = @_;
|
||||
my $this = JS::Runtime::NewContext($rt, $stacksize);
|
||||
return $this;
|
||||
} ##new
|
||||
|
||||
sub DESTROY #7/31/98 4:54PM
|
||||
{
|
||||
my $self = shift;
|
||||
warn "JS::Context::DESTROY\n" if $DEBUG;
|
||||
JS::Runtime::DestroyContext($self);
|
||||
} ##DESTROY
|
||||
|
||||
############################################################
|
||||
# JS::Object
|
||||
############################################################
|
||||
package JS::Object;
|
||||
use vars qw($AUTOLOAD $DEBUG);
|
||||
|
||||
sub AUTOLOAD #7/28/98 8:24PM
|
||||
{
|
||||
$_ = $AUTOLOAD;
|
||||
$_ =~ s/.*://;
|
||||
print "\nJS::Object::AUTOLOAD: $_, not implemented yet\n" if $DEBUG;
|
||||
} ##AUTOLOAD
|
||||
|
||||
|
||||
|
||||
############################################################
|
||||
# executable part
|
||||
############################################################
|
||||
#$JS::Runtime::DEBUG = 1;
|
||||
#$JS::Context::DEBUG = 1;
|
||||
#$JS::Object::DEBUG = 1;
|
||||
|
||||
&JS::boot();
|
||||
|
||||
1;
|
||||
|
||||
############################################################
|
||||
# the end
|
||||
############################################################
|
||||
|
||||
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
package JS;
|
||||
$VERSION = '0.03';
|
||||
require Exporter;
|
||||
|
|
@ -53,7 +179,8 @@ sub new #7/31/98 5:32PM
|
|||
{
|
||||
print "JS::new" if $DEBUG;
|
||||
my $rt = new JS::Runtime(10_000);
|
||||
return $this = new JS::Context($rt, 1_024);
|
||||
$this = new JS::Context($rt, 1_024);
|
||||
return $this
|
||||
} ##new
|
||||
|
||||
############################################################################
|
||||
|
|
@ -93,6 +220,7 @@ sub DESTROY #7/31/98 4:54PM
|
|||
{
|
||||
my $self = shift;
|
||||
print "JS::Runtime::DESTROY\n" if $DEBUG;
|
||||
warn("JS::Runtime::DESTROY\n");
|
||||
JS::DestroyRuntime($self);
|
||||
undef $this;
|
||||
} ##DESTROY
|
||||
|
|
@ -112,6 +240,7 @@ sub AUTOLOAD #7/28/98 8:24PM
|
|||
sub new #7/31/98 3:39PM
|
||||
{
|
||||
print "JS::Context::new\n" if $DEBUG;
|
||||
warn("JS::Context::new\n");
|
||||
my($class, $rt, $stacksize) = @_;
|
||||
$this = JS::Runtime::NewContext($rt, $stacksize);
|
||||
return $this;
|
||||
|
|
@ -123,7 +252,8 @@ sub new #7/31/98 3:39PM
|
|||
sub DESTROY #7/31/98 4:54PM
|
||||
{
|
||||
my $self = shift;
|
||||
print "JS::Contexts::DESTROY\n" if $DEBUG;
|
||||
print "JS::Context::DESTROY\n" if $DEBUG;
|
||||
warn("JS::Context::DESTROY\n");
|
||||
JS::Runtime::DestroyContext($self);
|
||||
undef $this;
|
||||
} ##DESTROY
|
||||
|
|
@ -141,4 +271,4 @@ sub AUTOLOAD #7/28/98 8:24PM
|
|||
|
||||
&JS::boot();
|
||||
|
||||
1;
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -56,6 +56,10 @@
|
|||
|
||||
#include "../jsapi.h"
|
||||
#include "jsperlpvt.h"
|
||||
#include <malloc.h>
|
||||
|
||||
/* __REMOVE__ */
|
||||
/* #include <stdio.h> */
|
||||
|
||||
static
|
||||
JSClass global_class = {
|
||||
|
|
@ -64,7 +68,422 @@ JSClass global_class = {
|
|||
JS_EnumerateStub, JS_ResolveStub, JS_ConvertStub, JS_FinalizeStub
|
||||
};
|
||||
|
||||
/* __PH__BEGIN */
|
||||
/* perl callback structure */
|
||||
/* prefix PCB means Perl CallBack */
|
||||
|
||||
struct PerlCallbackItem{
|
||||
char* name;
|
||||
SV* perl_proc;
|
||||
int param_num;
|
||||
struct PerlCallbackItem *next;
|
||||
};
|
||||
|
||||
typedef struct PerlCallbackItem PerlCallbackItem;
|
||||
|
||||
|
||||
struct PerlObjectItem {
|
||||
char * name;
|
||||
SV* pObject;
|
||||
JSObject *jsObject;
|
||||
JSClass *jsClass;
|
||||
struct PerlCallbackItem* vector;
|
||||
struct PerlObjectItem *next;
|
||||
};
|
||||
|
||||
typedef struct PerlObjectItem PerlObjectItem;
|
||||
|
||||
/* error reporter */
|
||||
//struct JSContextItem;
|
||||
//struct JSContextItem;
|
||||
struct JSContextItem {
|
||||
JSContext *cx;
|
||||
SV *errorReporter;
|
||||
PerlObjectItem *objects;
|
||||
int dieFromErrors;
|
||||
struct JSContextItem* next;
|
||||
};
|
||||
|
||||
typedef struct JSContextItem JSContextItem;
|
||||
|
||||
static JSContextItem *context_list = NULL;
|
||||
|
||||
static JSContextItem*
|
||||
PCB_NewContextItem() {
|
||||
JSContextItem *ret;
|
||||
ret = (JSContextItem*)calloc(1, sizeof(JSContextItem));
|
||||
}
|
||||
|
||||
static JSContextItem*
|
||||
PCB_FindContextItem (JSContext *cx) {
|
||||
JSContextItem *cxitem = context_list;
|
||||
while ( cxitem ) {
|
||||
if (cxitem->cx == cx ) return cxitem;
|
||||
cxitem = cxitem->next;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static SV*
|
||||
PCB_FindErrorReporter (JSContext *cx) {
|
||||
JSContextItem *cxitem;
|
||||
if (cxitem = PCB_FindContextItem(cx)) {
|
||||
return cxitem->errorReporter;
|
||||
} else {
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
PCB_ErrorReporter(JSContext *cx, const char *message, JSErrorReport *report)
|
||||
{
|
||||
SV *report_proc;
|
||||
if ( report_proc = PCB_FindErrorReporter(cx) ) {
|
||||
dSP;
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(sv_2mortal(newSVpv((char*)message, 0)));
|
||||
if ( report ) {
|
||||
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)));
|
||||
XPUSHs(sv_2mortal(newSVpv((char*)report->tokenptr, 0)));
|
||||
}
|
||||
}
|
||||
PUTBACK;
|
||||
perl_call_sv(report_proc, G_VOID | G_DISCARD);
|
||||
|
||||
} else {
|
||||
warn(message);
|
||||
}
|
||||
}
|
||||
|
||||
/* perl object stuff */
|
||||
|
||||
|
||||
/* functions for callback list handling */
|
||||
static PerlCallbackItem*
|
||||
PCB_AddCallback(PerlObjectItem* object, char *name,
|
||||
SV* perl_proc, int param_num) {
|
||||
PerlCallbackItem *cbk;
|
||||
|
||||
cbk = (PerlCallbackItem*)calloc(1, sizeof(PerlCallbackItem));
|
||||
cbk->name = (char*) malloc(strlen(name) + 1);
|
||||
strcpy(cbk->name, name);
|
||||
SvREFCNT_inc(perl_proc);
|
||||
cbk->perl_proc = perl_proc;
|
||||
cbk->param_num = param_num;
|
||||
|
||||
cbk->next = object->vector;
|
||||
object->vector = cbk;
|
||||
|
||||
return cbk;
|
||||
}
|
||||
|
||||
/* functions for perl object list handling */
|
||||
|
||||
static PerlObjectItem*
|
||||
PCB_AddObject(char *name, SV *pobj, JSContext *cx, JSObject *jso, JSClass *class) {
|
||||
JSContextItem *cxitem;
|
||||
PerlObjectItem *object;
|
||||
|
||||
/* we should always find the item */
|
||||
cxitem = PCB_FindContextItem(cx);
|
||||
object = (PerlObjectItem*) calloc(1, sizeof(PerlObjectItem));
|
||||
object->name = (char*) malloc(strlen(name) + 1);
|
||||
strcpy(object->name, name);
|
||||
SvREFCNT_inc(pobj);
|
||||
object->pObject = pobj;
|
||||
object->jsObject = jso;
|
||||
object->jsClass = class;
|
||||
object->next = cxitem->objects;
|
||||
cxitem->objects = object;
|
||||
|
||||
return object;
|
||||
}
|
||||
|
||||
static PerlObjectItem*
|
||||
PCB_FindObject(JSContext *cx, JSObject *jso) {
|
||||
JSContextItem *cxitem;
|
||||
PerlObjectItem *objitem;
|
||||
|
||||
cxitem = PCB_FindContextItem(cx);
|
||||
objitem = cxitem->objects;
|
||||
|
||||
while ( objitem ) {
|
||||
if ( objitem->jsObject == jso ) return objitem;
|
||||
objitem = objitem->next;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
static PerlCallbackItem*
|
||||
PCB_FindCallback(PerlObjectItem *obj, const char *name) {
|
||||
PerlCallbackItem *cbkitem;
|
||||
|
||||
cbkitem = obj->vector;
|
||||
while ( cbkitem ) {
|
||||
if ( strcmp(name, cbkitem->name) == 0 ) return cbkitem;
|
||||
cbkitem = cbkitem->next;
|
||||
}
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* deletion functions */
|
||||
|
||||
static void
|
||||
PCB_FreeCallbackItem(PerlCallbackItem *callback) {
|
||||
free(callback->name);
|
||||
/* we have to decrease ref. count to proc */
|
||||
SvREFCNT_dec(callback->perl_proc);
|
||||
free(callback);
|
||||
}
|
||||
|
||||
static void
|
||||
PCB_FreeObjectItem(PerlObjectItem *object) {
|
||||
PerlCallbackItem *cbkitem, *next;
|
||||
JSClass *class;
|
||||
|
||||
free(object->name);
|
||||
free(object->jsClass);
|
||||
|
||||
SvREFCNT_dec(object->pObject);
|
||||
cbkitem = object->vector;
|
||||
while ( cbkitem ) {
|
||||
next = cbkitem->next;
|
||||
PCB_FreeCallbackItem(cbkitem);
|
||||
cbkitem = next;
|
||||
}
|
||||
free(object);
|
||||
}
|
||||
|
||||
static void
|
||||
PCB_FreeContextItem(JSContext * cx) {
|
||||
JSContextItem *cxitem, *aux;
|
||||
PerlObjectItem *objitem, *next;
|
||||
|
||||
cxitem = PCB_FindContextItem(cx);
|
||||
objitem = cxitem->objects;
|
||||
|
||||
while ( objitem ) {
|
||||
next = objitem->next;
|
||||
PCB_FreeObjectItem(objitem);
|
||||
objitem = next;
|
||||
}
|
||||
|
||||
SvREFCNT_dec(cxitem->errorReporter);
|
||||
|
||||
if ( context_list == cxitem ) {
|
||||
context_list = cxitem->next;
|
||||
} else {
|
||||
aux = context_list;
|
||||
while ( aux->next != cxitem ) aux = aux->next;
|
||||
aux->next = cxitem->next;
|
||||
}
|
||||
free(cxitem);
|
||||
}
|
||||
|
||||
/* later the object list should be bind to JS Context
|
||||
in this case is needed to update destructor PerlFreeObjectList
|
||||
*/
|
||||
|
||||
/* property getter and setter - cooperate with AUTOLOAD */
|
||||
|
||||
static JSBool
|
||||
PCB_GetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval) {
|
||||
PerlObjectItem *po;
|
||||
int i, cnt, len;
|
||||
I32 ax;
|
||||
SV *proc_sv;
|
||||
HV *stash;
|
||||
char prop_name[256];
|
||||
char full_name[256];
|
||||
char *foo;
|
||||
GV *gv;
|
||||
dSP;
|
||||
|
||||
/* property name */
|
||||
strcpy(prop_name, JS_GetStringBytes(JSVAL_TO_STRING(name)));
|
||||
|
||||
if (! (po = PCB_FindObject(cx, obj)))
|
||||
croak("Couldn't find stub for object");
|
||||
if ( (PCB_FindCallback(po, prop_name)))
|
||||
return(JS_TRUE);
|
||||
|
||||
stash = SvSTASH(SvRV(po->pObject));
|
||||
/* strcpy(full_name, HvNAME(stash));
|
||||
strcat(full_name, "::");
|
||||
strcat(full_name, prop_name);
|
||||
|
||||
proc_sv = sv_newmortal();
|
||||
sv_setpv(proc_sv, full_name); */
|
||||
/* start of perl call stuff */
|
||||
|
||||
gv = gv_fetchmeth(stash, prop_name, strlen(prop_name), -1);
|
||||
|
||||
ENTER;
|
||||
SAVETMPS;
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(po->pObject); /* self for perl AUTOLOAD */
|
||||
PUTBACK;
|
||||
|
||||
/* cnt = perl_call_sv(proc_sv, 0); */
|
||||
cnt = perl_call_sv((SV*)GvCV(gv), 0);
|
||||
|
||||
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 {
|
||||
warn("sorry, but array properties are not supported yet...");
|
||||
}
|
||||
PUTBACK;
|
||||
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
return(JS_TRUE);
|
||||
}
|
||||
|
||||
static JSBool
|
||||
PCB_SetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval) {
|
||||
PerlObjectItem *po;
|
||||
int i, cnt, len;
|
||||
I32 ax;
|
||||
SV *proc_sv, *value_sv;
|
||||
HV *stash;
|
||||
char prop_name[256];
|
||||
char full_name[256];
|
||||
char *foo;
|
||||
dSP;
|
||||
|
||||
/* property name */
|
||||
strcpy(prop_name, JS_GetStringBytes(JSVAL_TO_STRING(name)));
|
||||
|
||||
if (! (po = PCB_FindObject(cx, obj)))
|
||||
croak("Couldn't find stub for object");
|
||||
if ( (PCB_FindCallback(po, prop_name)))
|
||||
return(JS_TRUE);
|
||||
|
||||
stash = SvSTASH(SvRV(po->pObject));
|
||||
strcpy(full_name, HvNAME(stash));
|
||||
strcat(full_name, "::");
|
||||
strcat(full_name, prop_name);
|
||||
|
||||
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;
|
||||
SAVETMPS;
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(po->pObject); /* self for perl AUTOLOAD */
|
||||
XPUSHs(value_sv);
|
||||
PUTBACK;
|
||||
|
||||
cnt = perl_call_sv(proc_sv, 0);
|
||||
|
||||
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 {
|
||||
warn("sorry, but array properties are not supported yet...");
|
||||
}
|
||||
PUTBACK;
|
||||
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
return(JS_TRUE);
|
||||
}
|
||||
|
||||
/* helper functions */
|
||||
/* JSClass pointer is disposed by
|
||||
JS engine during context cleanup _PH_
|
||||
*/
|
||||
static JSClass*
|
||||
PCB_NewStdJSClass(char *name) {
|
||||
JSClass *class;
|
||||
|
||||
class = (JSClass*)calloc(1, sizeof(JSClass));
|
||||
class->name = name;
|
||||
class->flags = JSCLASS_HAS_PRIVATE;
|
||||
class->addProperty = JS_PropertyStub;
|
||||
class->delProperty = JS_PropertyStub;
|
||||
class->getProperty = PCB_GetProperty;
|
||||
class->setProperty = PCB_SetProperty;
|
||||
class->enumerate = JS_EnumerateStub;
|
||||
class->resolve = JS_ResolveStub;
|
||||
class->convert = JS_ConvertStub;
|
||||
class->finalize = JS_FinalizeStub;
|
||||
return(class);
|
||||
}
|
||||
|
||||
static JSBool
|
||||
PCB_UniversalStub (JSContext *cx, JSObject *obj, uintN argc,
|
||||
jsval *argv, jsval *rval) {
|
||||
JSFunction *fun;
|
||||
PerlObjectItem *po;
|
||||
PerlCallbackItem *cbk;
|
||||
int i, cnt;
|
||||
I32 ax;
|
||||
SV* sv;
|
||||
dSP;
|
||||
|
||||
fun = JS_ValueToFunction(cx, argv[-2]);
|
||||
if (! (po = PCB_FindObject(cx, obj)))
|
||||
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);
|
||||
}
|
||||
PUTBACK;
|
||||
|
||||
cnt = perl_call_sv(SvRV(cbk->perl_proc), 0);
|
||||
|
||||
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 {
|
||||
warn("sorry, but array results are not supported yet...");
|
||||
}
|
||||
PUTBACK;
|
||||
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
return(JS_TRUE);
|
||||
};
|
||||
|
||||
/* __PH__END */
|
||||
|
||||
|
||||
/* Helper functions needed for most JS API routines */
|
||||
/*
|
||||
static JSRuntime *
|
||||
getRuntime()
|
||||
{
|
||||
|
|
@ -76,6 +495,7 @@ getContext()
|
|||
{
|
||||
return (JSContext *)SvIV((SV*)SvRV(perl_get_sv("JS::Context::this", FALSE)));
|
||||
}
|
||||
*/ /* commented as obsolete by __PH__ */
|
||||
|
||||
/*
|
||||
The following packages are defined below:
|
||||
|
|
@ -94,6 +514,8 @@ PROTOTYPES: DISABLE
|
|||
JSRuntime *
|
||||
JS_NewRuntime(maxbytes)
|
||||
int maxbytes
|
||||
OUTPUT:
|
||||
RETVAL
|
||||
|
||||
void
|
||||
JS_DestroyRuntime(rt)
|
||||
|
|
@ -106,11 +528,18 @@ JS_DestroyRuntime(rt)
|
|||
$rt1 = $rt;
|
||||
[exit here]
|
||||
So both $rt->DESTROY and $rt1->DESTROY will cause runtime destruction.
|
||||
|
||||
_PH_ Thats not true, I guess. At least for Perl 5.
|
||||
*/
|
||||
if(SvREFCNT(ST(0))==0){
|
||||
/* warn("===> before runtime check\n"); */
|
||||
if(SvREFCNT(ST(0)) == 1){
|
||||
/* warn("===> really runtime destroing"); */
|
||||
/* __PH__ */
|
||||
/*__PH__END */
|
||||
JS_DestroyRuntime(rt);
|
||||
}
|
||||
|
||||
|
||||
# package JS::Runtime
|
||||
MODULE = JS PACKAGE = JS::Runtime PREFIX = JS_
|
||||
|
||||
|
|
@ -118,13 +547,21 @@ JSContext *
|
|||
JS_NewContext(rt, stacksize)
|
||||
JSRuntime *rt
|
||||
int stacksize
|
||||
|
||||
PREINIT:
|
||||
JSContextItem *cxitem;
|
||||
CODE:
|
||||
{
|
||||
JSObject *obj;
|
||||
jsval v;
|
||||
/* jsval v; comment out unused var __PH__*/
|
||||
/* Here we are creating the globals object ourselves. */
|
||||
JSContext *cx = JS_NewContext(rt, stacksize);
|
||||
JSContext *cx;
|
||||
cx = JS_NewContext(rt, stacksize);
|
||||
cxitem = PCB_NewContextItem();
|
||||
cxitem->cx = cx;
|
||||
cxitem->next = context_list;
|
||||
context_list = cxitem;
|
||||
/* __PH__ set the error reporter */
|
||||
JS_SetErrorReporter(cx, PCB_ErrorReporter);
|
||||
obj = JS_NewObject(cx, &global_class, NULL, NULL);
|
||||
JS_InitStandardClasses(cx, obj);
|
||||
RETVAL = cx;
|
||||
|
|
@ -137,8 +574,11 @@ JS_DestroyContext(cx)
|
|||
JSContext *cx
|
||||
CODE:
|
||||
/* See the comment about ref. count above */
|
||||
if(SvREFCNT(ST(0))==0){
|
||||
/* warn("===> before context check\n"); */
|
||||
if(SvREFCNT(ST(0)) == 1){
|
||||
/* warn("===> really destroing context"); */
|
||||
JS_DestroyContext(cx);
|
||||
PCB_FreeContextItem(cx);
|
||||
}
|
||||
|
||||
|
||||
|
|
@ -149,14 +589,17 @@ jsval
|
|||
JS_eval(cx, bytes)
|
||||
JSContext *cx
|
||||
char *bytes
|
||||
|
||||
PREINIT:
|
||||
JSContextItem *cxitem;
|
||||
CODE:
|
||||
{
|
||||
jsval rval;
|
||||
JSObject *obj;
|
||||
/* Call on the global object */
|
||||
if(!JS_EvaluateScript(cx, JS_GetGlobalObject(cx), bytes, strlen(bytes), "Perl", 0, &rval)){
|
||||
croak("Perl eval failed");
|
||||
if(!JS_EvaluateScript(cx, JS_GetGlobalObject(cx),
|
||||
bytes, strlen(bytes), "Perl", 0, &rval)){
|
||||
cxitem = PCB_FindContextItem(cx);
|
||||
if (!cxitem || cxitem->dieFromErrors)
|
||||
croak("Perl eval failed");
|
||||
XSRETURN_UNDEF;
|
||||
}
|
||||
RETVAL = rval;
|
||||
|
|
@ -164,16 +607,105 @@ JS_eval(cx, bytes)
|
|||
OUTPUT:
|
||||
RETVAL
|
||||
|
||||
# __PH__
|
||||
void
|
||||
JS_setErrorReporter(cx, reporter)
|
||||
JSContext *cx
|
||||
SV* reporter
|
||||
PREINIT:
|
||||
JSContextItem *cxitem;
|
||||
CODE:
|
||||
cxitem = PCB_FindContextItem(cx);
|
||||
SvREFCNT_inc(reporter);
|
||||
if ( cxitem ) cxitem->errorReporter = reporter;
|
||||
|
||||
void
|
||||
JS_setDieFromErrors(cx, value)
|
||||
JSContext *cx
|
||||
int value
|
||||
PREINIT:
|
||||
JSContextItem *cxitem;
|
||||
CODE:
|
||||
cxitem = PCB_FindContextItem(cx);
|
||||
if ( cxitem ) cxitem->dieFromErrors = value;
|
||||
|
||||
void
|
||||
JS_createObject(cx, object, name, methods)
|
||||
JSContext *cx
|
||||
SV *object
|
||||
char *name
|
||||
SV *methods
|
||||
PREINIT:
|
||||
JSObject *jso;
|
||||
HV *m_hash;
|
||||
I32 len;
|
||||
HE *he;
|
||||
int i;
|
||||
PerlObjectItem *po;
|
||||
JSClass *object_class;
|
||||
PerlCallbackItem *pcbitem;
|
||||
CODE:
|
||||
if (SvTYPE(SvRV(methods)) != SVt_PVHV) {
|
||||
croak("Second parameter has to be HASHREF");
|
||||
}
|
||||
/* create js object in given context */
|
||||
object_class = PCB_NewStdJSClass(name);
|
||||
jso = JS_NewObject(cx, object_class, NULL, 0);
|
||||
if (!jso) croak("Unable create JS object");
|
||||
/* create callback info */
|
||||
po = PCB_AddObject(name, object, cx, jso, object_class);
|
||||
m_hash = (HV*)SvRV(methods);
|
||||
hv_iterinit(m_hash);
|
||||
while ((he = hv_iternext(m_hash))) {
|
||||
PCB_AddCallback(po, hv_iterkey(he, &len), hv_iterval(m_hash, he), 0);
|
||||
}
|
||||
/* set js object methods */
|
||||
/* HERE _PH_ */
|
||||
pcbitem = po->vector;
|
||||
while ( pcbitem ) {
|
||||
if (! JS_DefineFunction(cx, jso, pcbitem->name,
|
||||
PCB_UniversalStub, 0, 0))
|
||||
croak("Unable create JS function");
|
||||
pcbitem = pcbitem->next;
|
||||
}
|
||||
/* for (i = 0; i < po->count; i++) {
|
||||
if (! JS_DefineFunction(cx, jso,
|
||||
po->vector[i]->name,
|
||||
PCB_UniversalStub,
|
||||
0,0))
|
||||
croak("Unable create JS function\n");
|
||||
} */
|
||||
po->jsObject = JS_InitClass(cx, JS_GetGlobalObject(cx), jso,
|
||||
object_class, 0, 0,
|
||||
NULL, NULL, NULL, NULL);
|
||||
|
||||
|
||||
# __PH__END
|
||||
|
||||
|
||||
# package JS::Object
|
||||
MODULE = JS PACKAGE = JS::Object PREFIX = JS_
|
||||
|
||||
#
|
||||
# The methods below get used when hash is tied.
|
||||
#
|
||||
JSObject *
|
||||
SV *
|
||||
JS_TIEHASH(class, obj)
|
||||
char *class
|
||||
JSObject *obj
|
||||
SV *obj
|
||||
PREINIT:
|
||||
JSContext* cx;
|
||||
CODE:
|
||||
RETVAL = obj;
|
||||
OUTPUT:
|
||||
RETVAL
|
||||
|
||||
SV *
|
||||
JS_TIEARRAY(class, obj)
|
||||
char *class
|
||||
SV *obj
|
||||
PREINIT:
|
||||
JSContext* cx;
|
||||
CODE:
|
||||
RETVAL = obj;
|
||||
OUTPUT:
|
||||
|
|
@ -184,57 +716,122 @@ JS_FETCH(obj, key)
|
|||
JSObject *obj
|
||||
char *key
|
||||
PREINIT:
|
||||
JSContext* cx;
|
||||
jsval rval;
|
||||
MAGIC *magic;
|
||||
CODE:
|
||||
{
|
||||
/*printf("in FETCH\n");*/
|
||||
JS_GetProperty(getContext(), obj, key, &rval);
|
||||
/* printf("in FETCH\n"); */
|
||||
magic = mg_find(SvRV(ST(0)), '~');
|
||||
if (magic) {
|
||||
cx = (JSContext *)SvIV(magic->mg_obj);
|
||||
} else {
|
||||
warn("Tied object has no magic\n");
|
||||
}
|
||||
JS_GetProperty(cx, obj, key, &rval);
|
||||
RETVAL = rval;
|
||||
}
|
||||
OUTPUT:
|
||||
RETVAL
|
||||
|
||||
int
|
||||
JS_FETCHSIZE(obj)
|
||||
JSObject *obj
|
||||
PREINIT:
|
||||
JSContext* cx;
|
||||
MAGIC *magic;
|
||||
CODE:
|
||||
{
|
||||
/* printf("in FETCH\n"); */
|
||||
magic = mg_find(SvRV(ST(0)), '~');
|
||||
if (magic) {
|
||||
cx = (JSContext *)SvIV(magic->mg_obj);
|
||||
} else {
|
||||
warn("Tied object has no magic\n");
|
||||
}
|
||||
JS_GetArrayLength(cx, obj, &RETVAL);
|
||||
}
|
||||
OUTPUT:
|
||||
RETVAL
|
||||
|
||||
void
|
||||
JS_STORE(obj, key, value)
|
||||
JSObject *obj
|
||||
char *key
|
||||
jsval value
|
||||
PREINIT:
|
||||
JSContext* cx;
|
||||
MAGIC *magic;
|
||||
CODE:
|
||||
{
|
||||
/*printf("In STORE\n");*/
|
||||
JS_SetProperty(getContext(), obj, key, &value);
|
||||
/* printf("In STORE\n"); */
|
||||
magic = mg_find(SvRV(ST(0)), '~');
|
||||
if (magic) {
|
||||
cx = (JSContext *)SvIV(magic->mg_obj);
|
||||
} else {
|
||||
warn("Tied object has no magic\n");
|
||||
}
|
||||
JS_SetProperty(cx, obj, key, &value);
|
||||
}
|
||||
|
||||
void
|
||||
JS_DELETE(obj, key)
|
||||
JSObject *obj
|
||||
char *key
|
||||
PREINIT:
|
||||
JSContext* cx;
|
||||
MAGIC *magic;
|
||||
CODE:
|
||||
{
|
||||
/*printf("In DELETE\n");*/
|
||||
JS_DeleteProperty(getContext(), obj, key);
|
||||
/* printf("In DELETE\n"); */
|
||||
magic = mg_find(SvRV(ST(0)), '~');
|
||||
if (magic) {
|
||||
cx = (JSContext *)SvIV(magic->mg_obj);
|
||||
} else {
|
||||
warn("Tied object has no magic\n");
|
||||
}
|
||||
JS_DeleteProperty(cx, obj, key);
|
||||
}
|
||||
|
||||
void
|
||||
JS_CLEAR(obj)
|
||||
JSObject *obj
|
||||
PREINIT:
|
||||
JSContext* cx;
|
||||
MAGIC *magic;
|
||||
CODE:
|
||||
{
|
||||
/*printf("In CLEAR\n");*/
|
||||
JS_ClearScope(getContext(), obj);
|
||||
/* printf("In CLEAR\n"); */
|
||||
magic = mg_find(SvRV(ST(0)), '~');
|
||||
if (magic) {
|
||||
cx = (JSContext *)SvIV(magic->mg_obj);
|
||||
} else {
|
||||
warn("Tied object has no magic\n");
|
||||
}
|
||||
JS_ClearScope(cx, obj);
|
||||
}
|
||||
|
||||
int
|
||||
JS_EXISTS(obj, key)
|
||||
JSObject *obj
|
||||
char *key
|
||||
PREINIT:
|
||||
JSContext* cx;
|
||||
MAGIC *magic;
|
||||
CODE:
|
||||
{
|
||||
jsval v;
|
||||
|
||||
/*printf("In EXISTS\n");*/
|
||||
JS_LookupProperty(getContext(), obj, key, &v);
|
||||
/* printf("In EXISTS\n"); */
|
||||
magic = mg_find(SvRV(ST(0)), '~');
|
||||
if (magic) {
|
||||
cx = (JSContext *)SvIV(magic->mg_obj);
|
||||
} else {
|
||||
warn("Tied object has no magic\n");
|
||||
}
|
||||
JS_LookupProperty(cx, obj, key, &v);
|
||||
RETVAL = !JSVAL_IS_VOID(v);
|
||||
}
|
||||
OUTPUT:
|
||||
RETVAL
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,16 +1,32 @@
|
|||
use ExtUtils::MakeMaker;
|
||||
|
||||
# edit me!
|
||||
$jsbase = "/home/foo/mozilla/js/src"
|
||||
# we suppose running unix and files placed in perlconnect/ under
|
||||
# js base; otherwise you have to hack the next line
|
||||
|
||||
$jsbase = `pwd`;
|
||||
chomp $jsbase;
|
||||
$jsbase =~ s|/perlconnect||;
|
||||
|
||||
|
||||
$inc = "-I$jsbase -I$jsbase/Linux_All_DBG.OBJ";
|
||||
|
||||
$lib = "-L$jsbase/Linux_All_DBG.OBJ -ljs";
|
||||
|
||||
|
||||
%extras = ();
|
||||
|
||||
if ($^O eq "MSWin32") {
|
||||
$define = "-DXP_PC";
|
||||
$extras{OBJECT} = '$(BASEEXT)$(OBJ_EXT) jsperl.obj';
|
||||
} else {
|
||||
$define = '-DXP_UNIX';
|
||||
}
|
||||
|
||||
|
||||
WriteMakefile(NAME => 'JS',
|
||||
DEFINE => '-DXP_UNIX',
|
||||
DEFINE => $define,
|
||||
INC => $inc,
|
||||
LIBS => $lib,
|
||||
VERSION_FROM => 'JS.pm');
|
||||
VERSION_FROM => 'JS.pm',
|
||||
%extras,);
|
||||
|
||||
__END__
|
||||
|
|
|
|||
|
|
@ -44,6 +44,7 @@
|
|||
*/
|
||||
#include "EXTERN.h"
|
||||
#include "perl.h"
|
||||
#include "XSUB.h"
|
||||
|
||||
#include "../jsapi.h"
|
||||
#include <string.h>
|
||||
|
|
@ -519,17 +520,83 @@ PVGetRef(JSContext *cx, JSObject *obj)
|
|||
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 = 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 */
|
||||
ENTER;
|
||||
SAVETMPS;
|
||||
PUSHMARK(SP);
|
||||
XPUSHs(perl_object); /* self for perl object method */
|
||||
for (i = 0; i < argc; i++) {
|
||||
sv = sv_newmortal();
|
||||
JSVALToSV(cx, obj, argv[i], &sv);
|
||||
XPUSHs(sv);
|
||||
}
|
||||
PUTBACK;
|
||||
|
||||
cnt = perl_call_sv((SV*)GvCV(gv), 0);
|
||||
|
||||
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 {
|
||||
warn("sorry, but array results are not supported yet...");
|
||||
}
|
||||
PUTBACK;
|
||||
|
||||
FREETMPS;
|
||||
LEAVE;
|
||||
|
||||
return(JS_TRUE);
|
||||
}
|
||||
|
||||
/*
|
||||
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 look 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__ OK, array properties should be served first */
|
||||
if(JSVAL_IS_INT(name)){
|
||||
int32 ip;
|
||||
|
||||
|
|
@ -542,6 +609,7 @@ PVGetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
|
|||
|
||||
str = JS_GetStringBytes(JS_ValueToString(cx, name));
|
||||
|
||||
/* __PH__ may, be */
|
||||
if(!strcmp(str, "length")){
|
||||
SV* sv = SvRV(PVGetRef(cx, obj));
|
||||
|
||||
|
|
@ -558,19 +626,30 @@ PVGetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
|
|||
}
|
||||
}else{
|
||||
int i;
|
||||
/* __PH__ predefined methods have to 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 can 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;
|
||||
|
|
@ -758,7 +837,10 @@ PVConvert(JSContext *cx, JSObject *obj, JSType type, jsval *rval)
|
|||
static JSBool
|
||||
PVFinalize(JSContext *cx, JSObject *obj)
|
||||
{
|
||||
SV* sv = SvRV(PVGetRef(cx, 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*/
|
||||
|
||||
/* TODO: GC */
|
||||
if(SvREFCNT(sv)>0){
|
||||
|
|
@ -775,28 +857,22 @@ PVFinalize(JSContext *cx, JSObject *obj)
|
|||
Used for parameter passing. This function is also
|
||||
used by the Perl part of PerlConnect.
|
||||
*/
|
||||
#if 0
|
||||
|
||||
JSBool
|
||||
JSVALToSV(JSContext *cx, JSObject *obj, jsval v, SV** sv)
|
||||
{
|
||||
/* *sv = &sv_undef; */
|
||||
//*sv = &sv_undef; //__PH__??
|
||||
if(JSVAL_IS_PRIMITIVE(v)){
|
||||
/* printf("Primitive\n"); */
|
||||
if(JSVAL_IS_NULL(v) || JSVAL_IS_VOID(v)){
|
||||
/* *sv = newSVsv(&sv_undef); */
|
||||
**sv = sv_undef;
|
||||
}else
|
||||
if(JSVAL_IS_INT(v)){
|
||||
/* *sv = newSViv(JSVAL_TO_INT(v)); */
|
||||
sv_setiv(*sv, JSVAL_TO_INT(v));
|
||||
}else
|
||||
if(JSVAL_IS_DOUBLE(v)){
|
||||
/* *sv = newSVnv(*JSVAL_TO_DOUBLE(v)); */
|
||||
sv_setnv(*sv, *JSVAL_TO_DOUBLE(v));
|
||||
}else
|
||||
if(JSVAL_IS_STRING(v)){
|
||||
/* *sv = newSVpv(JS_GetStringBytes(JSVAL_TO_STRING(v)), 0); */
|
||||
/* printf("string %s\n", SvPV(*sv,na)); */
|
||||
sv_setpv(*sv, JS_GetStringBytes(JSVAL_TO_STRING(v)));
|
||||
}else{
|
||||
warn("Unknown primitive type");
|
||||
|
|
@ -804,30 +880,26 @@ JSVALToSV(JSContext *cx, JSObject *obj, jsval v, SV** sv)
|
|||
}else{
|
||||
if(JSVAL_IS_OBJECT(v)){
|
||||
JSObject *object = JSVAL_TO_OBJECT(v);
|
||||
|
||||
if(JS_InstanceOf(cx, object, &perlValueClass, NULL)){
|
||||
/* printf("Converting PerlValue\n"); */
|
||||
newSVsv(SvRV(PVGetRef(cx, object))); /* _PH_ ?? */
|
||||
newSVsv(SvRV(PVGetRef(cx, object))); //__PH__??
|
||||
}else{
|
||||
if(JS_IsArrayObject(cx, object)){
|
||||
/* printf("Converting Array\n"); */
|
||||
sv_setref_pv(*sv, "JSArray", (void*)object);
|
||||
}else{
|
||||
/* printf("Converting Object\n"); */
|
||||
sv_setref_pv(*sv, "JS::Object", (void*)object);
|
||||
sv_magic(SvRV(*sv), newSViv(cx), '~', NULL, 0);
|
||||
}else{
|
||||
sv_setref_pv(*sv, "JS::Object", (void*)object);
|
||||
sv_magic(SvRV(*sv), newSViv(cx), '~', NULL, 0);
|
||||
}
|
||||
}
|
||||
}else{
|
||||
warn("Type conversion is not supported");
|
||||
/* *sv = &sv_undef; */
|
||||
**sv = sv_undef;
|
||||
**sv = sv_undef; //__PH__??
|
||||
return JS_FALSE;
|
||||
}
|
||||
}
|
||||
|
||||
return JS_TRUE;
|
||||
}
|
||||
#endif
|
||||
|
||||
/*
|
||||
Converts a reference Perl value to a jsval. If ref points
|
||||
|
|
@ -835,64 +907,65 @@ JSVALToSV(JSContext *cx, JSObject *obj, jsval v, SV** sv)
|
|||
O.w. a PerlValue object is returned. This function is also
|
||||
used by the Perl part of PerlConnect.
|
||||
*/
|
||||
|
||||
|
||||
#define _IS_UNDEF(a) (SvANY(a) == SvANY(&sv_undef))
|
||||
|
||||
JSBool
|
||||
SVToJSVAL(JSContext *cx, JSObject *obj, SV *ref, jsval *rval){
|
||||
SVToJSVAL(JSContext *cx, JSObject *obj, SV *ref, jsval *rval) {
|
||||
SV *sv;
|
||||
char* name=NULL;
|
||||
|
||||
if(!SvRV(ref) || !SvROK(ref)){
|
||||
warn("Not a reference passed to SVToJS");
|
||||
if(_IS_UNDEF(ref) || !SvRV(ref) || !SvROK(ref)) {
|
||||
sv = ref;
|
||||
}else{
|
||||
sv = SvRV(ref);
|
||||
}
|
||||
|
||||
/* printf("In SVToJSVAL value %s, type=%d\n", SvPV(sv, na), SvTYPE(sv)); */
|
||||
|
||||
/* Scalars */
|
||||
/* Weird way to check that we are dealing with undef here. */
|
||||
if(SvANY(sv) == SvANY(&sv_undef)){
|
||||
/*printf("undef %s, %p, %p\n", SvPV(sv, na), sv, &sv_undef);*/
|
||||
/* object references are processed as objecs */
|
||||
if ( _IS_UNDEF(sv) ){
|
||||
*rval = JSVAL_VOID;
|
||||
}else
|
||||
} else
|
||||
if(SvIOK(sv)){
|
||||
/*printf("int\n");*/
|
||||
*rval = INT_TO_JSVAL(SvIV(sv));
|
||||
}else
|
||||
*rval = INT_TO_JSVAL(SvIV(sv));
|
||||
} else
|
||||
if(SvNOK(sv)){
|
||||
/*printf("double\n");*/
|
||||
JS_NewDoubleValue(cx, SvNV(sv), rval);
|
||||
}else
|
||||
} else
|
||||
if(SvPOK(sv)){
|
||||
/*printf("string\n");*/
|
||||
*rval = STRING_TO_JSVAL((JS_NewStringCopyZ(cx, SvPV(sv, na))));
|
||||
}else{
|
||||
} else
|
||||
if (1) /*(sv_isobject(ref))*/ {
|
||||
JSObject *perlValue;
|
||||
|
||||
|
||||
/*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;
|
||||
}*/
|
||||
|
||||
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("default\n");*/
|
||||
name = "Perl Value";
|
||||
/* __PH__ */
|
||||
SvREFCNT_inc(ref);
|
||||
perlValue = JS_DefineObject(cx, obj, "PerlValue",
|
||||
&perlValueClass, NULL, JSPROP_ENUMERATE);
|
||||
&perlValueClass, NULL, 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);
|
||||
name?STRING_TO_JSVAL(JS_NewStringCopyZ(cx, name)):JSVAL_VOID,
|
||||
NULL, NULL, JSPROP_PERMANENT|JSPROP_READONLY);
|
||||
*rval = OBJECT_TO_JSVAL(perlValue);
|
||||
}
|
||||
|
||||
|
||||
return JS_TRUE;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -44,3 +44,4 @@
|
|||
*/
|
||||
JS_EXTERN_API(JSObject*)
|
||||
JS_InitPerlClass(JSContext *cx, JSObject *obj);
|
||||
|
||||
|
|
|
|||
|
|
@ -35,6 +35,177 @@
|
|||
# Test file for JS.pm
|
||||
#
|
||||
|
||||
############################################################
|
||||
# support packages for test script
|
||||
############################################################
|
||||
|
||||
############################################################
|
||||
# Fotrik
|
||||
package Father;
|
||||
|
||||
sub old_meth {
|
||||
return "Father::old_meth";
|
||||
}
|
||||
|
||||
|
||||
############################################################
|
||||
# Synacek
|
||||
package Son;
|
||||
use vars qw( @ISA );
|
||||
@ISA = qw( Father );
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub new_meth {
|
||||
return "Son::new_meth";
|
||||
}
|
||||
|
||||
############################################################
|
||||
# Proxy
|
||||
package Proxy;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
$class = ref $class || $class;
|
||||
my $self = { property => shift };
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub getObj {
|
||||
my $ret = new Son();
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub getValue {
|
||||
my $self = shift;
|
||||
return $self->{ property };
|
||||
}
|
||||
|
||||
############################################################
|
||||
# main part of the test script
|
||||
############################################################
|
||||
|
||||
package main;
|
||||
use JS;
|
||||
|
||||
BEGIN
|
||||
{ $| = 1; print "1..11\n"; }
|
||||
END
|
||||
{ print "not ok 1\n" unless $loaded; }
|
||||
|
||||
$loaded = 1;
|
||||
print "ok 1\n";
|
||||
|
||||
use strict; #no typos, please
|
||||
|
||||
my $rt = new JS(1_204 ** 2);
|
||||
my $cx = $rt->createContext(8 * 1_024);
|
||||
|
||||
my $jsval;
|
||||
my $testc = 1; #testcounter
|
||||
############################################################
|
||||
# the simplest test
|
||||
$testc++;
|
||||
$jsval = $cx->eval('6;');
|
||||
print $jsval == 6 ? "ok $testc\n" : "not ok $testc\n";
|
||||
|
||||
############################################################
|
||||
#second very simple test
|
||||
$testc++;
|
||||
$jsval = $cx->eval('"hallo";');
|
||||
print $jsval eq "hallo" ? "ok $testc\n" : "not ok $testc\n";
|
||||
|
||||
############################################################
|
||||
# third very simple test
|
||||
$testc++;
|
||||
$jsval = $cx->eval("1.23");
|
||||
print $jsval == 1.23 ? "ok $testc\n" : "not ok $testc\n";
|
||||
|
||||
############################################################
|
||||
#undef is little bit tricky
|
||||
$testc++;
|
||||
$jsval = $cx->eval('undefined');
|
||||
print ! defined $jsval ? "ok $testc\n" : "not ok $testc\n";
|
||||
|
||||
############################################################
|
||||
#can ve tie js objects? (generally to hash, Arrays to arrays too)
|
||||
$testc++;
|
||||
$jsval = $cx->eval('foo = new Object(); foo.prop = 1; foo;');
|
||||
my %hash;
|
||||
#read js property
|
||||
tie %hash, 'JS::Object', $jsval;
|
||||
print $hash{prop} == 1 ? "ok $testc\n" : "not ok $testc\n";
|
||||
|
||||
############################################################
|
||||
#set js propertry
|
||||
$testc++;
|
||||
$hash{prop2} = 2;
|
||||
$jsval = $cx->eval('foo.prop2;');
|
||||
print $jsval == 2 ? "ok $testc\n" : "not ok $testc\n";
|
||||
|
||||
############################################################
|
||||
#tie array
|
||||
$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");
|
||||
|
||||
############################################################
|
||||
# object delegation test
|
||||
$testc++;
|
||||
$cx->createObject(new Proxy("init_value"), "perlobj",
|
||||
{ getObj => \&Proxy::getObj,
|
||||
getValue => \&Proxy::getValue,
|
||||
});
|
||||
$jsval = $cx->eval("perlobj.getValue()");
|
||||
print $jsval eq "init_value" ? "ok $testc\n" : "not ok $testc\n";
|
||||
|
||||
############################################################
|
||||
# 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";
|
||||
|
||||
|
||||
############################################################
|
||||
# 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";
|
||||
|
||||
############################################################
|
||||
# error test
|
||||
$testc++;
|
||||
my $line;
|
||||
sub js_ErrorReporter {
|
||||
my ($msg, $file, $line, $linebuf, $token) = @_;
|
||||
die "line $line";
|
||||
}
|
||||
$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";
|
||||
|
||||
############################################################
|
||||
# cleanup
|
||||
# so far we have to undef context value, to make sure
|
||||
# it is disposed before runtome
|
||||
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";
|
||||
|
|
@ -69,4 +240,4 @@ delete $hash{bar};
|
|||
# exists/clear
|
||||
(exists $hash{foo}) or warn "\$hash{foo} should exist";
|
||||
undef %hash;
|
||||
(!exists $hash{foo}) or warn "\$hash{foo} should be deleted";
|
||||
(!exists $hash{foo}) or warn "\$hash{foo} should be deleted";
|
||||
|
|
|
|||
|
|
@ -47,7 +47,7 @@ JSObject * OBJECT
|
|||
OUTPUT
|
||||
jsval
|
||||
{
|
||||
JSContext *cx = getContext();
|
||||
/* JSContext *cx = getContext(); */
|
||||
JSVALToSV(cx, JS_GetGlobalObject(cx), $var, &$arg);
|
||||
}
|
||||
|
||||
|
|
@ -66,7 +66,7 @@ RUNTIME
|
|||
INPUT
|
||||
jsval
|
||||
{
|
||||
JSContext *cx = getContext();
|
||||
/* JSContext *cx = getContext(); */
|
||||
SVToJSVAL(cx, JS_GetGlobalObject(cx), newRV($arg), &$var);
|
||||
}
|
||||
|
||||
|
|
|
|||
Загрузка…
Ссылка в новой задаче