The R Project SVN R

Rev

Rev 75449 | Rev 79007 | Go to most recent revision | Details | Compare with Previous | Last modification | View Log | RSS feed

Rev Author Line No. Line
2 r 1 
/*
73256 maechler 2 
 *  R : A Computer Language for Statistical Data Analysis
2 r 3 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
75449 kalibera 4 
 *  Copyright (C) 2001-2018   The R Core Team
2 r 5 
 *
6 
 *  This program is free software; you can redistribute it and/or modify
7 
 *  it under the terms of the GNU General Public License as published by
8 
 *  the Free Software Foundation; either version 2 of the License, or
9 
 *  (at your option) any later version.
10 
 *
11 
 *  This program is distributed in the hope that it will be useful,
12 
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
13 
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14 
 *  GNU General Public License for more details.
15 
 *
16 
 *  You should have received a copy of the GNU General Public License
42307 ripley 17 
 *  along with this program; if not, a copy is available at
68947 ripley 18 
 *  https://www.R-project.org/Licenses/
2 r 19 
 */
20 
 
5187 hornik 21 
#ifdef HAVE_CONFIG_H
7701 hornik 22 
#include <config.h>
5187 hornik 23 
#endif
24 
 
75571 maechler 25 
#include <Parse.h> // -> IOStuff.h, Defn.h
60667 ripley 26 
#include <Internal.h>
11668 ripley 27 
#include <Fileio.h>
28 
#include <Rconnections.h>
2 r 29 
 
44201 ripley 30 
SEXP attribute_hidden getParseContext(void)
35498 murdoch 31 
{
32 
    int i, last = PARSE_CONTEXT_SIZE;
33 
    char context[PARSE_CONTEXT_SIZE+1];
34 
 
35 
    SEXP ans = R_NilValue, ans2;
55061 ripley 36 
    int nn, nread;
35498 murdoch 37 
    char c;
38 
 
39 
    context[last] = '\0';
47713 murdoch 40 
    for (i=R_ParseContextLast; last>0 ; i += PARSE_CONTEXT_SIZE - 1) {
35498 murdoch 41 
	i = i % PARSE_CONTEXT_SIZE;
42 
	context[--last] = R_ParseContext[i];
43 
	if (!context[last]) {
44 
	    last++;
45 
	    break;
46 
	}
47 
    }
40705 ripley 48 
 
35498 murdoch 49 
    nn = 16; /* initially allocate space for 16 lines */
50 
    PROTECT(ans = allocVector(STRSXP, nn));
51 
    c = context[last];
52 
    nread = 0;
53 
    while(c) {
45446 ripley 54 
	nread++;
35498 murdoch 55 
	if(nread >= nn) {
56 
	    ans2 = allocVector(STRSXP, 2*nn);
57 
	    for(i = 0; i < nn; i++)
58 
		SET_STRING_ELT(ans2, i, STRING_ELT(ans, i));
59 
	    nn *= 2;
60 
	    UNPROTECT(1); /* old ans */
61 
	    PROTECT(ans = ans2);
62 
	}
63 
	i = last;
42147 murdoch 64 
	while((c = context[i++])) {
35498 murdoch 65 
	    if(c == '\n') break;
66 
	}
42147 murdoch 67 
	context[i-1] = '\0';
35498 murdoch 68 
	SET_STRING_ELT(ans, nread-1, mkChar(context + last));
40220 murdoch 69 
	last = i;
35498 murdoch 70 
    }
71 
    /* get rid of empty line after last newline */
47481 murdoch 72 
    if (nread && !length(STRING_ELT(ans, nread-1))) {
68923 ripley 73 
	nread--;
74 
	R_ParseContextLine--;
47481 murdoch 75 
    }
35498 murdoch 76 
    PROTECT(ans2 = allocVector(STRSXP, nread));
77 
    for(i = 0; i < nread; i++)
78 
	SET_STRING_ELT(ans2, i, STRING_ELT(ans, i));
79 
    UNPROTECT(2);
80 
    return ans2;
40705 ripley 81 
}
35498 murdoch 82 
 
55743 luke 83 
static void getParseFilename(char* buffer, size_t buflen)
39996 murdoch 84 
{
85 
    buffer[0] = '\0';
61399 murdoch 86 
    if (R_ParseErrorFile) {
68923 ripley 87 
	if (isEnvironment(R_ParseErrorFile)) {
61399 murdoch 88 
	    SEXP filename;
89 
	    PROTECT(filename = findVar(install("filename"), R_ParseErrorFile));
66671 murdoch 90 
	    if (isString(filename) && length(filename)) {
68923 ripley 91 
		strncpy(buffer, CHAR(STRING_ELT(filename, 0)), buflen - 1);
92 
		buffer[buflen - 1] = '\0';
93 
	    }
61399 murdoch 94 
	    UNPROTECT(1);
68923 ripley 95 
	} else if (isString(R_ParseErrorFile) && length(R_ParseErrorFile)) {
96 
	    strncpy(buffer, CHAR(STRING_ELT(R_ParseErrorFile, 0)), buflen - 1);
97 
	    buffer[buflen - 1] = '\0';
98 
	}
66671 murdoch 99 
    }
39996 murdoch 100 
}
101 
 
47713 murdoch 102 
static SEXP tabExpand(SEXP strings)
103 
{
104 
    int i;
105 
    char buffer[200], *b;
106 
    const char *input;
107 
    SEXP result;
48500 murdoch 108 
    PROTECT(strings);
47713 murdoch 109 
    PROTECT(result = allocVector(STRSXP, length(strings)));
110 
    for (i = 0; i < length(strings); i++) {
68923 ripley 111 
	input = CHAR(STRING_ELT(strings, i));
112 
	for (b = buffer; *input && (b-buffer < 192); input++) {
113 
	    if (*input == '\t') do {
114 
		*b++ = ' ';
115 
	    } while (((b-buffer) & 7) != 0);
116 
	    else *b++ = *input;
117 
	}
118 
	*b = '\0';
119 
	SET_STRING_ELT(result, i, mkCharCE(buffer, Rf_getCharCE(STRING_ELT(strings, i))));
47713 murdoch 120 
    }
48500 murdoch 121 
    UNPROTECT(2);
47713 murdoch 122 
    return result;
123 
}
68923 ripley 124 
 
67181 luke 125 
void NORET parseError(SEXP call, int linenum)
35498 murdoch 126 
{
47713 murdoch 127 
    SEXP context;
128 
    int len, width;
129 
    char filename[128], buffer[10];
130 
    PROTECT(context = tabExpand(getParseContext()));
131 
    len = length(context);
35498 murdoch 132 
    if (linenum) {
45446 ripley 133 
	getParseFilename(filename, sizeof(filename)-2);
47481 murdoch 134 
	if (strlen(filename)) strcpy(filename + strlen(filename), ":");
40705 ripley 135 
 
35498 murdoch 136 
	switch (len) {
40705 ripley 137 
	case 0:
60844 ripley 138 
	    error("%s%d:%d: %s",
47481 murdoch 139 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg);
40705 ripley 140 
	    break;
58489 ripley 141 
	case 1: // replaces use of %n
68923 ripley 142 
	    width = snprintf(buffer, 10, "%d: ", R_ParseContextLine);
60844 ripley 143 
	    error("%s%d:%d: %s\n%d: %s\n%*s",
47481 murdoch 144 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg,
68923 ripley 145 
		  R_ParseContextLine, CHAR(STRING_ELT(context, 0)),
63417 murdoch 146 
		  width+R_ParseErrorCol+1, "^");
40705 ripley 147 
	    break;
148 
	default:
62580 ripley 149 
	    width = snprintf(buffer, 10, "%d:", R_ParseContextLine);
60844 ripley 150 
	    error("%s%d:%d: %s\n%d: %s\n%d: %s\n%*s",
47481 murdoch 151 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg,
152 
		  R_ParseContextLine-1, CHAR(STRING_ELT(context, len-2)),
68923 ripley 153 
		  R_ParseContextLine, CHAR(STRING_ELT(context, len-1)),
63417 murdoch 154 
		  width+R_ParseErrorCol+1, "^");
40705 ripley 155 
	    break;
35498 murdoch 156 
	}
157 
    } else {
158 
	switch (len) {
40705 ripley 159 
	case 0:
60844 ripley 160 
	    error("%s", R_ParseErrorMsg);
40705 ripley 161 
	    break;
162 
	case 1:
60844 ripley 163 
	    error("%s in \"%s\"",
41715 ripley 164 
		  R_ParseErrorMsg, CHAR(STRING_ELT(context, 0)));
40705 ripley 165 
	    break;
166 
	default:
60844 ripley 167 
	    error("%s in:\n\"%s\n%s\"",
41715 ripley 168 
		  R_ParseErrorMsg, CHAR(STRING_ELT(context, len-2)),
169 
		  CHAR(STRING_ELT(context, len-1)));
40705 ripley 170 
	    break;
171 
	}
35498 murdoch 172 
    }
47713 murdoch 173 
    UNPROTECT(1);
35498 murdoch 174 
}
175 
 
75449 kalibera 176 
typedef struct parse_info {
177 
    Rconnection con;
178 
    Rboolean old_latin1;
179 
    Rboolean old_utf8;
180 
}  parse_cleanup_info;
181 
 
182 
static void parse_cleanup(void *data)
54018 ripley 183 
{
75449 kalibera 184 
    parse_cleanup_info *pci = (parse_cleanup_info *)data;
185 
    Rconnection con = pci->con;
186 
    if(con && con->isopen)
187 
	con->close(con);
188 
    known_to_be_latin1 = pci->old_latin1;
189 
    known_to_be_utf8 = pci->old_utf8;
54018 ripley 190 
}
191 
 
6189 maechler 192 
/* "do_parse" - the user interface input/output to files.
2 r 193 
 
6189 maechler 194 
 The internal R_Parse.. functions are defined in ./gram.y (-> gram.c)
2 r 195 
 
50833 ripley 196 
 .Internal( parse(file, n, text, prompt, srcfile, encoding) )
6189 maechler 197 
 If there is text then that is read and the other arguments are ignored.
198 
*/
36990 ripley 199 
SEXP attribute_hidden do_parse(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 200 
{
1839 ihaka 201 
    checkArity(op, args);
65994 ripley 202 
    if(!inherits(CAR(args), "connection"))
203 
	error(_("'file' must be a character string or connection"));
1839 ihaka 204 
    R_ParseError = 0;
39996 murdoch 205 
    R_ParseErrorMsg[0] = '\0';
2 r 206 
 
75571 maechler 207 
    int ifile = asInteger(CAR(args));                   args = CDR(args);
208 
    Rconnection con = getConnection(ifile);
209 
    Rboolean wasopen = con->isopen;
210 
    int num = asInteger(CAR(args));			args = CDR(args);
35189 tlumley 211 
    if (num == 0)
45446 ripley 212 
	return(allocVector(EXPRSXP, 0));
51330 ripley 213 
 
75571 maechler 214 
    SEXP text = PROTECT(coerceVector(CAR(args), STRSXP));
51330 ripley 215 
    if(length(CAR(args)) && !length(text))
70830 luke 216 
	error(_("coercion of 'text' to character was unsuccessful"));
51330 ripley 217 
    args = CDR(args);
75571 maechler 218 
    SEXP prompt = CAR(args);				args = CDR(args);
219 
    SEXP source = CAR(args);				args = CDR(args);
40672 ripley 220 
    if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
41715 ripley 221 
	error(_("invalid '%s' value"), "encoding");
75571 maechler 222 
    const char *encoding = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
75449 kalibera 223 
 
75571 maechler 224 
    parse_cleanup_info pci;
225 
    pci.con = NULL;
226 
    pci.old_latin1 = known_to_be_latin1;
227 
    pci.old_utf8 = known_to_be_utf8;
228 
    RCNTXT cntxt;
75449 kalibera 229 
    /* set up context to recover known_to_be_* and to close connection on
230 
       error if opened by do_parse */
231 
    begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
232 
		 R_NilValue, R_NilValue);
233 
    cntxt.cend = &parse_cleanup;
234 
    cntxt.cenddata = &pci;
235 
 
40672 ripley 236 
    known_to_be_latin1 = known_to_be_utf8 = FALSE;
75571 maechler 237 
    Rboolean allKnown = TRUE;
46864 ripley 238 
    /* allow 'encoding' to override declaration on 'text'. */
239 
    if(streql(encoding, "latin1")) {
240 
	known_to_be_latin1 = TRUE;
241 
	allKnown = FALSE;
48572 murdoch 242 
    } else if(streql(encoding, "UTF-8"))  {
46864 ripley 243 
	known_to_be_utf8 = TRUE;
244 
	allKnown = FALSE;
68923 ripley 245 
    } else if(!streql(encoding, "unknown") && !streql(encoding, "native.enc"))
246 
	warning(_("argument '%s = \"%s\"' will be ignored"), "encoding", encoding);
46864 ripley 247 
 
1839 ihaka 248 
    if (prompt == R_NilValue)
249 
	PROTECT(prompt);
250 
    else
251 
	PROTECT(prompt = coerceVector(prompt, STRSXP));
252 
 
75571 maechler 253 
    ParseStatus status;
254 
    SEXP s;
1839 ihaka 255 
    if (length(text) > 0) {
46864 ripley 256 
	/* If 'text' has known encoding then we can be sure it will be
257 
	   correctly re-encoded to the current encoding by
258 
	   translateChar in the parser and so could mark the result in
259 
	   a Latin-1 or UTF-8 locale.
260 
 
261 
	   A small complication is that different elements could have
262 
	   different encodings, but all that matters is that all
263 
	   non-ASCII elements have known encoding.
264 
	*/
75571 maechler 265 
	for(int i = 0; i < length(text); i++)
46864 ripley 266 
	    if(!ENC_KNOWN(STRING_ELT(text, i)) &&
58404 urbaneks 267 
	       !IS_ASCII(STRING_ELT(text, i))) {
46864 ripley 268 
		allKnown = FALSE;
269 
		break;
270 
	    }
271 
	if(allKnown) {
75449 kalibera 272 
	    known_to_be_latin1 = pci.old_latin1;
273 
	    known_to_be_utf8 = pci.old_utf8;
46864 ripley 274 
	}
275 
	if (num == NA_INTEGER) num = -1;
39999 murdoch 276 
	s = R_ParseVector(text, num, &status, source);
52834 murdoch 277 
	if (status != PARSE_OK) parseError(call, R_ParseError);
1839 ihaka 278 
    }
11656 ripley 279 
    else if (ifile >= 3) {/* file != "" */
46864 ripley 280 
	if (num == NA_INTEGER) num = -1;
45982 ripley 281 
	if(!wasopen) {
32873 ripley 282 
	    if(!con->open(con)) error(_("cannot open the connection"));
75449 kalibera 283 
	    pci.con = con; /* close the connection on error */
54018 ripley 284 
	}
285 
	if(!con->canread) error(_("cannot read from this connection"));
39996 murdoch 286 
	s = R_ParseConn(con, num, &status, source);
68094 luke 287 
	if(!wasopen) {
288 
	    PROTECT(s);
75449 kalibera 289 
	    pci.con = NULL;
68094 luke 290 
	    con->close(con);
291 
	    UNPROTECT(1);
292 
	}
35498 murdoch 293 
	if (status != PARSE_OK) parseError(call, R_ParseError);
1839 ihaka 294 
    }
295 
    else {
46864 ripley 296 
	if (num == NA_INTEGER) num = 1;
39996 murdoch 297 
	s = R_ParseBuffer(&R_ConsoleIob, num, &status, prompt, source);
52834 murdoch 298 
	if (status != PARSE_OK) parseError(call, R_ParseError);
1839 ihaka 299 
    }
75449 kalibera 300 
    known_to_be_latin1 = pci.old_latin1;
301 
    known_to_be_utf8 = pci.old_utf8;
302 
    PROTECT(s);
303 
    endcontext(&cntxt);
304 
    UNPROTECT(3);
6201 maechler 305 
    return s;
2 r 306 
}