static SEXP
convertNodeSetToR(xmlNodeSetPtr obj, SEXP fun, int encoding, SEXP manageMemory)
{
SEXP ans, expr = NULL, arg = NULL, ref;
int i;
if(!obj)
return(NULL_USER_OBJECT);
PROTECT(ans = NEW_LIST(obj->nodeNr));
if(GET_LENGTH(fun) && (TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)) {
PROTECT(expr = allocVector(LANGSXP, 2));
SETCAR(expr, fun);
arg = CDR(expr);
} else if(TYPEOF(fun) == LANGSXP) {
expr = fun;
arg = CDR(expr);
}
for(i = 0; i < obj->nodeNr; i++) {
xmlNodePtr el;
el = obj->nodeTab[i];
if(el->type == XML_ATTRIBUTE_NODE) {
#if 0
PROTECT(ref = mkString((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : ""));
SET_NAMES(ref, mkString(el->name));
#else
PROTECT(ref = ScalarString(mkCharCE((el->children && el->children->content) ? XMLCHAR_TO_CHAR(el->children->content) : "", encoding)));
SET_NAMES(ref, ScalarString(mkCharCE(el->name, encoding)));
#endif
SET_CLASS(ref, mkString("XMLAttributeValue"));
UNPROTECT(1);
} else if(el->type == XML_NAMESPACE_DECL)
ref = R_createXMLNsRef((xmlNsPtr) el);
else
ref = R_createXMLNodeRef(el, manageMemory);
if(expr) {
PROTECT(ref);
SETCAR(arg, ref);
PROTECT(ref = Rf_eval(expr, R_GlobalEnv)); /*XXX do we want to catch errors here? Maybe to release the namespaces. */
SET_VECTOR_ELT(ans, i, ref);
UNPROTECT(2);
} else
SET_VECTOR_ELT(ans, i, ref);
}
if(expr) {
if(TYPEOF(fun) == CLOSXP || TYPEOF(fun) == BUILTINSXP)
UNPROTECT(1);
} else
SET_CLASS(ans, mkString("XMLNodeSet"));
UNPROTECT(1);
return(ans);
}
/* split on \r\n or just one */
static SEXP splitClipboardText(const char *s, int ienc)
{
int cnt_r= 0, cnt_n = 0, n, nc, nl, line_len = 0;
const char *p;
char *line, *q, eol = '\n';
Rboolean last = TRUE; /* does final line have EOL */
Rboolean CRLF = FALSE;
SEXP ans;
for(p = s, nc = 0; *p; p++, nc++)
switch(*p) {
case '\n':
cnt_n++;
last = TRUE;
line_len = max(line_len, nc);
nc = -1;
break;
case '\r':
cnt_r++;
last = TRUE;
break;
default:
last = FALSE;
}
if (!last) line_len = max(line_len, nc); /* the unterminated last might be the longest */
n = max(cnt_n, cnt_r) + (last ? 0 : 1);
if (cnt_n == 0 && cnt_r > 0) eol = '\r';
if (cnt_r == cnt_n) CRLF = TRUE;
/* over-allocate a line buffer */
line = R_chk_calloc(1+line_len, 1);
PROTECT(ans = allocVector(STRSXP, n));
for(p = s, q = line, nl = 0; *p; p++) {
if (*p == eol) {
*q = '\0';
SET_STRING_ELT(ans, nl++, mkCharCE(line, ienc));
q = line;
*q = '\0';
} else if(CRLF && *p == '\r')
;
else *q++ = *p;
}
if (!last) {
*q = '\0';
SET_STRING_ELT(ans, nl, mkCharCE(line, ienc));
}
R_chk_free(line);
UNPROTECT(1);
return(ans);
}
static SEXP insertString(char *str, LocalData *l)
{
cetype_t enc = CE_NATIVE;
if (l->con->UTF8out || l->isUTF8) enc = CE_UTF8;
else if (l->isLatin1) enc = CE_LATIN1;
return mkCharCE(str, enc);
}
SEXP R_curl_escape(SEXP url, SEXP unescape_) {
if (TYPEOF(url) != STRSXP)
error("`url` must be a character vector.");
/* init curl */
CURL *curl = curl_easy_init();
if (!curl)
return(R_NilValue);
int unescape = asLogical(unescape_);
int n = Rf_length(url);
SEXP output = PROTECT(allocVector(STRSXP, n));
for (int i = 0; i < n; ++i) {
const char *in = CHAR(STRING_ELT(url, i));
char *out;
if (unescape) {
out = curl_easy_unescape(curl, in, 0, NULL);
} else {
out = curl_easy_escape(curl, in, 0);
}
SET_STRING_ELT(output, i, mkCharCE(out, CE_UTF8));
curl_free(out);
}
curl_easy_cleanup(curl);
UNPROTECT(1);
return output;
}
SEXP util_C2SEXP(void* arr,int type,int n) {
SEXP ans;
int i;
if(type==0) {
PROTECT(ans=allocVector(REALSXP,n));
for(i=0;i<n;i++) {
REAL(ans)[i]=((double*)arr)[i];
}
UNPROTECT(1);
} else if(type==1) {
PROTECT(ans=allocVector(INTSXP,n));
for(i=0;i<n;i++) {
INTEGER(ans)[i]=((int*)arr)[i];
}
UNPROTECT(1);
} else if(type==2) {
PROTECT(ans=allocVector(LGLSXP,n));
for(i=0;i<n;i++) {
LOGICAL(ans)[i]=((int*)arr)[i];
}
UNPROTECT(1);
} else if(type==3) {
PROTECT(ans=allocVector(STRSXP,n));
for(i=0;i<n;i++) {
char* str=((char**)arr)[i];
//printf("[%d]=%s|\n",i,str);
SET_STRING_ELT(ans,i,mkCharCE(str,CE_UTF8));
}
UNPROTECT(1);
} else ans=R_NilValue;
return ans;
}
static SEXP mkCharUcs(wchar_t *name)
{
int n = wcslen(name), N = 3*n+1;
char buf[N];
R_CheckStack();
wcstombs(buf, name, N); buf[N-1] = '\0';
return mkCharCE(buf, CE_UTF8);
}
/* collapse a json object with n spaces */
SEXP C_collapse_object_pretty(SEXP x, SEXP y, SEXP indent) {
if (!isString(x) || !isString(y))
error("x and y must character vectors.");
int ni = asInteger(indent);
if(ni == NA_INTEGER)
error("indent must not be NA");
int len = length(x);
if (len != length(y))
error("x and y must have same length.");
//calculate required space
size_t nchar_total = 0;
for (int i=0; i<len; i++) {
if(STRING_ELT(y, i) == NA_STRING) continue;
nchar_total += strlen(translateCharUTF8(STRING_ELT(x, i)));
nchar_total += strlen(translateCharUTF8(STRING_ELT(y, i)));
nchar_total += ni + 6; //indent plus two extra spaces plus ": " and ",\n"
}
//final indent plus curly braces and linebreak and terminator
nchar_total += (ni + 2 + 2);
//allocate memory and create a cursor
char *str = malloc(nchar_total);
char *cursor = str;
char **cur = &cursor;
//init object
append_text(cur, "{", 1);
const char *start = *cur;
//copy everything
for (int i=0; i<len; i++) {
if(STRING_ELT(y, i) == NA_STRING) continue;
append_text(cur, "\n", 1);
append_whitespace(cur, ni + 2);
append_text(cur, translateCharUTF8(STRING_ELT(x, i)), -1);
append_text(cur, ": ", 2);
append_text(cur, translateCharUTF8(STRING_ELT(y, i)), -1);
append_text(cur, ",", 1);
}
//finalize object
if(cursor != start){
cursor[-1] = '\n';
append_whitespace(cur, ni);
}
append_text(cur, "}\0", 2);
//encode as UTF8 string
SEXP out = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(out, 0, mkCharCE(str, CE_UTF8));
UNPROTECT(1);
free(str);
return out;
}
/* Operates on three CHARSXP (internal) arguments. Returns STRSXP vector.
* Returned strings alternate between "outside" and "inside" blocks.
* E.g. "Four .(score) and seven .(years)"
* returns c("Four ", "score", " and seven ", "years")
*/
SEXP find_subst_expressions(SEXP str, SEXP begin_delim, SEXP end_delim) {
const char *s, *b, *e;
const char *p, *start;
const char *before, *begin, *end, *after;
cetype_t enc;
step_t step;
int nBlocks, i;
SEXP out;
assert_type(str, CHARSXP);
assert_type(begin_delim, CHARSXP);
assert_type(end_delim, CHARSXP);
step = get_stepper(str, &s, &enc);
if (getCharCE(begin_delim) != enc) {
b = Rf_reEnc(CHAR(begin_delim), getCharCE(begin_delim), enc, 0);
} else {
b = CHAR(begin_delim);
}
if (getCharCE(end_delim) != enc) {
e = Rf_reEnc(CHAR(end_delim), getCharCE(end_delim), enc, 0);
} else {
e = CHAR(end_delim);
}
/* Scan once to count how many blocks we need, then scan again (ugh) */
nBlocks = 0;
p = s;
while(p && *p) {
if ( (p = block_search(p, b, e, NULL, NULL, NULL, NULL, step)) ) {
nBlocks++;
}
}
out = PROTECT(allocVector(STRSXP, 2*nBlocks+1));
start = s;
p = s;
for (i = 0; i < nBlocks; i++) {
p = block_search(p, b, e,
&before, &begin, &end, &after,
step);
/* extract leading unescaped block, then escaped block */
if (p) {
SET_STRING_ELT(out, 2*i, mkCharLenCE(start, before-start, enc));
SET_STRING_ELT(out, 2*i+1, mkCharLenCE(begin, end-begin, enc));
start = after;
}
}
/* then the rest of the string. */
SET_STRING_ELT(out, 2*i, mkCharCE(start, enc));
UNPROTECT(1);
return out;
}
SEXP C_collapse_array_pretty_outer(SEXP x, SEXP indent) {
if (!isString(x))
error("x must character vector.");
int len = length(x);
int ni = asInteger(indent);
if(ni == NA_INTEGER)
error("indent must not be NA");
//calculate required space
size_t nchar_total = 0;
for (int i=0; i<len; i++) {
nchar_total += strlen(translateCharUTF8(STRING_ELT(x, i)));
}
//for indent plus two extra spaces plus ",\n"
nchar_total += len * (ni + 4);
//outer parentheses plus final indent and linebreak and terminator
nchar_total += ni + 4;
//allocate memory and create a cursor
char *str = malloc(nchar_total);
char *cursor = str;
char **cur = &cursor;
//init object
append_text(cur, "[", 1);
const char *start = *cur;
//copy everything
for (int i=0; i<len; i++) {
append_text(cur, "\n", 1);
append_whitespace(cur, ni + 2);
append_text(cur, translateCharUTF8(STRING_ELT(x, i)), -1);
append_text(cur, ",", 1);
}
//remove trailing ", "
if(cursor != start){
cursor[-1] = '\n';
append_whitespace(cur, ni);
}
//finish up
append_text(cur, "]\0", 2);
//encode as UTF8 string
SEXP out = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(out, 0, mkCharCE(str, CE_UTF8));
UNPROTECT(1);
free(str);
return out;
}
SEXP ParseObject(yajl_val node, int bigint){
int len = YAJL_GET_OBJECT(node)->len;
SEXP keys = PROTECT(allocVector(STRSXP, len));
SEXP vec = PROTECT(allocVector(VECSXP, len));
for (int i = 0; i < len; ++i) {
SET_STRING_ELT(keys, i, mkCharCE(YAJL_GET_OBJECT(node)->keys[i], CE_UTF8));
SET_VECTOR_ELT(vec, i, ParseValue(YAJL_GET_OBJECT(node)->values[i], bigint));
}
setAttrib(vec, R_NamesSymbol, keys);
UNPROTECT(2);
return vec;
}
SEXP attribute_hidden do_substr(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, x, sa, so, el;
R_xlen_t i, len;
int start, stop, k, l;
size_t slen;
cetype_t ienc;
const char *ss;
char *buf;
checkArity(op, args);
x = CAR(args);
sa = CADR(args);
so = CADDR(args);
k = LENGTH(sa);
l = LENGTH(so);
if (!isString(x))
error(_("extracting substrings from a non-character object"));
len = XLENGTH(x);
PROTECT(s = allocVector(STRSXP, len));
if (len > 0) {
if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
error(_("invalid substring arguments"));
for (i = 0; i < len; i++) {
start = INTEGER(sa)[i % k];
stop = INTEGER(so)[i % l];
el = STRING_ELT(x,i);
if (el == NA_STRING || start == NA_INTEGER || stop == NA_INTEGER) {
SET_STRING_ELT(s, i, NA_STRING);
continue;
}
ienc = getCharCE(el);
ss = CHAR(el);
slen = strlen(ss); /* FIXME -- should handle embedded nuls */
buf = R_AllocStringBuffer(slen+1, &cbuff);
if (start < 1) start = 1;
if (start > stop || start > slen) {
buf[0] = '\0';
} else {
if (stop > slen) stop = (int) slen;
substr(buf, ss, ienc, start, stop);
}
SET_STRING_ELT(s, i, mkCharCE(buf, ienc));
}
R_FreeStringBufferL(&cbuff);
}
DUPLICATE_ATTRIB(s, x);
/* This copied the class, if any */
UNPROTECT(1);
return s;
}
SEXP ParseValue(yajl_val node, int bigint){
if(YAJL_IS_NULL(node)){
return R_NilValue;
}
if(YAJL_IS_STRING(node)){
SEXP tmp = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(tmp, 0, mkCharCE(YAJL_GET_STRING(node), CE_UTF8));
UNPROTECT(1);
return tmp;
}
if(YAJL_IS_INTEGER(node)){
long long int val = YAJL_GET_INTEGER(node);
/* 2^53 is highest int stored as double without loss */
if(bigint && (val > 9007199254740992 || val < -9007199254740992)){
char buf[32];
#ifdef _WIN32
snprintf(buf, 32, "%I64d", val);
#else
snprintf(buf, 32, "%lld", val);
#endif
return mkString(buf);
/* see .Machine$integer.max in R */
} else if(val > 2147483647 || val < -2147483647){
return ScalarReal(val);
} else {
return ScalarInteger(val);
}
}
if(YAJL_IS_DOUBLE(node)){
return(ScalarReal(YAJL_GET_DOUBLE(node)));
}
if(YAJL_IS_NUMBER(node)){
/* A number that is not int or double (very rare) */
/* This seems to correctly round to Inf/0/-Inf */
return(ScalarReal(YAJL_GET_DOUBLE(node)));
}
if(YAJL_IS_TRUE(node)){
return(ScalarLogical(1));
}
if(YAJL_IS_FALSE(node)){
return(ScalarLogical(0));
}
if(YAJL_IS_OBJECT(node)){
return(ParseObject(node, bigint));
}
if(YAJL_IS_ARRAY(node)){
return(ParseArray(node, bigint));
}
error("Invalid YAJL node type.");
}
static constxt char *convertToUTF8(constxt char *str, R_GE_gcontext *gc)
{
if (gc->fontface == 5) /* symbol font needs re-coding to UTF-8 */
str = symbol2utf8(str);
#ifdef translateCharUTF8
else { /* first check whether we are dealing with non-ASCII at all */
int ascii = 1;
constxt unsigned char *c = (constxt unsigned char*) str;
while (*c) { if (*c > 127) { ascii = 0; break; } c++; }
if (!ascii) /* non-ASCII, we need to convert it to UTF8 */
str = translateCharUTF8(mkCharCE(str, CE_NATIVE));
}
#endif
return str;
}
SEXP
R_jsonPrettyPrint(SEXP r_content, SEXP r_encoding)
{
const char *str = CHAR(STRING_ELT(r_content, 0));
JSONNODE *node;
json_char *ans;
node = json_parse(str);
if(!node) {
PROBLEM "couldn't parse the JSON content"
ERROR;
}
ans = json_write_formatted(node);
return(ScalarString(mkCharCE(ans, INTEGER(r_encoding)[0])));
}
SEXP C_collapse_array_pretty_inner(SEXP x) {
if (!isString(x))
error("x must character vector.");
//calculate required space
int len = length(x);
size_t nchar_total = 0;
for (int i=0; i<len; i++) {
nchar_total += strlen(translateCharUTF8(STRING_ELT(x, i)));
}
// n-1 ", " separators
nchar_total += (len-1)*2;
//outer parentheses plus terminator
nchar_total += 3;
//allocate memory and create a cursor
char *str = malloc(nchar_total);
char *cursor = str;
char **cur = &cursor;
//init object
append_text(cur, "[", 1);
//copy everything
for (int i=0; i<len; i++) {
append_text(cur, translateCharUTF8(STRING_ELT(x, i)), -1);
append_text(cur, ", ", 2);
}
//remove trailing ", "
if(len) {
cursor -= 2;
}
//finish up
append_text(cur, "]\0", 2);
//encode as UTF8 string
SEXP out = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(out, 0, mkCharCE(str, CE_UTF8));
UNPROTECT(1);
free(str);
return out;
}
/* base::file.choose */
SEXP attribute_hidden do_filechoose(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans;
wchar_t *fn;
char str[4*MAX_PATH+1];
checkArity(op, args);
setuserfilterW(L"All files (*.*)\0*.*\0\0");
fn = askfilenameW(G_("Select file"), "");
if (!fn)
error(_("file choice cancelled"));
wcstoutf8(str, fn, 4*MAX_PATH+1);
PROTECT(ans = allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, mkCharCE(str, CE_UTF8));
UNPROTECT(1);
return ans;
}
static SEXP tabExpand(SEXP strings)
{
int i;
char buffer[200], *b;
const char *input;
SEXP result;
PROTECT(strings);
PROTECT(result = allocVector(STRSXP, length(strings)));
for (i = 0; i < length(strings); i++) {
input = CHAR(STRING_ELT(strings, i));
for (b = buffer; *input && (b-buffer < 192); input++) {
if (*input == '\t') do {
*b++ = ' ';
} while (((b-buffer) & 7) != 0);
else *b++ = *input;
}
*b = '\0';
SET_STRING_ELT(result, i, mkCharCE(buffer, Rf_getCharCE(STRING_ELT(strings, i))));
}
UNPROTECT(2);
return result;
}
static void cpnretprefix(CPN *p, int n) {
if (!p)
return;
if (n >= __CBUF_SIZE - 1) {
cpnfree(p);
return;
}
unsigned char cen = enc;
enc |= (p->index > 0x7F);
cbuf[n] = p->index;
#ifdef __DEBUG
cbuf[n+1] = 0;
Rprintf(" %3i %i %s\n", p->count, enc, cbuf);
#endif
if (p->count > tcnt) {
if (use_bytes ||
!known_to_be_utf8 ||
!p->pl || (p->pl->index & 0xC0) != 0x80) {
INTEGER(rval)[nap] = p->count;
#ifndef __DEBUG
cbuf[n+1] = 0;
#endif
SET_STRING_ELT(nval, nap, mkCharCE((const char *) cbuf,
get_known_encoding()));
nap++;
}
cpnretprefix(p->pl, n+1);
} else
if (inc)
cpnfree(p->pl);
else
cpnretprefix(p->pl, n+1);
enc = cen;
cpnretprefix(p->pr, n);
free(p);
ncpn--;
}
/* utils::shortPathName */
SEXP in_shortpath(SEXP paths)
{
SEXP ans, el;
int i, n = LENGTH(paths);
char tmp[MAX_PATH];
wchar_t wtmp[32768];
DWORD res;
const void *vmax = vmaxget();
if(!isString(paths)) error(_("'path' must be a character vector"));
PROTECT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
el = STRING_ELT(paths, i);
if(getCharCE(el) == CE_UTF8) {
res = GetShortPathNameW(filenameToWchar(el, FALSE), wtmp, 32768);
if (res && res <= 32768)
wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
else
strcpy(tmp, translateChar(el));
/* documented to return paths using \, which the API call does
not necessarily do */
R_fixbackslash(tmp);
SET_STRING_ELT(ans, i, mkCharCE(tmp, CE_UTF8));
} else {
res = GetShortPathName(translateChar(el), tmp, MAX_PATH);
if (res == 0 || res > MAX_PATH) strcpy(tmp, translateChar(el));
/* documented to return paths using \, which the API call does
not necessarily do */
R_fixbackslash(tmp);
SET_STRING_ELT(ans, i, mkChar(tmp));
}
}
UNPROTECT(1);
vmaxset(vmax);
return ans;
}
SEXP
R_json_dateStringOp(const char *value, cetype_t encoding)
{
int withNew = 0, noNew = 0;
if( (noNew = (strncmp(value, "/Date(", 6) == 0)) ||
(withNew = strncmp(value, "/new Date(", 10)) == 0) {
double num;
if(noNew)
sscanf(value + 6, "%lf)/", &num);
else
sscanf(value + 10, "%lf)/", &num);
SEXP ans, classNames;
PROTECT(ans = ScalarReal(num));
PROTECT(classNames = NEW_CHARACTER(2));
SET_STRING_ELT(classNames, 0, mkChar("POSIXct"));
SET_STRING_ELT(classNames, 1, mkChar("POSIXt"));
SET_CLASS(ans, classNames);
UNPROTECT(2);
return(ans);
} else
return(ScalarString(mkCharCE(value, encoding)));
}
SEXP R_readline_read_line(SEXP prompt, SEXP multiline, SEXP history,
SEXP completions) {
char *line;
SEXP result;
linenoiseSetEncodingFunctions(
linenoiseUtf8PrevCharLen,
linenoiseUtf8NextCharLen,
linenoiseUtf8ReadCode);
if (!isNull(history)) linenoiseHistoryLoad(CHAR(STRING_ELT(history, 0)));
if (!isNull(completions)) {
R_readline_completions = completions;
linenoiseSetCompletionCallback(R_readline_completion);
}
linenoiseSetMultiLine(LOGICAL(multiline)[0]);
line = linenoise(CHAR(STRING_ELT(prompt, 0)));
result = ScalarString(mkCharCE(line, CE_UTF8));
free(line);
return result;
}
SEXP R_reformat(SEXP x, SEXP pretty, SEXP indent_string) {
yajl_status stat;
yajl_handle hand;
yajl_gen g;
SEXP output;
/* init generator */
g = yajl_gen_alloc(NULL);
yajl_gen_config(g, yajl_gen_beautify, asInteger(pretty));
yajl_gen_config(g, yajl_gen_indent_string, translateCharUTF8(asChar(indent_string)));
yajl_gen_config(g, yajl_gen_validate_utf8, 0);
yajl_gen_config(g, yajl_gen_escape_solidus, 1); //modified to only escape for "</"
/* init parser */
hand = yajl_alloc(&callbacks, NULL, (void *) g);
/* get data from R */
const char* json = translateCharUTF8(asChar(x));
/* ignore BOM */
if(json[0] == '\xEF' && json[1] == '\xBB' && json[2] == '\xBF'){
json = json + 3;
}
/* Get length (after removing bom) */
const size_t rd = strlen(json);
/* parse */
stat = yajl_parse(hand, (const unsigned char*) json, rd);
if(stat == yajl_status_ok) {
stat = yajl_complete_parse(hand);
}
//error message
if (stat != yajl_status_ok) {
unsigned char* str = yajl_get_error(hand, 1, (const unsigned char*) json, rd);
output = PROTECT(mkString((const char*) str));
yajl_free_error(hand, str);
} else {
//create R object
const unsigned char* buf;
size_t len;
yajl_gen_get_buf(g, &buf, &len);
//force as UTF8 string
output = PROTECT(allocVector(STRSXP, 1));
SET_STRING_ELT(output, 0, mkCharCE((const char*) buf, CE_UTF8));
setAttrib(output, R_ClassSymbol, mkString("json"));
}
/* clean up */
yajl_gen_clear(g);
yajl_gen_free(g);
yajl_free(hand);
/* return boolean vec (0 means no errors, means is valid) */
SEXP vec = PROTECT(allocVector(VECSXP, 2));
SET_VECTOR_ELT(vec, 0, ScalarInteger(stat));
SET_VECTOR_ELT(vec, 1, output);
UNPROTECT(2);
return vec;
}
SEXP attribute_hidden do_getenv(SEXP call, SEXP op, SEXP args, SEXP env)
{
int i, j;
SEXP ans;
checkArity(op, args);
if (!isString(CAR(args)))
error(_("wrong type for argument"));
if (!isString(CADR(args)) || LENGTH(CADR(args)) != 1)
error(_("wrong type for argument"));
i = LENGTH(CAR(args));
if (i == 0) {
#ifdef Win32
int n = 0, N;
wchar_t **w;
for (i = 0, w = _wenviron; *w != NULL; i++, w++)
n = max(n, wcslen(*w));
N = 3*n+1;
char buf[N];
PROTECT(ans = allocVector(STRSXP, i));
for (i = 0, w = _wenviron; *w != NULL; i++, w++) {
wcstoutf8(buf, *w, N); buf[N-1] = '\0';
SET_STRING_ELT(ans, i, mkCharCE(buf, CE_UTF8));
}
#else
char **e;
for (i = 0, e = environ; *e != NULL; i++, e++);
PROTECT(ans = allocVector(STRSXP, i));
for (i = 0, e = environ; *e != NULL; i++, e++)
SET_STRING_ELT(ans, i, mkChar(*e));
#endif
} else {
PROTECT(ans = allocVector(STRSXP, i));
for (j = 0; j < i; j++) {
#ifdef Win32
const wchar_t *wnm = wtransChar(STRING_ELT(CAR(args), j));
wchar_t *w = _wgetenv(wnm);
if (w == NULL)
SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));
else {
int n = wcslen(w), N = 3*n+1; /* UCS-2 maps to <=3 UTF-8 */
R_CheckStack2(N);
char buf[N];
wcstoutf8(buf, w, N); buf[N-1] = '\0'; /* safety */
SET_STRING_ELT(ans, j, mkCharCE(buf, CE_UTF8));
}
#else
char *s = getenv(translateChar(STRING_ELT(CAR(args), j)));
if (s == NULL)
SET_STRING_ELT(ans, j, STRING_ELT(CADR(args), 0));
else {
SEXP tmp;
if(known_to_be_latin1) tmp = mkCharCE(s, CE_LATIN1);
else if(known_to_be_utf8) tmp = mkCharCE(s, CE_UTF8);
else tmp = mkChar(s);
SET_STRING_ELT(ans, j, tmp);
}
#endif
}
}
UNPROTECT(1);
return (ans);
}
/* GetNativeSystemInfo is XP or later */
pGNSI = (PGNSI)
GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
"GetNativeSystemInfo");
if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
strcat(ver, " x64");
}
SET_STRING_ELT(ans, 1, mkChar(ver));
if((int)osvi.dwMajorVersion >= 5) {
if(osvi.wServicePackMajor > 0)
snprintf(ver, 256, "build %d, Service Pack %d",
LOWORD(osvi.dwBuildNumber),
(int) osvi.wServicePackMajor);
else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
} else
snprintf(ver, 256, "build %d, %s",
LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
SET_STRING_ELT(ans, 2, mkChar(ver));
GetComputerNameW(name, &namelen);
wcstoutf8(buf, name, 1000);
SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
#ifdef WIN64
SET_STRING_ELT(ans, 4, mkChar("x86-64"));
#else
SET_STRING_ELT(ans, 4, mkChar("x86"));
#endif
GetUserNameW(user, &userlen);
wcstoutf8(buf, user, 1000);
SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8));
SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
PROTECT(ansnames = allocVector(STRSXP, 8));
SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
SET_STRING_ELT(ansnames, 1, mkChar("release"));
SET_STRING_ELT(ansnames, 2, mkChar("version"));
SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
SET_STRING_ELT(ansnames, 4, mkChar("machine"));
SET_STRING_ELT(ansnames, 5, mkChar("login"));
SET_STRING_ELT(ansnames, 6, mkChar("user"));
SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(2);
return ans;
}
SEXP do_syssleep(SEXP call, SEXP op, SEXP args, SEXP rho)
{
DWORD mtime;
int ntime;
double time;
checkArity(op, args);
time = asReal(CAR(args));
if (ISNAN(time) || time < 0)
errorcall(call, _("invalid '%s' value"), "time");
ntime = 1000*(time) + 0.5;
while (ntime > 0) {
mtime = min(500, ntime);
ntime -= mtime;
Sleep(mtime);
R_ProcessEvents();
}
return R_NilValue;
}
#ifdef LEA_MALLOC
#define MALLINFO_FIELD_TYPE size_t
struct mallinfo {
MALLINFO_FIELD_TYPE arena; /* non-mmapped space allocated from system */
MALLINFO_FIELD_TYPE ordblks; /* number of free chunks */
MALLINFO_FIELD_TYPE smblks; /* number of fastbin blocks */
MALLINFO_FIELD_TYPE hblks; /* number of mmapped regions */
MALLINFO_FIELD_TYPE hblkhd; /* space in mmapped regions */
MALLINFO_FIELD_TYPE usmblks; /* maximum total allocated space */
MALLINFO_FIELD_TYPE fsmblks; /* space available in freed fastbin blocks */
MALLINFO_FIELD_TYPE uordblks; /* total allocated space */
MALLINFO_FIELD_TYPE fordblks; /* total free space */
MALLINFO_FIELD_TYPE keepcost; /* top-most, releasable (via malloc_trim) space */
};
extern R_size_t R_max_memory;
struct mallinfo mallinfo(void);
#endif
SEXP in_memsize(SEXP ssize)
{
SEXP ans;
int maxmem = NA_LOGICAL;
if(isLogical(ssize))
maxmem = asLogical(ssize);
else if(isReal(ssize)) {
R_size_t newmax;
double mem = asReal(ssize);
if (!R_FINITE(mem))
error(_("incorrect argument"));
#ifdef LEA_MALLOC
#ifndef WIN64
if(mem >= 4096)
error(_("don't be silly!: your machine has a 4Gb address limit"));
#endif
newmax = mem * 1048576.0;
if (newmax < R_max_memory)
warning(_("cannot decrease memory limit: ignored"));
else
R_max_memory = newmax;
#endif
} else
error(_("incorrect argument"));
PROTECT(ans = allocVector(REALSXP, 1));
#ifdef LEA_MALLOC
if(maxmem == NA_LOGICAL)
REAL(ans)[0] = R_max_memory;
else if(maxmem)
REAL(ans)[0] = mallinfo().usmblks;
else
REAL(ans)[0] = mallinfo().uordblks;
REAL(ans)[0] /= 1048576.0;
#else
REAL(ans)[0] = NA_REAL;
#endif
UNPROTECT(1);
return ans;
}
SEXP do_dllversion(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP path = R_NilValue, ans;
const wchar_t *dll;
DWORD dwVerInfoSize;
DWORD dwVerHnd;
checkArity(op, args);
path = CAR(args);
if(!isString(path) || LENGTH(path) != 1)
errorcall(call, _("invalid '%s' argument"), "path");
dll = filenameToWchar(STRING_ELT(path, 0), FALSE);
dwVerInfoSize = GetFileVersionInfoSizeW(dll, &dwVerHnd);
PROTECT(ans = allocVector(STRSXP, 2));
SET_STRING_ELT(ans, 0, mkChar(""));
SET_STRING_ELT(ans, 1, mkChar(""));
if (dwVerInfoSize) {
BOOL fRet;
LPSTR lpstrVffInfo;
LPSTR lszVer = NULL;
UINT cchVer = 0;
lpstrVffInfo = (LPSTR) malloc(dwVerInfoSize);
if (GetFileVersionInfoW(dll, 0L, dwVerInfoSize, lpstrVffInfo)) {
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\FileVersion"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 0, mkChar(lszVer));
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\R Version"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
else {
fRet = VerQueryValue(lpstrVffInfo,
TEXT("\\StringFileInfo\\040904E4\\Compiled under R Version"),
(LPVOID)&lszVer, &cchVer);
if(fRet) SET_STRING_ELT(ans, 1, mkChar(lszVer));
}
} else ans = R_NilValue;
free(lpstrVffInfo);
} else ans = R_NilValue;
UNPROTECT(1);
return ans;
}
int Rwin_rename(const char *from, const char *to)
{
return (MoveFileEx(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
}
int Rwin_wrename(const wchar_t *from, const wchar_t *to)
{
return (MoveFileExW(from, to, MOVEFILE_REPLACE_EXISTING | MOVEFILE_COPY_ALLOWED | MOVEFILE_WRITE_THROUGH) == 0);
}
const char *formatError(DWORD res)
{
static char buf[1000], *p;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
NULL, res,
MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
buf, 1000, NULL);
p = buf+strlen(buf) -1;
if(*p == '\n') *p = '\0';
p = buf+strlen(buf) -1;
if(*p == '\r') *p = '\0';
p = buf+strlen(buf) -1;
if(*p == '.') *p = '\0';
return buf;
}
void R_UTF8fixslash(char *s); /* from main/util.c */
SEXP do_normalizepath(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, paths = CAR(args), el, slash;
int i, n = LENGTH(paths), res;
char tmp[MAX_PATH], longpath[MAX_PATH], *tmp2;
wchar_t wtmp[32768], wlongpath[32768], *wtmp2;
int mustWork, fslash = 0;
checkArity(op, args);
if(!isString(paths))
errorcall(call, _("'path' must be a character vector"));
slash = CADR(args);
if(!isString(slash) || LENGTH(slash) != 1)
errorcall(call, "'winslash' must be a character string");
const char *sl = CHAR(STRING_ELT(slash, 0));
if (strcmp(sl, "/") && strcmp(sl, "\\"))
errorcall(call, "'winslash' must be '/' or '\\\\'");
if (strcmp(sl, "/") == 0) fslash = 1;
mustWork = asLogical(CADDR(args));
PROTECT(ans = allocVector(STRSXP, n));
for (i = 0; i < n; i++) {
int warn = 0;
SEXP result;
el = STRING_ELT(paths, i);
result = el;
if(getCharCE(el) == CE_UTF8) {
if ((res = GetFullPathNameW(filenameToWchar(el, FALSE), 32768,
wtmp, &wtmp2)) && res <= 32768) {
if ((res = GetLongPathNameW(wtmp, wlongpath, 32768))
&& res <= 32768) {
wcstoutf8(longpath, wlongpath, wcslen(wlongpath)+1);
if(fslash) R_UTF8fixslash(longpath);
result = mkCharCE(longpath, CE_UTF8);
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
wcstoutf8(tmp, wtmp, wcslen(wtmp)+1);
if(fslash) R_UTF8fixslash(tmp);
result = mkCharCE(tmp, CE_UTF8);
warn = 1;
}
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if (fslash) {
strcpy(tmp, translateCharUTF8(el));
R_UTF8fixslash(tmp);
result = mkCharCE(tmp, CE_UTF8);
}
warn = 1;
}
if (warn && (mustWork == NA_LOGICAL))
warningcall(call, "path[%d]=\"%ls\": %s", i+1,
filenameToWchar(el,FALSE),
formatError(GetLastError()));
} else {
if ((res = GetFullPathName(translateChar(el), MAX_PATH, tmp, &tmp2))
&& res <= MAX_PATH) {
if ((res = GetLongPathName(tmp, longpath, MAX_PATH))
&& res <= MAX_PATH) {
if(fslash) R_fixslash(longpath);
result = mkChar(longpath);
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if(fslash) R_fixslash(tmp);
result = mkChar(tmp);
warn = 1;
}
} else if(mustWork == 1) {
errorcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
} else {
if (fslash) {
strcpy(tmp, translateChar(el));
R_fixslash(tmp);
result = mkChar(tmp);
}
warn = 1;
}
if (warn && (mustWork == NA_LOGICAL))
warningcall(call, "path[%d]=\"%s\": %s", i+1,
translateChar(el),
formatError(GetLastError()));
}
SET_STRING_ELT(ans, i, result);
}
UNPROTECT(1);
return ans;
}
SEXP
processJSONNode(JSONNODE *n, int parentType, int simplify, SEXP nullValue, int simplifyWithNames, cetype_t charEncoding,
SEXP r_stringCall, StringFunctionType str_fun_type)
{
if (n == NULL){
PROBLEM "invalid JSON input"
ERROR;
}
JSONNODE *i;
int len = 0, ctr = 0;
int nprotect = 0;
int numNulls = 0;
len = json_size(n);
char startType = parentType; // was 127
int isNullHomogeneous = (TYPEOF(nullValue) == LGLSXP || TYPEOF(nullValue) == REALSXP ||
TYPEOF(nullValue) == STRSXP || TYPEOF(nullValue) == INTSXP);
int numStrings = 0;
int numLogicals = 0;
int numNumbers = 0;
SEXP ans, names = NULL;
PROTECT(ans = NEW_LIST(len)); nprotect++;
int homogeneous = 0;
int elType = NILSXP;
while (ctr < len){ // i != json_end(n)
i = json_at(n, ctr);
if (i == NULL){
PROBLEM "Invalid JSON Node"
ERROR;
}
json_char *node_name = json_name(i);
char type = json_type(i);
if(startType == 127)
startType = type;
SEXP el;
switch(type) {
case JSON_NULL:
el = nullValue; /* R_NilValue; */
numNulls++;
if(isNullHomogeneous) {
homogeneous++;
elType = setType(elType, TYPEOF(nullValue));
} else
elType = TYPEOF(nullValue);
break;
case JSON_ARRAY:
case JSON_NODE:
el = processJSONNode(i, type, simplify, nullValue, simplifyWithNames, charEncoding, r_stringCall, str_fun_type);
if(Rf_length(el) > 1)
elType = VECSXP;
else
elType = setType(elType, TYPEOF(el));
break;
case JSON_NUMBER:
el = ScalarReal(json_as_float(i));
homogeneous++;
elType = setType(elType, REALSXP);
numNumbers++;
break;
case JSON_BOOL:
el = ScalarLogical(json_as_bool(i));
elType = setType(elType, LGLSXP);
numLogicals++;
break;
case JSON_STRING:
{
//XXX Garbage collection
#if 0 //def JSON_UNICODE
wchar_t *wtmp = json_as_string(i);
char *tmp;
int len = wcslen(wtmp);
int size = sizeof(char) * (len * MB_LEN_MAX + 1);
tmp = (char *)malloc(size);
if (tmp == NULL) {
PROBLEM "Cannot allocate memory"
ERROR;
}
wcstombs(tmp, wtmp, size);
#else
char *tmp = json_as_string(i);
// tmp = reEnc(tmp, CE_BYTES, CE_UTF8, 1);
#endif
if(r_stringCall != NULL && TYPEOF(r_stringCall) == EXTPTRSXP) {
if(str_fun_type == SEXP_STR_ROUTINE) {
SEXPStringRoutine fun;
fun = (SEXPStringRoutine) R_ExternalPtrAddr(r_stringCall);
el = fun(tmp, charEncoding);
} else {
char *tmp1;
StringRoutine fun;
fun = (StringRoutine) R_ExternalPtrAddr(r_stringCall);
tmp1 = fun(tmp);
if(tmp1 != tmp)
json_free(tmp);
tmp = tmp1;
el = ScalarString(mkCharCE(tmp, charEncoding));
}
} else {
el = ScalarString(mkCharCE(tmp, charEncoding));
/* Call the R function if there is one. */
if(r_stringCall != NULL) {
SETCAR(CDR(r_stringCall), el);
el = Rf_eval(r_stringCall, R_GlobalEnv);
}
/* XXX compute with elType. */
}
json_free(tmp);
elType = setType(elType,
/* If we have a class, not a primitive type */
Rf_length(getAttrib(el, Rf_install("class"))) ? LISTSXP : TYPEOF(el));
if(r_stringCall != NULL && str_fun_type != NATIVE_STR_ROUTINE) {
switch(TYPEOF(el)) {
case REALSXP:
numNumbers++;
break;
case LGLSXP:
numLogicals++;
break;
case STRSXP:
numStrings++;
break;
}
} else if(TYPEOF(el) == STRSXP)
numStrings++;
}
break;
default:
PROBLEM "shouldn't be here"
WARN;
el = R_NilValue;
break;
}
SET_VECTOR_ELT(ans, ctr, el);
if(parentType == JSON_NODE || (node_name && node_name[0])) {
if(names == NULL) {
PROTECT(names = NEW_CHARACTER(len)); nprotect++;
}
if(node_name && node_name[0])
SET_STRING_ELT(names, ctr, mkChar(node_name));
}
json_free(node_name);
ctr++;
}
/* If we have an empty object, we try to make it into a form equivalent to emptyNamedList
if it is a {}, or as an AsIs object in R if an empty array. */
if(len == 0 && (parentType == -1 || parentType == JSON_ARRAY || parentType == JSON_NODE)) {
if(parentType == -1)
parentType = startType;
if(parentType == JSON_NODE)
SET_NAMES(ans, NEW_CHARACTER(0));
else {
SET_CLASS(ans, ScalarString(mkChar("AsIs")));
}
} else if(simplifyWithNames || names == NULL || Rf_length(names) == 0) {
int allSame = (numNumbers == len || numStrings == len || numLogicals == len) ||
((TYPEOF(nullValue) == LGLSXP && LOGICAL(nullValue)[0] == NA_INTEGER) &&
((numNumbers + numNulls) == len || (numStrings + numNulls) == len || (numLogicals + numNulls) == len));
homogeneous = allSame || ( (numNumbers + numStrings + numLogicals + numNulls) == len);
if(simplify == NONE) {
} else if(allSame &&
(numNumbers == len && (simplify & STRICT_NUMERIC)) ||
((numLogicals == len) && (simplify & STRICT_LOGICAL)) ||
( (numStrings == len) && (simplify & STRICT_CHARACTER))) {
ans = makeVector(ans, len, elType, nullValue);
} else if((simplify == ALL && homogeneous) || (simplify == STRICT && allSame)) {
ans = makeVector(ans, len, elType, nullValue);
}
}
if(names)
SET_NAMES(ans, names);
UNPROTECT(nprotect);
return(ans);
}
/* base::Sys.info */
SEXP do_sysinfo(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP ans, ansnames;
OSVERSIONINFOEX osvi;
char ver[256], buf[1000];
wchar_t name[MAX_COMPUTERNAME_LENGTH + 1], user[UNLEN+1];
DWORD namelen = MAX_COMPUTERNAME_LENGTH + 1, userlen = UNLEN+1;
checkArity(op, args);
PROTECT(ans = allocVector(STRSXP, 8));
osvi.dwOSVersionInfoSize = sizeof(OSVERSIONINFOEX);
if(!GetVersionEx((OSVERSIONINFO *)&osvi))
error(_("unsupported version of Windows"));
SET_STRING_ELT(ans, 0, mkChar("Windows"));
/* Here for unknown future versions */
snprintf(ver, 256, "%d.%d",
(int)osvi.dwMajorVersion, (int)osvi.dwMinorVersion);
if((int)osvi.dwMajorVersion >= 5) {
PGNSI pGNSI;
SYSTEM_INFO si;
if(osvi.dwMajorVersion == 6) {
if(osvi.wProductType == VER_NT_WORKSTATION) {
if(osvi.dwMinorVersion == 0)
strcpy(ver, "Vista");
else strcpy(ver, "7");
} else
strcpy(ver, "Server 2008");
}
if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 0)
strcpy(ver, "2000");
if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 1)
strcpy(ver, "XP");
if(osvi.dwMajorVersion == 5 && osvi.dwMinorVersion == 2) {
if(osvi.wProductType == VER_NT_WORKSTATION)
strcpy(ver, "XP Professional");
else strcpy(ver, "Server 2003");
}
/* GetNativeSystemInfo is XP or later */
pGNSI = (PGNSI)
GetProcAddress(GetModuleHandle(TEXT("kernel32.dll")),
"GetNativeSystemInfo");
if(NULL != pGNSI) pGNSI(&si); else GetSystemInfo(&si);
if(si.wProcessorArchitecture == PROCESSOR_ARCHITECTURE_AMD64)
strcat(ver, " x64");
}
SET_STRING_ELT(ans, 1, mkChar(ver));
if((int)osvi.dwMajorVersion >= 5) {
if(osvi.wServicePackMajor > 0)
snprintf(ver, 256, "build %d, Service Pack %d",
LOWORD(osvi.dwBuildNumber),
(int) osvi.wServicePackMajor);
else snprintf(ver, 256, "build %d", LOWORD(osvi.dwBuildNumber));
} else
snprintf(ver, 256, "build %d, %s",
LOWORD(osvi.dwBuildNumber), osvi.szCSDVersion);
SET_STRING_ELT(ans, 2, mkChar(ver));
GetComputerNameW(name, &namelen);
wcstoutf8(buf, name, 1000);
SET_STRING_ELT(ans, 3, mkCharCE(buf, CE_UTF8));
#ifdef WIN64
SET_STRING_ELT(ans, 4, mkChar("x86-64"));
#else
SET_STRING_ELT(ans, 4, mkChar("x86"));
#endif
GetUserNameW(user, &userlen);
wcstoutf8(buf, user, 1000);
SET_STRING_ELT(ans, 5, mkCharCE(buf, CE_UTF8));
SET_STRING_ELT(ans, 6, STRING_ELT(ans, 5));
SET_STRING_ELT(ans, 7, STRING_ELT(ans, 5));
PROTECT(ansnames = allocVector(STRSXP, 8));
SET_STRING_ELT(ansnames, 0, mkChar("sysname"));
SET_STRING_ELT(ansnames, 1, mkChar("release"));
SET_STRING_ELT(ansnames, 2, mkChar("version"));
SET_STRING_ELT(ansnames, 3, mkChar("nodename"));
SET_STRING_ELT(ansnames, 4, mkChar("machine"));
SET_STRING_ELT(ansnames, 5, mkChar("login"));
SET_STRING_ELT(ansnames, 6, mkChar("user"));
SET_STRING_ELT(ansnames, 7, mkChar("effective_user"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(2);
return ans;
}
SEXP attribute_hidden do_substrgets(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP s, x, sa, so, value, el, v_el;
R_xlen_t i, len;
int start, stop, k, l, v;
size_t slen;
cetype_t ienc, venc;
const char *ss, *v_ss;
char *buf;
const void *vmax;
checkArity(op, args);
x = CAR(args);
sa = CADR(args);
so = CADDR(args);
value = CADDDR(args);
k = LENGTH(sa);
l = LENGTH(so);
if (!isString(x))
error(_("replacing substrings in a non-character object"));
len = LENGTH(x);
PROTECT(s = allocVector(STRSXP, len));
if (len > 0) {
if (!isInteger(sa) || !isInteger(so) || k == 0 || l == 0)
error(_("invalid substring arguments"));
v = LENGTH(value);
if (!isString(value) || v == 0) error(_("invalid value"));
vmax = vmaxget();
for (i = 0; i < len; i++) {
el = STRING_ELT(x, i);
v_el = STRING_ELT(value, i % v);
start = INTEGER(sa)[i % k];
stop = INTEGER(so)[i % l];
if (el == NA_STRING || v_el == NA_STRING ||
start == NA_INTEGER || stop == NA_INTEGER) {
SET_STRING_ELT(s, i, NA_STRING);
continue;
}
ienc = getCharCE(el);
ss = CHAR(el);
slen = strlen(ss);
if (start < 1) start = 1;
if (stop > slen) stop = (int) slen; /* SBCS optimization */
if (start > stop) {
/* just copy element across */
SET_STRING_ELT(s, i, STRING_ELT(x, i));
} else {
int ienc2 = ienc;
v_ss = CHAR(v_el);
/* is the value in the same encoding?
FIXME: could prefer UTF-8 here
*/
venc = getCharCE(v_el);
if (venc != ienc && !strIsASCII(v_ss)) {
ss = translateChar(el);
slen = strlen(ss);
v_ss = translateChar(v_el);
ienc2 = CE_NATIVE;
}
/* might expand under MBCS */
buf = R_AllocStringBuffer(slen+strlen(v_ss), &cbuff);
strcpy(buf, ss);
substrset(buf, v_ss, ienc2, start, stop);
SET_STRING_ELT(s, i, mkCharCE(buf, ienc2));
}
vmaxset(vmax);
}
R_FreeStringBufferL(&cbuff);
}
UNPROTECT(1);
return s;
}
static SEXP Julia_R_Scalar(jl_value_t *Var)
{
SEXP ans = R_NilValue;
double tmpfloat;
//most common type is here
if (jl_is_int32(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_int32(Var)));
UNPROTECT(1);
}
else if (jl_is_int64(Var))
{
tmpfloat=(double)jl_unbox_int64(Var);
if (inInt32Range(tmpfloat))
PROTECT(ans = ScalarInteger((int32_t)jl_unbox_int64(Var)));
else
PROTECT(ans = ScalarReal(tmpfloat));
UNPROTECT(1);
}
//more integer type
if (jl_is_uint32(Var))
{
tmpfloat=(double)jl_unbox_uint32(Var);
if (inInt32Range(tmpfloat))
PROTECT(ans = ScalarInteger((int32_t)jl_unbox_uint32(Var)));
else
PROTECT(ans = ScalarReal(tmpfloat));
UNPROTECT(1);
}
else if (jl_is_uint64(Var))
{
tmpfloat=(double)jl_unbox_int64(Var);
if (inInt32Range(tmpfloat))
PROTECT(ans = ScalarInteger((int32_t)jl_unbox_uint64(Var)));
else
PROTECT(ans = ScalarReal(tmpfloat));
UNPROTECT(1);
}
else if (jl_is_float64(Var))
{
PROTECT(ans = ScalarReal(jl_unbox_float64(Var)));
UNPROTECT(1);
}
else if (jl_is_float32(Var))
{
PROTECT(ans = ScalarReal(jl_unbox_float32(Var)));
UNPROTECT(1);
}
else if (jl_is_bool(Var))
{
PROTECT(ans = ScalarLogical(jl_unbox_bool(Var)));
UNPROTECT(1);
}
else if (jl_is_int8(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_int8(Var)));
UNPROTECT(1);
}
else if (jl_is_uint8(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_uint8(Var)));
UNPROTECT(1);
}
else if (jl_is_int16(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_int16(Var)));
UNPROTECT(1);
}
else if (jl_is_uint16(Var))
{
PROTECT(ans = ScalarInteger(jl_unbox_uint16(Var)));
UNPROTECT(1);
}
else if (jl_is_utf8_string(Var))
{
PROTECT(ans = allocVector(STRSXP, 1));
SET_STRING_ELT(ans, 0, mkCharCE(jl_string_data(Var), CE_UTF8));
UNPROTECT(1);
}
else if (jl_is_ascii_string(Var))
{
PROTECT(ans = ScalarString(mkChar(jl_string_data(Var))));
UNPROTECT(1);
}
return ans;
}
static SEXP Julia_R_MD(jl_value_t *Var)
{
SEXP ans = R_NilValue;
jl_value_t *val;
if (((jl_array_t *)Var)->ptrarray)
val = jl_cellref(Var, 0);
else
val = jl_arrayref((jl_array_t *)Var, 0);
//get Julia dims and set R array Dims
int len = jl_array_len(Var);
if (len == 0)
return ans;
int ndims = jl_array_ndims(Var);
SEXP dims;
PROTECT(dims = allocVector(INTSXP, ndims));
for (size_t i = 0; i < ndims; i++)
{
INTEGER(dims)[i] = jl_array_dim(Var, i);
}
UNPROTECT(1);
if (jl_is_bool(val))
{
char *p = (char *) jl_array_data(Var);
PROTECT(ans = allocArray(LGLSXP, dims));
for (size_t i = 0; i < len; i++)
LOGICAL(ans)[i] = p[i];
UNPROTECT(1);
}
else if (jl_is_int32(val))
{
int32_t *p = (int32_t *) jl_array_data(Var);
jlint_to_r;
}
//int64
else if (jl_is_int64(val))
{
int64_t *p = (int64_t *) jl_array_data(Var);
jlbiggerint_to_r;
}
//more integer type
else if (jl_is_int8(val))
{
int8_t *p = (int8_t *) jl_array_data(Var);
jlint_to_r;
}
else if (jl_is_int16(val))
{
int16_t *p = (int16_t *) jl_array_data(Var);
jlint_to_r;
}
else if (jl_is_uint8(val))
{
uint8_t *p = (uint8_t *) jl_array_data(Var);
jlint_to_r;
}
else if (jl_is_uint16(val))
{
uint16_t *p = (uint16_t *) jl_array_data(Var);
jlint_to_r;
}
else if (jl_is_uint32(val))
{
uint32_t *p = (uint32_t *) jl_array_data(Var);
jlbiggerint_to_r;
}
else if (jl_is_uint64(val))
{
uint64_t *p = (uint64_t *) jl_array_data(Var);
jlbiggerint_to_r;
}
//double
else if (jl_is_float64(val))
{
double *p = (double *) jl_array_data(Var);
jlfloat_to_r;
}
else if (jl_is_float32(val))
{
float *p = (float *) jl_array_data(Var);
jlfloat_to_r;
}
//convert string array to STRSXP ,but not sure it is corret?
else if (jl_is_utf8_string(val))
{
PROTECT(ans = allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
SET_STRING_ELT(ans, i, mkCharCE(jl_string_data(jl_cellref(Var, i)), CE_UTF8));
UNPROTECT(1);
}
else if (jl_is_ascii_string(val))
{
PROTECT(ans = allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
SET_STRING_ELT(ans, i, mkChar(jl_string_data(jl_cellref(Var, i))));
UNPROTECT(1);
}
return ans;
}
static SEXP Julia_R_MD_NA(jl_value_t *Var)
{
SEXP ans = R_NilValue;
char *strData = "Varname0tmp.data";
char *strNA = "bitunpack(Varname0tmp.na)";
jl_set_global(jl_main_module, jl_symbol("Varname0tmp"), (jl_value_t *)Var);
jl_value_t *retData = jl_eval_string(strData);
jl_value_t *retNA = jl_eval_string(strNA);
jl_value_t *val;
if (((jl_array_t *)retData)->ptrarray)
val = jl_cellref(retData, 0);
else
val = jl_arrayref((jl_array_t *)retData, 0);
int len = jl_array_len(retData);
if (len == 0)
return ans;
int ndims = jl_array_ndims(retData);
SEXP dims;
PROTECT(dims = allocVector(INTSXP, ndims));
for (size_t i = 0; i < ndims; i++)
INTEGER(dims)[i] = jl_array_dim(retData, i);
UNPROTECT(1);
//bool array
char *pNA = (char *) jl_array_data(retNA);
if (jl_is_bool(val))
{
char *p = (char *) jl_array_data(retData);
PROTECT(ans = allocArray(LGLSXP, dims));
for (size_t i = 0; i < len; i++)
if (pNA[i])
LOGICAL(ans)[i] = NA_LOGICAL;
else
LOGICAL(ans)[i] = p[i];
UNPROTECT(1);
}
else if (jl_is_int32(val))
{
int32_t *p = (int32_t *) jl_array_data(retData);
jlint_to_r_na;
}
//int64
else if (jl_is_int64(val))
{
int64_t *p = (int64_t *) jl_array_data(retData);
jlbiggerint_to_r_na;
}
//more integer type
else if (jl_is_int8(val))
{
int8_t *p = (int8_t *) jl_array_data(retData);
jlint_to_r_na;
}
else if (jl_is_int16(val))
{
int16_t *p = (int16_t *) jl_array_data(retData);
jlint_to_r_na;
}
else if (jl_is_uint8(val))
{
uint8_t *p = (uint8_t *) jl_array_data(retData);
jlint_to_r_na;
}
else if (jl_is_uint16(val))
{
uint16_t *p = (uint16_t *) jl_array_data(retData);
jlint_to_r_na;
}
else if (jl_is_uint32(val))
{
uint32_t *p = (uint32_t *) jl_array_data(retData);
jlbiggerint_to_r_na;
}
else if (jl_is_uint64(val))
{
uint64_t *p = (uint64_t *) jl_array_data(retData);
jlbiggerint_to_r_na;
}
//double
else if (jl_is_float64(val))
{
double *p = (double *) jl_array_data(retData);
jlfloat_to_r_na;
}
else if (jl_is_float32(val))
{
float *p = (float *) jl_array_data(retData);
jlfloat_to_r_na;
}
//convert string array to STRSXP
else if (jl_is_utf8_string(val))
{
PROTECT(ans = allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
if (pNA[i])
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, mkCharCE(jl_string_data(jl_cellref(retData, i)), CE_UTF8));
UNPROTECT(1);
}
else if (jl_is_ascii_string(val))
{
PROTECT(ans = allocArray(STRSXP, dims));
for (size_t i = 0; i < len; i++)
if (pNA[i])
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, mkChar(jl_string_data(jl_cellref(retData, i))));
UNPROTECT(1);
}
return ans;
}