perlmodule.c

/* Copyright 2000-2001 ActiveState
 *
 * This is a python extension module that embeds perl.
 */

#include <Python.h>
#include <EXTERN.h>
#include <perl.h>

#include "2to3.h"

#include "thrd_ctx.h"
#include "perlmodule.h"
#include "svrv_object.h"
#include "lang_lock.h"
#include "lang_map.h"

static PyObject *PerlError;
extern void xs_init (pTHXo);

#ifdef MULTI_PERL

PerlInterpreter *
new_perl(void)
{
    PerlInterpreter *p;
    char *embedding[] = { "", "-mPython::Object", "-e", "$| = 1;", NULL };

    p = perl_alloc();
#if 0
    fprintf(stderr, "creating new perl %p\n", p); fflush(stderr);
#endif
    perl_construct(p);
#ifdef BOOT_FROM_PERL
    perl_parse(p, 0, 4, embedding, NULL);
#else
    perl_parse(p, xs_init, 4, embedding, NULL);
#endif
    perl_run(p);

    return p;
}

void
free_perl(PerlInterpreter *p)
{
#if 0
    fprintf(stderr, "destructing perl %p\n", p); fflush(stderr);
#endif
    perl_destruct(p);
    perl_free(p);
    PERL_SET_CONTEXT(0);
}

#else /* MULTI_PERL */

#ifdef USE_ITHREADS
PerlInterpreter *main_perl = 0;
#endif /* USE_ITHREADS */

#endif /* MULTI_PERL */

#include "Python-Object/PerlPyErr.h"


void
propagate_errsv()
{
    STRLEN n_a;
    dCTXP;

    ASSERT_LOCK_BOTH;

    if (SvROK(ERRSV) && sv_derived_from(ERRSV, "Python::Err")) {
    IV tmp = SvIV((SV*)SvRV(ERRSV));
    PerlPyErr *py_err = INT2PTR(PerlPyErr *,tmp);
    
    /* We want to keep the Exception object valid also after restore,
     * so increment reference counts first.
     */
    Py_XINCREF(py_err->type);
    Py_XINCREF(py_err->value);
    Py_XINCREF(py_err->traceback);

    PyErr_Restore(py_err->type, py_err->value, py_err->traceback);
    }
    else {
    char *s;
    PYTHON_UNLOCK;
    s = SvPV(ERRSV, n_a);
    ENTER_PYTHON;
    PyErr_SetString(PerlError, s);
    PERL_LOCK;
    }

    ASSERT_LOCK_BOTH;
}


PyObject *
call_perl(char *method, SV* obj, I32 gimme,
      PyObject *args,
      PyObject *keywds)
{
    PyObject *m_obj = 0;
    SV* func = 0;
    int argfirst = 0;
    int i, arglen;
    int ret_count;
    PyObject *ret_val;
    int errsv;
    dCTXP;
    dSP;   /* perl stack */

    ASSERT_LOCK_PYTHON;
    SET_CUR_PERL;

    assert(PyTuple_Check(args));
    arglen = PyTuple_Size(args);

    if (method) {
    if (!*method) {
        if (arglen < (obj ? 1 : 2)) {
        PyErr_SetString(PerlError, "Need both a method name and a object/class");
        ASSERT_LOCK_PYTHON;
        return NULL;
        }
        m_obj = PyTuple_GetItem(args, 0);
        m_obj = PyObject_Str(m_obj); /* need decrement refcount after call */
        assert(PyString_Check(m_obj));
        method = PyString_AsUTF8(m_obj);
        argfirst = 1;
    }
    else if (!obj && !arglen) {
        PyErr_SetString(PerlError, "Missing object/class");
        ASSERT_LOCK_PYTHON;
        return NULL;
    }
    }
    else if (obj) {
    func = obj;
    obj = 0;
    }
    else {
    if (arglen < 1) {
        PyErr_SetString(PerlError, "Missing function argument");
        ASSERT_LOCK_PYTHON;
        return NULL;
    }
    PERL_LOCK;
    func = pyo2sv(PyTuple_GetItem(args, 0));
    argfirst = 1;
    PERL_UNLOCK;
    }

    if (keywds) {
    PyObject *o;
    assert(PyDict_Check(keywds));

    if ( (o = PyDict_GetItemString(keywds, "__wantarray__"))) {
        gimme = (o == Py_None)     ? G_VOID :
            PyObject_IsTrue(o) ? G_ARRAY :
                                 G_SCALAR;
    }
    }

    /* At this point we should know we have enough arguments to actually
     * call out, so we start setting up the stack
     */

    PERL_LOCK;
  
    ENTER;
    SAVETMPS;

    PUSHMARK(SP);

    if (obj)
    XPUSHs(obj);

    for (i = argfirst; i < arglen; i++) {
    XPUSHs(sv_2mortal(pyo2sv(PyTuple_GET_ITEM(args, i))));
    }

    /* push keyword arguments too if there are any */
    if (keywds) {
    Py_ssize_t pos = 0;
    PyObject *key;
    char *key_str;
    PyObject *val;
    while (PyDict_Next(keywds, &pos, &key, &val)) {
        assert(PyString_Check(key));
        key_str = PyString_AsUTF8(key);
      
        if (key_str[0] == '_' && key_str[1] == '_')
        continue;

        XPUSHs(sv_2mortal(newSVpv(key_str, 0)));
        XPUSHs(sv_2mortal(pyo2sv(val)));
    }
    }

    PUTBACK;

    PYTHON_UNLOCK;

    if (method)
    ret_count = call_method(method, gimme | G_EVAL);
    else {
    ret_count = call_sv(func, gimme | G_EVAL);
    if (argfirst == 1)
        SvREFCNT_dec(func);
    }
    errsv = SvTRUE(ERRSV);

    SPAGAIN;

    ENTER_PYTHON;
    PERL_LOCK;

    if (errsv) {
    while (ret_count--)
        POPs;
    propagate_errsv();
    ret_val = NULL;
    }
    else {
    if (gimme == G_ARRAY || ret_count > 1) {
        ret_val = PyTuple_New(ret_count);
        for (i = 0; i < ret_count; i++)
        PyTuple_SET_ITEM(ret_val, ret_count - 1 - i, sv2pyo(POPs));
    }
    else if (ret_count == 1) {
        ret_val = sv2pyo(POPs);
    }
    else {
        ret_val = Py_BuildValue("");  /* None */
    }
    }

    PYTHON_UNLOCK;

    PUTBACK;
    FREETMPS;
    LEAVE;

    ENTER_PYTHON;
    Py_XDECREF(m_obj);

    ASSERT_LOCK_PYTHON;
    return ret_val;
}


#ifdef MULTI_PERL

#include "opcode.c"

static PyObject *
safecall(self, args, keywds)
     PyObject *self;
     PyObject *args;
     PyObject *keywds;
{
    char *root;
    char *op_mask;
    int op_mask_len;
    char op_mask_buf[OP_MASK_BUF_SIZE];
    PyObject *realargs;
    PyObject *ret;
    GV *gv;
    dCTXP;

    if (!PyArg_ParseTuple(args, "ss#O!:safecall",
              &root, &op_mask, &op_mask_len,
              &PyTuple_Type, &realargs))
    return NULL;

    ENTER_PERL;
    SET_CUR_PERL;
    /* This code is adapted from Opcode::_safe_call_sv() */

    ENTER;
    opmask_addlocal(aTHX_ op_mask, op_mask_len, op_mask_buf);

    save_aptr(&PL_endav);
    PL_endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now */

    save_hptr(&PL_defstash);        /* save current default stash    */
    save_hptr(&PL_curstash);
    /* the assignment to global defstash changes our sense of 'main'    */

    if (ctx->root_stash) {
    PL_defstash = PL_curstash = ctx->root_stash;
    }
    else {
    save_hptr(&ctx->root_stash);
    ctx->root_stash = PL_defstash;
    }

    PL_defstash = gv_stashpv(root, GV_ADDWARN); /* should exist already    */
    PL_curstash = PL_defstash;

    /* defstash must itself contain a main:: so we'll add that now    */
    /* take care with the ref counts (was cause of long standing bug)    */
    /* XXX I'm still not sure if this is right, GV_ADDWARN should warn!    */
    gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV);
    sv_free((SV*)GvHV(gv));
    GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);

    /* %INC must be clean for use/require in compartment */
    save_hash(PL_incgv);
    GvHV(PL_incgv) = (HV*)SvREFCNT_inc(GvHV(gv_HVadd(gv_fetchpv("INC",TRUE,SVt_PVHV))));
    
    ENTER_PYTHON; /* just so call_perl can change it back :-( */
    ret = call_perl(0, 0, G_SCALAR, realargs, keywds);

    ENTER_PERL;
    LEAVE;

    ENTER_PYTHON;
    return ret;
}

static void
restore_unsafe_env(thread_ctx *ctx)
{
    PerlInterpreter *my_perl = ctx->perl->my_perl;

    save_hptr(&PL_defstash);
    save_hptr(&PL_curstash);
    save_hptr(&ctx->root_stash);
    PL_defstash = PL_curstash = ctx->root_stash;
    ctx->root_stash = 0;

    /* Remove opmask */
    SAVEVPTR(PL_op_mask);
    PL_op_mask = 0;
}


static PyObject *
unsafe_call_perl(char *method, SV* obj, I32 gimme,
         PyObject *args,
         PyObject *keywds)
{
    dCTXP;
    PyObject *res;
    int leave_needed = 0;
    if (ctx->root_stash) {
    /* reenter from safe, set back root */
    ENTER;
    leave_needed++;
    restore_unsafe_env(ctx);
    }
    res = call_perl(method, obj, gimme, args, keywds);
    if (leave_needed)
    LEAVE;  /* restore safe env */
    return res;
}

#define CALL_PERL          unsafe_call_perl
#define RESTORE_UNSAFE_ENV if (ctx->root_stash) restore_unsafe_env(ctx)
#else /* MULTI_PERL */

#define CALL_PERL          call_perl
#define RESTORE_UNSAFE_ENV /*empty*/

#endif /* MULTI_PERL */


static PyObject *
call(self, args, keywds)
     PyObject *self;
     PyObject *args;
     PyObject *keywds;
{
    return CALL_PERL(0, 0, G_SCALAR, args, keywds);
}


static PyObject *
call_tuple(self, args, keywds)
     PyObject *self;
     PyObject *args;
     PyObject *keywds;
{
    return CALL_PERL(0, 0, G_ARRAY, args, keywds);
}


static PyObject *
callm(self, args, keywds)
     PyObject *self;
     PyObject *args;
     PyObject *keywds;
{
    return CALL_PERL("", 0, G_SCALAR, args, keywds);
}


static PyObject *
callm_tuple(self, args, keywds)
     PyObject *self;
     PyObject *args;
     PyObject *keywds;
{
    return CALL_PERL("", 0, G_ARRAY, args, keywds);
}


static PyObject *
eval(self, args)
     PyObject *self;
     PyObject *args;
{
    char* code;
    SV* res_sv;
    PyObject* res_pyo;
    int errsv;
    dCTXP;

    ASSERT_LOCK_PYTHON;
  
    if (!PyArg_ParseTuple(args, "s:perl.eval", &code))
    return NULL;

    ENTER_PERL;
    SET_CUR_PERL;

    ENTER;
    SAVETMPS;
    RESTORE_UNSAFE_ENV;

    fflush(stdout);
    res_sv = eval_pv(code, FALSE);
    errsv = SvTRUE(ERRSV);
  
    ENTER_PYTHON;
    PERL_LOCK;

    if (errsv) {
    propagate_errsv();
    res_pyo = NULL;
    }
    else {
    res_pyo = sv2pyo(res_sv);
    }

    PYTHON_UNLOCK;

    FREETMPS;
    LEAVE;

    ENTER_PYTHON;
    return res_pyo;
}


static PyObject *
require(self, args)
     PyObject *self;
     PyObject *args;
{
    char *module;
    SV *code;
    SV *res_sv;
    PyObject *res_pyo;
    STRLEN n_a;
    int errsv;
    dCTXP;

    ASSERT_LOCK_PYTHON;
  
    if (!PyArg_ParseTuple(args, "s:perl.require", &module))
    return NULL;

    ENTER_PERL;
    SET_CUR_PERL;

    ENTER;
    SAVETMPS;
    RESTORE_UNSAFE_ENV;

    code = newSVpv("require ", 0);
    sv_catpv(code, module);

    res_sv = eval_pv(SvPVx(code, n_a), FALSE);
    SvREFCNT_dec(code);
    errsv = SvTRUE(ERRSV);

    ENTER_PYTHON;
    PERL_LOCK;

    if (errsv) {
    propagate_errsv();
    res_pyo = NULL;
    }
    else {
    res_pyo = sv2pyo(res_sv);
    }

    PYTHON_UNLOCK;

    FREETMPS;
    LEAVE;

    ENTER_PYTHON;
    return res_pyo;
}


static PyObject *
defined(self, args)
     PyObject *self;
     PyObject *args;
{
    char *name;
    char type;
    SV* sv;
    dCTXP;

    ASSERT_LOCK_PYTHON;
    if (!PyArg_ParseTuple(args, "s:perl.defined", &name))
    return NULL;
    ENTER_PERL;
    SET_CUR_PERL;

    ENTER;
    RESTORE_UNSAFE_ENV;

    if (isIDFIRST(*name)) {
    type = '&';
    }
    else {
    type = *name;
    name++;
    }

    if (*name) {
    switch (type) {
    case '$': sv =      get_sv(name, 0); break;
    case '@': sv = (SV*)get_av(name, 0); break;
    case '%': sv = (SV*)get_hv(name, 0); break;
    case '&': sv = (SV*)get_cv(name, 0); break;
    default:
        LEAVE;
        ENTER_PYTHON;
        PyErr_Format(PerlError, "Bad type spec '%c'", type);
        return NULL;
    }
    }
    else {
    LEAVE;
    ENTER_PYTHON;
    PyErr_Format(PerlError, "Missing identifier name");
    return NULL;
    }
    LEAVE;
    ENTER_PYTHON;
    return Py_BuildValue("i", (sv != 0));
}


static PyObject *
get_ref(self, args, keywds)
     PyObject *self;
     PyObject *args;
     PyObject *keywds;
{
    char *name;
    int create = 0;
    char type;
    SV* sv;
    PyObject* pyo;
    static char *kwlist[] = { "name", "create", NULL };
    dCTXP;

    ASSERT_LOCK_PYTHON;

    /* Establish 'name' and 'create' */
    if (!PyArg_ParseTupleAndKeywords(args, keywds, "s|i:perl.get_ref", kwlist,
                     &name, &create))
    return NULL;

    PERL_LOCK;
    SET_CUR_PERL;

    ENTER;
    RESTORE_UNSAFE_ENV;

    /* We assume that none of the stuff below can trigger perl code to
     * start running, so it is safe to hold both locks while doing this work.
     */

    if (isIDFIRST(*name)) {
    type = '&';
    }
    else {
    type = *name;
    name++;
    }

    if (*name) {
    switch (type) {
    case '$': sv =      get_sv(name, create); break;
    case '@': sv = (SV*)get_av(name, create); break;
    case '%': sv = (SV*)get_hv(name, create); break;
    case '&': sv = (SV*)get_cv(name, create); break;
    default:
        LEAVE;
        PERL_UNLOCK;
        PyErr_Format(PerlError, "Bad type spec '%c'", type);
        return NULL;
    }
    if (!sv) {
        LEAVE;
        PERL_UNLOCK;
        PyErr_Format(PerlError, "No perl object named %s", name);
        return NULL;
    }
    SvREFCNT_inc(sv);
    }
    else {
    switch (type) {
    case '$': sv =      newSV(0); break;
    case '@': sv = (SV*)newAV();  break;
    case '%': sv = (SV*)newHV();  break;
    default:
        LEAVE;
        PERL_UNLOCK;
        PyErr_Format(PerlError, "Bad type spec '%c'", type);
        return NULL;
    }
    }

    sv = newRV_noinc(sv);
    pyo = PySVRV_New(sv);
    SvREFCNT_dec(sv);  /* since PySVRV_New incremented it */
    LEAVE;

    PERL_UNLOCK;
    ASSERT_LOCK_PYTHON;

    return pyo;
}


static PyObject *
array(self, args, keywds)
     PyObject *self;
     PyObject *args;
     PyObject *keywds;
{
    PyObject *o;
    int n, i;
    AV* av;
    SV* sv;
    PyObject *pyo;  /* return value */
    dCTXP;

    ASSERT_LOCK_PYTHON;

    /* Takes any sequence object and turn it into an perl array */
    if (!PyArg_ParseTuple(args, "O:perl.array", &o))
    return NULL;

    if (!PySequence_Check(o)) {
    PyErr_SetString(PyExc_TypeError, "perl.array() argument must be a sequence");
    return NULL;
    }

    n = PySequence_Length(o);
    if (n < 0)
    return NULL;

    PERL_LOCK;
    SET_CUR_PERL;

    av = newAV();
    if (n) {
    av_extend(av, n-1);
    i = 0;

    for (i = 0;; i++) {
        PyObject *item;

        PERL_UNLOCK;
        item = PySequence_GetItem(o, i);
        PERL_LOCK;

        if (item) {
        SV* item_sv = pyo2sv(item);
        if (!av_store(av, i, item_sv)) {
            SvREFCNT_dec(item_sv);
            SvREFCNT_dec(av);
            PERL_UNLOCK;
            PyErr_SetString(PyExc_RuntimeError, "av_store failed");
            ASSERT_LOCK_PYTHON;
            return NULL;
        }
        }
        else {
        if (PyErr_ExceptionMatches(PyExc_IndexError)) {
            PyErr_Clear();
            break;
        }
        /* Something else bad happened */
        SvREFCNT_dec(av);
        PERL_UNLOCK;
        ASSERT_LOCK_PYTHON;
        return NULL;
        }
    }
    }

    sv = newRV_inc((SV*)av);
    pyo = PySVRV_New(sv);
    SvREFCNT_dec(sv);  /* since PySVRV_New incremented it */

    PERL_UNLOCK;

    ASSERT_LOCK_PYTHON;
    return pyo;
}

static PyMethodDef PerlMethods[] = {
    { "call",        call,        METH_VARARGS|METH_KEYWORDS},
    { "call_tuple",  call_tuple,  METH_VARARGS|METH_KEYWORDS},
    { "callm",       callm,       METH_VARARGS|METH_KEYWORDS},
    { "callm_tuple", callm_tuple, METH_VARARGS|METH_KEYWORDS},
#ifdef MULTI_PERL
    { "safecall",    safecall,    METH_VARARGS|METH_KEYWORDS},
#endif
    { "eval",        eval,        METH_VARARGS},
    { "require",     require,     METH_VARARGS},
    { "defined",     defined,     METH_VARARGS},
    { "get_ref",     get_ref,     METH_VARARGS|METH_KEYWORDS},
    { "array",       array,       METH_VARARGS},
    { NULL, NULL } /* Sentinel */
};

struct module_state {
        PyObject *error;
};

#if PY_MAJOR_VERSION >= 3
#define GETSTATE(m) ((struct module_state*)PyModule_GetState(m))
#else
#define GETSTATE(m) (&_state)
static struct module_state _state;
#endif

#if PY_MAJOR_VERSION >= 3
static int perl_traverse(PyObject *m, visitproc visit, void *arg) {
    Py_VISIT(GETSTATE(m)->error);
    return 0;
}

static int perl_clear(PyObject *m) {
    Py_CLEAR(GETSTATE(m)->error);
    return 0;
}

static struct PyModuleDef moduledef = {
        PyModuleDef_HEAD_INIT,
        "perl",
        NULL,
        sizeof(struct module_state),
        PerlMethods,
        NULL,
        perl_traverse,
        perl_clear,
        NULL
};

#define INITERROR return NULL

PyObject*
#else
#define INITERROR return
void
#endif

#ifdef DL_HACK
initperl2()
#else
initperl()
#endif
{
    PyObject *m, *d;
#ifndef MULTI_PERL
    char *embedding[] = { "", "-mPython::Object", "-e", "$| = 1;" };
#if !defined(USE_ITHREADS)
    PerlInterpreter *main_perl;
#endif

    main_perl = perl_alloc();
    perl_construct(main_perl);
    perl_parse(main_perl, xs_init, 4, embedding, NULL);
    perl_run(main_perl);

    fake_inittry();
#else
    thrd_ctx_init();
#endif /* MULTI_PERL */

#ifdef DO_THREAD
    lang_lock_init();
#endif

    /* XXX what need to be done if this stuff is used to embed python
     * in perl?  Should we also destruct my_perl?  A good idea if
     * python itself was embedded before we imported perl.
     */

#if PY_MAJOR_VERSION >= 3
    m = PyModule_Create(&moduledef);
#else
    m = Py_InitModule("perl", PerlMethods);
#endif
    if (m == NULL)
        INITERROR;
    d = PyModule_GetDict(m);
    PerlError = PyErr_NewException("perl.PerlError", NULL, NULL);
    PyDict_SetItemString(d, "PerlError", PerlError);
#ifdef MULTI_PERL
    PyDict_SetItemString(d, "MULTI_PERL", PyLong_FromLong(1));
#else
    PyDict_SetItemString(d, "MULTI_PERL", PyLong_FromLong(0));
#endif
#if PY_MAJOR_VERSION >= 3
    return m;
#endif
}