kenmirrors
/
freeswitch
mirror of https://github.com/signalwire/freeswitch.git
1
0
Fork 0
Code Issues Projects Releases Wiki Activity
freeswitch/libs/js/src/perlconnect/jsperl.c

1101 lines
33 KiB
C
Raw Blame History

/* -*- Mode: C; tab-width: 8; indent-tabs-mode: nil; c-basic-offset: 4 -*-
*
* ***** BEGIN LICENSE BLOCK *****
* Version: MPL 1.1/GPL 2.0/LGPL 2.1
*
* The contents of this file are subject to the Mozilla Public License Version
* 1.1 (the "License"); you may not use this file except in compliance with
* the License. You may obtain a copy of the License at
* http://www.mozilla.org/MPL/
*
* Software distributed under the License is distributed on an "AS IS" basis,
* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
* for the specific language governing rights and limitations under the
* License.
*
* The Original Code is Mozilla Communicator client code, released
* March 31, 1998.
*
* The Initial Developer of the Original Code is
* Netscape Communications Corporation.
* Portions created by the Initial Developer are Copyright (C) 1998
* the Initial Developer. All Rights Reserved.
*
* Contributor(s):
*
* Alternatively, the contents of this file may be used under the terms of
* either the GNU General Public License Version 2 or later (the "GPL"), or
* the GNU Lesser General Public License Version 2.1 or later (the "LGPL"),
* in which case the provisions of the GPL or the LGPL are applicable instead
* of those above. If you wish to allow use of your version of this file only
* under the terms of either the GPL or the LGPL, and not to allow others to
* use your version of this file under the terms of the MPL, indicate your
* decision by deleting the provisions above and replace them with the notice
* and other provisions required by the GPL or the LGPL. If you do not delete
* the provisions above, a recipient may use your version of this file under
* the terms of any one of the MPL, the GPL or the LGPL.
*
* ***** END LICENSE BLOCK ***** */
/*
* PerlConnect module.
*/
/*
The first two headers are from the Perl distribution.
Play with "perl -MExtUtils::Embed -e ccopts -e ldopts"
to find out which directories should be included. Refer
to perlembed man page for more info.
*/
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <jsapi.h>
#include <string.h>
/*---------------------------------------------------------------------------*/
/* PerlConnect. Provides means for OO JS <==> Perl communications */
/* See README.html for more info on PerlConnect. Look for TODO in this file */
/* for things that are bogus or not completely implemented. Has been tested */
/* with 5.004 only */
/*---------------------------------------------------------------------------*/
/* Forward declarations */
static JSBool PerlConstruct(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *v);
static void PerlFinalize(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);
static JSBool use(JSContext *cx, JSObject *obj, int argc, jsval *argv, const char* t);
static JSBool PMGetProperty(JSContext *cx, JSObject *obj, jsval name, jsval* rval);
static JSBool PMSetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval);
static JSBool PerlToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval);
static JSBool processReturn(JSContext *cx, JSObject *obj, jsval* rval);
static JSBool checkError(JSContext *cx);
static JSBool PMToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval);
static JSBool PVToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval);
static SV* PVGetRef(JSContext *cx, JSObject *obj);
static JSBool PVGetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval);
static JSBool PVSetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval);
static JSBool PVGetElement(JSContext *cx, JSObject *obj, jsint index, jsval *rval);
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 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);
JS_EXPORT_API(JSBool) SVToJSVAL(JSContext *cx, JSObject *obj, SV *ref, jsval *rval);
/*
The following is required by the Perl dynamic loading mechanism to
link with modules that use C properly. See perlembed man page for details.
This allows things like sockets to be called via PerlConnect.
*/
#ifdef __cplusplus
# define EXTERN_C extern "C"
#else
# define EXTERN_C extern
#endif
EXTERN_C void boot_DynaLoader _((CV* cv));
EXTERN_C void
xs_init()
{
newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, __FILE__);
}
/* These properties are not processed by the getter for PerlValue */
static char* predefined_methods[] = {"toString", "valueOf", "type", "length"};
/* Represents a perl interpreter */
JSClass perlClass = {
"Perl", JSCLASS_HAS_PRIVATE,
JS_PropertyStub, JS_PropertyStub, PMGetProperty, /*PMSetProperty*/JS_PropertyStub,
JS_EnumerateStub, JS_ResolveStub, JS_ConvertStub, PerlFinalize
};
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 }
};
/* Represents a Perl module */
JSClass perlModuleClass = {
"PerlModule", JSCLASS_HAS_PRIVATE,
JS_PropertyStub, JS_PropertyStub, PMGetProperty, JS_PropertyStub,
JS_EnumerateStub, JS_ResolveStub, JS_ConvertStub, JS_FinalizeStub
};
JSFunctionSpec perlModuleMethods[] = {
{"toString", (JSNative)PMToString, 0},
{ NULL, NULL,0 }
};
/* Represents a value returned from Perl */
JSClass perlValueClass = {
"PerlValue", JSCLASS_HAS_PRIVATE,
JS_PropertyStub, JS_PropertyStub, PVGetProperty, PVSetProperty,
JS_EnumerateStub, JS_ResolveStub, PVConvert, PVFinalize
};
JSFunctionSpec perlValueMethods[] = {
{"toString", (JSNative)PVToString, 0},
{ NULL, NULL, 0}
};
/*
Initializes Perl class. Should be called by applications that
want to enable PerlConnect. This will probably preload the Perl
DLL even though Perl might not actually be used. We may postpone
this and load the DLL at runtime after the constructor is called.
*/
static JSObject*
js_InitPerlClass(JSContext *cx, JSObject *obj)
{
jsval v;
JSObject *module;
JSString *mainString = JS_NewStringCopyZ(cx, "main");
if (!mainString)
return NULL;
v = STRING_TO_JSVAL(mainString);
module = JS_NewObject(cx, &perlModuleClass, NULL, obj);
if (!module)
return NULL;
if (!JS_DefineFunctions(cx, module, perlModuleMethods))
return NULL;
JS_SetProperty(cx, module, "path", &v);
return JS_InitClass(cx, obj, module, &perlClass, PerlConstruct, 0,
NULL, NULL, NULL, NULL);
}
/* Public wrapper for the function above */
JSObject*
JS_InitPerlClass(JSContext *cx, JSObject *obj)
{
return js_InitPerlClass(cx, obj);
}
/*
Perl constructor. Allocates a new interpreter and defines methods on it.
The constructor is sort of bogus in that it doesn't create a new namespace
and all the variables defined in one instance of the Perl object will be
visible in others. In the future, I think it may be a good idea to use
Safe.pm to provide independent contexts for different Perl objects and
prohibit certain operations (like exit(), alarm(), die(), etc.). Or we
may simple disallow calling the constructor more than once.
*/
static JSBool
PerlConstruct(JSContext *cx, JSObject *obj, uintN argc, jsval *argv, jsval *v)
{
PerlInterpreter *perl;
JSObject *perlObject;
JSBool ok;
char *embedding[] = {"", "-e", "0"};
char *t = "use PerlConnect qw(perl_eval perl_resolve perl_call $js $ver);";
/* create a new interpreter */
perl = perl_alloc();
if(perl==NULL){
JS_ReportError(cx, "Can't allocate a new interpreter");
return JS_FALSE;
}
perl_construct(perl);
if(perl_parse(perl, xs_init, 3, embedding, NULL)){
JS_ReportError(cx, "Parsing failed");
return JS_FALSE;
}
if(perl_run(perl)){
JS_ReportError(cx, "Run failed");
return JS_FALSE;
}
ok = use(cx, obj, argc, argv, t);
/* make it into an object */
perlObject = JS_NewObject(cx, &perlClass, NULL, NULL);
if(!perlObject)
return JS_FALSE;
if(!JS_DefineFunctions(cx, perlObject, perlMethods))
return JS_FALSE;
JS_SetPrivate(cx, perlObject, perl);
*v = OBJECT_TO_JSVAL(perlObject);
return ok;
}
/* Destructor. Deallocates the interpreter */
static void
PerlFinalize(JSContext *cx, JSObject *obj)
{
PerlInterpreter *perl = JS_GetPrivate(cx, obj);
if (perl) {
perl_destruct(perl);
perl_free(perl);
}
/* return JS_TRUE; */
}
/*
Returns a string representation of the Perl interpreter.
Can add printing of the Perl version, @ISA, etc., like the
output produced by perl -V. Can also make certain variables
available off the Perl object, like Perl.version, etc.
*/
static JSBool
PerlToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval){
JSString *imported;
SV* sv = perl_get_sv("JS::ver", FALSE);
if (!sv) {
JS_ReportOutOfMemory(cx);
return JS_FALSE;
}
imported = JS_NewStringCopyZ(cx, SvPV(sv, PL_na));
if (!imported)
return JS_FALSE;
*rval = STRING_TO_JSVAL(imported);
return JS_TRUE;
}
/*
Evaluates the first parameter in Perl and put the eval's
return value into *rval. The return value is of type PerlValue.
This procedure uses JS::perl_eval. Example of use of perl.eval():
p = new Perl();
str = p.eval("'-' x 80"); // str contains 80 dashes
*/
static JSBool
perl_eval(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval)
{
char *statement;
char *args[] = {NULL, NULL}; /* two elements */
if(argc!=1){
JS_ReportError(cx, "Perl.eval expects one parameter");
return JS_FALSE;
}
statement = JS_GetStringBytes(JS_ValueToString(cx, argv[0]));
args[0] = statement;
perl_call_argv("JS::perl_eval", G_SCALAR|G_KEEPERR|G_EVAL, args);
return processReturn(cx, obj, rval);
}
/*
Call the perl procedure specified as the first argument and
pass all the other arguments as parameters. The return value
is returned in *rval. Example of use of perl.call():
p = new Perl('Time::gmtime');
time = p.call("Time::gmtime::gmtime"); // time is now the following array:
// [40,42,1,22,6,98,3,202,0]
NB: The full function name has to be supplied, i.e. Time::gmtime::gmtime
instead of gmtime unless gmtime is exported into the current package.
This method is also used when one uses the full package name syntax like
this:
p = new Perl("Sys::Hostname", "JS")
result = p.JS.c(1, 2, 4)
p.hostname()
This gets called from PMGetProperty, which creates a
function whose native method is perl_call. Also see
JS::perl_call.
*/
static JSBool
perl_call(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval)
{
JSBool ok;
int count, i;
char* fun_name;
SV *sv;
dSP;
/* 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 = (char*)JS_GetFunctionName(JS_GetPrivate(cx, JSVAL_TO_OBJECT(argv[-2])));
i=0;
}else{
fun_name = JS_GetStringBytes(JS_ValueToString(cx, argv[0]));
i=1;
}
PUSHMARK(sp);
XPUSHs(sv_2mortal(newSVpv(fun_name,0)));
for(;i<argc;i++){
JSVALToSV(cx, obj, argv[i], &sv);
XPUSHs(sv);
}
PUTBACK;
count = perl_call_sv(newSVpv("JS::perl_call", 0), G_KEEPERR|G_SCALAR|G_EVAL|G_DISCARD);
if(count!=0){
JS_ReportError(cx, "Implementation error: count=%d, must be 0!\n", count);
return JS_FALSE;
}
ok = processReturn(cx, obj, rval);
return ok;
}
/*
Loads Perl libraries specified as arguments.
*/
static JSBool
perl_use(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval)
{
return use(cx, obj, argc, argv, NULL);
}
/*
Utility function used by perl_use and Perl's constructor.
Executes use lib1; use lib2, etc. in the current interpreter.
*/
static JSBool
use(JSContext *cx, JSObject *obj, int argc, jsval *argv, const char* t){
char *evalStr = JS_malloc(cx, t?strlen(t)+1:1);
int i;
if (!evalStr)
return JS_FALSE;
strcpy(evalStr, t?t:"");
for(i=0;i<argc;i++){
char *arg = JS_GetStringBytes(JS_ValueToString(cx, argv[i])), *tmp, old[256];
/* call use() on every parameter */
strcpy(old, evalStr);
JS_free(cx, evalStr);
tmp = JS_malloc(cx, strlen(old)+strlen(arg)+6);
if (!tmp)
return JS_FALSE;
sprintf(tmp, "%suse %s;", old, arg);
evalStr = tmp;
}
perl_eval_sv(newSVpv(evalStr, 0), G_KEEPERR);
checkError(cx);
JS_free(cx, evalStr);
return JS_TRUE;
}
/*
Looks at $@ to see if there was an error. Used by
perl_eval, perl_call, etc.
*/
static JSBool
checkError(JSContext *cx)
{
if(SvTRUE(GvSV(PL_errgv))){
JS_ReportError(cx, "perl eval failed: %s",
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;
}
return JS_TRUE;
}
/*
Take the value of $JS::js and convert in to a jsval. It's stotred
in *rval. perl_eval and perl_call use $JS::js to store return results.
*/
static JSBool
processReturn(JSContext *cx, JSObject *obj, jsval* rval)
{
SV *js;
js = perl_get_sv("JS::js", FALSE);
if(!js || !SvOK(js)){
*rval = JSVAL_VOID;
/* XXX isn't this wrong? */
return JS_FALSE;
}
if(!SvROK(js)){
JS_ReportError(cx, "$js (%s) must be of reference type", SvPV(js,PL_na));
return JS_FALSE;
}
checkError(cx);
return SVToJSVAL(cx, obj, js, rval);
}
/*
Implements namespace-like syntax that maps Perl packages to
JS objects. One can say
p = new Perl('Foo::Bar')
and then call
a = p.Foo.Bar.f()
or access variables exported from those packages like this:
a = p.Foo.Bar["$var"]
this syntax will also work:
a = p.Foo.Bar.$var
but if you want to access non-scalar values, you must use the subscript syntax:
p.Foo.Bar["@arr"]
and
p.Foo.Bar["%hash"]
*/
static JSBool
PMGetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
{
char *last = JS_GetStringBytes(JS_ValueToString(cx, name)), *path, package[256];
char *args[] = {NULL, NULL};
char *predefined_methods[] = {"toString", "eval", "call", "use", "path"};
int count;
SV *js;
jsval v;
int i;
for(i=0;i<sizeof(predefined_methods)/sizeof(char*);i++){
if(!strcmp(predefined_methods[i], last)){
return JS_TRUE;
}
}
JS_GetProperty(cx, obj, "path", &v);
path = JS_GetStringBytes(JS_ValueToString(cx, v));
sprintf(package, "%s::%s", path, last);
args[0] = package;
count = perl_call_argv("JS::perl_resolve", G_KEEPERR|G_SCALAR|G_EVAL|G_DISCARD, args);
if(count!=0){
JS_ReportError(cx, "Implementation error: count=%d, must be 0!\n", count);
return JS_FALSE;
}
checkError(cx);
js = perl_get_sv("JS::js", FALSE);
if(js && SvOK(js)){
if(SvROK(js)){
SVToJSVAL(cx, obj, js, rval);
}else{
/* defined function */
if(SvIV(js) == 1){
JSFunction *f = JS_NewFunction(cx, (JSNative)perl_call, 0, 0, NULL, package);
if (!f) {
return JS_FALSE;
}
*rval = OBJECT_TO_JSVAL(JS_GetFunctionObject(f));
}else
if(SvIV(js) == 2){
JSObject *module;
JSString *packageString;
module = JS_NewObject(cx, &perlModuleClass, NULL, obj);
packageString = JS_NewStringCopyZ(cx,package);
if (!module || !packageString) {
return JS_FALSE;
}
v = (js && SvTRUE(js))?STRING_TO_JSVAL(packageString):JSVAL_VOID;
JS_SetProperty(cx, module, "path", &v);
*rval = OBJECT_TO_JSVAL(module);
}else{
JS_ReportError(cx, "Symbol %s is not defined", package);
*rval = JSVAL_VOID;
}
}
return JS_TRUE;
}else{
JS_ReportError(cx, "failure");
return JS_FALSE;
}
}
/*
Gets called when a Perl value gets assigned to like this:
p.Foo.Bar["$var"] = 100
*/
static JSBool
PMSetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
{
/* TODO: just call SVToJSVAL() and make the assignment. */
return JS_TRUE;
}
/*
toString() for PerlModule. Prints the path the module represents.
Note that the path doesn't necessarily have to be valid. We don't
have a way to check that until we call a function from that package.
TODO: In 5.005 exists Foo::{Bar::} checks is Foo::{Bar::} exists.
We can use this to validate package names.
*/
static JSBool
PMToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval){
char str[256];
JSString *s, *newString;
jsval v;
JS_GetProperty(cx, obj, "path", &v);
s = JSVAL_TO_STRING(v);
sprintf(str, "[PerlModule %s]", JS_GetStringBytes(s));
newString = JS_NewStringCopyZ(cx, str);
if (!newString)
return JS_FALSE;
*rval = STRING_TO_JSVAL(newString);
return JS_TRUE;
}
/*
Helped method. Retrieves the Perl reference stored
in PerlValue object as private data.
*/
#include <stdio.h>
static SV*
PVGetRef(JSContext *cx, JSObject *obj)
{
SV* ref;
ref = (SV*)JS_GetInstancePrivate(cx, obj, &perlValueClass, NULL);
if(!ref || !SvOK(ref) || !SvROK(ref)){
JS_ReportError(cx, "Can't extract ref");
return NULL;
}
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 = (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();
JSVALToSV(cx, obj, argv[i], &sv);
//sv_2mortal(sv);
XPUSHs(sv);
}
PUTBACK;
cnt = perl_call_sv((SV*)GvCV(gv), G_ARRAY | G_KEEPERR | G_EVAL);
//SvREFCNT_dec(perl_object);
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 {
JSObject *jsarr;
jsval val;
int i;
jsarr = JS_NewArrayObject(cx, 0, NULL);
for (i = 0; i < cnt; i++) {
SVToJSVAL(cx, JS_GetGlobalObject(cx), ST(i), &val);
JS_DefineElement(cx, jsarr, i, val, NULL, NULL, 0);
}
*rval = OBJECT_TO_JSVAL(jsarr);
}
PUTBACK;
FREETMPS;
LEAVE;
//return(JS_TRUE);
return checkError(cx);
}
/*
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 looks 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__ array properties should be served first */
if(JSVAL_IS_INT(name)){
int32 ip;
JS_ValueToInt32(cx, name, &ip);
PVGetElement(cx, obj, ip, rval);
if(*rval!=JSVAL_VOID){
return JS_TRUE;
}
}
str = JS_GetStringBytes(JS_ValueToString(cx, name));
/* __PH__ may, be */
if(!strcmp(str, "length")){
SV* sv = SvRV(PVGetRef(cx, obj));
if(SvTYPE(sv)==SVt_PVAV){
*rval = INT_TO_JSVAL(av_len((AV*)sv)+1);
return JS_TRUE;
}else
if(SvTYPE(sv)==SVt_PVHV){
*rval = INT_TO_JSVAL(av_len((AV*)sv)+1);
return JS_TRUE;
}else{
*rval = INT_TO_JSVAL(0);
return JS_TRUE;
}
}else{
int i;
/* __PH__ predefined methods NUST 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 may 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;
}
/*
Set property of PerlValue object. Like GetProperty is looks at
both array and hash components.
*/
static JSBool
PVSetProperty(JSContext *cx, JSObject *obj, jsval name, jsval *rval)
{
char* str = JS_GetStringBytes(JS_ValueToString(cx, name));
if(JSVAL_IS_INT(name)){
int32 ip;
JS_ValueToInt32(cx, name, &ip);
if(PVSetElement(cx, obj, ip, *rval)) return JS_TRUE;
}
return PVSetKey(cx, obj, str, *rval);
}
/*
Retrieve numerical property of a PerlValue object.
If the object doesn't contain an array, or the
property doesn't exist, NULL is returned.
*/
static JSBool
PVGetElement(JSContext *cx, JSObject *obj, jsint index, jsval *rval)
{
SV *ref, **sv;
AV *list;
*rval = JSVAL_VOID;
ref = PVGetRef(cx, obj);
if(SvTYPE(SvRV(ref)) != SVt_PVAV){
return JS_FALSE;
}
list = (AV*)SvRV(ref);
if(!list){
return JS_FALSE;
}
sv = av_fetch(list, (I32)index, 0);
if(!sv){
return JS_FALSE;
}
//return SVToJSVAL(cx, obj, newRV_inc(*sv), rval);
return SVToJSVAL(cx, obj, *sv, rval);
}
/*
Set a numeric property of a PerlValue object.
If the object doesn't contain an array or the
index doesn't exist, JS_FALSE is returned.
*/
static JSBool
PVSetElement(JSContext *cx, JSObject *obj, jsint index, jsval v)
{
SV *ref, **sv, *s;
AV *list;
ref = PVGetRef(cx, obj);
if(SvTYPE(SvRV(ref)) != SVt_PVAV){
return JS_FALSE;
}
list = (AV*)SvRV(ref);
if(!list) return JS_FALSE;
JSVALToSV(cx, obj, v, &s);
sv = av_store(list, (I32)index, s);
if(!sv) return JS_FALSE;
return JS_TRUE;
}
/*
Retrieve property. If the object doesn't contain an hash, or the
property doesn't exist, NULL is returned.
*/
static JSBool
PVGetKey(JSContext *cx, JSObject *obj, char* name, jsval *rval)
{
SV *ref, **sv;
HV *hash;
*rval = JSVAL_VOID;
ref = PVGetRef(cx, obj);
if(SvTYPE(SvRV(ref)) != SVt_PVHV){
return JS_FALSE;
}
hash = (HV*)SvRV(ref);
if(!hash){
return JS_FALSE;
}
sv = hv_fetch(hash, name, strlen(name), 0);
if(!sv){
return JS_FALSE;
}
return SVToJSVAL(cx, obj, newRV_inc(*sv), rval);
}
/*
Get property of a PerlValue object.
If the object doesn't contain a hash or the
property doesn't exist, JS_FALSE is returned.
*/
static JSBool
PVSetKey(JSContext *cx, JSObject *obj, char* name, jsval v)
{
SV *ref, **sv, *s;
HV *hash;
ref = PVGetRef(cx, obj);
if(SvTYPE(SvRV(ref)) != SVt_PVHV){
return JS_FALSE;
}
hash = (HV*)SvRV(ref);
if(!hash) return JS_FALSE;
JSVALToSV(cx, obj, v, &s);
sv = hv_store(hash, name, strlen(name), s, 0);
if(!sv) return JS_FALSE;
else return JS_TRUE;
}
/*
toString() method for PerlValue. For arrays uses array's methods.
If this fails, the type of the value gets returned. TODO: It's actually
better to use a Perl module like Data::Dumpvar.pm to print complex
data structures recursively.
*/
static JSBool
PVToString(JSContext *cx, JSObject *obj, int argc, jsval *argv, jsval* rval)
{
SV* ref = PVGetRef(cx, obj);
SV* sv = SvRV(ref);
svtype type = SvTYPE(sv);
/*jsval args[]= {STRING_TO_JSVAL(JS_NewStringCopyZ(cx, "JS::Object::toString")),
OBJECT_TO_JSVAL(obj)};*/
jsval v;
/*return perl_call(cx, obj, 2, args, rval);*/
if (type==SVt_PVAV) {
JSObject *arrayObject = JS_NewArrayObject(cx,0,NULL);
JSFunction *fun;
JS_GetProperty(cx, arrayObject, "toString", &v);
fun = JS_ValueToFunction(cx, v);
return JS_CallFunction(cx, obj, fun, 0, NULL, rval);
}
{
char out[256];
JSString *newString;
JS_GetProperty(cx, obj, "type", &v);
if(!JSVAL_IS_VOID(v))
sprintf(out, "[%s]", JS_GetStringBytes(JSVAL_TO_STRING(v)));
else
strcpy(out, "[PerlValue]");
newString = JS_NewStringCopyZ(cx, out);
if (!newString)
return JS_FALSE;
*rval = STRING_TO_JSVAL(newString);
}
return JS_TRUE;
}
static JSBool
PVConvert (JSContext *cx, JSObject *obj, JSType type, jsval *rval)
{
*rval = OBJECT_TO_JSVAL(obj);
return JS_TRUE;
}
/*
Takes care of GC in Perl: we need to decrement Perl's
reference count when PV goes out of scope.
*/
/* #include <stdio.h> */
static void
PVFinalize (JSContext *cx, JSObject *obj)
{
/* SV* sv = SvRV(PVGetRef(cx, obj)); */
SV *sv;
if ( obj ) {
sv = PVGetRef(cx, obj);
/* SV *sv = PVGetRef(cx, obj);
if ( SvROK(sv) ) sv = SvRV( sv ); _PH_ test*/
/* TODO: GC */
if(sv && SvREFCNT(sv) > 0){
/*fprintf(stderr, "Finalization: %d references left", SvREFCNT(sv));*/
SvREFCNT_dec(sv);
/*fprintf(stderr, "Finalization: %d references left", SvREFCNT(sv));*/
}
}
/* return JS_TRUE; */
}
/*
Convert a jsval to a SV* (scalar value pointer).
Used for parameter passing. This function is also
used by the Perl part of PerlConnect.
*/
JSBool
JSVALToSV(JSContext *cx, JSObject *obj, jsval v, SV** sv)
{
//*sv = &sv_undef; //__PH__??
if(JSVAL_IS_PRIMITIVE(v)){
if(JSVAL_IS_NULL(v) || JSVAL_IS_VOID(v)){
*sv = &PL_sv_undef;
//printf("===> JSVALToSV: VOID\n");
}else
if(JSVAL_IS_INT(v)){
*sv = sv_newmortal();
sv_setiv(*sv, JSVAL_TO_INT(v));
//*sv = newSViv(JSVAL_TO_INT(v));
//printf("===> JSVALToSV: INT\n");
}else
if(JSVAL_IS_DOUBLE(v)){
*sv = sv_newmortal();
sv_setnv(*sv, *JSVAL_TO_DOUBLE(v));
//*sv = newSVnv(*JSVAL_TO_DOUBLE(v));
//printf("===> JSVALToSV: DOUBLE\n");
}else
if(JSVAL_IS_STRING(v)){
*sv = sv_newmortal();
sv_setpv(*sv, JS_GetStringBytes(JSVAL_TO_STRING(v)));
//*sv = newSViv(0);
//sv_setpv(*sv, JS_GetStringBytes(JSVAL_TO_STRING(v)));
//printf("===> JSVALToSV: CHAR\n");
}else{
warn("Unknown primitive type");
}
}else{
if(JSVAL_IS_OBJECT(v)){
JSObject *object = JSVAL_TO_OBJECT(v);
if(JS_InstanceOf(cx, object, &perlValueClass, NULL)){
*sv = PVGetRef(cx, object);
}else{
if(JS_IsArrayObject(cx, object)){
*sv = sv_newmortal();
sv_setref_pv(*sv, "JS::Object", (void*)object);
sv_magic(SvRV(*sv), sv_2mortal(newSViv((IV)cx)),
'~', NULL, 0);
/* printf("===> JSVALToSV: ARRAY\n); */
}else{
*sv = sv_newmortal();
sv_setref_pv(*sv, "JS::Object", (void*)object);
sv_magic(SvRV(*sv), sv_2mortal(newSViv((IV)cx)),
'~', NULL, 0);
//printf("===> JSVALToSV: JS OBJECT\n");
}
}
}else{
warn("Type conversion is not supported");
*sv = &PL_sv_undef; //__PH__??
return JS_FALSE;
}
}
return JS_TRUE;
}
/*
Converts a reference Perl value to a jsval. If ref points
to an immediate value, the value itself is returned in rval.
O.w. a PerlValue object is returned. This function is also
used by the Perl part of PerlConnect.
*/
#define SV_BIND_TO_OBJECT(sv) (sv_isobject(sv) || (SvROK(sv) && (\
SvTYPE(SvRV(sv)) == SVt_RV ||\
SvTYPE(SvRV(sv)) == SVt_PVAV ||\
SvTYPE(SvRV(sv)) == SVt_PVHV ||\
SvTYPE(SvRV(sv)) == SVt_PVCV\
)))
JSBool
SVToJSVAL(JSContext *cx, JSObject *obj, SV *ref, jsval *rval) {
SV *sv;
char* name=NULL;
JSBool ok = JS_TRUE;
/* we'll use the dereferrenced value (excpet for object) */
if( SvROK(ref) ) {
sv = SvRV(ref);
}else{
sv = ref;
}
/* printf("+++> In SVToJSVAL value %s, type=%d\n", SvPV(sv, PL_na), SvTYPE(sv)); */
if ( ! SvOK( ref ) ){
*rval = JSVAL_VOID;
/* printf("---> SVToJSVAL returning VOID\n"); */
} else
if ( SV_BIND_TO_OBJECT(ref) ) {
JSObject *perlValue, *prototype = NULL;
JSString *nameString;
/*svtype type = SvTYPE(sv);
switch(type){
case SVt_RV: name = "Perl Reference"; break;
case SVt_PVAV: name = "Perl Array"; break;
case SVt_PVHV: name = "Perl Hash"; break;
case SVt_PVCV: name = "Perl Code Reference"; break;
case SVt_PVMG: name = "Perl Magic"; break;
default:
warn("Unsupported type in SVToJSVAL: %d", type);
*rval = JSVAL_VOID;
return JS_FALSE;
}*/
/* printf("---> SVToJSVAL returning object\n"); */
name = "Perl Value";
/* __PH__ */
SvREFCNT_inc(ref);
if (SvTYPE(sv) == SVt_PVAV) {
prototype = JS_NewArrayObject(cx, 0, NULL);
if (!prototype)
return JS_FALSE;
}
perlValue = JS_DefineObject(cx, obj, "PerlValue",
&perlValueClass, prototype,
JSPROP_ENUMERATE);
if (!perlValue)
return JS_FALSE;
JS_SetPrivate(cx, perlValue, ref);
if (!JS_DefineFunctions(cx, perlValue, perlValueMethods))
return JS_FALSE;
if (name) {
nameString = JS_NewStringCopyZ(cx, name);
if (!nameString)
return JS_FALSE;
}
if (!JS_DefineProperty(cx, perlValue, "type",
name?STRING_TO_JSVAL(nameString):JSVAL_VOID,
NULL, NULL, JSPROP_PERMANENT|JSPROP_READONLY))
return JS_FALSE;
*rval = OBJECT_TO_JSVAL(perlValue);
} else
if(SvIOK(sv)){
*rval = INT_TO_JSVAL(SvIV(sv));
/* printf("---> SVToJSVAL returning INTEGER\n"); */
} else
if(SvNOK(sv)){
ok = JS_NewDoubleValue(cx, SvNV(sv), rval);
/* printf("---> SVToJSVAL returning DOUBLE\n"); */
} else
if(SvPOK(sv)){
*rval = STRING_TO_JSVAL((JS_NewStringCopyZ(cx, SvPV(sv, PL_na))));
/* printf("---> SVToJSVAL returning CHAR\n\n"); */
} else {
*rval = JSVAL_VOID; /* shouldn't happen */
/* printf("---> SVToJSVAL returning VOID (panic)\n"); */
}
return ok;
}
Reference in New Issue View Git Blame Copy Permalink