/* Get the font description object defined in swfFont.h */
static pfontDesc swfGetFontDesc(const pGEcontext gc, pswfDesc swfInfo)
{
int gcfontface = gc->fontface;
pfontDesc font;
SEXP fontList;
SEXP fontNames;
SEXP extPtr;
int i, listLen;
/* Font list is .pkg.env$.font.list, defined in font.R */
PROTECT(fontList = Rf_findVar(install(".font.list"), swfInfo->pkgEnv));
UNPROTECT(1);
fontNames = GET_NAMES(fontList);
listLen = Rf_length(fontList);
for(i = 0; i < listLen; i++)
{
if(strcmp(gc->fontfamily, CHAR(STRING_ELT(fontNames, i))) == 0)
{
break;
}
}
if(i == listLen) i = 0;
if(gcfontface < 1 || gcfontface > 5) gcfontface = 1;
extPtr = VECTOR_ELT(VECTOR_ELT(fontList, i), gcfontface - 1);
font = (pfontDesc) R_ExternalPtrAddr(extPtr);
return font;
}
SEXP R_get_function(char *fname)
{
SEXP expr, res;
int error;
printf("fname: %s\n", fname);
SEXP robj = Rf_findVar(Rf_install(fname), R_GlobalEnv);
if (robj == R_UnboundValue)
return R_NilValue;
robj = Rf_findFun(Rf_install(fname), R_GlobalEnv);
printf("VALUE: \n");
Rf_PrintValue(robj);
PROTECT(expr = allocVector(LANGSXP, 2));
SETCAR(expr, install("get"));
SETCAR(CDR(expr), Rf_mkString(fname));
res = R_tryEval(expr, R_GlobalEnv, &error);
// Rf_PrintValue(res);
if (error) {
// rb_raise(rb_eRException, "R execution exception. %s", expr);
UNPROTECT(1);
return NULL;
}
UNPROTECT(1);
return res;
}
SEXP GetVarFromPkgEnv(const char *varName, const char *pkgName)
{
/* See grDevices/src/devPS getFontDB() */
SEXP pkgNS, pkgEnv, var;
PROTECT(pkgNS = R_FindNamespace(ScalarString(mkChar(pkgName))));
PROTECT(pkgEnv = Rf_findVar(install(".pkg.env"), pkgNS));
if(TYPEOF(pkgEnv) == PROMSXP) {
PROTECT(pkgEnv);
pkgEnv = eval(pkgEnv, pkgNS);
UNPROTECT(1);
}
PROTECT(var = Rf_findVar(install(varName), pkgEnv));
UNPROTECT(3);
return var;
}
/* Autoload default packages and names from autoloads.h
*
* This function behaves in almost every way like
* R's autoload:
* function (name, package, reset = FALSE, ...)
* {
* if (!reset && exists(name, envir = .GlobalEnv, inherits = FALSE))
* stop("an object with that name already exists")
* m <- match.call()
* m[[1]] <- as.name("list")
* newcall <- eval(m, parent.frame())
* newcall <- as.call(c(as.name("autoloader"), newcall))
* newcall$reset <- NULL
* if (is.na(match(package, .Autoloaded)))
* assign(".Autoloaded", c(package, .Autoloaded), env = .AutoloadEnv)
* do.call("delayedAssign", list(name, newcall, .GlobalEnv,
* .AutoloadEnv))
* invisible()
* }
*
* What's missing is the updating of the string vector .Autoloaded with the list
* of packages, which by my code analysis is useless and only for informational
* purposes.
*
*/
void autoloads(void){
SEXP da, dacall, al, alcall, AutoloadEnv, name, package;
int i,j, idx=0, errorOccurred, ptct;
/* delayedAssign call*/
PROTECT(da = Rf_findFun(Rf_install("delayedAssign"), R_GlobalEnv));
PROTECT(AutoloadEnv = Rf_findVar(Rf_install(".AutoloadEnv"), R_GlobalEnv));
if (AutoloadEnv == R_NilValue){
fprintf(stderr,"%s: Cannot find .AutoloadEnv!\n", programName);
exit(1);
}
PROTECT(dacall = allocVector(LANGSXP,5));
SETCAR(dacall,da);
/* SETCAR(CDR(dacall),name); */ /* arg1: assigned in loop */
/* SETCAR(CDR(CDR(dacall)),alcall); */ /* arg2: assigned in loop */
SETCAR(CDR(CDR(CDR(dacall))),R_GlobalEnv); /* arg3 */
SETCAR(CDR(CDR(CDR(CDR(dacall)))),AutoloadEnv); /* arg3 */
/* autoloader call */
PROTECT(al = Rf_findFun(Rf_install("autoloader"), R_GlobalEnv));
PROTECT(alcall = allocVector(LANGSXP,3));
SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
SETCAR(alcall,al);
/* SETCAR(CDR(alcall),name); */ /* arg1: assigned in loop */
/* SETCAR(CDR(CDR(alcall)),package); */ /* arg2: assigned in loop */
ptct = 5;
for(i = 0; i < packc; i++){
idx += (i != 0)? packobjc[i-1] : 0;
for (j = 0; j < packobjc[i]; j++){
/*printf("autload(%s,%s)\n",packobj[idx+j],pack[i]);*/
PROTECT(name = NEW_CHARACTER(1));
PROTECT(package = NEW_CHARACTER(1));
SET_STRING_ELT(name, 0, COPY_TO_USER_STRING(packobj[idx+j]));
SET_STRING_ELT(package, 0, COPY_TO_USER_STRING(pack[i]));
/* Set up autoloader call */
PROTECT(alcall = allocVector(LANGSXP,3));
SET_TAG(alcall, R_NilValue); /* just like do_ascall() does */
SETCAR(alcall,al);
SETCAR(CDR(alcall),name);
SETCAR(CDR(CDR(alcall)),package);
/* Setup delayedAssign call */
SETCAR(CDR(dacall),name);
SETCAR(CDR(CDR(dacall)),alcall);
R_tryEval(dacall,R_GlobalEnv,&errorOccurred);
if (errorOccurred){
fprintf(stderr,"%s: Error calling delayedAssign!\n", programName);
exit(1);
}
ptct += 3;
}
}
UNPROTECT(ptct);
}
/*
* Get an R **function** object by its name. When not found, an exception is
* raised. The checking of the length of the identifier is needed to
* avoid R raising an error.
*/
SEXP get_fun_from_name(char *ident) {
SEXP obj;
/* For R not to throw an error, we must check the identifier is
neither null nor greater than MAXIDSIZE */
if (!*ident) {
rb_raise(rb_eRuntimeError, "Attempt to use zero-length variable name");
return NULL;
}
if (strlen(ident) > MAXIDSIZE) {
rb_raise(rb_eRuntimeError, "symbol print-name too long");
return NULL;
}
#if R_VERSION < 0x20000
obj = Rf_findVar(Rf_install(ident), R_GlobalEnv);
#else
/*
* For R-2.0.0 and later, it is necessary to use findFun to get
* functions. Unfortunately, calling findFun on an undefined name
* causes a segfault!
*
* Solution:
*
* 1) Call findVar on the name
*
* 2) If something has the name, call findFun
*
* 3) Raise an error if either step 1 or 2 fails.
*/
obj = Rf_findVar(Rf_install(ident), R_GlobalEnv);
if (obj != R_UnboundValue)
obj = Rf_findFun(Rf_install(ident), R_GlobalEnv);
#endif
if (obj == R_UnboundValue) {
rb_raise(rb_eNoMethodError, "R Function \"%s\" not found", ident);
return NULL;
}
return obj;
}
SEXP GetPkgEnv(const char *pkgName)
{
SEXP pkgNS, pkgEnv;
PROTECT(pkgNS = R_FindNamespace(ScalarString(mkChar(pkgName))));
PROTECT(pkgEnv = Rf_findVar(install(".pkg.env"), pkgNS));
if(TYPEOF(pkgEnv) == PROMSXP) {
PROTECT(pkgEnv);
pkgEnv = eval(pkgEnv, pkgNS);
UNPROTECT(1);
}
UNPROTECT(2);
return pkgEnv;
}
SEXP get_fun_from_name(char *ident) {
SEXP obj;
if (!*ident) {
return NULL;
}
obj = Rf_findVar(Rf_install(ident), R_GlobalEnv);
/* if (obj != R_UnboundValue) { */
/* obj = Rf_findFun(Rf_install(ident), R_GlobalEnv); */
/* } */
if (obj == R_UnboundValue)
rb_raise(rb_eRobjException, "There is no symbol \"%s\".", ident);
return obj;
}
void plot::render_from_snapshot() {
auto xdd = reinterpret_cast<ide_device*>(_device_desc->deviceSpecific);
xdd->output_and_kill_file_device();
try {
rhost::util::errors_to_exceptions([&] {
auto snapshot = Rf_findVar(Rf_install(_snapshot_varname.c_str()), R_GlobalEnv);
if (snapshot != R_UnboundValue && snapshot != R_NilValue) {
Rf_protect(snapshot);
pGEDevDesc ge_dev_desc = Rf_desc2GEDesc(_device_desc);
GEplaySnapshot(snapshot, ge_dev_desc);
Rf_unprotect(1);
} else {
Rf_error("Plot snapshot is missing. Plot history may be corrupted. You should restart your session.");
}
});
} catch (rhost::util::r_error&) {
render_empty();
}
}
int execute_tool2(const wchar_t* script_path, IArray* pParameters)
{
if (pParameters == 0)
return 0;
//gp_connect_impl connect;
//if (!connect.init())
// return 1;
if (pParameters == 0)
return 0;
_bstr_t file_path(script_path);
long nParams = 0;
pParameters->get_Count(&nParams);
//CComQIPtr<IGPScriptTool>(pGPTool)->get_FileName(file_path.GetAddress());
bool ok = true;
int errorOccurred = 0;
if (file_path.length() && nParams)
{
std::vector< CAdapt<CComPtr<IGPParameter> > > return_params;
//ipParameters->get_Count(&n);
SEXP arc_env = Rf_findVar(Rf_install("arc"), R_GlobalEnv);
{
std::vector<SEXP> in_params;
std::vector<std::string> in_params_names;
std::vector<SEXP> out_params;
std::vector<std::string> out_params_names;
tools::protect pt;
for (int i = 0; i < nParams; i++)
{
CComPtr<IUnknown> ipUnk;
pParameters->get_Element(i, &ipUnk);
CComQIPtr<IGPParameter> ipParam(ipUnk);
esriGPParameterDirection eD;
ipParam->get_Direction(&eD);
std::pair<SEXP, std::string> p = param2r(ipParam);
if (eD == esriGPParameterDirectionInput)
{
in_params.push_back(pt.add(p.first));
in_params_names.push_back(p.second);
}
else
{
out_params.push_back(pt.add(p.first));
out_params_names.push_back(p.second);
return_params.push_back(ipParam);
}
}
SEXP p1 = tools::newVal(in_params, pt);
tools::nameIt(p1, in_params_names);
SEXP p2 = tools::newVal(out_params, pt);
tools::nameIt(p2, out_params_names);
Rf_defineVar(Rf_install(".file"), tools::newVal(file_path, pt), arc_env);
Rf_defineVar(Rf_install(".in"), p1, arc_env);
Rf_defineVar(Rf_install(".out"), p2, arc_env);
}
const static wchar_t eval_str[] = L"arc$.ret<-local({"
L"en<-new.env(hash=TRUE);"
L"eval(parse(file=arc$.file), envir=en);"
L"tool_exec<-get('tool_exec',en);"
L"tool_exec(in_param, out_param)"
L"},envir=list('in_param'=arc$.in,'out_param'=arc$.out))";
ok = current_connect->eval_one(eval_str) == 1;
current_connect->print_out(NULL, -1);
Rf_defineVar(Rf_install(".file"), R_NilValue, arc_env);
Rf_defineVar(Rf_install(".in"), R_NilValue, arc_env);
Rf_defineVar(Rf_install(".out"), R_NilValue, arc_env);
R_gc();
//TODO: handle ok
if (ok)
{
/*CComPtr<IGPMessages> ipMsgs;
if (connect.m_ipGeoProcessor)
connect.m_ipGeoProcessor->GetReturnMessages(&ipMsgs);
if (ipMsgs)
{
VARIANT_BOOL bErr = VARIANT_FALSE;
CComQIPtr<IGPMessage>(ipMsgs)->IsError(&bErr);
if (bErr != VARIANT_FALSE)
ok = false;
}*/
if (!return_params.empty())
{
//connect.m_ipGeoProcessor->Is
SEXP ret = Rf_findVar(Rf_install(".ret"), arc_env);
tools::vectorGeneric ret_out(ret);
//tools::vectorGeneric ret_out(ret.get());
for (size_t i = 0, n = return_params.size(); i < n; i++)
{
_bstr_t name;
return_params[i].m_T->get_Name(name.GetAddress());
size_t idx = ret_out.idx(std::string(name));
if (idx != (size_t)-1)
{
if (!r2param(ret_out.at(idx), return_params[i].m_T))
{
std::wstring msg(L"failed to set output parameter - ");
msg += name;
current_connect->print_out(msg.c_str(), 2);
}
}
}
//TODO list
}
Rf_defineVar(Rf_install(".ret"), R_NilValue, arc_env);
}
}
return ok ? 0 : 1;
}
// TODO: split out some of the large blocks into helper functions, to make this easier to read
void RKStructureGetter::getStructureWorker (SEXP val, const QString &name, bool misplaced, RData *storage) {
RK_TRACE (RBACKEND);
bool is_function = false;
bool is_container = false;
bool is_environment = false;
unsigned int type = 0;
unsigned int count;
RK_DO (qDebug ("fetching '%s': %p, s-type %d", name.toLatin1().data(), val, TYPEOF (val)), RBACKEND, DL_DEBUG);
PROTECT (val);
// manually resolve any promises
SEXP value = resolvePromise (val);
UNPROTECT (1); /* val */
PROTECT (value);
// first field: get name
RData *namedata = new RData;
namedata->datatype = RData::StringVector;
namedata->length = 1;
QString *name_dummy = new QString[1];
name_dummy[0] = name;
namedata->data = name_dummy;
// get classes
SEXP classes_s;
if (TYPEOF (value) == LANGSXP) { // if it's a call, we should NEVER send it through eval
extern SEXP R_data_class (SEXP, Rboolean);
classes_s = R_data_class (value, (Rboolean) 0);
value = coerceVector (value, EXPRSXP); // make sure the object is safe for everything to come
UNPROTECT (1); /* old value */
PROTECT (classes_s);
PROTECT (value);
} else {
classes_s = callSimpleFun (class_fun, value, R_BaseEnv);
PROTECT (classes_s);
}
QString *classes = SEXPToStringList (classes_s, &count);
unsigned int num_classes = count;
UNPROTECT (1); /* classes_s */
// store classes
RData *classdata = new RData;
classdata->datatype = RData::StringVector;
classdata->data = classes;
classdata->length = num_classes;
// basic classification
for (unsigned int i = 0; i < num_classes; ++i) {
#warning: Using is.data.frame() may be more reliable (would need to be called only on List-objects, thus no major performance hit)
if (classes[i] == "data.frame") type |= RObject::DataFrame;
}
if (callSimpleBool (is_matrix_fun, value, R_BaseEnv)) type |= RObject::Matrix;
if (callSimpleBool (is_array_fun, value, R_BaseEnv)) type |= RObject::Array;
if (callSimpleBool (is_list_fun, value, R_BaseEnv)) type |= RObject::List;
if (type != 0) {
is_container = true;
type |= RObject::Container;
} else {
if (callSimpleBool (is_function_fun, value, R_BaseEnv)) {
is_function = true;
type |= RObject::Function;
} else if (callSimpleBool (is_environment_fun, value, R_BaseEnv)) {
is_container = true;
is_environment = true;
type |= RObject::Environment;
} else {
type |= RObject::Variable;
if (callSimpleBool (is_factor_fun, value, R_BaseEnv)) type |= RObject::Factor;
else if (callSimpleBool (is_numeric_fun, value, R_BaseEnv)) type |= RObject::Numeric;
else if (callSimpleBool (is_character_fun, value, R_BaseEnv)) type |= RObject::Character;
else if (callSimpleBool (is_logical_fun, value, R_BaseEnv)) type |= RObject::Logical;
}
}
if (misplaced) type |= RObject::Misplaced;
// get meta data, if any
RData *metadata = new RData;
metadata->datatype = RData::StringVector;
if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) {
type |= RObject::HasMetaObject;
SEXP meta_s = callSimpleFun (get_meta_fun, value, R_GlobalEnv);
PROTECT (meta_s);
metadata->data = SEXPToStringList (meta_s, &count);
metadata->length = count;
UNPROTECT (1); /* meta_s */
} else {
metadata->length = 1;
QString *meta_dummy = new QString[1];
meta_dummy[0] = "";
metadata->data = meta_dummy;
}
// store type
RData *typedata = new RData;
typedata->datatype = RData::IntVector;
typedata->length = 1;
int *type_dummy = new int[1];
type_dummy[0] = type;
typedata->data = type_dummy;
// get dims
int *dims;
unsigned int num_dims;
SEXP dims_s = callSimpleFun (dims_fun, value, R_BaseEnv);
if (!Rf_isNull (dims_s)) {
dims = SEXPToIntArray (dims_s, &num_dims);
} else {
num_dims = 1;
unsigned int len = Rf_length (value);
if ((len < 2) && (!is_function)) { // suspicious. Maybe some kind of list
SEXP len_s = callSimpleFun (length_fun, value, R_BaseEnv);
PROTECT (len_s);
if (Rf_isNull (len_s)) {
dims = new int[1];
dims[0] = len;
} else {
dims = SEXPToIntArray (len_s, &num_dims);
}
UNPROTECT (1); /* len_s */
} else {
dims = new int[1];
dims[0] = len;
}
}
// store dims
RData *dimdata = new RData;
dimdata->datatype = RData::IntVector;
dimdata->length = num_dims;
dimdata->data = dims;
// store everything we have so far
if (is_container) {
storage->length = 6;
} else if (is_function) {
storage->length = 7;
} else {
storage->length = 5;
}
storage->datatype = RData::StructureVector;
RData **res = new RData*[storage->length];
storage->data = res;
res[0] = namedata;
res[1] = typedata;
res[2] = classdata;
res[3] = metadata;
res[4] = dimdata;
// now add the extra info for containers and functions
if (is_container) {
bool do_env = (is_environment && (++envir_depth < 2));
bool do_cont = is_container && (!is_environment);
RData *childdata = new RData;
childdata->datatype = RData::StructureVector;
childdata->length = 0;
childdata->data = 0;
res[5] = childdata;
// fetch list of child names
unsigned int childcount;
SEXP childnames_s;
if (do_env) {
childnames_s = R_lsInternal (value, (Rboolean) 1);
} else if (do_cont) {
childnames_s = callSimpleFun (names_fun, value, R_BaseEnv);
} else {
childnames_s = R_NilValue; // dummy
}
PROTECT (childnames_s);
QString *childnames = SEXPToStringList (childnames_s, &childcount);
childdata->length = childcount;
RData **children = new RData*[childcount];
childdata->data = children;
childdata->length = childcount;
for (unsigned int i = 0; i < childcount; ++i) { // in case there is an error while fetching one of the children, let's pre-initialize everything.
children[i] = new RData;
children[i]->data = 0;
children[i]->length = 0;
children[i]->datatype = RData::NoData;
}
if (do_env) {
RK_DO (qDebug ("recurse into environment %s", name.toLatin1().data ()), RBACKEND, DL_DEBUG);
for (unsigned int i = 0; i < childcount; ++i) {
SEXP current_childname = install(CHAR(STRING_ELT(childnames_s, i)));
PROTECT (current_childname);
SEXP child = Rf_findVar (current_childname, value);
PROTECT (child);
bool child_misplaced = false;
if (with_namespace) {
/* before R 2.4.0, operator "::" would only work on true namespaces, not on package names (operator "::" work, if there is a namespace, and that namespace has the symbol in it)
TODO remove once we depend on R >= 2.4.0 */
# ifndef R_2_5
if (Rf_isNull (namespace_envir)) {
child_misplaced = true;
} else {
SEXP dummy = Rf_findVarInFrame (namespace_envir, current_childname);
if (Rf_isNull (dummy) || (dummy == R_UnboundValue)) child_misplaced = true;
}
/* for R 2.4.0 or greater: operator "::" works if package has no namespace at all, or has a namespace with the symbol in it */
# else
if (!Rf_isNull (namespace_envir)) {
SEXP dummy = Rf_findVarInFrame (namespace_envir, current_childname);
if (Rf_isNull (dummy) || (dummy == R_UnboundValue)) child_misplaced = true;
}
# endif
}
getStructureSafe (child, childnames[i], child_misplaced, children[i]);
UNPROTECT (2); /* childname, child */
}
} else if (do_cont) {
RK_DO (qDebug ("recurse into list %s", name.toLatin1().data ()), RBACKEND, DL_DEBUG);
// fewer elements than names() can happen, although I doubt it is supposed to happen.
// see http://sourceforge.net/tracker/?func=detail&aid=3002439&group_id=50231&atid=459007
bool may_be_special = Rf_length (value) < childcount;
if (Rf_isList (value) && (!may_be_special)) { // old style list
for (unsigned int i = 0; i < childcount; ++i) {
SEXP child = CAR (value);
getStructureSafe (child, childnames[i], false, children[i]);
CDR (value);
}
} else if (Rf_isNewList (value) && (!may_be_special)) { // new style list
for (unsigned int i = 0; i < childcount; ++i) {
SEXP child = VECTOR_ELT(value, i);
getStructureSafe (child, childnames[i], false, children[i]);
}
} else { // probably an S4 object disguised as a list
SEXP index = Rf_allocVector(INTSXP, 1);
PROTECT (index);
for (unsigned int i = 0; i < childcount; ++i) {
INTEGER (index)[0] = (i + 1);
SEXP child = callSimpleFun2 (double_brackets_fun, value, index, R_BaseEnv);
getStructureSafe (child, childnames[i], false, children[i]);
}
UNPROTECT (1); /* index */
}
}
UNPROTECT (1); /* childnames_s */
delete [] childnames;
} else if (is_function) {
RData *funargsdata = new RData;
funargsdata->datatype = RData::StringVector;
funargsdata->length = 0;
funargsdata->data = 0;
res[5] = funargsdata;
RData *funargvaluesdata = new RData;
funargvaluesdata->datatype = RData::StringVector;
funargvaluesdata->length = 0;
funargvaluesdata->data = 0;
res[6] = funargvaluesdata;
// TODO: this is still the major bottleneck, but no idea, how to improve on this
SEXP formals_s = callSimpleFun (get_formals_fun, value, R_GlobalEnv);
PROTECT (formals_s);
// the default values
funargvaluesdata->data = SEXPToStringList (formals_s, &(funargvaluesdata->length));
// the argument names
SEXP names_s = getAttrib (formals_s, R_NamesSymbol);
PROTECT (names_s);
funargsdata->data = SEXPToStringList (names_s, &(funargsdata->length));
UNPROTECT (2); /* names_s, formals_s */
}
UNPROTECT (1); /* value */
}
static void nvimcom_list_env()
{
const char *varName;
SEXP envVarsSEXP, varSEXP;
if(tmpdir[0] == 0)
return;
if(objbr_auto != 1)
return;
#ifndef WIN32
struct timeval begin, middle, end, tdiff1, tdiff2;
if(verbose > 1)
gettimeofday(&begin, NULL);
#endif
memset(obbrbuf2, 0, obbrbufzise);
char *p = nvimcom_strcat(obbrbuf2, ".GlobalEnv | Libraries\n\n");
PROTECT(envVarsSEXP = R_lsInternal(R_GlobalEnv, allnames));
for(int i = 0; i < Rf_length(envVarsSEXP); i++){
varName = CHAR(STRING_ELT(envVarsSEXP, i));
PROTECT(varSEXP = Rf_findVar(Rf_install(varName), R_GlobalEnv));
if (varSEXP != R_UnboundValue) // should never be unbound
{
p = nvimcom_browser_line(&varSEXP, varName, "", " ", p);
} else {
REprintf("Unexpected R_UnboundValue returned from R_lsInternal.\n");
}
UNPROTECT(1);
}
UNPROTECT(1);
#ifndef WIN32
if(verbose > 1)
gettimeofday(&middle, NULL);
#endif
int len1 = strlen(obbrbuf1);
int len2 = strlen(obbrbuf2);
if(len1 != len2){
nvimcom_write_obbr();
} else {
for(int i = 0; i < len1; i++){
if(obbrbuf1[i] != obbrbuf2[i]){
nvimcom_write_obbr();
break;
}
}
}
#ifndef WIN32
if(verbose > 1){
gettimeofday(&end, NULL);
timersub(&middle, &begin, &tdiff1);
timersub(&end, &middle, &tdiff2);
Rprintf("Time to Update the Object Browser: %ld.%06ld + %ld.%06ld\n",
(long int)tdiff1.tv_sec, (long int)tdiff1.tv_usec,
(long int)tdiff2.tv_sec, (long int)tdiff2.tv_usec);
}
#endif
}
// TODO: split out some of the large blocks into helper functions, to make this easier to read
void RKStructureGetter::getStructureWorker (SEXP val, const QString &name, int add_type_flags, RData *storage, int nesting_depth) {
RK_TRACE (RBACKEND);
bool at_toplevel = (toplevel_value == val);
bool is_function = false;
bool is_container = false;
bool is_environment = false;
bool no_recurse = (nesting_depth >= 2); // TODO: should be configurable
unsigned int type = 0;
RK_DEBUG (RBACKEND, DL_DEBUG, "fetching '%s': %p, s-type %d", name.toLatin1().data(), val, TYPEOF (val));
SEXP value = val;
PROTECT_INDEX value_index;
PROTECT_WITH_INDEX (value, &value_index);
// manually resolve any promises
REPROTECT (value = resolvePromise (value), value_index);
bool is_s4 = Rf_isS4 (value);
SEXP baseenv = R_BaseEnv;
if (is_s4) baseenv = R_GlobalEnv;
// first field: get name
RData *namedata = new RData;
namedata->setData (QStringList (name));
// get classes
SEXP classes_s;
if ((TYPEOF (value) == LANGSXP) || (TYPEOF (value) == SYMSXP)) { // if it's a call, we should NEVER send it through eval
extern SEXP R_data_class (SEXP, Rboolean);
classes_s = R_data_class (value, (Rboolean) 0);
REPROTECT (value = Rf_coerceVector (value, EXPRSXP), value_index); // make sure the object is safe for everything to come
PROTECT (classes_s);
} else {
classes_s = RKRSupport::callSimpleFun (class_fun, value, baseenv);
PROTECT (classes_s);
}
QStringList classes = RKRSupport::SEXPToStringList (classes_s);
UNPROTECT (1); /* classes_s */
// store classes
RData *classdata = new RData;
classdata->setData (classes);
// basic classification
for (int i = classes.size () - 1; i >= 0; --i) {
#warning: Using is.data.frame() may be more reliable (would need to be called only on List-objects, thus no major performance hit)
if (classes[i] == "data.frame") type |= RObject::DataFrame;
}
if (RKRSupport::callSimpleBool (is_matrix_fun, value, baseenv)) type |= RObject::Matrix;
if (RKRSupport::callSimpleBool (is_list_fun, value, baseenv)) type |= RObject::List;
if (type != 0) {
is_container = true;
type |= RObject::Container;
} else {
if (RKRSupport::callSimpleBool (is_function_fun, value, baseenv)) {
is_function = true;
type |= RObject::Function;
} else if (RKRSupport::callSimpleBool (is_environment_fun, value, baseenv)) {
is_container = true;
type |= RObject::Environment;
is_environment = true;
} else {
type |= RObject::Variable;
if (RKRSupport::callSimpleBool (is_factor_fun, value, baseenv)) type |= RObject::Factor;
else if (RKRSupport::callSimpleBool (is_numeric_fun, value, baseenv)) type |= RObject::Numeric;
else if (RKRSupport::callSimpleBool (is_character_fun, value, baseenv)) type |= RObject::Character;
else if (RKRSupport::callSimpleBool (is_logical_fun, value, baseenv)) type |= RObject::Logical;
if (RKRSupport::callSimpleBool (is_array_fun, value, baseenv)) type |= RObject::Array;
}
}
type |= add_type_flags;
if (is_container) {
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into %s", name.toLatin1().data ());
}
}
// get meta data, if any
RData *metadata = new RData;
if (!Rf_isNull (Rf_getAttrib (value, meta_attrib))) {
SEXP meta_s = RKRSupport::callSimpleFun (get_meta_fun, value, R_GlobalEnv);
PROTECT (meta_s);
metadata->setData (RKRSupport::SEXPToStringList (meta_s));
UNPROTECT (1); /* meta_s */
} else {
metadata->setData (QStringList ());
}
// get dims
RData::IntStorage dims;
SEXP dims_s = RKRSupport::callSimpleFun (dims_fun, value, baseenv);
if (!Rf_isNull (dims_s)) {
dims = RKRSupport::SEXPToIntArray (dims_s);
} else {
unsigned int len = Rf_length (value);
if ((len < 2) && (!is_function)) { // suspicious. Maybe some kind of list
SEXP len_s = RKRSupport::callSimpleFun (length_fun, value, baseenv);
PROTECT (len_s);
if (Rf_isNull (len_s)) {
dims.append (len);
} else {
dims = RKRSupport::SEXPToIntArray (len_s);
}
UNPROTECT (1); /* len_s */
} else {
dims.append (len);
}
}
// store dims
RData *dimdata = new RData;
dimdata->setData (dims);
RData *slotsdata = new RData ();
// does it have slots?
if (is_s4) {
type |= RObject::S4Object;
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into slots of %s", name.toLatin1().data ());
} else {
RData::RDataStorage dummy (1, 0);
dummy[0] = new RData ();
SEXP slots_pseudo_object = RKRSupport::callSimpleFun (rk_get_slots_fun, value, R_GlobalEnv);
PROTECT (slots_pseudo_object);
getStructureSafe (slots_pseudo_object, "SLOTS", RObject::PseudoObject, dummy[0], nesting_depth); // do not increase depth for this pseudo-object
UNPROTECT (1);
slotsdata->setData (dummy);
}
}
// store type
RData *typedata = new RData;
typedata->setData (RData::IntStorage (1, type));
// store everything we have so far
int storage_length = RObject::StorageSizeBasicInfo;
if (is_container) {
storage_length = RObject::StorageSizeBasicInfo + 1;
} else if (is_function) {
storage_length = RObject::StorageSizeBasicInfo + 2;
}
RData::RDataStorage res (storage_length, 0);
res[RObject::StoragePositionName] = namedata;
res[RObject::StoragePositionType] = typedata;
res[RObject::StoragePositionClass] = classdata;
res[RObject::StoragePositionMeta] = metadata;
res[RObject::StoragePositionDims] = dimdata;
res[RObject::StoragePositionSlots] = slotsdata;
// now add the extra info for containers and functions
if (is_container) {
bool do_env = (is_environment && (!no_recurse));
bool do_cont = is_container && (!is_environment) && (!no_recurse);
// fetch list of child names
SEXP childnames_s;
if (do_env) {
childnames_s = R_lsInternal (value, (Rboolean) 1);
} else if (do_cont) {
childnames_s = RKRSupport::callSimpleFun (names_fun, value, baseenv);
} else {
childnames_s = R_NilValue; // dummy
}
PROTECT (childnames_s);
QStringList childnames = RKRSupport::SEXPToStringList (childnames_s);
int childcount = childnames.size ();
if (childcount > NAMED_CHILDREN_LIMIT) {
RK_DEBUG (RBACKEND, DL_WARNING, "object %s has %d named children. Will only retrieve the first %d", name.toLatin1().data (), childcount, NAMED_CHILDREN_LIMIT);
childcount = NAMED_CHILDREN_LIMIT;
}
RData::RDataStorage children (childcount, 0);
for (int i = 0; i < childcount; ++i) {
children[i] = new RData (); // NOTE: RData-ctor pre-initalizes these to empty. Thus, we're safe even if there is an error while fetching one of the children.
}
if (do_env) {
RK_DEBUG (RBACKEND, DL_DEBUG, "recurse into environment %s", name.toLatin1().data ());
if (!Rf_isEnvironment (value)) {
// some classes (ReferenceClasses) are identified as envionments by is.environment(), but are not internally ENVSXPs.
// For these, Rf_findVar would fail.
REPROTECT (value = RKRSupport::callSimpleFun (as_environment_fun, value, R_GlobalEnv), value_index);
}
for (int i = 0; i < childcount; ++i) {
SEXP current_childname = Rf_install(CHAR(STRING_ELT(childnames_s, i))); // ??? Why does simply using STRING_ELT(childnames_i, i) crash?
PROTECT (current_childname);
SEXP child = Rf_findVar (current_childname, value);
PROTECT (child);
bool child_misplaced = false;
if (at_toplevel && with_namespace && (!RKRBackend::this_pointer->RRuntimeIsVersion (2, 14, 0))) {
if (!Rf_isNull (namespace_envir)) {
SEXP dummy = Rf_findVarInFrame (namespace_envir, current_childname);
if (Rf_isNull (dummy) || (dummy == R_UnboundValue)) child_misplaced = true;
}
}
getStructureSafe (child, childnames[i], child_misplaced ? RObject::Misplaced : 0, children[i], nesting_depth + 1);
UNPROTECT (2); /* current_childname, child */
}
} else if (do_cont) {
RK_DEBUG (RBACKEND, DL_DEBUG, "recurse into list %s", name.toLatin1().data ());
// fewer elements than names() can happen, although I doubt it is supposed to happen.
// see http://sourceforge.net/tracker/?func=detail&aid=3002439&group_id=50231&atid=459007
bool may_be_special = Rf_length (value) < childcount;
if (Rf_isList (value) && (!may_be_special)) { // old style list
for (int i = 0; i < childcount; ++i) {
SEXP child = CAR (value);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
CDR (value);
}
} else if (Rf_isNewList (value) && (!may_be_special)) { // new style list
for (int i = 0; i < childcount; ++i) {
SEXP child = VECTOR_ELT(value, i);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
}
} else { // probably an S4 object disguised as a list
SEXP index = Rf_allocVector(INTSXP, 1);
PROTECT (index);
for (int i = 0; i < childcount; ++i) {
INTEGER (index)[0] = (i + 1);
SEXP child = RKRSupport::callSimpleFun2 (double_brackets_fun, value, index, baseenv);
getStructureSafe (child, childnames[i], 0, children[i], nesting_depth + 1);
}
UNPROTECT (1); /* index */
}
}
UNPROTECT (1); /* childnames_s */
RData *childdata = new RData;
childdata->setData (children);
res[RObject::StoragePositionChildren] = childdata;
if (is_environment && at_toplevel && with_namespace) {
RData *namespacedata = new RData;
if (no_recurse) {
type |= RObject::Incomplete;
RK_DEBUG (RBACKEND, DL_DEBUG, "Depth limit reached. Will not recurse into namespace of %s", name.toLatin1().data ());
} else {
RData::RDataStorage dummy (1, 0);
dummy[0] = new RData ();
getStructureSafe (namespace_envir, "NAMESPACE", RObject::PseudoObject, dummy[0], nesting_depth+99); // HACK: By default, do not recurse into the children of the namespace, until dealing with the namespace object itself.
namespacedata->setData (dummy);
}
res.insert (RObject::StoragePositionNamespace, namespacedata);
}
} else if (is_function) {
// TODO: getting the formals is still a bit of a bottleneck, but no idea, how to improve on this, any further
SEXP formals_s;
if (Rf_isPrimitive (value)) formals_s = FORMALS (RKRSupport::callSimpleFun (args_fun, value, baseenv)); // primitives don't have formals, internally
else formals_s = FORMALS (value);
PROTECT (formals_s);
// get the default values
QStringList formals = RKRSupport::SEXPToStringList (formals_s);
// for the most part, the implicit as.character in SEXPToStringList does a good on the formals (and it's the fastest of many options that I have tried).
// Only for naked strings (as in 'function (a="something")'), we're missing the quotes. So we add quotes, after conversion, as needed:
SEXP dummy = formals_s;
const int formals_len = Rf_length (formals_s);
for (int i = 0; i < formals_len; ++i) {
if (TYPEOF (CAR (dummy)) == STRSXP) formals[i] = RKRSharedFunctionality::quote (formals[i]);
dummy = CDR (dummy);
}
RData *funargvaluesdata = new RData;
funargvaluesdata->setData (formals);
// the argument names
SEXP names_s = Rf_getAttrib (formals_s, R_NamesSymbol);
PROTECT (names_s);
RData *funargsdata = new RData;
funargsdata->setData (RKRSupport::SEXPToStringList (names_s));
UNPROTECT (2); /* names_s, formals_s */
res[RObject::StoragePositionFunArgs] = funargsdata;
res[RObject::StoragePositionFunValues] = funargvaluesdata;
}
UNPROTECT (1); /* value */
RK_ASSERT (!res.contains (0));
storage->setData (res);
}
