/*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*
*
* Implementation of the module '_rpy' and the 'Robj' type.
*
* $Id: rpymodule.c,v 1.11 2004/02/17 18:48:27 warnes Exp $
*
*/
#include "RPy.h"
#define NONAMELESSUNION
#include <stdio.h>
#include <string.h>
#ifdef _WIN32
#include <windows.h>
#include <Startup.h>
#endif
/* Global objects */
static SEXP get_item;
static SEXP set_item;
static SEXP length;
static SEXP aperm;
static PyObject *class_table;
static PyObject *proc_table;
static int default_mode;
static PyObject *r_lock;
PyObject *RPyExc_Exception;
/* Global interpreter */
PyInterpreterState *my_interp;
/* Signal whether R is running interactively */
int R_interact;
/* RPy namespace */
PyObject *rpy;
PyObject *rpy_dict;
#ifdef WITH_NUMERIC
static PyObject *Py_transpose;
#endif
/* Global list to protect R objects from garbage collection */
/* This is inspired in $R_SRC/src/main/memory.c */
static SEXP R_References;
static SEXP
RecursiveRelease(SEXP obj, SEXP list)
{
if (!isNull(list)) {
if (obj == CAR(list))
return CDR(list);
else
SETCDR(list, RecursiveRelease(obj, CDR(list)));
}
return list;
}
/* Robj methods. Following xxmodule.c from Python distro. */
static void
Robj_dealloc(RobjObject *self)
{
/* Remove the object from the list of protected objects */
R_References = RecursiveRelease(self->R_obj, R_References);
SET_SYMVALUE(install("R.References"), R_References);
PyObject_Del(self);
}
RobjObject *
Robj_new(SEXP robj, int conversion)
{
RobjObject *self;
self = PyObject_New(RobjObject, &Robj_Type);
if (!self)
return NULL;
if (!robj)
return NULL;
/* Protect the R object */
R_References = CONS(robj, R_References);
SET_SYMVALUE(install("R.References"), R_References);
self->R_obj = robj;
self->conversion = conversion;
return self;
}
#ifndef PRE_2_2
static PyObject *
Robj_tpnew(PyTypeObject *type, PyObject *args, PyObject *kwds)
{
PyObject *self;
self = type->tp_alloc(type, 0);
return self;
}
#endif
/* Type conversion routines. See documentation for details */
/* These are auxiliaries for a state machine for converting Python
list to the coarsest R vector type */
#define ANY_T 0
#define INT_T 1
#define FLOAT_T 2
#define COMPLEX_T 3
#define STRING_T 4
static int
type_to_int(PyObject *obj)
{
int r = 0;
if (PyInt_Check(obj))
r = INT_T;
if (PyFloat_Check(obj))
r = FLOAT_T;
if (PyComplex_Check(obj))
r = COMPLEX_T;
if (PyNumber_Check(obj))
return r;
if (PyString_Check(obj))
return STRING_T;
return ANY_T;
}
/* Make a R list or vector from a Python sequence */
static SEXP
seq_to_R(PyObject *obj)
{
PyObject *it;
SEXP robj, rit;
int i, len, state;
int fsm[5][5] = {{0, 0, 0, 0, 0},
{0, 1, 2, 3, 0},
{0, 2, 2, 3, 0},
{0, 3, 3, 3, 0},
{0, 0, 0, 0, 4}};
len = PySequence_Length(obj);
if (len == 0)
return R_NilValue;
PROTECT(robj = NEW_LIST(len));
state = -1;
for (i=0; i<len; i++) {
if (!(it = PySequence_GetItem(obj, i)))
goto exception;
if (state < 0)
state = type_to_int(it);
else
state = fsm[state][type_to_int(it)];
if (!(rit = to_Robj(it)))
goto exception;
SET_VECTOR_ELT(robj, i, rit);
Py_XDECREF(it);
}
if (state == INT_T)
robj = AS_INTEGER(robj);
if (state == FLOAT_T)
robj = AS_NUMERIC(robj);
if (state == COMPLEX_T)
robj = AS_COMPLEX(robj);
if (state == STRING_T)
robj = AS_CHARACTER(robj);
UNPROTECT(1);
return robj;
exception:
Py_XDECREF(it);
UNPROTECT(1);
return NULL;
}
/* Make a R named list or vector from a Python dictionary */
static SEXP
dict_to_R(PyObject *obj)
{
int len;
PyObject *keys, *values;
SEXP robj, names;
len = PyMapping_Length(obj);
if (len == 0)
return R_NilValue;
/* If 'keys' succeed and 'values' fails this leaks */
if (!(keys = PyMapping_Keys(obj)))
return NULL;
if (!(values = PyMapping_Values(obj)))
return NULL;
if (!(robj = seq_to_R(values)))
goto fail;
if (!(names = seq_to_R(keys)))
goto fail;
PROTECT(robj);
SET_NAMES(robj, names);
Py_DECREF(keys);
Py_DECREF(values);
UNPROTECT(1);
return robj;
fail:
Py_DECREF(keys);
Py_DECREF(values);
return NULL;
}
#ifdef WITH_NUMERIC
/* Convert a Numeric array to a R array */
SEXP
to_Rarray(PyObject *o)
{
PyObject *pytl, *nobj;
PyArrayObject *obj;
SEXP Rdims, tRdims, Rarray, e;
int *dims, i;
long tl;
obj = (PyArrayObject *)o;
dims = obj->dimensions;
tl = 1;
PROTECT(Rdims = allocVector(INTSXP, obj->nd));
PROTECT(tRdims = allocVector(INTSXP, obj->nd));
for (i=0; i<obj->nd; i++) {
if (dims[i] == 0) {
UNPROTECT(2);
return R_NilValue;
}
tl *= dims[i];
INTEGER(Rdims)[i] = dims[(obj->nd)-i-1];
INTEGER(tRdims)[i] = (obj->nd)-i;
}
/* if (!(pytl = PyList_New(1))) */
/* goto exception; */
/* if (!(it = PyInt_FromLong(tl))) */
/* goto exception; */
/* if (PyList_SetItem(pytl, 0, it) < 0) */
/* goto exception; */
pytl = Py_BuildValue("[i]", tl);
obj = (PyArrayObject *)PyArray_ContiguousFromObject((PyObject *)obj,
PyArray_NOTYPE, 0, 0);
nobj = PyArray_Reshape(obj, pytl);
Py_XDECREF(pytl);
Py_XDECREF(obj);
if (!nobj)
goto exception;
PROTECT(Rarray = seq_to_R(nobj));
Py_XDECREF(nobj);
SET_DIM(Rarray, Rdims);
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, aperm);
SETCAR(CDR(e), Rarray);
SETCAR(CDR(CDR(e)), tRdims);
PROTECT(Rarray = do_eval_expr(e));
UNPROTECT(5);
return Rarray;
exception:
UNPROTECT(2);
return NULL;
}
#endif
/* Convert a Python object to a R object. An Robj is passed w/o
* modifications, an object which provides a '.as_r()' method, is
* passed as the result of that method */
SEXP
to_Robj(PyObject *obj)
{
SEXP robj;
Py_complex c;
PyObject *to_r_meth;
int do_decref = 0;
if (!obj)
return NULL;
if (obj == Py_None) {
return R_NilValue;
}
to_r_meth = PyObject_GetAttrString(obj, "as_r");
if (to_r_meth) {
obj = PyObject_CallObject(to_r_meth, NULL);
Py_DECREF(to_r_meth);
if (!obj)
return NULL;
do_decref = 1;
}
PyErr_Clear();
if (Robj_Check(obj)) {
PROTECT(robj = ((RobjObject *)obj)->R_obj);
} else if (PyInt_Check(obj)) {
PROTECT(robj = NEW_INTEGER(1));
INTEGER_DATA(robj)[0] = PyInt_AsLong(obj);
} else if (PyFloat_Check(obj)) {
PROTECT(robj = NEW_NUMERIC(1));
NUMERIC_DATA(robj)[0] = PyFloat_AsDouble(obj);
} else if (PyComplex_Check(obj)) {
PROTECT(robj = NEW_COMPLEX(1));
c = PyComplex_AsCComplex(obj);
COMPLEX_DATA(robj)[0].r = c.real;
COMPLEX_DATA(robj)[0].i = c.imag;
} else if (PyString_Check(obj)) {
PROTECT(robj = NEW_STRING(1));
SET_STRING_ELT(robj, 0, COPY_TO_USER_STRING(PyString_AsString(obj)));
#ifdef WITH_NUMERIC
} else if (PyArray_Check(obj)) {
PROTECT(robj = to_Rarray(obj));
#endif
} else if ((PySequence_Check(obj)) &&
(PySequence_Size(obj) >= 0)) {
PROTECT(robj = seq_to_R(obj)); /* No labels */
} else if ((PyMapping_Check(obj)) &&
(PyMapping_Size(obj) >= 0)) {
PROTECT(robj = dict_to_R(obj));
} else {
PyErr_Format(RPyExc_Exception, "cannot convert from type '%s'",
obj->ob_type->tp_name);
PROTECT(robj = NULL); /* Protected to avoid stack inbalance */
}
if (do_decref) {
Py_DECREF(obj);
}
UNPROTECT(1);
return robj;
}
/* Convert a R named vector or list to a Python dictionary */
static PyObject *
to_PyDict(PyObject *obj, SEXP names)
{
int len, i;
PyObject *it, *dict;
char *name;
if ((len = PySequence_Length(obj)) < 0)
return NULL;
dict = PyDict_New();
for (i=0; i<len; i++) {
if (!(it = PyList_GetItem(obj, i)))
return NULL;
name = CHAR(STRING_ELT(names, i));
if ((PyDict_SetItemString(dict, name, it)) < 0) {
return NULL;
}
}
return dict;
}
/* We need to transpose the list because R makes array by the
* fastest index */
static PyObject *
ltranspose(PyObject *list, int *dims, int *strides,
int pos, int shift, int len)
{
PyObject *nl, *it;
int i;
if (!(nl = PyList_New(dims[pos])))
return NULL;
if (pos == len-1) {
for (i=0; i<dims[pos]; i++) {
if (!(it = PyList_GetItem(list, i*strides[pos]+shift)))
return NULL;
Py_INCREF(it);
if (PyList_SetItem(nl, i, it) < 0)
return NULL;
}
return nl;
}
for (i=0; i<dims[pos]; i++) {
if (!(it = ltranspose(list, dims, strides, pos+1, shift, len)))
return NULL;
if (PyList_SetItem(nl, i, it) < 0)
return NULL;
shift += strides[pos];
}
return nl;
}
/* Convert a Python list to a Python array (in the form of
* list of lists of ...) */
PyObject *
to_PyArray(PyObject *obj, int *dims, int l)
{
PyObject *list;
int i, c, *strides;
strides = (int *)PyMem_Malloc(l*sizeof(int));
if (!strides)
PyErr_NoMemory();
c = 1;
for (i=0; i<l; i++) {
strides[i] = c;
c *= dims[i];
}
list = ltranspose(obj, dims, strides, 0, 0, l);
PyMem_Free(strides);
return list;
}
/* Convert a Python sequence to a Numeric array */
#ifdef WITH_NUMERIC
PyObject *
to_PyNumericArray(PyObject *seq, SEXP dim)
{
PyObject *array, *ret, *dims, *it;
int l, i, j;
array = PyArray_ContiguousFromObject(seq, PyArray_NOTYPE, 0,0);
if (!array)
return NULL;
l = GET_LENGTH(dim);
dims = PyList_New(l);
for (i=0; i<l; i++) {
j = INTEGER(dim)[l-i-1];
if (j == 0) {
Py_DECREF(array);
Py_DECREF(dims);
Py_INCREF(Py_None);
return Py_None;
}
if (!(it = PyInt_FromLong(j)))
return NULL;
if (PyList_SetItem(dims, i, it) < 0)
return NULL;
}
ret = PyArray_Reshape((PyArrayObject *)array, dims);
Py_DECREF(array);
Py_DECREF(dims);
if (!ret)
return NULL;
array = PyObject_CallFunction(Py_transpose, "O", ret);
Py_XDECREF(ret);
return array;
}
#endif
/* Convert a R object to a 'basic' Python object (mode 1) */
int
to_Pyobj_basic(SEXP robj, PyObject **obj)
{
PyObject *it, *tmp;
SEXP names, dim;
int len, *integers, i;
char *strings, *thislevel;
double *reals;
Rcomplex *complexes;
#ifdef WITH_NUMERIC
PyObject *array;
#endif
if (!robj)
return -1; /* error */
if (robj == R_NilValue) {
Py_INCREF(Py_None);
*obj = Py_None;
return 1; /* succeed */
}
len = GET_LENGTH(robj);
tmp = PyList_New(len);
for (i=0; i<len; i++) {
switch (TYPEOF(robj)) {
case LGLSXP:
case INTSXP:
integers = INTEGER(robj);
if(isFactor(robj)) {
thislevel = CHAR(STRING_ELT(GET_LEVELS(robj), integers[i]-1));
if (!(it = PyString_FromString(thislevel)))
return -1;
}
else {
if (!(it = PyInt_FromLong(integers[i])))
return -1;
}
break;
case REALSXP:
reals = REAL(robj);
if (!(it = PyFloat_FromDouble(reals[i])))
return -1;
break;
case CPLXSXP:
complexes = COMPLEX(robj);
if (!(it = PyComplex_FromDoubles(complexes[i].r,
complexes[i].i)))
return -1;
break;
case STRSXP:
strings = CHAR(STRING_ELT(robj, i));
if (!(it = PyString_FromString(strings)))
return -1;
break;
case LISTSXP:
if (!(it = to_Pyobj_with_mode(elt(robj, i), 1)))
return -1;
break;
case VECSXP:
if (!(it = to_Pyobj_with_mode(VECTOR_ELT(robj, i), 1)))
return -1;
break;
default:
Py_DECREF(tmp);
return 0; /* failed */
}
if (PyList_SetItem(tmp, i, it) < 0)
return -1;
}
dim = GET_DIM(robj);
if (dim != R_NilValue) {
#ifdef WITH_NUMERIC
array = to_PyNumericArray(tmp, dim);
if (array) { /* If the conversion to Numeric succeed.. */
*obj = array; /* we are done */
Py_DECREF(tmp);
return 1;
}
PyErr_Clear();
#endif
len = GET_LENGTH(dim);
*obj = to_PyArray(tmp, INTEGER(dim), len);
Py_DECREF(tmp);
return 1;
}
names = GET_NAMES(robj);
if (names == R_NilValue)
if (len == 1) {
*obj = PyList_GetItem(tmp, 0);
Py_XINCREF(*obj);
Py_DECREF(tmp);
}
else {
*obj = tmp;
}
else {
*obj = to_PyDict(tmp, names);
Py_DECREF(tmp);
}
return 1;
}
/* Search a conversion procedure from the class attribute */
PyObject *
from_class_table(SEXP robj)
{
SEXP rclass;
PyObject *lkey, *key, *fun;
int i;
PROTECT(rclass = GET_CLASS(robj));
fun = NULL;
if (rclass != R_NilValue) {
lkey = to_Pyobj_with_mode(rclass, 1);
key = PyList_AsTuple(lkey);
if (key) {
Py_DECREF(lkey);
} else {
PyErr_Clear();
key = lkey;
}
fun = PyDict_GetItem(class_table, key);
Py_DECREF(key);
if (!fun) {
PyErr_Clear();
for (i=0; i<GET_LENGTH(rclass); i++)
if ((fun = PyDict_GetItemString(class_table,
CHAR(STRING_ELT(rclass, i)))))
break;
}
else
Py_INCREF(fun);
}
UNPROTECT(1);
return fun;
}
/* Search a conversion procedure from the proc table */
int
from_proc_table(SEXP robj, PyObject **fun)
{
PyObject *procs, *proc, *funs, *res, *obj;
int i, l, k, error;
proc = NULL;
procs = PyDict_Keys(proc_table);
funs = PyDict_Values(proc_table);
l = PyMapping_Size(proc_table);
obj = (PyObject *)Robj_new(robj, TOP_MODE);
error = 0;
for (i=0; i<l; i++) {
proc = PyList_GetItem(procs, i);
Py_XINCREF(proc);
res = PyObject_CallFunction(proc, "O", obj);
if (!res) {
error = -1;
break;
}
k = PyObject_IsTrue(res);
Py_DECREF(res);
if (k) {
*fun = PyList_GetItem(funs, i);
Py_XINCREF(*fun);
break;
}
}
Py_DECREF(obj);
Py_XDECREF(proc);
Py_XDECREF(procs);
Py_XDECREF(funs);
return error;
}
int
to_Pyobj_proc(SEXP robj, PyObject **obj)
{
PyObject *fun=NULL, *tmp;
int i;
i = from_proc_table(robj, &fun);
if (i < 0)
return -1; /* an error occurred */
if (!fun)
return 0; /* conversion failed */
tmp = (PyObject *)Robj_new(robj, TOP_MODE);
*obj = PyObject_CallFunction(fun, "O", tmp);
Py_DECREF(fun);
Py_DECREF(tmp);
return 1; /* conversion succeed */
}
/* Convert a Robj to a Python object via the class table (mode 2) */
/* See the docs for conversion rules */
int
to_Pyobj_class(SEXP robj, PyObject **obj)
{
PyObject *fun, *tmp;
fun = from_class_table(robj);
if (!fun)
return 0; /* conversion failed */
tmp = (PyObject *)Robj_new(robj, TOP_MODE);
*obj = PyObject_CallFunction(fun, "O", tmp);
Py_DECREF(fun);
Py_DECREF(tmp);
return 1; /* conversion succeed */
}
PyObject *
to_Pyobj_with_mode(SEXP robj, int mode)
{
PyObject *obj;
int i;
switch (mode) {
case PROC_CONVERSION:
i = to_Pyobj_proc(robj, &obj);
if (i<0) return NULL;
if (i==1) break;
case CLASS_CONVERSION:
i = to_Pyobj_class(robj, &obj);
if (i<0) return NULL;
if (i==1) break;
case BASIC_CONVERSION:
i = to_Pyobj_basic(robj, &obj);
if (i<0) return NULL;
if (i==1) break;
default:
obj = (PyObject *)Robj_new(robj, TOP_MODE);
}
return obj;
}
/* Convert a tuple to arguments for a R function */
int
make_args(int largs, PyObject *args, SEXP *e)
{
SEXP r;
int i;
for (i=0; i<largs; i++) {
r = to_Robj(PyTuple_GetItem(args, i));
if (!r)
return 0;
SETCAR(*e, r);
*e = CDR(*e);
}
return 1;
}
/* Implements the conversion rules for names. See the 'USING' file. We
don't care about '<-' because it doesn't appear in keywords. */
char *
dotter(char *s)
{
char *r, *res;
int l;
l = strlen(s);
r = (char *)PyMem_Malloc(l+1);
if (!r) {
PyErr_NoMemory();
return NULL;
}
res = strcpy(r, s);
if ((l > 1) && (res[l-1] == '_') && (res[l-2] != '_'))
res[l-1]=0;
while ((r=strchr(r, '_')))
*r = '.';
return res;
}
/* Convert a dict to keywords arguments for a R function */
int
make_kwds(int lkwds, PyObject *kwds, SEXP *e)
{
SEXP r;
char *s;
int i;
PyObject *citems=NULL, *it;
if (kwds) {
citems = PyMapping_Items(kwds);
}
for (i=0; i<lkwds; i++) {
it = PySequence_GetItem(citems, i);
r = to_Robj(PyTuple_GetItem(it, 1));
Py_DECREF(it);
if (!r)
goto fail;
SETCAR(*e, r);
s = dotter(PyString_AsString(PyTuple_GetItem(it, 0)));
if (!s)
goto fail;
SET_TAG(*e, Rf_install(s));
PyMem_Free(s);
*e = CDR(*e);
}
Py_XDECREF(citems);
return 1;
fail:
Py_XDECREF(citems);
return 0;
}
/* This is the method to call when invoking an 'Robj' */
static PyObject *
Robj_call(PyObject *self, PyObject *args, PyObject *kwds)
{
SEXP exp, e, res;
int largs, lkwds, conv;
PyObject *obj;
largs = lkwds = 0;
if (args)
largs = PyObject_Length(args);
if (kwds)
lkwds = PyObject_Length(kwds);
if ((largs<0) || (lkwds<0))
return NULL;
/* A SEXP with the function to call and the arguments and keywords. */
PROTECT(exp = allocVector(LANGSXP, largs+lkwds+1));
e = exp;
SETCAR(e, ((RobjObject *)self)->R_obj);
e = CDR(e);
if (!make_args(largs, args, &e)) {
UNPROTECT(1);
return NULL;
}
if (!make_kwds(lkwds, kwds, &e)) {
UNPROTECT(1);
return NULL;
}
PROTECT(res = do_eval_expr(exp));
if (!res) {
UNPROTECT(2);
return NULL;
}
if (default_mode < 0)
conv = ((RobjObject *)self)->conversion;
else
conv = default_mode;
obj = to_Pyobj_with_mode(res, conv);
UNPROTECT(2);
return obj;
}
/* Convert a sequence of (name, value) pairs to arguments to an R
function call */
int
make_argl(int largl, PyObject *argl, SEXP *e)
{
SEXP rvalue;
char *name;
int i;
PyObject *it, *nobj, *value;
if( !PySequence_Check(argl) ) goto fail_arg;
for (i=0; i<largl; i++) {
it = PySequence_GetItem(argl, i);
if(!it) goto fail_arg;
if( PySequence_Size(it) != 2 )
{
Py_DECREF(it);
goto fail_arg;
}
nobj = PySequence_GetItem(it, 0);
/* Name can be a string, None, or NULL, error otherwise. */
if (PyString_Check(nobj))
{
name = dotter(PyString_AsString(nobj));
Py_DECREF(nobj);
}
else if (nobj == Py_None)
{
name = NULL;
Py_DECREF(nobj);
}
else if(nobj == NULL)
{
name = NULL;
}
else
{
Py_DECREF(nobj);
goto fail_arg;
}
/* Value can be anything. */
value = PySequence_GetItem(it, 1);
if (!value)
{
PyMem_Free(name);
goto fail;
}
rvalue = to_Robj(value);
Py_DECREF(value);
Py_DECREF(it);
/* Add parameter value to call */
SETCAR(*e, rvalue);
/* Add name (if present) */
if (name && strlen(name)>0)
{
SET_TAG(*e, Rf_install(name));
PyMem_Free(name);
}
/* Move index to new end of call */
*e = CDR(*e);
}
return 1;
fail_arg:
PyErr_SetString(PyExc_ValueError,
"Argument must be a sequence of (\"name\", value) pairs.\n");
fail:
return 0;
}
/* Methods for the 'Robj' type */
/* Explicitly call an R object with a list containing (name, value) *
* argument pairs. 'name' can be None or '' to provide unnamed
* arguments. This function is necessary when the *order* of named
* arguments needs to be preserved.
*/
static PyObject *
Robj_lcall(PyObject *self, PyObject *args)
{
SEXP exp, e, res;
int largs, largl, conv;
PyObject *obj, *argl;
/* Check arguments, there should be *exactly one* unnamed sequence. */
largs = 0;
if (args)
largs = PyObject_Length(args);
if (largs<0)
return NULL;
if(largs != 1 || !PySequence_Check(args) )
{
PyErr_SetString(PyExc_ValueError,
"Argument must be a sequence of (\"name\", value) pairs.\n");
return NULL;
}
// extract our one argument
argl = PySequence_GetItem(args, 0);
Py_DECREF(args);
largl = 0;
if (argl)
largl = PyObject_Length(argl);
if (largl<0)
return NULL;
// A SEXP with the function to call and the arguments
PROTECT(exp = allocVector(LANGSXP, largl+1));
e = exp;
SETCAR(e, ((RobjObject *)self)->R_obj);
e = CDR(e);
// Add the arguments to the SEXP
if (!make_argl(largl, argl, &e)) {
UNPROTECT(1);
return NULL;
}
// Evaluate
PROTECT(res = do_eval_expr(exp));
if (!res) {
UNPROTECT(2);
return NULL;
}
// Convert
if (default_mode < 0)
conv = ((RobjObject *)self)->conversion;
else
conv = default_mode;
obj = to_Pyobj_with_mode(res, conv);
UNPROTECT(2);
// Return
return obj;
}
/* Without args return the value of the conversion flag. With an
argument set the conversion flag to the truth value of the argument. */
static PyObject *
Robj_autoconvert(PyObject *self, PyObject *args, PyObject *kwds)
{
PyObject *obj;
int conversion=-2;
static char *kwlist[] = {"val", 0};
if (!PyArg_ParseTupleAndKeywords(args, kwds, "|i:autoconvert", kwlist,
&conversion))
return NULL;
if (conversion > 3) {
PyErr_SetString(PyExc_ValueError, "wrong mode");
return NULL;
}
if (conversion == -2) {
obj = PyInt_FromLong((long)((RobjObject *)self)->conversion);
} else {
((RobjObject *)self)->conversion = conversion;
obj = Py_None;
Py_XINCREF(obj);
}
return obj;
}
static PyObject *
Robj_as_py(PyObject *self, PyObject *args, PyObject *kwds)
{
PyObject *obj;
static char *kwlist[] = {"mode", 0};
int conv=default_mode;
if (!PyArg_ParseTupleAndKeywords(args, kwds, "|i:as_py", kwlist,
&conv))
return NULL;
if (conv <= -2 || conv > TOP_MODE) {
PyErr_SetString(PyExc_ValueError, "wrong mode");
return NULL;
}
if (conv < 0)
conv = TOP_MODE;
obj = to_Pyobj_with_mode(((RobjObject *)self)->R_obj, conv);
return obj;
}
static PyMethodDef Robj_methods[] = {
{"autoconvert", (PyCFunction)Robj_autoconvert, METH_VARARGS|METH_KEYWORDS},
{"local_mode", (PyCFunction)Robj_autoconvert, METH_VARARGS|METH_KEYWORDS},
{"as_py", (PyCFunction)Robj_as_py, METH_VARARGS|METH_KEYWORDS},
{"lcall", (PyCFunction)Robj_lcall, METH_VARARGS},
{NULL, NULL} /* sentinel */
};
/* Sequence protocol implementation */
/* len(a) */
static int
Robj_len(PyObject *a)
{
SEXP e, robj;
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, length);
SETCAR(CDR(e), ((RobjObject *)a)->R_obj);
if (!(robj = do_eval_expr(e))) {
UNPROTECT(1);
return -1;
}
UNPROTECT(1);
return INTEGER_DATA(robj)[0];
}
/* a[i] = v */
static int
Robj_ass_item(PyObject *a, int i, PyObject *v)
{
SEXP e, ri, robj;
PROTECT(e = allocVector(LANGSXP, 4));
ri = NEW_INTEGER(1);
INTEGER_DATA(ri)[0] = i+1;
SETCAR(e, set_item);
SETCAR(CDR(e), ((RobjObject *)a)->R_obj);
SETCAR(CDR(CDR(e)), ri);
SETCAR(CDR(CDR(CDR(e))), to_Robj(v));
if (!(robj = do_eval_expr(e))) {
UNPROTECT(1);
return -1;
}
((RobjObject *)a)->R_obj = robj;
UNPROTECT(1);
return 0;
}
/* a[i] */
static PyObject *
Robj_item(PyObject *a, int i)
{
SEXP ri, robj, e;
PyObject *obj;
int len, c;
if ((len = Robj_len(a)) < 0)
return NULL;
if (i >= len || i < 0) {
PyErr_SetString(PyExc_IndexError, "R object index out of range");
return NULL;
}
PROTECT(ri = NEW_INTEGER(1));
INTEGER_DATA(ri)[0] = i+1;
PROTECT(e = allocVector(LANGSXP, 3));
SETCAR(e, get_item);
SETCAR(CDR(e), ((RobjObject *)a)->R_obj);
SETCAR(CDR(CDR(e)), ri);
if (!(robj = do_eval_expr(e))) {
UNPROTECT(2);
return NULL;
}
UNPROTECT(2);
/* If there is a default mode, use it; otherwise, use the top mode. */
if (default_mode < 0)
c = 3;
else
c = default_mode;
obj = to_Pyobj_with_mode(robj, c);
return obj;
}
/* We should implement sq_slice, sq_contains ... */
static PySequenceMethods Robj_as_sequence = {
(inquiry)Robj_len, /* sq_length */
0, /* sq_concat */
0, /* sq_repeat */
(intargfunc)Robj_item, /* sq_item */
0, /* sq_slice */
(intobjargproc)Robj_ass_item, /* sq_ass_item */
0, /* sq_ass_slice */
0, /* sq_contains */
};
/* The 'Robj' table. When compiled under Python 2.2, the type 'Robj'
is subclassable. */
#if defined(PRE_2_2) || defined(_WIN32)
static PyObject *
Robj_getattr(RobjObject *self, char *name)
{
return Py_FindMethod(Robj_methods, (PyObject *)self, name);
}
#endif
PyTypeObject Robj_Type = {
/* The ob_type field must be initialized in the module init function
* to be portable to Windows without using C++. */
#if defined(PRE_2_2)
PyObject_HEAD_INIT(NULL)
#else
PyObject_HEAD_INIT(&PyType_Type)
#endif
0, /*ob_size*/
"Robj", /*tp_name*/
sizeof(RobjObject), /*tp_basicsize*/
0, /*tp_itemsize*/
/* methods */
(destructor)Robj_dealloc, /*tp_dealloc*/
0, /*tp_print*/
#ifdef PRE_2_2
(getattrfunc)Robj_getattr,
#else
0,
#endif
0,
0, /*tp_compare*/
0, /*tp_repr*/
0, /*tp_as_number*/
&Robj_as_sequence, /*tp_as_sequence*/
0, /*tp_as_mapping*/
0, /*tp_hash*/
(ternaryfunc)Robj_call, /*tp_call*/
0, /*tp_str*/
#if defined(PRE_2_2) || defined(_WIN32)
0,
#else
PyObject_GenericGetAttr, /*tp_getattro*/
#endif
0, /*tp_setattro*/
0, /*tp_as_buffer*/
#ifdef PRE_2_2
0,
#else
Py_TPFLAGS_DEFAULT | Py_TPFLAGS_BASETYPE, /*tp_flags*/
#endif
0, /*tp_doc*/
0, /*tp_traverse*/
#ifndef PRE_2_2
0, /*tp_clear*/
0, /*tp_richcompare*/
0, /*tp_weaklistoffset*/
0, /*tp_iter*/
0, /*tp_iternext*/
Robj_methods, /*tp_methods*/
0, /*tp_members*/
0, /*tp_getset*/
0, /*tp_base*/
0, /*tp_dict*/
0, /*tp_descr_get*/
0, /*tp_descr_set*/
0, /*tp_dictoffset*/
0, /*tp_init*/
#ifdef _WIN32
0, /*tp_alloc*/
#else
PyType_GenericAlloc, /*tp_alloc*/
#endif
Robj_tpnew, /*tp_new*/
0, /*tp_free*/
0, /*tp_is_gc*/
#endif
};
/* Module functions */
/* Obtain an R object via its name. 'autoconvert' is the keyword to
set the autoconversion flag. */
static PyObject *
get(PyObject *self, PyObject *args, PyObject *kwds)
{
char *obj_str;
int conversion=TOP_MODE;
SEXP robj;
static char *kwlist[] = {"name", "autoconvert", 0};
if (!PyArg_ParseTupleAndKeywords(args, kwds, "s|i:get", kwlist,
&obj_str, &conversion))
return NULL;
robj = get_from_name(obj_str);
if (!robj)
return NULL;
return (PyObject *)Robj_new(robj, conversion);
}
static PyObject *
set_mode(PyObject *self, PyObject *args)
{
int i=-1;
if (!PyArg_ParseTuple(args, "i:set_mode", &i))
return NULL;
if (i<-1 || i>TOP_MODE) {
PyErr_SetString(PyExc_ValueError, "wrong mode");
return NULL;
}
default_mode = i;
Py_INCREF(Py_None);
return Py_None;
}
static PyObject *
get_mode(PyObject *self, PyObject *args)
{
if (!PyArg_ParseTuple(args, ":get_mode"))
return NULL;
return PyInt_FromLong(default_mode);
}
static PyObject *
r_events(PyObject *self, PyObject *args, PyObject *kwds)
#ifdef _WIN32
{
return NULL;
}
#else
{
fd_set *what;
int usec=10000;
static char *kwlist[] = {"usec", 0};
if (!PyArg_ParseTupleAndKeywords(args, kwds, "|i:r_events",
kwlist, &usec))
return NULL;
if (R_interact) {
Py_BEGIN_ALLOW_THREADS
what = R_checkActivity(usec, 0);
R_runHandlers(R_InputHandlers, what);
Py_END_ALLOW_THREADS
}
Py_INCREF(Py_None);
return Py_None;
}
#endif
void
stop_events(void)
{
PyObject *o;
if (!rpy_dict)
return;
if (!r_lock)
r_lock = PyDict_GetItemString(rpy_dict, "_r_lock");
o = PyObject_CallMethod(r_lock, "acquire", NULL);
Py_XDECREF(o);
}
void
start_events(void)
{
PyObject *o;
if (!rpy_dict)
return;
if (!r_lock)
r_lock = PyDict_GetItemString(rpy_dict, "_r_lock");
o = PyObject_CallMethod(r_lock, "release", NULL);
Py_XDECREF(o);
}
/* List of functions defined in the module */
static PyMethodDef rpy_methods[] = {
{"get", (PyCFunction)get, METH_VARARGS | METH_KEYWORDS},
{"set_mode", (PyCFunction)set_mode, METH_VARARGS},
{"get_mode", (PyCFunction)get_mode, METH_VARARGS},
{"set_output", (PyCFunction)set_output, METH_VARARGS},
{"set_input", (PyCFunction)set_input, METH_VARARGS},
{"set_showfiles", (PyCFunction)set_showfiles, METH_VARARGS},
{"get_output", (PyCFunction)get_output, METH_VARARGS},
{"get_input", (PyCFunction)get_input, METH_VARARGS},
{"get_showfiles", (PyCFunction)get_showfiles, METH_VARARGS},
{"r_events", (PyCFunction)r_events, METH_VARARGS | METH_KEYWORDS},
{NULL, NULL} /* sentinel */
};
#ifdef _WIN32
static void char_message( char *s )
{
if (!s) return;
R_WriteConsole(s, strlen(s));
}
static int char_yesnocancel( char *s )
{
return 1;
}
static void
RPyBusy( int which )
{
/* set a busy cursor ... in which = 1, unset if which = 0 */
}
static void
RPyDoNothing( void )
{
}
/* initialise embedded R; based on rproxy_impl.c from the R distribution */
static void
init_embedded_win32( void ) {
structRstart rp;
Rstart Rp = &rp;
char Rversion[25];
static char RUser[MAX_PATH], RHome[MAX_PATH]; /* BR */
char *p;
snprintf( Rversion, 25, "%s.%s", R_MAJOR, R_MINOR );
if( strcmp( getDLLVersion(), Rversion ) != 0 ) {
PyErr_SetString( PyExc_ImportError, "R.DLL version does not match" );
}
R_DefParams(Rp);
/* first, try process-local environment space (CRT) */
if ( getenv( "R_HOME" ) ) {
strcpy( RHome, getenv("R_HOME") );
}
else {
/* get variable from process-local environment space (Windows API) */
if ( GetEnvironmentVariable( "R_HOME", RHome, sizeof( RHome ) ) == 0) {
/* not found, look in the registry */
LONG rc;
HKEY hkey;
DWORD keytype = REG_SZ;
DWORD cbData = sizeof( RHome );
rc = RegOpenKeyEx (HKEY_LOCAL_MACHINE, "Software\\R-core\\R", 0,
KEY_READ, &hkey);
if (rc == ERROR_SUCCESS) {
rc = RegQueryValueEx (hkey, "InstallPath", 0, &keytype,
(LPBYTE)RHome, &cbData);
RegCloseKey (hkey);
}
if (rc == ERROR_SUCCESS) {
/* set R_HOME */
char *buf = (char *) malloc( (strlen( RHome ) + 8) * sizeof( char ));
strcpy( buf, "R_HOME=");
strcat( buf, RHome );
putenv( buf );
}
else {
/* not found, fall back to getRHOME() */
strcpy(RHome, getRHOME());
}
}
}
/* set R_HOME */
Rp->rhome = RHome;
/*
* try R_USER then HOME then working directory
*/
if (getenv("R_USER")) {
strcpy(RUser, getenv("R_USER")); /* BR */
} else if (getenv("HOME")) {
strcpy(RUser, getenv("HOME"));
} else if (getenv("HOMEDRIVE")) { /* BR */
strcpy(RUser, getenv("HOMEDRIVE"));
strcat(RUser, getenv("HOMEPATH"));
} else
GetCurrentDirectory(MAX_PATH, RUser);
p = RUser + (strlen(RUser) - 1); /* BR */
if (*p == '/' || *p == '\\') *p = '\0'; /* BR */
Rp->home = RUser;
Rp->CharacterMode = LinkDLL;
Rp->ReadConsole = (blah1) R_ReadConsole;
Rp->WriteConsole = (blah2) R_WriteConsole;
Rp->CallBack = (blah3) RPyDoNothing;
Rp->message = char_message;
Rp->yesnocancel = char_yesnocancel;
Rp->busy = RPyBusy;
Rp->R_Quiet = 1;
/* run as "interactive", so server won't be killed after an error */
Rp->R_Slave = Rp->R_Verbose = 0;
Rp->R_Interactive = 1;
Rp->RestoreAction = 0; /* no restore */
Rp->SaveAction = 2; /* no save */
Rp->CommandLineArgs = NULL;
Rp->NumCommandLineArgs = 0;
R_SetParams(Rp); /* so R_ShowMessage is set */
R_SizeFromEnv(Rp);
R_SetParams(Rp);
setup_term_ui();
setup_Rmainloop();
}
#endif
/* Initialization function for the module */
DL_EXPORT(void)
init_rpy(void)
{
PyObject *m, *d;
char *defaultargv[] = {"rpy", "-q", "--vanilla"};
PyOS_sighandler_t old_int;
#ifndef _WIN32
PyOS_sighandler_t old_usr1, old_usr2;
#endif
SEXP interact;
#ifdef WITH_NUMERIC
PyObject *multiarray, *dict;
#endif
Robj_Type.ob_type = &PyType_Type;
#if defined( _WIN32 ) && ! defined( PRE_2_2 )
Robj_Type.tp_getattro = PyObject_GenericGetAttr;
Robj_Type.tp_alloc = PyType_GenericAlloc;
#endif
m = Py_InitModule("_rpy", rpy_methods);
#ifdef WITH_NUMERIC
import_array();
multiarray = PyImport_ImportModule("multiarray");
if (multiarray) {
dict = PyModule_GetDict(multiarray);
if (dict)
Py_transpose = PyDict_GetItemString(dict, "transpose");
}
#endif
d = PyModule_GetDict(m);
/* Save this interpreter */
PyEval_InitThreads();
my_interp = PyThreadState_Get()->interp;
/* Save the Python signal handlers. If R inserts its handlers, we
cannot return to the Python interpreter. */
old_int = PyOS_getsig(SIGINT);
python_sigint = old_int;
#ifndef _WIN32
old_usr1 = PyOS_getsig(SIGUSR1);
old_usr2 = PyOS_getsig(SIGUSR2);
#endif
#ifdef _WIN32
init_embedded_win32();
#else
// envvar c-def
setenv("R_HOME", R_HOME, 1);
Rf_initEmbeddedR( sizeof(defaultargv) / sizeof(defaultargv[0]),
defaultargv);
#endif
/* Restore Python handlers */
PyOS_setsig(SIGINT, old_int);
#ifndef _WIN32
PyOS_setsig(SIGUSR1, old_usr1);
PyOS_setsig(SIGUSR2, old_usr2);
#endif
/* The new exception */
RPyExc_Exception = PyErr_NewException("rpy.RException", NULL, NULL);
if (RPyExc_Exception)
PyDict_SetItemString(d, "RException", RPyExc_Exception);
// The conversion table
class_table = PyDict_New();
proc_table = PyDict_New();
PyDict_SetItemString(d, "__class_table__", class_table);
PyDict_SetItemString(d, "__proc_table__", proc_table);
// The globals R objects for the sequence protocol
get_item = get_from_name("[");
set_item = get_from_name("[<-");
length = get_from_name("length");
// Function to transpose arrays
aperm = get_from_name("aperm");
// Initialize the list of protected objects
R_References = R_NilValue;
SET_SYMVALUE(install("R.References"), R_References);
// Initialize the default mode
default_mode = -1;
// Check whether R is interactive or no
interact = do_eval_fun("interactive");
R_interact = INTEGER(interact)[0];
// I/O routines
init_io_routines(d);
rpy = PyImport_ImportModule("rpy");
rpy_dict = PyModule_GetDict(rpy);
// r_lock = PyDict_GetItemString(rpy_dict, "_r_lock");
// PyObject_Print(r_lock, stderr, Py_PRINT_RAW);
r_lock = NULL;
}
syntax highlighted by Code2HTML, v. 0.9.1