Rboolean R_ToplevelExec(void (*fun)(void *), void *data) { RCNTXT thiscontext; RCNTXT * volatile saveToplevelContext; volatile SEXP topExp, oldHStack; Rboolean result; PROTECT(topExp = R_CurrentExpr); PROTECT(oldHStack = R_HandlerStack); R_HandlerStack = R_NilValue; saveToplevelContext = R_ToplevelContext; begincontext(&thiscontext, CTXT_TOPLEVEL, R_NilValue, R_GlobalEnv, R_BaseEnv, R_NilValue, R_NilValue); if (SETJMP(thiscontext.cjmpbuf)) result = FALSE; else { R_GlobalContext = R_ToplevelContext = &thiscontext; fun(data); result = TRUE; } endcontext(&thiscontext); R_ToplevelContext = saveToplevelContext; R_CurrentExpr = topExp; R_HandlerStack = oldHStack; UNPROTECT(2); return result; }
int runcmd_timeout(const char *cmd, cetype_t enc, int wait, int visible, const char *fin, const char *fout, const char *ferr, int timeout, int *timedout) { if (!wait && timeout) error("Timeout with background running processes is not supported."); HANDLE hIN = getInputHandle(fin), hOUT, hERR; int ret = 0; PROCESS_INFORMATION pi; int close1 = 0, close2 = 0, close3 = 0; if (hIN && fin && fin[0]) close1 = 1; hOUT = getOutputHandle(fout, 0); if (!hOUT) return 1; if (fout && fout[0]) close2 = 1; if (fout && fout[0] && ferr && streql(fout, ferr)) hERR = hOUT; else { hERR = getOutputHandle(ferr, 1); if (!hERR) return 1; if (ferr && ferr[0]) close3 = 1; } memset(&pi, 0, sizeof(pi)); pcreate(cmd, enc, !wait, visible, hIN, hOUT, hERR, &pi); if (pi.hProcess) { if (wait) { RCNTXT cntxt; begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue); cntxt.cend = &terminate_process; cntxt.cenddata = π DWORD timeoutMillis = (DWORD) (1000*timeout); ret = pwait2(pi.hProcess, timeoutMillis, timedout); endcontext(&cntxt); snprintf(RunError, 501, _("Exit code was %d"), ret); ret &= 0xffff; } else ret = 0; CloseHandle(pi.hProcess); } else { ret = NOLAUNCH; } if (close1) CloseHandle(hIN); if (close2) CloseHandle(hOUT); if (close3) CloseHandle(hERR); return ret; }
SEXP R_ExecWithCleanup(SEXP (*fun)(void *), void *data, void (*cleanfun)(void *), void *cleandata) { RCNTXT cntxt; SEXP result; begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue); cntxt.cend = cleanfun; cntxt.cenddata = cleandata; result = fun(data); cleanfun(cleandata); endcontext(&cntxt); return result; }
/* Used for external commands in file.show() and edit(), and for system(intern=FALSE). Also called from postscript(). wait != 0 says wait for child to terminate before returning. visible = -1, 0, 1 for hide, minimized, default fin is either NULL or the name of a file from which to redirect stdin for the child. fout/ferr are NULL (use NUL:), "" (use standard streams) or filenames. */ int runcmd(const char *cmd, cetype_t enc, int wait, int visible, const char *fin, const char *fout, const char *ferr) { HANDLE hIN = getInputHandle(fin), hOUT, hERR; int ret = 0; PROCESS_INFORMATION pi; int close1 = 0, close2 = 0, close3 = 0; if (hIN && fin && fin[0]) close1 = 1; hOUT = getOutputHandle(fout, 0); if (!hOUT) return 1; if (fout && fout[0]) close2 = 1; if (fout && fout[0] && ferr && streql(fout, ferr)) hERR = hOUT; else { hERR = getOutputHandle(ferr, 1); if (!hERR) return 1; if (ferr && ferr[0]) close3 = 1; } memset(&pi, 0, sizeof(pi)); pcreate(cmd, enc, !wait, visible, hIN, hOUT, hERR, &pi); if (!pi.hProcess) return NOLAUNCH; if (wait) { RCNTXT cntxt; begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue); cntxt.cend = &terminate_process; cntxt.cenddata = π ret = pwait2(pi.hProcess); endcontext(&cntxt); snprintf(RunError, 501, _("Exit code was %d"), ret); ret &= 0xffff; } else ret = 0; CloseHandle(pi.hProcess); if (close1) CloseHandle(hIN); if (close2) CloseHandle(hOUT); if (close3) CloseHandle(hERR); return ret; }
SEXP attribute_hidden do_readDCF(SEXP call, SEXP op, SEXP args, SEXP env) { int nwhat, nret, nc, nr, m, k, lastm, need; Rboolean blank_skip, field_skip = FALSE; int whatlen, dynwhat, buflen = 8096; // was 100, but that re-alloced often char *line, *buf; regex_t blankline, contline, trailblank, regline, eblankline; regmatch_t regmatch[1]; SEXP file, what, what2, retval, retval2, dims, dimnames; Rconnection con = NULL; Rboolean wasopen, is_eblankline; RCNTXT cntxt; SEXP fold_excludes; Rboolean field_fold = TRUE, has_fold_excludes; const char *field_name; int offset = 0; /* -Wall */ checkArity(op, args); file = CAR(args); con = getConnection(asInteger(file)); wasopen = con->isopen; if(!wasopen) { if(!con->open(con)) error(_("cannot open the connection")); /* Set up a context which will close the connection on error */ begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue); cntxt.cend = &con_cleanup; cntxt.cenddata = con; } if(!con->canread) error(_("cannot read from this connection")); args = CDR(args); PROTECT(what = coerceVector(CAR(args), STRSXP)); /* argument fields */ nwhat = LENGTH(what); dynwhat = (nwhat == 0); args = CDR(args); PROTECT(fold_excludes = coerceVector(CAR(args), STRSXP)); has_fold_excludes = (LENGTH(fold_excludes) > 0); buf = (char *) malloc(buflen); if(!buf) error(_("could not allocate memory for 'read.dcf'")); nret = 20; /* it is easier if we first have a record per column */ PROTECT(retval = allocMatrixNA(STRSXP, LENGTH(what), nret)); /* These used to use [:blank:] but that can match \xa0 as part of a UTF-8 character (and is nbspace on Windows). */ tre_regcomp(&blankline, "^[[:blank:]]*$", REG_NOSUB & REG_EXTENDED); tre_regcomp(&trailblank, "[ \t]+$", REG_EXTENDED); tre_regcomp(&contline, "^[[:blank:]]+", REG_EXTENDED); tre_regcomp(®line, "^[^:]+:[[:blank:]]*", REG_EXTENDED); tre_regcomp(&eblankline, "^[[:space:]]+\\.[[:space:]]*$", REG_EXTENDED); k = 0; lastm = -1; /* index of the field currently being recorded */ blank_skip = TRUE; void *vmax = vmaxget(); while((line = Rconn_getline2(con))) { if(strlen(line) == 0 || tre_regexecb(&blankline, line, 0, 0, 0) == 0) { /* A blank line. The first one after a record ends a new * record, subsequent ones are skipped */ if(!blank_skip) { k++; if(k > nret - 1){ nret *= 2; PROTECT(retval2 = allocMatrixNA(STRSXP, LENGTH(what), nret)); transferVector(retval2, retval); UNPROTECT_PTR(retval); retval = retval2; } blank_skip = TRUE; lastm = -1; field_skip = FALSE; field_fold = TRUE; } } else { blank_skip = FALSE; if(tre_regexecb(&contline, line, 1, regmatch, 0) == 0) { /* A continuation line: wrong if at the beginning of a record. */ if((lastm == -1) && !field_skip) { line[20] = '\0'; error(_("Found continuation line starting '%s ...' at begin of record."), line); } if(lastm >= 0) { need = (int) strlen(CHAR(STRING_ELT(retval, lastm + nwhat * k))) + 2; if(tre_regexecb(&eblankline, line, 0, NULL, 0) == 0) { is_eblankline = TRUE; } else { is_eblankline = FALSE; if(field_fold) { offset = regmatch[0].rm_eo; /* Also remove trailing whitespace. */ if((tre_regexecb(&trailblank, line, 1, regmatch, 0) == 0)) line[regmatch[0].rm_so] = '\0'; } else { offset = 0; } need += (int) strlen(line + offset); } if(buflen < need) { char *tmp = (char *) realloc(buf, need); if(!tmp) { free(buf); error(_("could not allocate memory for 'read.dcf'")); } else buf = tmp; buflen = need; } strcpy(buf,CHAR(STRING_ELT(retval, lastm + nwhat * k))); strcat(buf, "\n"); if(!is_eblankline) strcat(buf, line + offset); SET_STRING_ELT(retval, lastm + nwhat * k, mkChar(buf)); } } else { if(tre_regexecb(®line, line, 1, regmatch, 0) == 0) { for(m = 0; m < nwhat; m++){ whatlen = (int) strlen(CHAR(STRING_ELT(what, m))); if(strlen(line) > whatlen && line[whatlen] == ':' && strncmp(CHAR(STRING_ELT(what, m)), line, whatlen) == 0) { /* An already known field we are recording. */ lastm = m; field_skip = FALSE; field_name = CHAR(STRING_ELT(what, lastm)); if(has_fold_excludes) { field_fold = field_is_foldable_p(field_name, fold_excludes); } if(field_fold) { offset = regmatch[0].rm_eo; /* Also remove trailing whitespace. */ if((tre_regexecb(&trailblank, line, 1, regmatch, 0) == 0)) line[regmatch[0].rm_so] = '\0'; } else { offset = 0; } SET_STRING_ELT(retval, m + nwhat * k, mkChar(line + offset)); break; } else { /* This is a field, but not one prespecified */ lastm = -1; field_skip = TRUE; } } if(dynwhat && (lastm == -1)) { /* A previously unseen field and we are * recording all fields */ field_skip = FALSE; PROTECT(what2 = allocVector(STRSXP, nwhat+1)); PROTECT(retval2 = allocMatrixNA(STRSXP, nrows(retval)+1, ncols(retval))); if(nwhat > 0) { copyVector(what2, what); for(nr = 0; nr < nrows(retval); nr++){ for(nc = 0; nc < ncols(retval); nc++){ SET_STRING_ELT(retval2, nr+nc*nrows(retval2), STRING_ELT(retval, nr+nc*nrows(retval))); } } } UNPROTECT_PTR(retval); UNPROTECT_PTR(what); retval = retval2; what = what2; /* Make sure enough space was used */ need = (int) (Rf_strchr(line, ':') - line + 1); if(buflen < need){ char *tmp = (char *) realloc(buf, need); if(!tmp) { free(buf); error(_("could not allocate memory for 'read.dcf'")); } else buf = tmp; buflen = need; } strncpy(buf, line, Rf_strchr(line, ':') - line); buf[Rf_strchr(line, ':') - line] = '\0'; SET_STRING_ELT(what, nwhat, mkChar(buf)); nwhat++; /* lastm uses C indexing, hence nwhat - 1 */ lastm = nwhat - 1; field_name = CHAR(STRING_ELT(what, lastm)); if(has_fold_excludes) { field_fold = field_is_foldable_p(field_name, fold_excludes); } offset = regmatch[0].rm_eo; if(field_fold) { /* Also remove trailing whitespace. */ if((tre_regexecb(&trailblank, line, 1, regmatch, 0) == 0)) line[regmatch[0].rm_so] = '\0'; } SET_STRING_ELT(retval, lastm + nwhat * k, mkChar(line + offset)); } } else { /* Must be a regular line with no tag ... */ line[20] = '\0'; error(_("Line starting '%s ...' is malformed!"), line); } } } } vmaxset(vmax); if(!wasopen) {endcontext(&cntxt); con->close(con);} free(buf); tre_regfree(&blankline); tre_regfree(&contline); tre_regfree(&trailblank); tre_regfree(®line); tre_regfree(&eblankline); if(!blank_skip) k++; /* and now transpose the whole matrix */ PROTECT(retval2 = allocMatrixNA(STRSXP, k, LENGTH(what))); copyMatrix(retval2, retval, 1); PROTECT(dimnames = allocVector(VECSXP, 2)); PROTECT(dims = allocVector(INTSXP, 2)); INTEGER(dims)[0] = k; INTEGER(dims)[1] = LENGTH(what); SET_VECTOR_ELT(dimnames, 1, what); setAttrib(retval2, R_DimSymbol, dims); setAttrib(retval2, R_DimNamesSymbol, dimnames); UNPROTECT(6); return(retval2); }
/* browser(text = "", condition = NULL, expr = TRUE, skipCalls = 0L) * ------- but also called from ./eval.c */ SEXP attribute_hidden do_browser(SEXP call, SEXP op, SEXP args, SEXP rho) { RCNTXT *saveToplevelContext; RCNTXT *saveGlobalContext; RCNTXT thiscontext, returncontext, *cptr; int savestack, browselevel; SEXP ap, topExp, argList; /* argument matching */ PROTECT(ap = list4(R_NilValue, R_NilValue, R_NilValue, R_NilValue)); SET_TAG(ap, install("text")); SET_TAG(CDR(ap), install("condition")); SET_TAG(CDDR(ap), install("expr")); SET_TAG(CDDDR(ap), install("skipCalls")); argList = matchArgs(ap, args, call); UNPROTECT(1); PROTECT(argList); /* substitute defaults */ if(CAR(argList) == R_MissingArg) SETCAR(argList, mkString("")); if(CADR(argList) == R_MissingArg) SETCAR(CDR(argList), R_NilValue); if(CADDR(argList) == R_MissingArg) SETCAR(CDDR(argList), ScalarLogical(1)); if(CADDDR(argList) == R_MissingArg) SETCAR(CDDDR(argList), ScalarInteger(0)); /* return if 'expr' is not TRUE */ if( !asLogical(CADDR(argList)) ) { UNPROTECT(1); return R_NilValue; } /* Save the evaluator state information */ /* so that it can be restored on exit. */ browselevel = countContexts(CTXT_BROWSER, 1); savestack = R_PPStackTop; PROTECT(topExp = R_CurrentExpr); saveToplevelContext = R_ToplevelContext; saveGlobalContext = R_GlobalContext; if (!RDEBUG(rho)) { int skipCalls = asInteger(CADDDR(argList)); cptr = R_GlobalContext; while ( ( !(cptr->callflag & CTXT_FUNCTION) || skipCalls--) && cptr->callflag ) cptr = cptr->nextcontext; Rprintf("Called from: "); int tmp = asInteger(GetOption(install("deparse.max.lines"), R_BaseEnv)); if(tmp != NA_INTEGER && tmp > 0) R_BrowseLines = tmp; if( cptr != R_ToplevelContext ) { PrintValueRec(cptr->call, rho); SET_RDEBUG(cptr->cloenv, 1); } else Rprintf("top level \n"); R_BrowseLines = 0; } R_ReturnedValue = R_NilValue; /* Here we establish two contexts. The first */ /* of these provides a target for return */ /* statements which a user might type at the */ /* browser prompt. The (optional) second one */ /* acts as a target for error returns. */ begincontext(&returncontext, CTXT_BROWSER, call, rho, R_BaseEnv, argList, R_NilValue); if (!SETJMP(returncontext.cjmpbuf)) { begincontext(&thiscontext, CTXT_RESTART, R_NilValue, rho, R_BaseEnv, R_NilValue, R_NilValue); if (SETJMP(thiscontext.cjmpbuf)) { SET_RESTART_BIT_ON(thiscontext.callflag); R_ReturnedValue = R_NilValue; R_Visible = FALSE; } R_GlobalContext = &thiscontext; R_InsertRestartHandlers(&thiscontext, TRUE); R_ReplConsole(rho, savestack, browselevel+1); endcontext(&thiscontext); } endcontext(&returncontext); /* Reset the interpreter state. */ R_CurrentExpr = topExp; UNPROTECT(1); R_PPStackTop = savestack; UNPROTECT(1); R_CurrentExpr = topExp; R_ToplevelContext = saveToplevelContext; R_GlobalContext = saveGlobalContext; return R_ReturnedValue; }
/* "do_parse" - the user interface input/output to files. The internal R_Parse.. functions are defined in ./gram.y (-> gram.c) .Internal( parse(file, n, text, prompt, srcfile, encoding) ) If there is text then that is read and the other arguments are ignored. */ SEXP attribute_hidden do_parse(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP text, prompt, s, source; Rconnection con; Rboolean wasopen, old_latin1 = known_to_be_latin1, old_utf8 = known_to_be_utf8, allKnown = TRUE; int ifile, num, i; const char *encoding; ParseStatus status; RCNTXT cntxt; checkArity(op, args); if(!inherits(CAR(args), "connection")) error(_("'file' must be a character string or connection")); R_ParseError = 0; R_ParseErrorMsg[0] = '\0'; ifile = asInteger(CAR(args)); args = CDR(args); con = getConnection(ifile); wasopen = con->isopen; num = asInteger(CAR(args)); args = CDR(args); if (num == 0) return(allocVector(EXPRSXP, 0)); PROTECT(text = coerceVector(CAR(args), STRSXP)); if(length(CAR(args)) && !length(text)) errorcall(call, _("coercion of 'text' to character was unsuccessful")); args = CDR(args); prompt = CAR(args); args = CDR(args); source = CAR(args); args = CDR(args); if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1) error(_("invalid '%s' value"), "encoding"); encoding = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */ known_to_be_latin1 = known_to_be_utf8 = FALSE; /* allow 'encoding' to override declaration on 'text'. */ if(streql(encoding, "latin1")) { known_to_be_latin1 = TRUE; allKnown = FALSE; } else if(streql(encoding, "UTF-8")) { known_to_be_utf8 = TRUE; allKnown = FALSE; } else if(!streql(encoding, "unknown") && !streql(encoding, "native.enc")) warning(_("argument '%s = \"%s\"' will be ignored"), "encoding", encoding); if (prompt == R_NilValue) PROTECT(prompt); else PROTECT(prompt = coerceVector(prompt, STRSXP)); if (length(text) > 0) { /* If 'text' has known encoding then we can be sure it will be correctly re-encoded to the current encoding by translateChar in the parser and so could mark the result in a Latin-1 or UTF-8 locale. A small complication is that different elements could have different encodings, but all that matters is that all non-ASCII elements have known encoding. */ for(i = 0; i < length(text); i++) if(!ENC_KNOWN(STRING_ELT(text, i)) && !IS_ASCII(STRING_ELT(text, i))) { allKnown = FALSE; break; } if(allKnown) { known_to_be_latin1 = old_latin1; known_to_be_utf8 = old_utf8; } if (num == NA_INTEGER) num = -1; s = R_ParseVector(text, num, &status, source); if (status != PARSE_OK) parseError(call, R_ParseError); } else if (ifile >= 3) {/* file != "" */ if (num == NA_INTEGER) num = -1; if(!wasopen) { if(!con->open(con)) error(_("cannot open the connection")); /* Set up a context which will close the connection on error */ begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue); cntxt.cend = &con_cleanup; cntxt.cenddata = con; } if(!con->canread) error(_("cannot read from this connection")); s = R_ParseConn(con, num, &status, source); if(!wasopen) { PROTECT(s); endcontext(&cntxt); con->close(con); UNPROTECT(1); } if (status != PARSE_OK) parseError(call, R_ParseError); } else { if (num == NA_INTEGER) num = 1; s = R_ParseBuffer(&R_ConsoleIob, num, &status, prompt, source); if (status != PARSE_OK) parseError(call, R_ParseError); } UNPROTECT(2); known_to_be_latin1 = old_latin1; known_to_be_utf8 = old_utf8; return s; }
SEXP writetable(SEXP call, SEXP op, SEXP args, SEXP env) { SEXP x, sep, rnames, eol, na, dec, quote, xj; int nr, nc, i, j, qmethod; Rboolean wasopen, quote_rn = FALSE, *quote_col; Rconnection con; const char *csep, *ceol, *cna, *sdec, *tmp=NULL /* -Wall */; char cdec; SEXP *levels; R_StringBuffer strBuf = {NULL, 0, MAXELTSIZE}; wt_info wi; RCNTXT cntxt; args = CDR(args); x = CAR(args); args = CDR(args); /* this is going to be a connection open or openable for writing */ if(!inherits(CAR(args), "connection")) error(_("'file' is not a connection")); con = getConnection(asInteger(CAR(args))); args = CDR(args); if(!con->canwrite) error(_("cannot write to this connection")); wasopen = con->isopen; if(!wasopen) { strcpy(con->mode, "wt"); if(!con->open(con)) error(_("cannot open the connection")); } nr = asInteger(CAR(args)); args = CDR(args); nc = asInteger(CAR(args)); args = CDR(args); rnames = CAR(args); args = CDR(args); sep = CAR(args); args = CDR(args); eol = CAR(args); args = CDR(args); na = CAR(args); args = CDR(args); dec = CAR(args); args = CDR(args); quote = CAR(args); args = CDR(args); qmethod = asLogical(CAR(args)); if(nr == NA_INTEGER) error(_("invalid '%s' argument"), "nr"); if(nc == NA_INTEGER) error(_("invalid '%s' argument"), "nc"); if(!isNull(rnames) && !isString(rnames)) error(_("invalid '%s' argument"), "rnames"); if(!isString(sep)) error(_("invalid '%s' argument"), "sep"); if(!isString(eol)) error(_("invalid '%s' argument"), "eol"); if(!isString(na)) error(_("invalid '%s' argument"), "na"); if(!isString(dec)) error(_("invalid '%s' argument"), "dec"); if(qmethod == NA_LOGICAL) error(_("invalid '%s' argument"), "qmethod"); csep = translateChar(STRING_ELT(sep, 0)); ceol = translateChar(STRING_ELT(eol, 0)); cna = translateChar(STRING_ELT(na, 0)); sdec = translateChar(STRING_ELT(dec, 0)); if(strlen(sdec) != 1) error(_("'dec' must be a single character")); cdec = sdec[0]; quote_col = (Rboolean *) R_alloc(nc, sizeof(Rboolean)); for(j = 0; j < nc; j++) quote_col[j] = FALSE; for(i = 0; i < length(quote); i++) { /* NB, quote might be NULL */ int this = INTEGER(quote)[i]; if(this == 0) quote_rn = TRUE; if(this > 0) quote_col[this - 1] = TRUE; } R_AllocStringBuffer(0, &strBuf); PrintDefaults(); wi.savedigits = R_print.digits; R_print.digits = DBL_DIG;/* MAX precision */ wi.con = con; wi.wasopen = wasopen; wi.buf = &strBuf; begincontext(&cntxt, CTXT_CCODE, call, R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue); cntxt.cend = &wt_cleanup; cntxt.cenddata = &wi; if(isVectorList(x)) { /* A data frame */ /* handle factors internally, check integrity */ levels = (SEXP *) R_alloc(nc, sizeof(SEXP)); for(j = 0; j < nc; j++) { xj = VECTOR_ELT(x, j); if(LENGTH(xj) != nr) error(_("corrupt data frame -- length of column %d does not not match nrows"), j+1); if(inherits(xj, "factor")) { levels[j] = getAttrib(xj, R_LevelsSymbol); } else levels[j] = R_NilValue; } for(i = 0; i < nr; i++) { if(i % 1000 == 999) R_CheckUserInterrupt(); if(!isNull(rnames)) Rconn_printf(con, "%s%s", EncodeElement2(rnames, i, quote_rn, qmethod, &strBuf, cdec), csep); for(j = 0; j < nc; j++) { xj = VECTOR_ELT(x, j); if(j > 0) Rconn_printf(con, "%s", csep); if(isna(xj, i)) tmp = cna; else { if(!isNull(levels[j])) { /* We do not assume factors have integer levels, although they should. */ if(TYPEOF(xj) == INTSXP) tmp = EncodeElement2(levels[j], INTEGER(xj)[i] - 1, quote_col[j], qmethod, &strBuf, cdec); else if(TYPEOF(xj) == REALSXP) tmp = EncodeElement2(levels[j], (int) (REAL(xj)[i] - 1), quote_col[j], qmethod, &strBuf, cdec); else error("column %s claims to be a factor but does not have numeric codes", j+1); } else { tmp = EncodeElement2(xj, i, quote_col[j], qmethod, &strBuf, cdec); } /* if(cdec) change_dec(tmp, cdec, TYPEOF(xj)); */ } Rconn_printf(con, "%s", tmp); } Rconn_printf(con, "%s", ceol); } } else { /* A matrix */ if(!isVectorAtomic(x)) UNIMPLEMENTED_TYPE("write.table, matrix method", x); /* quick integrity check */ if(LENGTH(x) != nr * nc) error(_("corrupt matrix -- dims not not match length")); for(i = 0; i < nr; i++) { if(i % 1000 == 999) R_CheckUserInterrupt(); if(!isNull(rnames)) Rconn_printf(con, "%s%s", EncodeElement2(rnames, i, quote_rn, qmethod, &strBuf, cdec), csep); for(j = 0; j < nc; j++) { if(j > 0) Rconn_printf(con, "%s", csep); if(isna(x, i + j*nr)) tmp = cna; else { tmp = EncodeElement2(x, i + j*nr, quote_col[j], qmethod, &strBuf, cdec); /* if(cdec) change_dec(tmp, cdec, TYPEOF(x)); */ } Rconn_printf(con, "%s", tmp); } Rconn_printf(con, "%s", ceol); } } endcontext(&cntxt); wt_cleanup(&wi); return R_NilValue; }
SEXP attribute_hidden do_cat(SEXP call, SEXP op, SEXP args, SEXP rho) { cat_info ci; RCNTXT cntxt; SEXP objs, file, fill, sepr, labs, s; int ifile; Rconnection con; int append; int i, iobj, n, nobjs, pwidth, width, sepw, lablen, ntot, nlsep, nlines; char buf[512]; const char *p = ""; checkArity(op, args); /* Use standard printing defaults */ PrintDefaults(); objs = CAR(args); args = CDR(args); file = CAR(args); ifile = asInteger(file); con = getConnection(ifile); if(!con->canwrite) /* if it is not open, we may not know yet */ error(_("cannot write to this connection")); args = CDR(args); sepr = CAR(args); if (!isString(sepr)) error(_("invalid '%s' specification"), "sep"); nlsep = 0; for (i = 0; i < LENGTH(sepr); i++) if (strstr(CHAR(STRING_ELT(sepr, i)), "\n")) nlsep = 1; /* ASCII */ args = CDR(args); fill = CAR(args); if ((!isNumeric(fill) && !isLogical(fill)) || (length(fill) != 1)) error(_("invalid '%s' argument"), "fill"); if (isLogical(fill)) { if (asLogical(fill) == 1) pwidth = R_print.width; else pwidth = INT_MAX; } else pwidth = asInteger(fill); if(pwidth <= 0) { warning(_("non-positive 'fill' argument will be ignored")); pwidth = INT_MAX; } args = CDR(args); labs = CAR(args); if (!isString(labs) && labs != R_NilValue) error(_("invalid '%s' argument"), "labels"); lablen = length(labs); args = CDR(args); append = asLogical(CAR(args)); if (append == NA_LOGICAL) error(_("invalid '%s' specification"), "append"); ci.wasopen = con->isopen; ci.changedcon = switch_stdout(ifile, 0); /* will open new connection if required, and check for writeable */ #ifdef Win32 /* do this after re-sinking output */ WinCheckUTF8(); #endif ci.con = con; /* set up a context which will close the connection if there is an error */ begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv, R_NilValue, R_NilValue); cntxt.cend = &cat_cleanup; cntxt.cenddata = &ci; nobjs = length(objs); width = 0; ntot = 0; nlines = 0; for (iobj = 0; iobj < nobjs; iobj++) { s = VECTOR_ELT(objs, iobj); if (iobj != 0 && !isNull(s)) cat_printsep(sepr, ntot++); n = length(s); /* 0-length objects are ignored */ if (n > 0) { if (labs != R_NilValue && (iobj == 0) && (asInteger(fill) > 0)) { Rprintf("%s ", trChar(STRING_ELT(labs, nlines % lablen))); /* FIXME -- Rstrlen allows for double-width chars */ width += Rstrlen(STRING_ELT(labs, nlines % lablen), 0) + 1; nlines++; } if (isString(s)) p = trChar(STRING_ELT(s, 0)); else if (isSymbol(s)) /* length 1 */ p = CHAR(PRINTNAME(s)); else if (isVectorAtomic(s)) { /* Not a string, as that is covered above. Thus the maximum size is about 60. The copy is needed as cat_newline might reuse the buffer. Use strncpy is in case these assumptions change. */ p = EncodeElement0(s, 0, 0, OutDec); strncpy(buf, p, 512); buf[511] = '\0'; p = buf; } #ifdef fixed_cat else if (isVectorList(s)) { /* FIXME: call EncodeElement() for every element of s. Real Problem: `s' can be large; should do line breaking etc.. (buf is of limited size) */ } #endif else errorcall(call, _("argument %d (type '%s') cannot be handled by 'cat'"), 1+iobj, type2char(TYPEOF(s))); /* FIXME : cat(...) should handle ANYTHING */ size_t w = strlen(p); cat_sepwidth(sepr, &sepw, ntot); if ((iobj > 0) && (width + w + sepw > pwidth)) { cat_newline(labs, &width, lablen, nlines); nlines++; } for (i = 0; i < n; i++, ntot++) { Rprintf("%s", p); width += (int)(w + sepw); if (i < (n - 1)) { cat_printsep(sepr, ntot); if (isString(s)) p = trChar(STRING_ELT(s, i+1)); else { p = EncodeElement0(s, i+1, 0, OutDec); strncpy(buf, p, 512); buf[511] = '\0'; p = buf; } w = (int) strlen(p); cat_sepwidth(sepr, &sepw, ntot); /* This is inconsistent with the version above. As from R 2.3.0, fill <= 0 is ignored. */ if ((width + w + sepw > pwidth) && pwidth) { cat_newline(labs, &width, lablen, nlines); nlines++; } } else ntot--; /* we don't print sep after last, so don't advance */ } } } if ((pwidth != INT_MAX) || nlsep) Rprintf("\n"); /* end the context after anything that could raise an error but before doing the cleanup so the cleanup doesn't get done twice */ endcontext(&cntxt); cat_cleanup(&ci); return R_NilValue; }