void rlang_register_pointer(const char* ns, const char* ptr_name, DL_FUNC fn) {
SEXP ptr = PROTECT(R_MakeExternalPtrFn(fn, R_NilValue, R_NilValue));
SEXP ptr_obj = PROTECT(Rf_allocVector(VECSXP, 1));
SET_VECTOR_ELT(ptr_obj, 0, ptr);
Rf_setAttrib(ptr_obj, R_ClassSymbol, Rf_mkString("fn_pointer"));
Rf_defineVar(Rf_install(ptr_name), ptr_obj, rlang_namespace(ns));
UNPROTECT(2);
}
static char *RAPIinstalladdons(void) {
int evalErr;
ParseStatus status;
char rlibs[FILENAME_MAX];
char rapiinclude[BUFSIZ];
SEXP librisexp;
int len;
// r library folder, create if not exists
len = snprintf(rlibs, sizeof(rlibs), "%s%c%s", GDKgetenv("gdk_dbpath"), DIR_SEP, "rapi_packages");
if (len == -1 || len >= FILENAME_MAX)
return "cannot create rapi_packages directory because the path is too large";
if (mkdir(rlibs, S_IRWXU) != 0 && errno != EEXIST) {
return "cannot create rapi_packages directory";
}
#ifdef _RAPI_DEBUG_
printf("# R libraries installed in %s\n",rlibs);
#endif
PROTECT(librisexp = allocVector(STRSXP, 1));
SET_STRING_ELT(librisexp, 0, mkChar(rlibs));
Rf_defineVar(Rf_install(".rapi.libdir"), librisexp, R_GlobalEnv);
UNPROTECT(1);
// run rapi.R environment setup script
{
char *f = locate_file("rapi", ".R", 0);
snprintf(rapiinclude, sizeof(rapiinclude), "source(\"%s\")", f);
GDKfree(f);
}
#if DIR_SEP != '/'
{
char *p;
for (p = rapiinclude; *p; p++)
if (*p == DIR_SEP)
*p = '/';
}
#endif
R_tryEvalSilent(
VECTOR_ELT(
R_ParseVector(mkString(rapiinclude), 1, &status,
R_NilValue), 0), R_GlobalEnv, &evalErr);
// of course the script may contain errors as well
if (evalErr != FALSE) {
return "failure running R setup script";
}
return NULL;
}
void plot::save_snapshot_variable() {
rhost::util::errors_to_exceptions([&] {
pGEDevDesc ge_dev_desc = Rf_desc2GEDesc(_device_desc);
SEXP snapshot = Rf_protect(GEcreateSnapshot(ge_dev_desc));
SEXP klass = Rf_protect(Rf_mkString("recordedplot"));
Rf_classgets(snapshot, klass);
Rf_defineVar(Rf_install(_snapshot_varname.c_str()), snapshot, R_GlobalEnv);
Rf_unprotect(2);
});
}
SEXP init_Rcpp_cache(){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
Rcpp::Shield<SEXP> RCPP( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
Rcpp::Shield<SEXP> cache( Rf_allocVector( VECSXP, RCPP_CACHE_SIZE ) );
// the Rcpp namespace
SET_VECTOR_ELT( cache, 0, RCPP ) ;
set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ; // error occured
set_current_error( cache, R_NilValue ) ; // current error
SET_VECTOR_ELT( cache, 3, R_NilValue ) ; // stack trace
SET_VECTOR_ELT( cache, RCPP_HASH_CACHE_INDEX, Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE) ) ;
Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
return cache ;
}
void plot::set_snapshot(const rhost::util::protected_sexp& snapshot) {
// Ignore if we already created a snapshot
if (_snapshot_varname.empty()) {
_snapshot_varname = get_snapshot_varname();
}
rhost::util::errors_to_exceptions([&] {
SEXP klass = Rf_protect(Rf_mkString("recordedplot"));
Rf_classgets(snapshot.get(), klass);
SEXP duplicated_snapshot = Rf_protect(Rf_duplicate(snapshot.get()));
Rf_defineVar(Rf_install(_snapshot_varname.c_str()), duplicated_snapshot, R_GlobalEnv);
Rf_unprotect(2);
});
}
char *oc_register(SEXP what, char *dst, int len, const char *name) {
SEXP x;
if (len <= MAX_OC_TOKEN_LEN) return NULL;
if (!oc_env) {
SEXP env = eval(PROTECT(lang3(install("new.env"), ScalarLogical(TRUE), R_EmptyEnv)), R_GlobalEnv);
UNPROTECT(1);
if (TYPEOF(env) != ENVSXP) return NULL;
oc_env = env;
R_PreserveObject(oc_env);
}
x = PROTECT(CONS(what, R_NilValue));
if (name) SET_TAG(x, install(name));
oc_new(dst);
Rf_defineVar(install(dst), x, oc_env);
UNPROTECT(1);
return dst;
}
int
SexpEnvironment_setvalue(const SEXP envir, const char* name, const SEXP value) {
if (! RINTERF_ISREADY()) {
printf("R is not ready.\n");
return -1;
}
RStatus ^= RINTERF_IDLE;
SEXP symbol;
symbol = Rf_install(name);
//FIXME: is the copy really needed / good ?
SEXP value_copy;
PROTECT(value_copy = Rf_duplicate(value));
Rf_defineVar(symbol, value_copy, envir);
//FIXME: protect/unprotect from garbage collection (for now protect only)
UNPROTECT(1);
RStatus ^= RINTERF_IDLE;
return 0;
}
SEXP init_Rcpp_cache(){
SEXP getNamespaceSym = Rf_install("getNamespace"); // cannot be gc()'ed once in symbol table
SEXP RCPP = PROTECT( Rf_eval(Rf_lang2( getNamespaceSym, Rf_mkString("Rcpp") ), R_GlobalEnv) ) ;
SEXP cache = PROTECT( Rf_allocVector( VECSXP, RCPP_CACHE_SIZE ) );
// the Rcpp namespace
SET_VECTOR_ELT( cache, 0, RCPP ) ;
set_error_occured( cache, Rf_ScalarLogical(FALSE) ) ; // error occured
set_current_error( cache, R_NilValue ) ; // current error
SET_VECTOR_ELT( cache, 3, R_NilValue ) ; // stack trace
SET_VECTOR_ELT( cache, RCPP_HASH_CACHE_INDEX, Rf_allocVector(INTSXP, RCPP_HASH_CACHE_INITIAL_SIZE) ) ;
SEXP stack = PROTECT(Rf_allocVector(VECSXP, RCPP_PROTECT_STACK_INITIAL_SIZE)) ;
// we use true length to store "top"
SET_TRUELENGTH(stack, -1 ) ;
SET_VECTOR_ELT( cache, RCPP_PROTECTION_STACK_INDEX, stack ) ;
Rf_defineVar( Rf_install(".rcpp_cache"), cache, RCPP );
UNPROTECT(3) ;
return cache ;
}
str RAPIprelude(void *ret) {
(void) ret;
if (RAPIEnabled()) {
MT_lock_set(&rapiLock);
/* startup internal R environment */
if (!rapiInitialized) {
char *initstatus;
initstatus = RAPIinitialize();
if (initstatus != 0) {
MT_lock_unset(&rapiLock);
throw(MAL, "rapi.eval",
"failed to initialize R environment (%s)", initstatus);
}
Rf_defineVar(Rf_install("MONETDB_LIBDIR"), ScalarString(RSTR(LIBDIR)), R_GlobalEnv);
}
MT_lock_unset(&rapiLock);
printf("# MonetDB/R module loaded\n");
}
return MAL_SUCCEED;
}
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;
}
str RAPIeval(Client cntxt, MalBlkPtr mb, MalStkPtr stk, InstrPtr pci, bit grouped) {
sql_func * sqlfun = NULL;
str exprStr = *getArgReference_str(stk, pci, pci->retc + 1);
SEXP x, env, retval;
SEXP varname = R_NilValue;
SEXP varvalue = R_NilValue;
ParseStatus status;
int i = 0;
char argbuf[64];
char *argnames = NULL;
size_t argnameslen;
size_t pos;
char* rcall = NULL;
size_t rcalllen;
int ret_cols = 0; /* int because pci->retc is int, too*/
str *args;
int evalErr;
char *msg = MAL_SUCCEED;
BAT *b;
node * argnode;
int seengrp = FALSE;
rapiClient = cntxt;
if (!RAPIEnabled()) {
throw(MAL, "rapi.eval",
"Embedded R has not been enabled. Start server with --set %s=true",
rapi_enableflag);
}
if (!rapiInitialized) {
throw(MAL, "rapi.eval",
"Embedded R initialization has failed");
}
if (!grouped) {
sql_subfunc *sqlmorefun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc));
if (sqlmorefun) sqlfun = (*(sql_subfunc**) getArgReference(stk, pci, pci->retc))->func;
} else {
sqlfun = *(sql_func**) getArgReference(stk, pci, pci->retc);
}
args = (str*) GDKzalloc(sizeof(str) * pci->argc);
if (args == NULL) {
throw(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
}
// get the lock even before initialization of the R interpreter, as this can take a second and must be done only once.
MT_lock_set(&rapiLock);
env = PROTECT(eval(lang1(install("new.env")), R_GlobalEnv));
assert(env != NULL);
// first argument after the return contains the pointer to the sql_func structure
// NEW macro temporarily renamed to MNEW to allow including sql_catalog.h
if (sqlfun != NULL && sqlfun->ops->cnt > 0) {
int carg = pci->retc + 2;
argnode = sqlfun->ops->h;
while (argnode) {
char* argname = ((sql_arg*) argnode->data)->name;
args[carg] = GDKstrdup(argname);
carg++;
argnode = argnode->next;
}
}
// the first unknown argument is the group, we don't really care for the rest.
argnameslen = 2;
for (i = pci->retc + 2; i < pci->argc; i++) {
if (args[i] == NULL) {
if (!seengrp && grouped) {
args[i] = GDKstrdup("aggr_group");
seengrp = TRUE;
} else {
snprintf(argbuf, sizeof(argbuf), "arg%i", i - pci->retc - 1);
args[i] = GDKstrdup(argbuf);
}
}
argnameslen += strlen(args[i]) + 2; /* extra for ", " */
}
// install the MAL variables into the R environment
// we can basically map values to int ("INTEGER") or double ("REAL")
for (i = pci->retc + 2; i < pci->argc; i++) {
int bat_type = getBatType(getArgType(mb,pci,i));
// check for BAT or scalar first, keep code left
if (!isaBatType(getArgType(mb,pci,i))) {
b = COLnew(0, getArgType(mb, pci, i), 0, TRANSIENT);
if (b == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
if ( getArgType(mb,pci,i) == TYPE_str) {
if (BUNappend(b, *getArgReference_str(stk, pci, i), false) != GDK_SUCCEED) {
BBPreclaim(b);
b = NULL;
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
} else {
if (BUNappend(b, getArgReference(stk, pci, i), false) != GDK_SUCCEED) {
BBPreclaim(b);
b = NULL;
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
} else {
b = BATdescriptor(*getArgReference_bat(stk, pci, i));
if (b == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
// check the BAT count, if it is bigger than RAPI_MAX_TUPLES, fail
if (BATcount(b) > RAPI_MAX_TUPLES) {
msg = createException(MAL, "rapi.eval",
"Got "BUNFMT" rows, but can only handle "LLFMT". Sorry.",
BATcount(b), (lng) RAPI_MAX_TUPLES);
BBPunfix(b->batCacheid);
goto wrapup;
}
varname = PROTECT(Rf_install(args[i]));
varvalue = bat_to_sexp(b, bat_type);
if (varvalue == NULL) {
msg = createException(MAL, "rapi.eval", "unknown argument type ");
goto wrapup;
}
BBPunfix(b->batCacheid);
// install vector into R environment
Rf_defineVar(varname, varvalue, env);
UNPROTECT(2);
}
/* we are going to evaluate the user function within an anonymous function call:
* ret <- (function(arg1){return(arg1*2)})(42)
* the user code is put inside the {}, this keeps our environment clean (TM) and gives
* a clear path for return values, namely using the builtin return() function
* this is also compatible with PL/R
*/
pos = 0;
argnames = malloc(argnameslen);
if (argnames == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
argnames[0] = '\0';
for (i = pci->retc + 2; i < pci->argc; i++) {
pos += snprintf(argnames + pos, argnameslen - pos, "%s%s",
args[i], i < pci->argc - 1 ? ", " : "");
}
rcalllen = 2 * pos + strlen(exprStr) + 100;
rcall = malloc(rcalllen);
if (rcall == NULL) {
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
snprintf(rcall, rcalllen,
"ret <- as.data.frame((function(%s){%s})(%s), nm=NA, stringsAsFactors=F)\n",
argnames, exprStr, argnames);
free(argnames);
argnames = NULL;
#ifdef _RAPI_DEBUG_
printf("# R call %s\n",rcall);
#endif
x = R_ParseVector(mkString(rcall), 1, &status, R_NilValue);
if (LENGTH(x) != 1 || status != PARSE_OK) {
msg = createException(MAL, "rapi.eval",
"Error parsing R expression '%s'. ", exprStr);
goto wrapup;
}
retval = R_tryEval(VECTOR_ELT(x, 0), env, &evalErr);
if (evalErr != FALSE) {
char* errormsg = strdup(R_curErrorBuf());
size_t c;
if (errormsg == NULL) {
msg = createException(MAL, "rapi.eval", "Error running R expression.");
goto wrapup;
}
// remove newlines from error message so it fits into a MAPI error (lol)
for (c = 0; c < strlen(errormsg); c++) {
if (errormsg[c] == '\r' || errormsg[c] == '\n') {
errormsg[c] = ' ';
}
}
msg = createException(MAL, "rapi.eval",
"Error running R expression: %s", errormsg);
free(errormsg);
goto wrapup;
}
// ret should be a data frame with exactly as many columns as we need from retc
ret_cols = LENGTH(retval);
if (ret_cols != pci->retc) {
msg = createException(MAL, "rapi.eval",
"Expected result of %d columns, got %d", pci->retc, ret_cols);
goto wrapup;
}
// collect the return values
for (i = 0; i < pci->retc; i++) {
SEXP ret_col = VECTOR_ELT(retval, i);
int bat_type = getBatType(getArgType(mb,pci,i));
if (bat_type == TYPE_any || bat_type == TYPE_void) {
getArgType(mb,pci,i) = bat_type;
msg = createException(MAL, "rapi.eval",
"Unknown return value, possibly projecting with no parameters.");
goto wrapup;
}
// hand over the vector into a BAT
b = sexp_to_bat(ret_col, bat_type);
if (b == NULL) {
msg = createException(MAL, "rapi.eval",
"Failed to convert column %i", i);
goto wrapup;
}
// bat return
if (isaBatType(getArgType(mb,pci,i))) {
*getArgReference_bat(stk, pci, i) = b->batCacheid;
} else { // single value return, only for non-grouped aggregations
BATiter li = bat_iterator(b);
if (VALinit(&stk->stk[pci->argv[i]], bat_type,
BUNtail(li, 0)) == NULL) { // TODO BUNtail here
msg = createException(MAL, "rapi.eval", SQLSTATE(HY001) MAL_MALLOC_FAIL);
goto wrapup;
}
}
msg = MAL_SUCCEED;
}
/* unprotect environment, so it will be eaten by the GC. */
UNPROTECT(1);
wrapup:
MT_lock_unset(&rapiLock);
if (argnames)
free(argnames);
if (rcall)
free(rcall);
for (i = 0; i < pci->argc; i++)
GDKfree(args[i]);
GDKfree(args);
return msg;
}
