static int process_Renviron(const char *filename) { FILE *fp; char *s, *p, sm[BUF_SIZE], *lhs, *rhs, msg[MSG_SIZE+50]; int errs = 0; if (!filename || !(fp = R_fopen(filename, "r"))) return 0; snprintf(msg, MSG_SIZE+50, "\n File %s contains invalid line(s)", filename); while(fgets(sm, BUF_SIZE, fp)) { sm[BUF_SIZE-1] = '\0'; s = rmspace(sm); if(strlen(s) == 0 || s[0] == '#') continue; if(!(p = Rf_strchr(s, '='))) { errs++; if(strlen(msg) < MSG_SIZE) { strcat(msg, "\n "); strcat(msg, s); } continue; } *p = '\0'; lhs = rmspace(s); rhs = findterm(rmspace(p+1)); /* set lhs = rhs */ if(strlen(lhs) && strlen(rhs)) Putenv(lhs, rhs); } fclose(fp); if (errs) { strcat(msg, "\n They were ignored\n"); R_ShowMessage(msg); } return 1; }
/* As from R 2.7.0 we assume file, editor are in UTF-8 */ int R_EditFiles(int nfile, const char **file, const char **title, const char *editor) { int i; char buf[1024]; if (nfile > 0) { if (editor == NULL || strlen(editor) == 0) editor = "internal"; for (i = 0; i < nfile; i++) { if (!strcmp(editor, "internal")) { Rgui_Edit(file[i], CE_UTF8, title[i], 0); } else { /* Quote path if necessary */ if (editor[0] != '"' && Rf_strchr(editor, ' ')) snprintf(buf, 1024, "\"%s\" \"%s\"", editor, file[i]); else snprintf(buf, 1024, "%s \"%s\"", editor, file[i]); runcmd(buf, CE_UTF8, 0, 1, NULL, NULL, NULL); } } return 0; } return 1; }
static char *findterm(char *s) { char *p, *q, *r2, *ss=s; static char ans[BUF_SIZE]; if(!strlen(s)) return ""; ans[0] = '\0'; while(1) { /* Look for ${...}, taking care to look for inner matches */ p = Rf_strchr(s, '$'); if(!p || p[1] != '{') break; q = findRbrace(p+2); if(!q) break; /* copy over leading part */ size_t nans = strlen(ans); strncat(ans, s, (size_t) (p - s)); ans[nans + p - s] = '\0'; char r[q - p + 2]; strncpy(r, p, (size_t) (q - p + 1)); r[q - p + 1] = '\0'; r2 = subterm(r); if(strlen(ans) + strlen(r2) < BUF_SIZE) strcat(ans, r2); else return ss; /* now repeat on the tail */ s = q+1; } if(strlen(ans) + strlen(s) < BUF_SIZE) strcat(ans, s); else return ss; return ans; }
/* * nfile = number of files * file = array of filenames * editor = editor to be used. */ int R_EditFiles(int nfile, const char **file, const char **title, const char *editor) { char buf[1024]; if (ptr_R_EditFiles) return(ptr_R_EditFiles(nfile, file, title, editor)); if (nfile > 0) { if (nfile > 1) R_ShowMessage(_("WARNING: Only editing the first in the list of files")); if (ptr_R_EditFile) ptr_R_EditFile((char *) file[0]); else { /* Quote path if necessary */ if (editor[0] != '"' && Rf_strchr(editor, ' ')) snprintf(buf, 1024, "\"%s\" \"%s\"", editor, file[0]); else snprintf(buf, 1024, "%s \"%s\"", editor, file[0]); if (R_system(buf) == 127) warningcall(R_NilValue, _("error in running command")); } return 0; } return 1; }
/* skip along until we find an unmatched right brace */ static char *findRbrace(char *s) { char *p = s, *pl, *pr; int nl = 0, nr = 0; while(nr <= nl) { pl = Rf_strchr(p, '{'); pr = Rf_strchr(p, '}'); if(!pr) return NULL; if(!pl || pr < pl) { p = pr+1; nr++; } else { p = pl+1; nl++; } } return pr; }
int R_ShowFiles(int nfile, const char **file, const char **headers, const char *wtitle, Rboolean del, const char *pager) { int i; char buf[1024]; if (nfile > 0) { if (pager == NULL || strlen(pager) == 0) pager = "internal"; for (i = 0; i < nfile; i++) { if(!access(file[i], R_OK)) { if (!strcmp(pager, "internal")) { newpager(wtitle, file[i], CE_NATIVE, headers[i], del); } else if (!strcmp(pager, "console")) { size_t len; FILE *f; f = R_fopen(file[i], "rt"); if(f) { while((len = fread(buf, 1, 1023, f))) { buf[len] = '\0'; R_WriteConsole(buf, strlen(buf)); } fclose(f); if (del) DeleteFile(file[i]); /* add a blank line */ R_WriteConsole("", 0); } else { snprintf(buf, 1024, _("cannot open file '%s': %s"), file[i], strerror(errno)); warning(buf); } } else { /* Quote path if necessary */ if(pager[0] != '"' && Rf_strchr(pager, ' ')) snprintf(buf, 1024, "\"%s\" \"%s\"", pager, file[i]); else snprintf(buf, 1024, "%s \"%s\"", pager, file[i]); runcmd(buf, CE_NATIVE, 0, 1, NULL, NULL, NULL); } } else { snprintf(buf, 1024, _("file.show(): file '%s' does not exist\n"), file[i]); warning(buf); } } return 0; } return 1; }
static char *subterm(char *s) { char *p, *q; if(strncmp(s, "${", 2)) return s; if(s[strlen(s) - 1] != '}') return s; /* remove leading ${ and final } */ s[strlen(s) - 1] = '\0'; s += 2; s = rmspace(s); if(!strlen(s)) return ""; p = Rf_strchr(s, '-'); if(p) { q = p + 1; /* start of value */ if(p - s > 1 && *(p-1) == ':') *(p-1) = '\0'; else *p = '\0'; } else q = NULL; p = getenv(s); if(p && strlen(p)) return p; /* variable was set and non-empty */ return q ? subterm(q) : (char *) ""; }
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho) { int i, rc; ParseStatus status; SEXP x, fn, envir, ed, src, srcfile, Rfn; char *filename, *editcmd; const char *cmd; const void *vmaxsave; FILE *fp; #ifdef Win32 SEXP ti; char *title; #endif checkArity(op, args); vmaxsave = vmaxget(); x = CAR(args); args = CDR(args); if (TYPEOF(x) == CLOSXP) envir = CLOENV(x); else envir = R_NilValue; PROTECT(envir); fn = CAR(args); args = CDR(args); if (!isString(fn)) error(_("invalid argument to edit()")); if (LENGTH(STRING_ELT(fn, 0)) > 0) { const char *ss = translateChar(STRING_ELT(fn, 0)); filename = R_alloc(strlen(ss), sizeof(char)); strcpy(filename, ss); } else filename = DefaultFileName; if (x != R_NilValue) { if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL) errorcall(call, _("unable to open file")); if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++; if (TYPEOF(x) != CLOSXP || isNull(src = getAttrib(x, R_SourceSymbol))) src = deparse1(x, CXXRFALSE, FORSOURCING); /* deparse for sourcing, not for display */ for (i = 0; i < LENGTH(src); i++) fprintf(fp, "%s\n", translateChar(STRING_ELT(src, i))); fclose(fp); } #ifdef Win32 ti = CAR(args); #endif args = CDR(args); ed = CAR(args); if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid")); cmd = translateChar(STRING_ELT(ed, 0)); if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set")); editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char)); #ifdef Win32 if (!strcmp(cmd,"internal")) { if (!isString(ti)) error(_("'title' must be a string")); if (LENGTH(STRING_ELT(ti, 0)) > 0) { title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char)); strcpy(title, CHAR(STRING_ELT(ti, 0))); } else { title = R_alloc(strlen(filename)+1, sizeof(char)); strcpy(title, filename); } Rgui_Edit(filename, CE_NATIVE, title, 1); } else { /* Quote path if necessary */ if(cmd[0] != '"' && Rf_strchr(cmd, ' ')) sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename); else sprintf(editcmd, "%s \"%s\"", cmd, filename); rc = runcmd(editcmd, CE_NATIVE, 1, 1, NULL, NULL, NULL); if (rc == NOLAUNCH) errorcall(call, _("unable to run editor '%s'"), cmd); if (rc != 0) warningcall(call, _("editor ran but returned error status")); } #else if (ptr_R_EditFile) rc = ptr_R_EditFile(filename); else { sprintf(editcmd, "'%s' '%s'", cmd, filename); // allow for spaces rc = R_system(editcmd); } if (rc != 0) errorcall(call, _("problem with running editor %s"), cmd); #endif if (asLogical(GetOption1(install("keep.source")))) { PROTECT(Rfn = findFun(install("readLines"), R_BaseEnv)); PROTECT(src = lang2(Rfn, ScalarString(mkChar(R_ExpandFileName(filename))))); PROTECT(src = eval(src, R_BaseEnv)); PROTECT(Rfn = findFun(install("srcfilecopy"), R_BaseEnv)); PROTECT(srcfile = lang3(Rfn, ScalarString(mkChar("<tmp>")), src)); srcfile = eval(srcfile, R_BaseEnv); UNPROTECT(5); } else srcfile = R_NilValue; PROTECT(srcfile); /* <FIXME> setup a context to close the file, and parse and eval line by line */ if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL) errorcall(call, _("unable to open file to read")); x = PROTECT(R_ParseFile(fp, -1, &status, srcfile)); fclose(fp); if (status != PARSE_OK) errorcall(call, _("%s occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseErrorMsg, R_ParseError); R_ResetConsole(); { /* can't just eval(x) here */ int j, n; SEXP tmp = R_NilValue; n = LENGTH(x); for (j = 0 ; j < n ; j++) tmp = eval(XVECTOR_ELT(x, j), R_GlobalEnv); x = tmp; } if (TYPEOF(x) == CLOSXP && envir != R_NilValue) SET_CLOENV(x, envir); UNPROTECT(3); vmaxset(vmaxsave); return x; }
SEXP getfmts(SEXP format) { int cnt, v, nfmt; char fmt[MAXLINE+1], bit[MAXLINE+1]; const char *formatString; size_t n, cur, chunk, maxlen = 0; int nthis, nstar; Rboolean use_UTF8; SEXP res = PROTECT(allocVector(STRSXP, MAXNARGS)); #define SET_RESULT(n, s) { \ if (n >= MAXNARGS) error(_("only %d arguments are allowed"), MAXNARGS); \ maxlen = (n) < maxlen ? maxlen : (n) + 1; \ SET_STRING_ELT(res, (n), mkChar(s)); \ } if (!isString(format)) error(_("'fmt' is not a character vector")); nfmt = LENGTH(format); if (nfmt != 1) error(_("'fmt' must be length 1")); use_UTF8 = getCharCE(STRING_ELT(format, 0)) == CE_UTF8; formatString = TRANSLATE_CHAR(format, 0); n = strlen(formatString); if (n > MAXLINE) error(_("'fmt' length exceeds maximal format length %d"), MAXLINE); /* process the format string */ for (cur = 0, cnt = 0; cur < n; cur += chunk) { const char *curFormat = formatString + cur; char *starc; if (formatString[cur] == '%') { /* handle special format command */ if (cur < n - 1 && formatString[cur + 1] == '%') { /* take care of %% in the format */ chunk = 2; strcpy(bit, "%"); } else { /* recognise selected types from Table B-1 of K&R */ /* NB: we deal with "%%" in branch above. */ /* This is MBCS-OK, as we are in a format spec */ /* Include formats c, u, p and n as well as the R formats; this needs to match */ /* C code as well */ chunk = strcspn(curFormat + 1, "diosfeEgGxXaAcupn") + 2; if (cur + chunk > n) error(_("unrecognised format specification '%s'"), curFormat); strncpy(fmt, curFormat, chunk); fmt[chunk] = '\0'; nthis = -1; /* now look for %n$ or %nn$ form */ if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') { v = fmt[1] - '0'; if(fmt[2] == '$') { nthis = v-1; memmove(fmt+1, fmt+3, strlen(fmt)-2); } else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') { v = 10*v + fmt[2] - '0'; nthis = v-1; memmove(fmt+1, fmt+4, strlen(fmt)-3); } } starc = Rf_strchr(fmt, '*'); if (starc) { /* handle * format if present */ nstar = -1; if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') { v = starc[1] - '0'; if(starc[2] == '$') { nstar = v-1; memmove(starc+1, starc+3, strlen(starc)-2); } else if(starc[2] >= '0' && starc[2] <= '9' && starc[3] == '$') { v = 10*v + starc[2] - '0'; nstar = v-1; memmove(starc+1, starc+4, strlen(starc)-3); } } if(nstar < 0) { nstar = cnt++; } if (Rf_strchr(starc+1, '*')) error(_("at most one asterisk '*' is supported in each conversion specification")); SET_RESULT(nstar, "*"); } if (fmt[strlen(fmt) - 1] == '%') { } else { if(nthis < 0) { nthis = cnt++; } SET_RESULT(nthis, fmt); } } } else { /* not '%' : handle string part */ char *ch = Rf_strchr(curFormat, '%'); /* MBCS-aware version used */ chunk = (ch) ? (size_t) (ch - curFormat) : strlen(curFormat); strncpy(bit, curFormat, chunk); bit[chunk] = '\0'; } } /* end for ( each chunk ) */ res = xlengthgets(res, maxlen); UNPROTECT(1); return res; }
SEXP attribute_hidden do_sprintf(SEXP call, SEXP op, SEXP args, SEXP env) { int i, nargs, cnt, v, thislen, nfmt, nprotect = 0; /* fmt2 is a copy of fmt with '*' expanded. bit will hold numeric formats and %<w>s, so be quite small. */ char fmt[MAXLINE+1], fmt2[MAXLINE+10], *fmtp, bit[MAXLINE+1], *outputString; const char *formatString; size_t n, cur, chunk; SEXP format, _this, a[MAXNARGS], ans /* -Wall */ = R_NilValue; int ns, maxlen, lens[MAXNARGS], nthis, nstar, star_arg = 0; static R_StringBuffer outbuff = {NULL, 0, MAXELTSIZE}; Rboolean has_star, use_UTF8; #define _my_sprintf(_X_) \ { \ int nc = snprintf(bit, MAXLINE+1, fmtp, _X_); \ if (nc > MAXLINE) \ error(_("required resulting string length %d is greater than maximal %d"), \ nc, MAXLINE); \ } nargs = length(args); /* grab the format string */ format = CAR(args); if (!isString(format)) error(_("'fmt' is not a character vector")); nfmt = length(format); if (nfmt == 0) return allocVector(STRSXP, 0); args = CDR(args); nargs--; if(nargs >= MAXNARGS) error(_("only %d arguments are allowed"), MAXNARGS); /* record the args for possible coercion and later re-ordering */ for(i = 0; i < nargs; i++, args = CDR(args)) { SEXPTYPE t_ai; a[i] = CAR(args); if((t_ai = TYPEOF(a[i])) == LANGSXP || t_ai == SYMSXP) /* << maybe add more .. */ error(_("invalid type of argument[%d]: '%s'"), i+1, CHAR(type2str(t_ai))); lens[i] = length(a[i]); if(lens[i] == 0) return allocVector(STRSXP, 0); } #define CHECK_maxlen \ maxlen = nfmt; \ for(i = 0; i < nargs; i++) \ if(maxlen < lens[i]) maxlen = lens[i]; \ if(maxlen % nfmt) \ error(_("arguments cannot be recycled to the same length")); \ for(i = 0; i < nargs; i++) \ if(maxlen % lens[i]) \ error(_("arguments cannot be recycled to the same length")) CHECK_maxlen; outputString = R_AllocStringBuffer(0, &outbuff); /* We do the format analysis a row at a time */ for(ns = 0; ns < maxlen; ns++) { outputString[0] = '\0'; use_UTF8 = getCharCE(STRING_ELT(format, ns % nfmt)) == CE_UTF8; if (!use_UTF8) { for(i = 0; i < nargs; i++) { if (!isString(a[i])) continue; if (getCharCE(STRING_ELT(a[i], ns % lens[i])) == CE_UTF8) { use_UTF8 = TRUE; break; } } } formatString = TRANSLATE_CHAR(format, ns % nfmt); n = strlen(formatString); if (n > MAXLINE) error(_("'fmt' length exceeds maximal format length %d"), MAXLINE); /* process the format string */ for (cur = 0, cnt = 0; cur < n; cur += chunk) { const char *curFormat = formatString + cur, *ss; char *starc; ss = NULL; if (formatString[cur] == '%') { /* handle special format command */ if (cur < n - 1 && formatString[cur + 1] == '%') { /* take care of %% in the format */ chunk = 2; strcpy(bit, "%"); } else { /* recognise selected types from Table B-1 of K&R */ /* NB: we deal with "%%" in branch above. */ /* This is MBCS-OK, as we are in a format spec */ chunk = strcspn(curFormat + 1, "diosfeEgGxXaA") + 2; if (cur + chunk > n) error(_("unrecognised format specification '%s'"), curFormat); strncpy(fmt, curFormat, chunk); fmt[chunk] = '\0'; nthis = -1; /* now look for %n$ or %nn$ form */ if (strlen(fmt) > 3 && fmt[1] >= '1' && fmt[1] <= '9') { v = fmt[1] - '0'; if(fmt[2] == '$') { if(v > nargs) error(_("reference to non-existent argument %d"), v); nthis = v-1; memmove(fmt+1, fmt+3, strlen(fmt)-2); } else if(fmt[2] >= '0' && fmt[2] <= '9' && fmt[3] == '$') { v = 10*v + fmt[2] - '0'; if(v > nargs) error(_("reference to non-existent argument %d"), v); nthis = v-1; memmove(fmt+1, fmt+4, strlen(fmt)-3); } } starc = Rf_strchr(fmt, '*'); if (starc) { /* handle * format if present */ nstar = -1; if (strlen(starc) > 3 && starc[1] >= '1' && starc[1] <= '9') { v = starc[1] - '0'; if(starc[2] == '$') { if(v > nargs) error(_("reference to non-existent argument %d"), v); nstar = v-1; memmove(starc+1, starc+3, strlen(starc)-2); } else if(starc[2] >= '0' && starc[2] <= '9' && starc[3] == '$') { v = 10*v + starc[2] - '0'; if(v > nargs) error(_("reference to non-existent argument %d"), v); nstar = v-1; memmove(starc+1, starc+4, strlen(starc)-3); } } if(nstar < 0) { if (cnt >= nargs) error(_("too few arguments")); nstar = cnt++; } if (Rf_strchr(starc+1, '*')) error(_("at most one asterisk '*' is supported in each conversion specification")); _this = a[nstar]; if(ns == 0 && TYPEOF(_this) == REALSXP) { _this = coerceVector(_this, INTSXP); PROTECT(a[nstar] = _this); nprotect++; } if(TYPEOF(_this) != INTSXP || LENGTH(_this)<1 || INTEGER(_this)[ns % LENGTH(_this)] == NA_INTEGER) error(_("argument for '*' conversion specification must be a number")); star_arg = INTEGER(_this)[ns % LENGTH(_this)]; has_star = TRUE; } else has_star = FALSE; if (fmt[strlen(fmt) - 1] == '%') { /* handle % with formatting options */ if (has_star) snprintf(bit, MAXLINE+1, fmt, star_arg); else strcpy(bit, fmt); /* was sprintf(..) for which some compiler warn */ } else { Rboolean did_this = FALSE; if(nthis < 0) { if (cnt >= nargs) error(_("too few arguments")); nthis = cnt++; } _this = a[nthis]; if (has_star) { size_t nf; char *p, *q = fmt2; for (p = fmt; *p; p++) if (*p == '*') q += sprintf(q, "%d", star_arg); else *q++ = *p; *q = '\0'; nf = strlen(fmt2); if (nf > MAXLINE) error(_("'fmt' length exceeds maximal format length %d"), MAXLINE); fmtp = fmt2; } else fmtp = fmt; #define CHECK_this_length \ PROTECT(_this); \ thislen = length(_this); \ if(thislen == 0) \ error(_("coercion has changed vector length to 0")) /* Now let us see if some minimal coercion would be sensible, but only do so once, for ns = 0: */ if(ns == 0) { SEXP tmp; Rboolean do_check; switch(*findspec(fmtp)) { case 'd': case 'i': case 'o': case 'x': case 'X': if(TYPEOF(_this) == REALSXP) { double r = REAL(_this)[0]; if((double)((int) r) == r) _this = coerceVector(_this, INTSXP); PROTECT(a[nthis] = _this); nprotect++; } break; case 'a': case 'A': case 'e': case 'f': case 'g': case 'E': case 'G': if(TYPEOF(_this) != REALSXP && /* no automatic as.double(<string>) : */ TYPEOF(_this) != STRSXP) { PROTECT(tmp = lang2(install("as.double"), _this)); #define COERCE_THIS_TO_A \ _this = eval(tmp, env); \ UNPROTECT(1); \ PROTECT(a[nthis] = _this); \ nprotect++; \ did_this = TRUE; \ CHECK_this_length; \ do_check = (lens[nthis] == maxlen); \ lens[nthis] = thislen; /* may have changed! */ \ if(do_check && thislen < maxlen) { \ CHECK_maxlen; \ } COERCE_THIS_TO_A } break; case 's': if(TYPEOF(_this) != STRSXP) { /* as.character method might call sprintf() */ size_t nc = strlen(outputString); char *z = Calloc(nc+1, char); strcpy(z, outputString); PROTECT(tmp = lang2(install("as.character"), _this)); COERCE_THIS_TO_A strcpy(outputString, z); Free(z); } break; default: break; } } /* ns == 0 (first-time only) */ if(!did_this) CHECK_this_length; switch(TYPEOF(_this)) { case LGLSXP: { int x = LOGICAL(_this)[ns % thislen]; if (checkfmt(fmtp, "di")) error(_("invalid format '%s'; %s"), fmtp, _("use format %d or %i for logical objects")); if (x == NA_LOGICAL) { fmtp[strlen(fmtp)-1] = 's'; _my_sprintf("NA") } else { _my_sprintf(x) } break; } case INTSXP: { int x = INTEGER(_this)[ns % thislen]; if (checkfmt(fmtp, "dioxX")) error(_("invalid format '%s'; %s"), fmtp, _("use format %d, %i, %o, %x or %X for integer objects")); if (x == NA_INTEGER) { fmtp[strlen(fmtp)-1] = 's'; _my_sprintf("NA") } else { _my_sprintf(x) } break; }
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); }
static int find_char(int ch, const char *str) { char *p; p = Rf_strchr(str, ch); if(!p) return -1; else return p - str; }
SEXP do_edit(SEXP call, SEXP op, SEXP args, SEXP rho) { int i, rc; ParseStatus status; SEXP x, fn, envir, ti, ed, t; char *filename, *editcmd, *vmaxsave, *cmd; FILE *fp; #ifdef Win32 char *title; #endif checkArity(op, args); vmaxsave = vmaxget(); x = CAR(args); args = CDR(args); if (TYPEOF(x) == CLOSXP) envir = CLOENV(x); else envir = R_NilValue; PROTECT(envir); fn = CAR(args); args = CDR(args); if (!isString(fn)) error(_("invalid argument to edit()")); if (LENGTH(STRING_ELT(fn, 0)) > 0) { filename = R_alloc(strlen(CHAR(STRING_ELT(fn, 0))), sizeof(char)); strcpy(filename, CHAR(STRING_ELT(fn, 0))); } else filename = DefaultFileName; if (x != R_NilValue) { if((fp=R_fopen(R_ExpandFileName(filename), "w")) == NULL) errorcall(call, _("unable to open file")); if (LENGTH(STRING_ELT(fn, 0)) == 0) EdFileUsed++; if (TYPEOF(x) != CLOSXP || isNull(t = getAttrib(x, R_SourceSymbol))) t = deparse1(x, 0, FORSOURCING); /* deparse for sourcing, not for display */ for (i = 0; i < LENGTH(t); i++) fprintf(fp, "%s\n", CHAR(STRING_ELT(t, i))); fclose(fp); } ti = CAR(args); args = CDR(args); ed = CAR(args); if (!isString(ed)) errorcall(call, _("argument 'editor' type not valid")); cmd = CHAR(STRING_ELT(ed, 0)); if (strlen(cmd) == 0) errorcall(call, _("argument 'editor' is not set")); editcmd = R_alloc(strlen(cmd) + strlen(filename) + 6, sizeof(char)); #ifdef Win32 if (!strcmp(cmd,"internal")) { if (!isString(ti)) error(_("'title' must be a string")); if (LENGTH(STRING_ELT(ti, 0)) > 0) { title = R_alloc(strlen(CHAR(STRING_ELT(ti, 0)))+1, sizeof(char)); strcpy(title, CHAR(STRING_ELT(ti, 0))); } else { title = R_alloc(strlen(filename)+1, sizeof(char)); strcpy(title, filename); } Rgui_Edit(filename, title, 1); } else { /* Quote path if necessary */ if(cmd[0] != '"' && Rf_strchr(cmd, ' ')) sprintf(editcmd, "\"%s\" \"%s\"", cmd, filename); else sprintf(editcmd, "%s \"%s\"", cmd, filename); rc = runcmd(editcmd, 1, 1, ""); if (rc == NOLAUNCH) errorcall(call, _("unable to run editor '%s'"), cmd); if (rc != 0) warningcall(call, _("editor ran but returned error status")); } #else if (ptr_R_EditFile) rc = ptr_R_EditFile(filename); else { sprintf(editcmd, "%s %s", cmd, filename); rc = R_system(editcmd); } if (rc != 0) errorcall(call, _("problem with running editor %s"), cmd); #endif if((fp = R_fopen(R_ExpandFileName(filename), "r")) == NULL) errorcall(call, _("unable to open file to read")); R_ParseCnt = 0; x = PROTECT(R_ParseFile(fp, -1, &status)); fclose(fp); if (status != PARSE_OK) errorcall(call, _("an error occurred on line %d\n use a command like\n x <- edit()\n to recover"), R_ParseError); R_ResetConsole(); { /* can't just eval(x) here */ int j, n; SEXP tmp = R_NilValue; n = LENGTH(x); for (j = 0 ; j < n ; j++) tmp = eval(VECTOR_ELT(x, j), R_GlobalEnv); x = tmp; } if (TYPEOF(x) == CLOSXP && envir != R_NilValue) SET_CLOENV(x, envir); UNPROTECT(2); vmaxset(vmaxsave); return (x); }