jsperl.c

caffeine-monkey java实现的js模拟引擎

/* -*- 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,0,0},
    {"eval",            (JSNative)perl_eval,    0,0,0},
    {"call",            (JSNative)perl_call,    0,0,0},
    {"use",             (JSNative)perl_use,     0,0,0},
    {NULL, NULL, 0,0,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,0,0},
    {NULL, NULL, 0,0,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,0,0},
    {NULL, NULL, 0,0,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);