The R Project SVN R

Rev

Rev 86821 | 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
87891 ripley 3 
 *  Copyright (C) 2001--2025  The R Core Team
2 r 4 
 *  Copyright (C) 1995, 1996  Robert Gentleman and Ross Ihaka
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 
 
83446 ripley 30 
attribute_hidden SEXP 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;
86821 luke 89 
	    PROTECT(filename = R_findVar(install("filename"),
90 
					 R_ParseErrorFile));
66671 murdoch 91 
	    if (isString(filename) && length(filename)) {
68923 ripley 92 
		strncpy(buffer, CHAR(STRING_ELT(filename, 0)), buflen - 1);
93 
		buffer[buflen - 1] = '\0';
94 
	    }
61399 murdoch 95 
	    UNPROTECT(1);
68923 ripley 96 
	} else if (isString(R_ParseErrorFile) && length(R_ParseErrorFile)) {
97 
	    strncpy(buffer, CHAR(STRING_ELT(R_ParseErrorFile, 0)), buflen - 1);
98 
	    buffer[buflen - 1] = '\0';
99 
	}
66671 murdoch 100 
    }
39996 murdoch 101 
}
102 
 
47713 murdoch 103 
static SEXP tabExpand(SEXP strings)
104 
{
105 
    int i;
106 
    char buffer[200], *b;
107 
    const char *input;
108 
    SEXP result;
48500 murdoch 109 
    PROTECT(strings);
47713 murdoch 110 
    PROTECT(result = allocVector(STRSXP, length(strings)));
111 
    for (i = 0; i < length(strings); i++) {
68923 ripley 112 
	input = CHAR(STRING_ELT(strings, i));
113 
	for (b = buffer; *input && (b-buffer < 192); input++) {
114 
	    if (*input == '\t') do {
115 
		*b++ = ' ';
116 
	    } while (((b-buffer) & 7) != 0);
117 
	    else *b++ = *input;
118 
	}
119 
	*b = '\0';
120 
	SET_STRING_ELT(result, i, mkCharCE(buffer, Rf_getCharCE(STRING_ELT(strings, i))));
47713 murdoch 121 
    }
48500 murdoch 122 
    UNPROTECT(2);
47713 murdoch 123 
    return result;
124 
}
68923 ripley 125 
 
83454 ripley 126 
NORET void parseError(SEXP call, int linenum)
35498 murdoch 127 
{
47713 murdoch 128 
    SEXP context;
129 
    int len, width;
130 
    char filename[128], buffer[10];
131 
    PROTECT(context = tabExpand(getParseContext()));
132 
    len = length(context);
35498 murdoch 133 
    if (linenum) {
45446 ripley 134 
	getParseFilename(filename, sizeof(filename)-2);
47481 murdoch 135 
	if (strlen(filename)) strcpy(filename + strlen(filename), ":");
40705 ripley 136 
 
35498 murdoch 137 
	switch (len) {
40705 ripley 138 
	case 0:
60844 ripley 139 
	    error("%s%d:%d: %s",
47481 murdoch 140 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg);
40705 ripley 141 
	    break;
58489 ripley 142 
	case 1: // replaces use of %n
68923 ripley 143 
	    width = snprintf(buffer, 10, "%d: ", R_ParseContextLine);
60844 ripley 144 
	    error("%s%d:%d: %s\n%d: %s\n%*s",
47481 murdoch 145 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg,
68923 ripley 146 
		  R_ParseContextLine, CHAR(STRING_ELT(context, 0)),
63417 murdoch 147 
		  width+R_ParseErrorCol+1, "^");
40705 ripley 148 
	    break;
149 
	default:
62580 ripley 150 
	    width = snprintf(buffer, 10, "%d:", R_ParseContextLine);
60844 ripley 151 
	    error("%s%d:%d: %s\n%d: %s\n%d: %s\n%*s",
47481 murdoch 152 
		  filename, linenum, R_ParseErrorCol, R_ParseErrorMsg,
153 
		  R_ParseContextLine-1, CHAR(STRING_ELT(context, len-2)),
68923 ripley 154 
		  R_ParseContextLine, CHAR(STRING_ELT(context, len-1)),
63417 murdoch 155 
		  width+R_ParseErrorCol+1, "^");
40705 ripley 156 
	    break;
35498 murdoch 157 
	}
158 
    } else {
159 
	switch (len) {
40705 ripley 160 
	case 0:
60844 ripley 161 
	    error("%s", R_ParseErrorMsg);
40705 ripley 162 
	    break;
163 
	case 1:
79888 maechler 164 
	    error(_("%s in \"%s\""),
41715 ripley 165 
		  R_ParseErrorMsg, CHAR(STRING_ELT(context, 0)));
40705 ripley 166 
	    break;
167 
	default:
79888 maechler 168 
	    error(_("%s in:\n\"%s\n%s\""),
41715 ripley 169 
		  R_ParseErrorMsg, CHAR(STRING_ELT(context, len-2)),
170 
		  CHAR(STRING_ELT(context, len-1)));
40705 ripley 171 
	    break;
172 
	}
35498 murdoch 173 
    }
47713 murdoch 174 
    UNPROTECT(1);
35498 murdoch 175 
}
176 
 
75449 kalibera 177 
typedef struct parse_info {
178 
    Rconnection con;
87891 ripley 179 
    bool old_latin1;
180 
    bool old_utf8;
75449 kalibera 181 
}  parse_cleanup_info;
182 
 
183 
static void parse_cleanup(void *data)
54018 ripley 184 
{
75449 kalibera 185 
    parse_cleanup_info *pci = (parse_cleanup_info *)data;
186 
    Rconnection con = pci->con;
187 
    if(con && con->isopen)
188 
	con->close(con);
189 
    known_to_be_latin1 = pci->old_latin1;
190 
    known_to_be_utf8 = pci->old_utf8;
54018 ripley 191 
}
192 
 
6189 maechler 193 
/* "do_parse" - the user interface input/output to files.
2 r 194 
 
6189 maechler 195 
 The internal R_Parse.. functions are defined in ./gram.y (-> gram.c)
2 r 196 
 
50833 ripley 197 
 .Internal( parse(file, n, text, prompt, srcfile, encoding) )
6189 maechler 198 
 If there is text then that is read and the other arguments are ignored.
199 
*/
83446 ripley 200 
attribute_hidden SEXP do_parse(SEXP call, SEXP op, SEXP args, SEXP env)
2 r 201 
{
1839 ihaka 202 
    checkArity(op, args);
65994 ripley 203 
    if(!inherits(CAR(args), "connection"))
204 
	error(_("'file' must be a character string or connection"));
1839 ihaka 205 
    R_ParseError = 0;
39996 murdoch 206 
    R_ParseErrorMsg[0] = '\0';
2 r 207 
 
75571 maechler 208 
    int ifile = asInteger(CAR(args));                   args = CDR(args);
209 
    Rconnection con = getConnection(ifile);
87891 ripley 210 
    bool wasopen = con->isopen;
75571 maechler 211 
    int num = asInteger(CAR(args));			args = CDR(args);
35189 tlumley 212 
    if (num == 0)
45446 ripley 213 
	return(allocVector(EXPRSXP, 0));
51330 ripley 214 
 
75571 maechler 215 
    SEXP text = PROTECT(coerceVector(CAR(args), STRSXP));
51330 ripley 216 
    if(length(CAR(args)) && !length(text))
70830 luke 217 
	error(_("coercion of 'text' to character was unsuccessful"));
51330 ripley 218 
    args = CDR(args);
75571 maechler 219 
    SEXP prompt = CAR(args);				args = CDR(args);
220 
    SEXP source = CAR(args);				args = CDR(args);
40672 ripley 221 
    if(!isString(CAR(args)) || LENGTH(CAR(args)) != 1)
41715 ripley 222 
	error(_("invalid '%s' value"), "encoding");
75571 maechler 223 
    const char *encoding = CHAR(STRING_ELT(CAR(args), 0)); /* ASCII */
75449 kalibera 224 
 
75571 maechler 225 
    parse_cleanup_info pci;
226 
    pci.con = NULL;
227 
    pci.old_latin1 = known_to_be_latin1;
228 
    pci.old_utf8 = known_to_be_utf8;
229 
    RCNTXT cntxt;
75449 kalibera 230 
    /* set up context to recover known_to_be_* and to close connection on
231 
       error if opened by do_parse */
232 
    begincontext(&cntxt, CTXT_CCODE, R_NilValue, R_BaseEnv, R_BaseEnv,
233 
		 R_NilValue, R_NilValue);
234 
    cntxt.cend = &parse_cleanup;
235 
    cntxt.cenddata = &pci;
236 
 
87891 ripley 237 
    known_to_be_latin1 = known_to_be_utf8 = false;
238 
    bool allKnown = true;
46864 ripley 239 
    /* allow 'encoding' to override declaration on 'text'. */
240 
    if(streql(encoding, "latin1")) {
77735 kalibera 241 
	if (!mbcslocale) {
87891 ripley 242 
	    known_to_be_latin1 = true;
243 
	    allKnown = false;
77735 kalibera 244 
	} else
245 
	    warning(_("argument encoding=\"latin1\" is ignored in MBCS locales"));
48572 murdoch 246 
    } else if(streql(encoding, "UTF-8"))  {
79007 kalibera 247 
	if (!mbcslocale || utf8locale) {
87891 ripley 248 
	    known_to_be_utf8 = true;
249 
	    allKnown = false;
79007 kalibera 250 
	} else
251 
	    /* the input may be invalid or not parseable when interpreted as
252 
	       in different multi-byte encoding; related to PR#16819 */
253 
	    warning(_("argument encoding=\"UTF-8\" is ignored in MBCS locales"));
68923 ripley 254 
    } else if(!streql(encoding, "unknown") && !streql(encoding, "native.enc"))
255 
	warning(_("argument '%s = \"%s\"' will be ignored"), "encoding", encoding);
46864 ripley 256 
 
1839 ihaka 257 
    if (prompt == R_NilValue)
258 
	PROTECT(prompt);
259 
    else
260 
	PROTECT(prompt = coerceVector(prompt, STRSXP));
261 
 
75571 maechler 262 
    ParseStatus status;
263 
    SEXP s;
1839 ihaka 264 
    if (length(text) > 0) {
46864 ripley 265 
	/* If 'text' has known encoding then we can be sure it will be
266 
	   correctly re-encoded to the current encoding by
267 
	   translateChar in the parser and so could mark the result in
268 
	   a Latin-1 or UTF-8 locale.
269 
 
270 
	   A small complication is that different elements could have
271 
	   different encodings, but all that matters is that all
272 
	   non-ASCII elements have known encoding.
273 
	*/
79397 maechler 274 
	if(allKnown)
275 
	  for(int i = 0; i < length(text); i++)
46864 ripley 276 
	    if(!ENC_KNOWN(STRING_ELT(text, i)) &&
79397 maechler 277 
	       ! IS_ASCII(STRING_ELT(text, i))) {
87891 ripley 278 
		allKnown = false;
46864 ripley 279 
		break;
280 
	    }
281 
	if(allKnown) {
75449 kalibera 282 
	    known_to_be_latin1 = pci.old_latin1;
283 
	    known_to_be_utf8 = pci.old_utf8;
46864 ripley 284 
	}
285 
	if (num == NA_INTEGER) num = -1;
39999 murdoch 286 
	s = R_ParseVector(text, num, &status, source);
1839 ihaka 287 
    }
11656 ripley 288 
    else if (ifile >= 3) {/* file != "" */
46864 ripley 289 
	if (num == NA_INTEGER) num = -1;
45982 ripley 290 
	if(!wasopen) {
32873 ripley 291 
	    if(!con->open(con)) error(_("cannot open the connection"));
75449 kalibera 292 
	    pci.con = con; /* close the connection on error */
54018 ripley 293 
	}
294 
	if(!con->canread) error(_("cannot read from this connection"));
39996 murdoch 295 
	s = R_ParseConn(con, num, &status, source);
68094 luke 296 
	if(!wasopen) {
297 
	    PROTECT(s);
75449 kalibera 298 
	    pci.con = NULL;
68094 luke 299 
	    con->close(con);
300 
	    UNPROTECT(1);
301 
	}
1839 ihaka 302 
    }
303 
    else {
46864 ripley 304 
	if (num == NA_INTEGER) num = 1;
39996 murdoch 305 
	s = R_ParseBuffer(&R_ConsoleIob, num, &status, prompt, source);
1839 ihaka 306 
    }
79397 maechler 307 
    if (status != PARSE_OK) parseError(call, R_ParseError);
308 
 
75449 kalibera 309 
    known_to_be_latin1 = pci.old_latin1;
310 
    known_to_be_utf8 = pci.old_utf8;
311 
    PROTECT(s);
312 
    endcontext(&cntxt);
313 
    UNPROTECT(3);
6201 maechler 314 
    return s;
2 r 315 
}