js.xs

来自「一个基于alice开发的机器人」· XS 代码 · 共 1,046 行 · 第 1/2 页

/* -*- Mode: C; tab-width: 8; indent-tabs-mode: nil; c-basic-offset: 4 -*-
 *
 * The contents of this file are subject to the Netscape 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/NPL/
 *
 * 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 Netscape are
 * Copyright (C) 1998 Netscape Communications Corporation. All
 * Rights Reserved.
 *
 * Contributor(s): 
 *
 * Alternatively, the contents of this file may be used under the
 * terms of the GNU Public License (the "GPL"), in which case the
 * provisions of the GPL are applicable instead of those above.
 * If you wish to allow use of your version of this file only
 * under the terms of the GPL and not to allow others to use your
 * version of this file under the NPL, indicate your decision by
 * deleting the provisions above and replace them with the notice
 * and other provisions required by the GPL.  If you do not delete
 * the provisions above, a recipient may use your version of this
 * file under either the NPL or the GPL.
 */

/*
 * PerlConnect. Provides means for OO Perl <==> JS communications
 */

/* This is an program written in XSUB. You need to compile it using xsubpp   */
/* usually found in your perl\bin directory. On my machine I do it like this:*/
/*      perl c:\perl\lib\ExtUtils\xsubpp  -typemap  \                        */
/*           c:\perl\lib\extutils\typemap -typemap typemap JS.xs > JS.c      */
/* See perlxs man page for details.                                          */
/* Don't edit the resulting C file directly. See README.html for more info   */
/* on PerlConnect in general                                                 */

#ifdef __cplusplus
    extern "C"; {
#endif
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef __cplusplus
    }
#endif

#include <jsapi.h>
#include "jsperlpvt.h"
#include <malloc.h>

/* __REMOVE__ */
/* #include <stdio.h>  */

/************************************************************/
/* utils */

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;
}

static void
clearException(JSContext *cx) 
{
    if (JS_IsExceptionPending(cx)) {
        JS_ClearPendingException(cx);
    }
}

/************************************************************/
/* calback stub */

/* this is internal js structure needed in errorFromPrivate */
typedef struct JSExnPrivate {
    JSErrorReport *errorReport;
} JSExnPrivate;

static
JSClass global_class = {
    "Global", 0,
    JS_PropertyStub,  JS_PropertyStub,  JS_PropertyStub,  JS_PropertyStub,
    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 *jsStub;
    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));
    return ret;
}

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 ) {
            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)));
                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;
    }

    if (cxitem->errorReporter) {
        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);
    /* better check and error report should be done here */
    if (!gv) return JS_FALSE;

    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), G_ARRAY);    

    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);
}

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);
    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, G_ARRAY);
    
    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);
}

/* helper functions */ 
/* JSClass pointer is disposed by 
   JS engine during context cleanup _PH_ 
*/
void
PCB_FinalizeStub(JSContext *cx, JSObject *obj) {
}

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;
    class->finalize = PCB_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++) {
        JSVALToSV(cx, obj, argv[i], &sv);
        XPUSHs(sv);
    }
    PUTBACK;
    cnt = perl_call_sv(SvRV(cbk->perl_proc), G_ARRAY | G_KEEPERR | G_EVAL);

    SPAGAIN;
    /* adjust stack for use of ST macro (see perlcall) */
    SP -= cnt;
    ax = (SP - PL_stack_base) + 1;