/**
Convert R object into either a function or the address of a C routine.
For a C routine, the caller can specify the name of the typedef which is
checked using the TAG for the external pointer.
*/
void *
Rfrom_Callbable(SEXP obj, const char * const TypeDefName, CallableType *type)
{
/* If TypeDefName is NULL, we don't bother checking*/
if(TYPEOF(obj) == EXTPTRSXP) {
if(TypeDefName && R_ExternalPtrTag(obj) != Rf_install(TypeDefName)) {
PROBLEM "[RfromCallbable] incorrect type name for a native routine pointer %s, not %s",
CHAR(asChar(R_ExternalPtrTag(obj))), TypeDefName
ERROR;
}
if(type)
*type = NATIVE_ROUTINE;
return(R_ExternalPtrAddr(obj));
} else if(TYPEOF(obj) == CLOSXP) {
if(type)
*type = R_FUNCTION;
return(obj);
}
PROBLEM "the Rfrom_Callable routine only handles native routines and "
ERROR;
return((void *) NULL);
}
void *
derefRDCOMPointer(SEXP el)
{
void *ptr = NULL;
if(TYPEOF(el) != EXTPTRSXP || el == R_NilValue) {
PROBLEM "Looking at a COM object that does not have an external pointer in the ref slot"
ERROR;
}
#if USE_COM_SYMBOLS
if(R_ExternalPtrTag(el) != R_IDispatchSym || R_ExternalPtrTag(el) != R_IUnknownSym) {
PROBLEM "Unusual RCOM object since the internal tag is not one we have seen."
WARN;
}
#endif
ptr = R_ExternalPtrAddr(el);
if(!ptr) {
PROBLEM "RDCOM Reference object is not valid (NULL). This may be due to restoring it from a previous session."
ERROR;
}
return(ptr);
}
void *
R_getExternalRef(SEXP obj, const char *className)
{
SEXP ref = GET_SLOT(obj, Rf_install("ref"));
void *ans;
if(TYPEOF(ref) != EXTPTRSXP) {
PROBLEM "Expected external pointer object"
ERROR;
}
if(className && R_ExternalPtrTag(ref) != Rf_install(className)) {
PROBLEM "Expected external pointer to have internal tag %s, got %s",
className, CHAR(PRINTNAME(R_ExternalPtrTag(ref)))
ERROR;
}
ans = R_ExternalPtrAddr(ref);
if(!ans) {
PROBLEM "Got NULL value in reference for %s", className
ERROR;
}
return(ans);
}
void *
R_getNativeReference(SEXP arg, const char *type, const char *tag)
{
SEXP el = GET_SLOT(arg, Rf_install("ref"));
void *ans;
if(R_ExternalPtrTag(el) != Rf_install(tag)) {
/* So not a direct match. Now see if it is from a derived class
by comparing the value in the object to the name of each of the
ancestor classes.
*/
SEXP ancestors = GET_SLOT(arg, Rf_install("classes"));
int n, i;
n = Rf_length(ancestors);
for(i = 0; i < n ; i ++) {
if(strcmp(CHAR(STRING_ELT(ancestors, i)), tag) == 0)
break;
}
if(i == n) {
PROBLEM "Looking for %s, got %s",
type, CHAR(PRINTNAME(R_ExternalPtrTag(el)))
ERROR;
}
}
ans = R_ExternalPtrAddr(el);
if(!ans) {
PROBLEM "NULL value passed to R_getNativeReference. This may not be an error, but it could be very serious!"
ERROR;
}
return(ans);
}
void checkPointer(SEXP s) {
if (TYPEOF(s) != EXTPTRSXP) {
errorLog << "Pointer is not EXTPTRSXP" << endl << errorExit;
}
if (R_ExternalPtrTag(s) != install("AbstractMatrix") && R_ExternalPtrTag(s) != install("FilteredMatrix")) {
errorLog << "R_ExternalPtrTag(s) = " << (void*)R_ExternalPtrTag(s) << endl;
errorLog << "Pointer is not AbstractMatrix nor FilteredMatrix" << endl << errorExit;
}
}
SEXP get_intervals_from_stream(SEXP streamid)
{
int sid = *INTEGER(R_ExternalPtrTag(streamid));
if(current_streams.find(sid) == current_streams.end())
return (R_NilValue);
jobject intervals = env->CallObjectMethod(p, fn["Persistence.computeIntervals"], current_streams[sid]);
jfieldID dimension = env->GetFieldID(cl["PersistenceInterval.Float"], "dimension", "I");
jfieldID start = env->GetFieldID(cl["PersistenceInterval.Float"], "start", "D");
jfieldID end = env->GetFieldID(cl["PersistenceInterval.Float"], "end", "D");
int len = env->GetArrayLength((jobjectArray)intervals);
SEXP pintervals;
PROTECT(pintervals = allocVector(REALSXP, 3*len));
for(int i = 0; i < len; i++)
{
jobject firstint = env->GetObjectArrayElement((jobjectArray)intervals, i);
REAL(pintervals)[3*i + 0] = (double)env->GetIntField(firstint, dimension);
REAL(pintervals)[3*i + 1] = (double)env->GetDoubleField(firstint, start);
REAL(pintervals)[3*i + 2] = (double)env->GetDoubleField(firstint, end);
}
UNPROTECT(1);
if(env->ExceptionOccurred())
return R_exception();
return(pintervals);
}
porStreamBuf *get_porStreamBuf(SEXP porStream){
if(TYPEOF(porStream) != EXTPTRSXP || R_ExternalPtrTag(porStream) != install("porStreamBuf"))
error("not a porStream");
porStreamBuf *b = R_ExternalPtrAddr(porStream);
if (b == NULL){
b = Calloc(1,porStreamBuf);
R_SetExternalPtrAddr(porStream,b);
initPorStreamBuf(b);
SEXP name = getAttrib(porStream,install("file.name"));
if(name == R_NilValue || name == NULL){
R_SetExternalPtrAddr(porStream,NULL);
Free(b);
error("need filename to reopen file");
}
b->f = fopen(CHAR(STRING_ELT(name, 0)),"rb");
if(b->f == NULL){
R_SetExternalPtrAddr(porStream,NULL);
Free(b);
error("cannot reopen file -- does it still exist?");
}
Rprintf("File '%s' reopened\n",CHAR(STRING_ELT(name, 0)));
}
if (b == NULL) error("something strange happened here!?");
return(b);
}
SEXP attribute_hidden
do_getRegisteredRoutines(SEXP call, SEXP op, SEXP args, SEXP env)
{
const char * const names[] = {".C", ".Call", ".Fortran", ".External"};
checkArity(op, args);
SEXP dll = CAR(args), ans, snames;
if(TYPEOF(dll) != EXTPTRSXP &&
R_ExternalPtrTag(dll) != install("DLLInfo"))
error(_("R_getRegisteredRoutines() expects a DllInfo reference"));
DllInfo *info = (DllInfo *) R_ExternalPtrAddr(dll);
if(!info) error(_("NULL value passed for DllInfo"));
PROTECT(ans = allocVector(VECSXP, 4));
SET_VECTOR_ELT(ans, 0, R_getRoutineSymbols(R_C_SYM, info));
SET_VECTOR_ELT(ans, 1, R_getRoutineSymbols(R_CALL_SYM, info));
SET_VECTOR_ELT(ans, 2, R_getRoutineSymbols(R_FORTRAN_SYM, info));
SET_VECTOR_ELT(ans, 3, R_getRoutineSymbols(R_EXTERNAL_SYM, info));
PROTECT(snames = allocVector(STRSXP, 4));
for(int i = 0; i < 4; i++)
SET_STRING_ELT(snames, i, mkChar(names[i]));
setAttrib(ans, R_NamesSymbol, snames);
UNPROTECT(2);
return(ans);
}
SEXP attribute_hidden
do_getSymbolInfo(SEXP call, SEXP op, SEXP args, SEXP env)
{
const char *package = "", *name;
R_RegisteredNativeSymbol symbol = {R_ANY_SYM, {NULL}, NULL};
SEXP sym = R_NilValue;
DL_FUNC f = NULL;
checkArity(op, args);
SEXP sname = CAR(args), spackage = CADR(args),
withRegistrationInfo = CADDR(args);
name = translateChar(STRING_ELT(sname, 0));
if(length(spackage)) {
if(TYPEOF(spackage) == STRSXP)
package = translateChar(STRING_ELT(spackage, 0));
else if(TYPEOF(spackage) == EXTPTRSXP &&
R_ExternalPtrTag(spackage) == install("DLLInfo")) {
f = R_dlsym((DllInfo *) R_ExternalPtrAddr(spackage), name, &symbol);
package = NULL;
} else
error(_("must pass package name or DllInfo reference"));
}
if(package)
f = R_FindSymbol(name, package, &symbol);
if(f)
sym = createRSymbolObject(sname, f, &symbol,
LOGICAL(withRegistrationInfo)[0]);
return sym;
}
USER_OBJECT_
directConvertFromPerl(SV * perlObj, USER_OBJECT_ convert)
{
USER_OBJECT_ ans = NULL_USER_OBJECT;
if(TYPEOF(convert) == CLOSXP) {
SEXP e, ref;
PROTECT(e = allocVector(LANGSXP, 2));
SETCAR(e, convert);
PROTECT(ref = makeForeignPerlReference((SV*) perlObj, makeRSPerlClassVector("PerlReference"), &exportReferenceTable));
/* Alternative way of creating the reference.
SEXP classes;
PROTECT(classes = computeRSPerlClassVector(val, &elementType, convert));
PROTECT(ref = makeForeignPerlReference(perlObj, classes, &exportReferenceTable));
*/
SETCAR(CDR(e), ref);
ans = Rf_eval(e, R_GlobalEnv);
UNPROTECT(2);
} else if(TYPEOF(convert) == EXTPTRSXP) {
FromPerlNativeConverter f;
if(R_ExternalPtrTag(convert) != Rf_install("native symbol")) {
PROBLEM "Unrecognized external pointer passed to directConvertFromPerlRoutine"
ERROR;
}
f = (FromPerlNativeConverter) R_ExternalPtrAddr(convert);
ans = f(perlObj);
}
return(ans);
}
static int _selfrefok(SEXP x, Rboolean checkNames, Rboolean verbose) {
SEXP v, p, tag, prot, names;
v = getAttrib(x, SelfRefSymbol);
if (v==R_NilValue || TYPEOF(v)!=EXTPTRSXP) {
// .internal.selfref missing is expected and normal for i) a pre v1.7.8 data.table loaded
// from disk, and ii) every time a new data.table is over-allocated for the first time.
// Not being an extptr is for when users contruct a data.table via structure() using dput, post
// a question, and find the extptr doesn't parse so put quotes around it (for example).
// In both cases the selfref is not ok.
return 0;
}
p = R_ExternalPtrAddr(v);
if (p==NULL) {
if (verbose) Rprintf(".internal.selfref ptr is NULL. This is expected and normal for a data.table loaded from disk. If not, please report to datatable-help.\n");
return -1;
}
if (!isNull(p)) error("Internal error: .internal.selfref ptr is not NULL or R_NilValue");
tag = R_ExternalPtrTag(v);
if (!(isNull(tag) || isString(tag))) error("Internal error: .internal.selfref tag isn't NULL or a character vector");
names = getAttrib(x, R_NamesSymbol);
if (names != tag && isString(names))
SET_TRUELENGTH(names, LENGTH(names));
// R copied this vector not data.table; it's not actually over-allocated. It looks over-allocated
// because R copies the original vector's tl over despite allocating length.
prot = R_ExternalPtrProtected(v);
if (TYPEOF(prot) != EXTPTRSXP) // Very rare. Was error(".internal.selfref prot is not itself an extptr").
return 0; // See http://stackoverflow.com/questions/15342227/getting-a-random-internal-selfref-error-in-data-table-for-r
if (x != R_ExternalPtrAddr(prot))
SET_TRUELENGTH(x, LENGTH(x)); // R copied this vector not data.table, it's not actually over-allocated
return checkNames ? names==tag : x==R_ExternalPtrAddr(prot);
}
SEXP make_random_landmarks(SEXP pdata_handle, SEXP landmark_count)
{
int sid = *INTEGER(R_ExternalPtrTag(pdata_handle));
if(current_pointdata.find(sid) == current_pointdata.end())
return (R_NilValue);
jobject arr = env->CallStaticObjectMethod(cl["WitnessStream"], fn["WitnessStream.<s>makeRandomLandmarks"],
current_pointdata[sid], *INTEGER(landmark_count));
int len = env->GetArrayLength((jintArray)arr);
SEXP landmarks_arr;
PROTECT(landmarks_arr = allocVector(INTSXP, len));
int *parr = env->GetIntArrayElements((jintArray)arr, NULL);
memcpy(INTEGER(landmarks_arr), parr, len*sizeof(int));
env->ReleaseIntArrayElements((jintArray)arr, parr, JNI_ABORT);
UNPROTECT(1);
if(env->ExceptionOccurred())
return R_exception();
return landmarks_arr;
}
/* {{{ rberkeley_db_exists */
SEXP rberkeley_db_exists (SEXP _dbp, SEXP _txnid, SEXP _key, SEXP _flags)
{
DB *dbp;
DB_TXN *txnid;
DBT key;
u_int32_t flags;
int ret;
memset(&key, 0, sizeof(DBT));
if(TYPEOF(_flags) == INTSXP)
flags = (u_int32_t)INTEGER(_flags)[0];
else flags=0;
flags = 0; /* only accepts 0 */
key.data = (unsigned char *)RAW(_key);
key.size = length(_key);
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_txnid)) {
txnid = R_ExternalPtrAddr(_txnid);
} else txnid = NULL;
ret = dbp->exists(dbp, txnid, &key, flags);
return ScalarInteger(ret);
}
/*
This is the routine associated with the getNativeSymbolInfo()
function and it takes the name of a symbol and optionally an
object identifier (package usually) in which to restrict the search
for this symbol. It resolves the symbol and returns it to the caller
giving the symbol address, the package information (i.e. name and
fully qualified shared object name). If the symbol was explicitly
registered (rather than dynamically resolved by R), then we pass
back that information also, giving the number of arguments it
expects and the interface by which it should be called.
The returned object has class NativeSymbol. If the symbol was
registered, we add a class identifying the interface type
for which it is intended (i.e. .C(), .Call(), etc.)
*/
SEXP attribute_hidden
R_getSymbolInfo(SEXP sname, SEXP spackage, SEXP withRegistrationInfo)
{
const void *vmax = vmaxget();
const char *package, *name;
R_RegisteredNativeSymbol symbol = {R_ANY_SYM, {NULL}, NULL};
SEXP sym = R_NilValue;
DL_FUNC f = NULL;
package = "";
name = translateChar(STRING_ELT(sname, 0));
if(length(spackage)) {
if(TYPEOF(spackage) == STRSXP)
package = translateChar(STRING_ELT(spackage, 0));
else if(TYPEOF(spackage) == EXTPTRSXP &&
R_ExternalPtrTag(spackage) == install("DLLInfo")) {
f = R_dlsym((DllInfo *) R_ExternalPtrAddr(spackage), name, &symbol);
package = NULL;
} else
error(_("must pass package name or DllInfo reference"));
}
if(package)
f = R_FindSymbol(name, package, &symbol);
if(f)
sym = createRSymbolObject(sname, f, &symbol,
LOGICAL(withRegistrationInfo)[0]);
vmaxset(vmax);
return sym;
}
SEXP is_extmat(SEXP ptr) {
SEXP ans;
ext_matrix *e = NULL;
PROTECT(ans = allocVector(LGLSXP, 1));
LOGICAL(ans)[0] = 1;
/* object is an external pointer */
if (TYPEOF(ptr) != EXTPTRSXP)
LOGICAL(ans)[0] = 0;
/* tag should be 'external matrix' */
if (LOGICAL(ans)[0] &&
R_ExternalPtrTag(ptr) != install("external matrix"))
LOGICAL(ans)[0] = 0;
/* pointer itself should not be null */
if (LOGICAL(ans)[0]) {
e = R_ExternalPtrAddr(ptr);
if (!e)
LOGICAL(ans)[0] = 0;
}
/* finally, type should be nonnull */
if (LOGICAL(ans)[0] && e && e->type == NULL)
LOGICAL(ans)[0] = 0;
UNPROTECT(1);
return ans;
}
/* {{{ rberkeley_db_set_errfile */
SEXP rberkeley_db_set_errfile (SEXP _dbp, SEXP _errfile)
{
DB *dbp;
FILE *errfile = NULL;
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_errfile)) {
/* highly unlikely to be portable --- FIXME */
errfile = fopen(CHAR(STRING_ELT(_errfile,0)),"w");
if(errfile == NULL)
error("open failed!\n");
} else errfile = NULL;
dbp->set_errfile(dbp, errfile);
if(errfile == NULL) {
return R_NilValue;
} else {
SEXP ptr = R_MakeExternalPtr(errfile, install("errfile"), ScalarLogical(TRUE));
R_RegisterCFinalizer(ptr, (R_CFinalizer_t) rberkeley_fclose);
return ptr;
}
}
/* {{{ rberkeley_db_put */
SEXP rberkeley_db_put(SEXP _dbp, SEXP _txnid, SEXP _key, SEXP _data, SEXP _flags)
{
DB *dbp;
DBT key, data;
DB_TXN *txnid;
u_int32_t flags = INTEGER(_flags)[0];
int ret;
memset(&key, 0, sizeof(key));
memset(&data, 0, sizeof(data));
key.data = (unsigned char *)RAW(_key);
key.size = length(_key);
data.data = (unsigned char *)RAW(_data);
data.size = length(_data);
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_txnid)) {
txnid = R_ExternalPtrAddr(_txnid);
} else txnid = NULL;
/* Store a key/data pair. */
if ((ret = dbp->put(dbp, txnid, &key, &data, flags)) == 0) {
return ScalarInteger(ret);
} else {
dbp->err(dbp, ret, "DB->put");
}
return R_NilValue;
}
/* {{{ rberkeley_db_get_type */
SEXP rberkeley_db_get_type (SEXP _dbp)
{
DB *dbp;
DBTYPE type;
int ret;
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
ret = dbp->get_type(dbp, &type);
switch(type) {
case DB_BTREE:
return mkString("DB_BTREE");
break;
case DB_HASH:
return mkString("DB_HASH");
break;
case DB_RECNO:
return mkString("DB_RECNO");
break;
case DB_QUEUE:
return mkString("DB_QUEUE");
break;
case DB_UNKNOWN:
return mkString("DB_UNKNOWN");
break;
default:
return R_NilValue;
break;
}
}
/* {{{ rberkeley_db_get_dbname */
SEXP rberkeley_db_get_dbname (SEXP _dbp)
{
DB *dbp;
const char *filenamep, *dbnamep;
int ret;
SEXP names, getnames;
PROTECT(getnames = allocVector(VECSXP, 2));
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
ret = dbp->get_dbname(dbp, &filenamep, &dbnamep);
if(ret==0) {
if(filenamep) {
SET_VECTOR_ELT(getnames, 0, mkString(filenamep));
} else {
SET_VECTOR_ELT(getnames, 0, R_NilValue);
}
if(dbnamep) {
SET_VECTOR_ELT(getnames, 1, mkString(dbnamep));
} else {
SET_VECTOR_ELT(getnames, 1, R_NilValue);
}
PROTECT(names = allocVector(STRSXP, 2));
SET_STRING_ELT(names, 0, mkChar("filename"));
SET_STRING_ELT(names, 1, mkChar("dbname"));
setAttrib(getnames, R_NamesSymbol, names);
} else {
return R_NilValue;
}
UNPROTECT(2);
return getnames;
}
/* {{{ rberkeley_db_get */
SEXP rberkeley_db_get(SEXP _dbp, SEXP _txnid, SEXP _key, SEXP _data, SEXP _flags)
{
DB *dbp;
DBT key, data;
DB_TXN *txnid;
u_int32_t flags = INTEGER(_flags)[0];
int ret;
memset(&key, 0, sizeof(key));
memset(&data, 0, sizeof(data));
key.data = (unsigned char *)RAW(_key);
key.size = length(_key);
if(!isNull(_data)) {
data.data = (unsigned char *)RAW(_data);
data.size = length(_data);
}
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_txnid)) {
txnid = R_ExternalPtrAddr(_txnid);
} else txnid = NULL;
ret = dbp->get(dbp, txnid, &key, &data, flags);
if(ret == 0) {
SEXP retdata;
PROTECT(retdata = allocVector(RAWSXP, data.size));
memcpy(RAW(retdata), data.data, data.size);
UNPROTECT(1);
return retdata;
} else return ScalarInteger(ret);
}
SEXP estimate_r_max(SEXP pdata_handle, SEXP landmarks)
{
// landmarks represented as an array of ints. translate this back into java
int sid = *INTEGER(R_ExternalPtrTag(pdata_handle));
if(current_pointdata.find(sid) == current_pointdata.end())
return (R_NilValue);
int len = length(landmarks);
jintArray landmarkarr = env->NewIntArray(len);
int *parr = env->GetIntArrayElements(landmarkarr, NULL);
memcpy(parr, INTEGER(landmarks), len*sizeof(int));
env->ReleaseIntArrayElements(landmarkarr, parr, 0);
jdouble rmax = env->CallStaticDoubleMethod(cl["WitnessStream"], fn["WitnessStream.<s>estimateRmax"],
current_pointdata[sid], landmarkarr);
SEXP r_rmax;
PROTECT(r_rmax = allocVector(REALSXP, 1));
REAL(r_rmax)[0] = rmax;
UNPROTECT(1);
if(env->ExceptionOccurred())
return R_exception();
return r_rmax;
}
/* {{{ rberkeley_db_del */
SEXP rberkeley_db_del(SEXP _dbp, SEXP _txnid, SEXP _key, SEXP _flags)
{
DB *dbp;
DBT key;
DB_TXN *txnid;
u_int32_t flags;
int ret;
memset(&key, 0, sizeof(key));
key.data = (unsigned char *)RAW(_key);
key.size = length(_key);
dbp = R_ExternalPtrAddr(_dbp);
if(R_ExternalPtrTag(_dbp) != RBerkeley_DB || dbp == NULL)
error("invalid 'db' handle");
if(!isNull(_txnid)) {
txnid = R_ExternalPtrAddr(_txnid);
} else {
txnid = NULL;
}
flags = (u_int32_t)INTEGER(_flags)[0];
ret = dbp->del(dbp, txnid, &key, flags);
return ScalarInteger(ret);
}
SEXP FFI_asTypeCode(SEXP s) {
/* No need to convert the already converted */
if(TYPEOF(s)==EXTPTRSXP &&
R_ExternalPtrTag(s) == FFI_TypeTag) return s;
if(TYPEOF(s)==VECSXP) return VectorAsType(s);
return ScalarAsType(s);
}
SEXP BWGSectionList_add(SEXP r_sections, SEXP r_seq, SEXP r_ranges,
SEXP r_score, SEXP r_format)
{
struct bwgSection *sections = NULL;
const char *seq = CHAR(asChar(r_seq));
double *score = REAL(r_score);
const char *format = CHAR(asChar(r_format));
SEXP ans;
struct lm *lm;
enum bwgSectionType type = bwgTypeBedGraph;
if (sameString(format, "fixedStep"))
type = bwgTypeFixedStep;
else if (sameString(format, "variableStep"))
type = bwgTypeVariableStep;
if (r_sections != R_NilValue) {
sections = R_ExternalPtrAddr(r_sections);
lm = R_ExternalPtrAddr(R_ExternalPtrTag(r_sections));
} else lm = lmInit(0);
pushRHandlers();
if (r_ranges != R_NilValue) {
BWGSectionList_addRle(§ions, seq, r_ranges, score, type, lm);
} else {
BWGSectionList_addAtomic(§ions, seq, score, length(r_score), lm);
}
popRHandlers();
PROTECT(ans = R_MakeExternalPtr(sections, R_NilValue, R_NilValue));
R_SetExternalPtrTag(ans, R_MakeExternalPtr(lm, R_NilValue, R_NilValue));
UNPROTECT(1);
return ans;
}
/* {{{ rberkeley_dbcursor_get_priority */
SEXP rberkeley_dbcursor_get_priority (SEXP _dbc)
{
DBC *dbc;
DB_CACHE_PRIORITY priority;
int ret;
dbc = R_ExternalPtrAddr(_dbc);
if(R_ExternalPtrTag(_dbc) != install("DBC") || dbc == NULL)
error("invalid 'dbc' handle");
ret = dbc->get_priority(dbc, &priority);
if(ret != 0)
return ScalarInteger(ret);
switch(priority) {
case DB_PRIORITY_VERY_LOW:
return mkString("DB_PRIORITY_VERY_LOW");
break;
case DB_PRIORITY_LOW:
return mkString("DB_PRIORITY_LOW");
break;
case DB_PRIORITY_DEFAULT:
return mkString("DB_PRIORITY_DEFAULT");
break;
case DB_PRIORITY_HIGH:
return mkString("DB_PRIORITY_HIGH");
break;
case DB_PRIORITY_VERY_HIGH:
return mkString("DB_PRIORITY_VERY_HIGH");
break;
default:
return R_NilValue;
}
}
/* {{{ rberkeley_dbcursor_put */
SEXP rberkeley_dbcursor_put (SEXP _dbc, SEXP _key, SEXP _data, SEXP _flags)
{
DBC *dbc;
DBT key, data;
u_int32_t flags;
int ret;
flags = (u_int32_t)INTEGER(_flags)[0];
if(flags != DB_AFTER &&
flags != DB_BEFORE &&
flags != DB_CURRENT &&
flags != DB_KEYFIRST &&
flags != DB_KEYLAST &&
flags != DB_NODUPDATA) {
error("incorrect flags value");
}
dbc = R_ExternalPtrAddr(_dbc);
if(R_ExternalPtrTag(_dbc) != install("DBC") || dbc == NULL)
error("invalid 'dbc' handle");
memset(&key, 0, sizeof(DBT));
memset(&data, 0, sizeof(DBT));
key.data = (unsigned char *)RAW(_key);
key.size = length(_key);
data.data = (unsigned char *)RAW(_data);
data.size = length(_data);
ret = dbc->put(dbc, &key, &data, flags);
return ScalarInteger(ret);
}
void RGtk_finalizer(USER_OBJECT_ extptr) {
void *ptr = getPtrValue(extptr);
/*Rprintf("finalizing a %s\n", asCString(GET_CLASS(extptr)));*/
if (ptr) {
((RPointerFinalizer)getPtrValue(R_ExternalPtrTag(extptr)))(ptr);
R_ClearExternalPtr(extptr);
}
}
//////////////////////////
// Check that the external pointer is the right thing
TEntryList* checkForEntryListWrapper(SEXP ptr)
{
if ( TYPEOF(ptr) != EXTPTRSXP ||
R_ExternalPtrTag(ptr) != entrylist_type_tag ||
! R_ExternalPtrAddr(ptr) )
error("Bad Pointer to EntryListWrapper");
return (TEntryList*) R_ExternalPtrAddr(ptr);
}
/* --- .Call ENTRY POINT --- */
SEXP BWGSectionList_cleanup(SEXP r_sections)
{
pushRHandlers();
if (r_sections != R_NilValue) {
struct lm *lm = R_ExternalPtrAddr(R_ExternalPtrTag(r_sections));
lmCleanup(&lm);
}
popRHandlers();
return R_NilValue;
}
//////////////////////////
// Check that the external pointer is the right thing
TFile* checkForFileForHistsWrapper(SEXP ptr)
{
if ( TYPEOF(ptr) != EXTPTRSXP ||
R_ExternalPtrTag(ptr) != fh_type_tag ||
! R_ExternalPtrAddr(ptr) )
error("Bad Pointer to FileForHistsWrapper");
return (TFile*) R_ExternalPtrAddr(ptr);
}