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;
}
