/* NB this is called by R.app even though it is in no public header, so alter there if you alter this */ const char *EncodeElement(SEXP x, int indx, int quote, char cdec) { char dec[2]; dec[0] = cdec; dec[1] = '\0'; return EncodeElement0(x, indx, quote, dec); }
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; }