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);
}
void ffi_PrintCIF(SEXP cif) {
SEXP p = R_ExternalPtrProtected(cif);
SEXP r = VECTOR_ELT(p,0);
SEXP a = VECTOR_ELT(p,1);
int i;
ffi_PrintTypeCode(r);Rprintf(" (*FUN)(");
for(i=0;i<length(a);i++) {
ffi_PrintTypeCode(VECTOR_ELT(a,i));
if(i+1<length(a)) Rprintf(",");
}
Rprintf(")\n");
}
SEXP
R_duplicateArray(SEXP r_ref, SEXP r_size, SEXP r_elementDup)
{
void *array, *copy;
size_t numBytes = (size_t) REAL(r_size)[0];
SEXP r_ans, tmp;
array = R_getNativeReference(r_ref, NULL, NULL);
copy = malloc( numBytes );
if(!copy) {
PROBLEM "Cannot allocate %lf bytes to copy native array", REAL(r_size)[0]
ERROR;
}
memcpy(copy, array, numBytes);
tmp = GET_SLOT(r_ref, Rf_install("ref"));
r_ans = R_MakeExternalPtr(copy, R_ExternalPtrTag(tmp), R_ExternalPtrProtected(tmp));
return(r_ans);
}
static void RPROC ExternalRef_finalizer (SEXP externalref) {
char *pszDestructor = (char*)R_ExternalPtrAddr (externalref);
if (pszDestructor) {
SEXP value = R_ExternalPtrProtected (externalref);
PROTECT (value);
Data data;
#ifdef _WIN32
ZeroMemory (&data, sizeof (data));
#else /* ifdef _WIN32 */
memset (&data, 0, sizeof (data));
#endif /* ifdef _WIN32 */
CRCallback oR (R_GlobalEnv);
data._single = CValue::FromSEXP (&oR, value);
UNPROTECT (1);
R_ClearExternalPtr (externalref);
if (data._single) {
LOGDEBUG ("Calling destructor '" << pszDestructor << "'");
if (g_poProcedures) {
const CProcedureEntry *poEntry = g_poProcedures->Get (pszDestructor);
if (poEntry) {
const Data *apArgs[1] = { &data };
LOGINFO ("Invoke " << poEntry->GetName ());
g_poProcedures->Invoke (poEntry, apArgs, NULL, NULL);
} else {
LOGERROR (ERR_PARAMETER_VALUE);
}
} else {
LOGERROR (ERR_INITIALISATION);
}
CValue::Release (data._single);
} else {
LOGERROR (ERR_PARAMETER_VALUE);
}
free (pszDestructor);
} else {
LOGERROR (ERR_PARAMETER_VALUE);
}
}
SEXP R_ptr_get_prot(SEXP ptr_col){
return R_ExternalPtrProtected(ptr_col);
}
SEXP RExternalRef::Fetch (SEXP externalref) {
return R_ExternalPtrProtected (externalref);
}
SEXP R_handle_setopt(SEXP ptr, SEXP keys, SEXP values){
CURL *handle = get_handle(ptr);
SEXP prot = R_ExternalPtrProtected(ptr);
SEXP optnames = PROTECT(getAttrib(values, R_NamesSymbol));
if(!isInteger(keys))
error("keys` must be an integer");
if(!isVector(values))
error("`values` must be a list");
for(int i = 0; i < length(keys); i++){
int key = INTEGER(keys)[i];
const char* optname = CHAR(STRING_ELT(optnames, i));
SEXP val = VECTOR_ELT(values, i);
if(val == R_NilValue){
assert(curl_easy_setopt(handle, key, NULL));
#ifdef HAS_XFERINFOFUNCTION
} else if (key == CURLOPT_XFERINFOFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_XFERINFOFUNCTION,
(curl_progress_callback) R_curl_callback_xferinfo));
assert(curl_easy_setopt(handle, CURLOPT_XFERINFODATA, val));
assert(curl_easy_setopt(handle, CURLOPT_NOPROGRESS, 0));
SET_VECTOR_ELT(prot, 1, val); //protect gc
#endif
} else if (key == CURLOPT_PROGRESSFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_PROGRESSFUNCTION,
(curl_progress_callback) R_curl_callback_progress));
assert(curl_easy_setopt(handle, CURLOPT_PROGRESSDATA, val));
assert(curl_easy_setopt(handle, CURLOPT_NOPROGRESS, 0));
SET_VECTOR_ELT(prot, 2, val); //protect gc
} else if (key == CURLOPT_READFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_READFUNCTION,
(curl_read_callback) R_curl_callback_read));
assert(curl_easy_setopt(handle, CURLOPT_READDATA, val));
SET_VECTOR_ELT(prot, 3, val); //protect gc
} else if (key == CURLOPT_DEBUGFUNCTION) {
if (TYPEOF(val) != CLOSXP)
error("Value for option %s (%d) must be a function.", optname, key);
assert(curl_easy_setopt(handle, CURLOPT_DEBUGFUNCTION,
(curl_debug_callback) R_curl_callback_debug));
assert(curl_easy_setopt(handle, CURLOPT_DEBUGDATA, val));
SET_VECTOR_ELT(prot, 4, val); //protect gc
} else if (key == CURLOPT_URL) {
/* always use utf-8 for urls */
const char * url_utf8 = translateCharUTF8(STRING_ELT(val, 0));
assert(curl_easy_setopt(handle, CURLOPT_URL, url_utf8));
} else if (opt_is_linked_list(key)) {
error("Option %s (%d) not supported.", optname, key);
} else if(key < 10000){
if(!isNumeric(val) || length(val) != 1) {
error("Value for option %s (%d) must be a number.", optname, key);
}
assert(curl_easy_setopt(handle, key, (long) asInteger(val)));
} else if(key < 20000){
switch (TYPEOF(val)) {
case RAWSXP:
if(key == CURLOPT_POSTFIELDS || key == CURLOPT_COPYPOSTFIELDS)
assert(curl_easy_setopt(handle, CURLOPT_POSTFIELDSIZE_LARGE, (curl_off_t) Rf_length(val)));
assert(curl_easy_setopt(handle, key, RAW(val)));
break;
case STRSXP:
if (length(val) != 1)
error("Value for option %s (%d) must be length-1 string", optname, key);
assert(curl_easy_setopt(handle, key, CHAR(STRING_ELT(val, 0))));
break;
default:
error("Value for option %s (%d) must be a string or raw vector.", optname, key);
}
} else if(key >= 30000 && key < 40000){
if(!isNumeric(val) || length(val) != 1) {
error("Value for option %s (%d) must be a number.", optname, key);
}
assert(curl_easy_setopt(handle, key, (curl_off_t) asReal(val)));
} else {
error("Option %s (%d) not supported.", optname, key);
}
}
UNPROTECT(1);
return ScalarLogical(1);
}
SEXP FFI_SummaryCIF(SEXP cif) {
return R_ExternalPtrProtected(cif);
}
