Exemplo n.º 1
0
Arquivo: xpath.c Projeto: jetaber/XML
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);
}
Exemplo n.º 2
0
/* 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);
}
Exemplo n.º 3
0
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);
}
Exemplo n.º 4
0
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;
}
Exemplo n.º 5
0
Arquivo: Rffi.c Projeto: rcqls/R4ffi
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; 
}
Exemplo n.º 6
0
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);
}
Exemplo n.º 7
0
/* 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;
}
Exemplo n.º 8
0
/* 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;
}
Exemplo n.º 9
0
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;
}
Exemplo n.º 10
0
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;
}
Exemplo n.º 11
0
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;
}
Exemplo n.º 12
0
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.");
}
Exemplo n.º 13
0
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;
}
Exemplo n.º 14
0
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])));
}
Exemplo n.º 15
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;
}
Exemplo n.º 16
0
Arquivo: extra.c Projeto: csilles/cxxr
/* 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;
}
Exemplo n.º 17
0
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;
}
Exemplo n.º 18
0
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--;
}
Exemplo n.º 19
0
Arquivo: extra.c Projeto: csilles/cxxr
/* 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;
}
Exemplo n.º 20
0
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)));
}
Exemplo n.º 21
0
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;
}
Exemplo n.º 22
0
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;
}
Exemplo n.º 23
0
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);
}
Exemplo n.º 24
0
Arquivo: extra.c Projeto: csilles/cxxr
	/* 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;
}
Exemplo n.º 25
0
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);
}
Exemplo n.º 26
0
Arquivo: extra.c Projeto: csilles/cxxr
/* 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;
}
Exemplo n.º 27
0
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;
}
Exemplo n.º 28
0
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;
}
Exemplo n.º 29
0
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;
}
Exemplo n.º 30
0
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;
}