This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlapi: Remove per-thread section; move to real scns
[perl5.git] / dquote.c
CommitLineData
a55c5245 1/* dquote.c
04e98a4d 2 *
a55c5245
JH
3 * This file contains functions that are related to
4 * parsing double-quotish expressions.
04e98a4d 5 *
04e98a4d
AD
6*/
7
a55c5245
JH
8#include "EXTERN.h"
9#define PERL_IN_DQUOTE_C
10#include "perl.h"
881ffab6 11
68b355dd 12/* XXX Add documentation after final interface and behavior is decided */
68b355dd 13
73351a71
KW
14bool
15Perl_grok_bslash_c(pTHX_ const char source,
16 U8 * result,
17 const char** message,
18 U32 * packed_warn)
68b355dd 19{
73351a71 20 PERL_ARGS_ASSERT_GROK_BSLASH_C;
68b355dd 21
73351a71
KW
22 /* This returns TRUE if the \c? sequence is valid; FALSE otherwise. If it
23 * is valid, the sequence evaluates to a single character, which will be
24 * stored into *result.
25 *
26 * source is the character immediately after a '\c' sequence.
27 * result points to a char variable into which this function will store
28 * what the sequence evaluates to, if valid; unchanged otherwise.
29 * message A pointer to any warning or error message will be stored into
30 * this pointer; NULL if none.
31 * packed_warn if NULL on input asks that this routine display any warning
32 * messages. Otherwise, if the function found a warning, the
33 * packed warning categories will be stored into *packed_warn (and
34 * the corresponding message text into *message); 0 if none.
35 */
36
37 *message = NULL;
38 if (packed_warn) *packed_warn = 0;
68b355dd 39
421e43ba 40 if (! isPRINT_A(source)) {
73351a71
KW
41 *message = "Character following \"\\c\" must be printable ASCII";
42 return FALSE;
68b355dd 43 }
73351a71
KW
44
45 if (source == '{') {
a27ed980
KW
46 const char control = toCTRL('{');
47 if (isPRINT_A(control)) {
48 /* diag_listed_as: Use "%s" instead of "%s" */
73351a71 49 *message = Perl_form(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
a27ed980
KW
50 }
51 else {
73351a71 52 *message = "Sequence \"\\c{\" invalid";
a27ed980 53 }
73351a71 54 return FALSE;
421e43ba 55 }
68b355dd 56
73351a71
KW
57 *result = toCTRL(source);
58 if (isPRINT_A(*result) && ckWARN(WARN_SYNTAX)) {
4d8be631
KW
59 U8 clearer[3];
60 U8 i = 0;
73351a71
KW
61 char format[] = "\"\\c%c\" is more clearly written simply as \"%s\"";
62
63 if (! isWORDCHAR(*result)) {
4d8be631
KW
64 clearer[i++] = '\\';
65 }
73351a71 66 clearer[i++] = *result;
4d8be631 67 clearer[i++] = '\0';
68b355dd 68
73351a71
KW
69 if (packed_warn) {
70 *message = Perl_form(aTHX_ format, source, clearer);
71 *packed_warn = packWARN(WARN_SYNTAX);
72 }
73 else {
74 Perl_warner(aTHX_ packWARN(WARN_SYNTAX), format, source, clearer);
75 }
68b355dd
KW
76 }
77
73351a71 78 return TRUE;
68b355dd
KW
79}
80
8d1e72f0
KW
81const char *
82Perl_form_alien_digit_msg(pTHX_
83 const U8 which, /* 8 or 16 */
84 const STRLEN valids_len, /* length of input before first bad char */
85 const char * const first_bad, /* Ptr to that bad char */
86 const char * const send, /* End of input string */
87 const bool UTF, /* Is it in UTF-8? */
88 const bool braced) /* Is it enclosed in {} */
89{
90 /* Generate a mortal SV containing an appropriate warning message about
91 * alien characters found in an octal or hex constant given by the inputs,
92 * and return a pointer to that SV's string. The message looks like:
93 *
94 * Non-hex character '?' terminates \x early. Resolved as "\x{...}"
95 *
96 */
97
98 /* The usual worst case scenario: 2 chars to display per byte, plus \x{}
99 * (leading zeros could take up more space, and the scalar will
100 * automatically grow if necessary). Space for NUL is added by the newSV()
101 * function */
102 SV * display_char = newSV(2 * UTF8_MAXBYTES + 4);
103 SV * message_sv = sv_newmortal();
104 char symbol;
105
106 PERL_ARGS_ASSERT_FORM_ALIEN_DIGIT_MSG;
107 assert(which == 8 || which == 16);
108
109 /* Calculate the display form of the character */
110 if ( UVCHR_IS_INVARIANT(*first_bad)
111 || (UTF && isUTF8_CHAR((U8 *) first_bad, (U8 *) send)))
112 {
113 pv_uni_display(display_char, (U8 *) first_bad, UTF8SKIP(first_bad),
114 (STRLEN) -1, UNI_DISPLAY_QQ);
115 }
116 else { /* Is not UTF-8, or is illegal UTF-8. Show just the one byte */
117
118 /* It also isn't a UTF-8 invariant character, so no display shortcuts
119 * are available. Use \\x{...} */
120 Perl_sv_setpvf(aTHX_ display_char, "\\x{%02x}", *first_bad);
121 }
122
123 /* Ready to start building the message */
124 sv_setpvs(message_sv, "Non-");
125 if (which == 8) {
126 sv_catpvs(message_sv, "octal");
127 if (braced) {
128 symbol = 'o';
129 }
130 else {
131 symbol = '0'; /* \008, for example */
132 }
133 }
134 else {
135 sv_catpvs(message_sv, "hex");
136 symbol = 'x';
137 }
138 sv_catpvs(message_sv, " character ");
139
140 if (isPRINT(*first_bad)) {
141 sv_catpvs(message_sv, "'");
142 }
143 sv_catsv(message_sv, display_char);
144 if (isPRINT(*first_bad)) {
145 sv_catpvs(message_sv, "'");
146 }
147 Perl_sv_catpvf(aTHX_ message_sv, " terminates \\%c early. Resolved as "
148 "\"\\%c", symbol, symbol);
149 if (braced) {
150 sv_catpvs(message_sv, "{");
151 }
152
153 /* Octal constants have an extra leading 0, but \0 already includes that */
154 if (symbol == 'o' && valids_len < 3) {
155 sv_catpvs(message_sv, "0");
156 }
157 if (valids_len == 0) { /* No legal digits at all */
158 sv_catpvs(message_sv, "00");
159 }
160 else if (valids_len == 1) { /* Just one is legal */
161 sv_catpvs(message_sv, "0");
162 }
163 sv_catpvn(message_sv, first_bad - valids_len, valids_len);
164
165 if (braced) {
166 sv_catpvs(message_sv, "}");
167 }
168 else {
169 sv_catsv(message_sv, display_char);
170 }
171 sv_catpvs(message_sv, "\"");
172
173 SvREFCNT_dec_NN(display_char);
174
175 return SvPVX_const(message_sv);
176}
177
178const char *
179Perl_form_cp_too_large_msg(pTHX_
180 const U8 which, /* 8 or 16 */
181 const char * string, /* NULL, or the text that is supposed to
182 represent a code point */
183 const Size_t len, /* length of 'string' if not NULL; else 0 */
184 const UV cp) /* 0 if 'string' not NULL; else the too-large
185 code point */
186{
187 /* Generate a mortal SV containing an appropriate warning message about
188 * code points that are too large for this system, given by the inputs,
189 * and return a pointer to that SV's string. Either the text of the string
190 * to be converted to a code point is input, or a code point itself. The
191 * former is needed to accurately represent something that overflows.
192 *
193 * The message looks like:
194 *
195 * Use of code point %s is not allowed; the permissible max is %s
196 *
197 */
198
199 SV * message_sv = sv_newmortal();
200 const char * format;
201 const char * prefix;
202
203 PERL_ARGS_ASSERT_FORM_CP_TOO_LARGE_MSG;
204 assert(which == 8 || which == 16);
205
206 /* One but not both must be non-zero */
207 assert((string != NULL) ^ (cp != 0));
208 assert((string == NULL) || len);
209
210 if (which == 8) {
211 format = "%" UVof;
212 prefix = "0";
213 }
214 else {
215 format = "%" UVXf;
216 prefix = "0x";
217 }
218
219 Perl_sv_setpvf(aTHX_ message_sv, "Use of code point %s", prefix);
220 if (string) {
221 Perl_sv_catpvf(aTHX_ message_sv, "%.*s", (int) len, string);
222 }
223 else {
224 Perl_sv_catpvf(aTHX_ message_sv, format, cp);
225 }
226 Perl_sv_catpvf(aTHX_ message_sv, " is not allowed; the permissible max is %s", prefix);
227 Perl_sv_catpvf(aTHX_ message_sv, format, MAX_LEGAL_CP);
228
229 return SvPVX_const(message_sv);
230}
231
a55c5245 232bool
e8278639 233Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv,
5763c818 234 const char** message,
8d1e72f0
KW
235 U32 * packed_warn,
236 const bool strict,
237 const bool allow_UV_MAX,
80f4111b 238 const bool UTF)
db30362b
KW
239{
240
241/* Documentation to be supplied when interface nailed down finally
8d1e72f0
KW
242 * This returns FALSE if there is an error the caller should probably die
243 * from; otherwise TRUE.
e8278639
KW
244 * s is the address of a pointer to a string. **s is 'o', and the
245 * previous character was a backslash. At exit, *s will be advanced
246 * to the byte just after those absorbed by this function. Hence the
8d1e72f0
KW
247 * caller can continue parsing from there. In the case of an error
248 * when this function returns FALSE, continuing to parse is not an
249 * option, this routine has generally positioned *s to point just to
250 * the right of the first bad spot, so that a message that has a "<--"
251 * to mark the spot will be correctly positioned.
e8278639
KW
252 * send - 1 gives a limit in *s that this function is not permitted to
253 * look beyond. That is, the function may look at bytes only in the
254 * range *s..send-1
db30362b 255 * uv points to a UV that will hold the output value, valid only if the
8d1e72f0
KW
256 * return from the function is TRUE; may be changed from the input
257 * value even when FALSE is returned.
258 * message A pointer to any warning or error message will be stored into
259 * this pointer; NULL if none.
260 * packed_warn if NULL on input asks that this routine display any warning
261 * messages. Otherwise, if the function found a warning, the packed
262 * warning categories will be stored into *packed_warn (and the
263 * corresponding message text into *message); 0 if none.
80f4111b
KW
264 * strict is true if this should fail instead of warn if there are
265 * non-octal digits within the braces
8d1e72f0
KW
266 * allow_UV_MAX is true if this shouldn't fail if the input code point is
267 * UV_MAX, which is normally illegal, reserved for internal use.
80f4111b 268 * UTF is true iff the string *s is encoded in UTF-8.
db30362b 269 */
00ce5563 270 char* e;
db30362b
KW
271 STRLEN numbers_len;
272 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8d1e72f0
KW
273 | PERL_SCAN_DISALLOW_PREFIX
274 | PERL_SCAN_SILENT_NON_PORTABLE
275 | PERL_SCAN_SILENT_ILLDIGIT
276 | PERL_SCAN_SILENT_OVERFLOW;
db30362b
KW
277
278 PERL_ARGS_ASSERT_GROK_BSLASH_O;
279
7f4ec488
KW
280 assert(*(*s - 1) == '\\');
281 assert(* *s == 'o');
8d1e72f0
KW
282
283 *message = NULL;
284 if (packed_warn) *packed_warn = 0;
285
00ce5563 286 (*s)++;
db30362b 287
83a1b28e 288 if (send <= *s || **s != '{') {
5763c818 289 *message = "Missing braces on \\o{}";
db30362b
KW
290 return FALSE;
291 }
292
e8278639 293 e = (char *) memchr(*s, '}', send - *s);
db30362b 294 if (!e) {
00ce5563 295 (*s)++; /* Move past the '{' */
b8de99ca
KW
296 while (isOCTAL(**s)) { /* Position beyond the legal digits */
297 (*s)++;
298 }
3b34e85b 299 *message = "Missing right brace on \\o{}";
db30362b
KW
300 return FALSE;
301 }
302
00ce5563
KW
303 (*s)++; /* Point to expected first digit (could be first byte of utf8
304 sequence if not a digit) */
305 numbers_len = e - *s;
db30362b 306 if (numbers_len == 0) {
8d1e72f0 307 (*s)++; /* Move past the '}' */
5763c818 308 *message = "Empty \\o{}";
db30362b
KW
309 return FALSE;
310 }
311
00ce5563 312 *uv = grok_oct(*s, &numbers_len, &flags, NULL);
8d1e72f0
KW
313 if (UNLIKELY( (flags & PERL_SCAN_GREATER_THAN_UV_MAX)
314 || (! allow_UV_MAX && *uv == UV_MAX)))
315 {
316 *message = form_cp_too_large_msg(8, *s, numbers_len, 0);
317 *s = e + 1;
318 return FALSE;
319 }
320
db30362b
KW
321 /* Note that if has non-octal, will ignore everything starting with that up
322 * to the '}' */
80f4111b 323 if (numbers_len != (STRLEN) (e - *s)) {
8d1e72f0 324 *s += numbers_len;
80f4111b 325 if (strict) {
6dd641e1 326 *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1;
5763c818 327 *message = "Non-octal character";
80f4111b
KW
328 return FALSE;
329 }
8d1e72f0
KW
330
331 if (ckWARN(WARN_DIGIT)) {
332 const char * failure = form_alien_digit_msg(8, numbers_len, *s, send,
333 UTF, TRUE);
334 if (packed_warn) {
335 *message = failure;
336 *packed_warn = packWARN(WARN_DIGIT);
337 }
338 else {
339 Perl_warner(aTHX_ packWARN(WARN_DIGIT), "%s", failure);
340 }
80f4111b 341 }
db30362b
KW
342 }
343
00ce5563
KW
344 /* Return past the '}' */
345 *s = e + 1;
346
db30362b
KW
347 return TRUE;
348}
349
ce54a8b9 350bool
8d1e72f0 351Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv,
5763c818 352 const char** message,
8d1e72f0
KW
353 U32 * packed_warn,
354 const bool strict,
355 const bool allow_UV_MAX,
ce54a8b9
KW
356 const bool UTF)
357{
5e0a247b 358
ce54a8b9 359/* Documentation to be supplied when interface nailed down finally
8d1e72f0 360 * This returns FALSE if there is an error the caller should probably die
ce54a8b9
KW
361 * from; otherwise TRUE.
362 * It guarantees that the returned codepoint, *uv, when expressed as
363 * utf8 bytes, would fit within the skipped "\x{...}" bytes.
364 *
365 * On input:
e8278639
KW
366 * s is the address of a pointer to a string. **s is 'x', and the
367 * previous character was a backslash. At exit, *s will be advanced
368 * to the byte just after those absorbed by this function. Hence the
369 * caller can continue parsing from there. In the case of an error,
370 * this routine has generally positioned *s to point just to the right
371 * of the first bad spot, so that a message that has a "<--" to mark
372 * the spot will be correctly positioned.
373 * send - 1 gives a limit in *s that this function is not permitted to
374 * look beyond. That is, the function may look at bytes only in the
375 * range *s..send-1
ce54a8b9 376 * uv points to a UV that will hold the output value, valid only if the
8d1e72f0
KW
377 * return from the function is TRUE; may be changed from the input
378 * value even when FALSE is returned.
379 * message A pointer to any warning or error message will be stored into
380 * this pointer; NULL if none.
381 * packed_warn if NULL on input asks that this routine display any warning
382 * messages. Otherwise, if the function found a warning, the packed
383 * warning categories will be stored into *packed_warn (and the
384 * corresponding message text into *message); 0 if none.
ce54a8b9
KW
385 * strict is true if anything out of the ordinary should cause this to
386 * fail instead of warn or be silent. For example, it requires
387 * exactly 2 digits following the \x (when there are no braces).
388 * 3 digits could be a mistake, so is forbidden in this mode.
8d1e72f0
KW
389 * allow_UV_MAX is true if this shouldn't fail if the input code point is
390 * UV_MAX, which is normally illegal, reserved for internal use.
ce54a8b9
KW
391 * UTF is true iff the string *s is encoded in UTF-8.
392 */
393 char* e;
394 STRLEN numbers_len;
eb761011 395 I32 flags = PERL_SCAN_DISALLOW_PREFIX
8d1e72f0
KW
396 | PERL_SCAN_SILENT_ILLDIGIT
397 | PERL_SCAN_NOTIFY_ILLDIGIT
398 | PERL_SCAN_SILENT_NON_PORTABLE
399 | PERL_SCAN_SILENT_OVERFLOW;
5e0a247b 400
ce54a8b9 401 PERL_ARGS_ASSERT_GROK_BSLASH_X;
5e0a247b 402
7f4ec488
KW
403 assert(*(*s - 1) == '\\');
404 assert(* *s == 'x');
0b97d156 405
8d1e72f0
KW
406 *message = NULL;
407 if (packed_warn) *packed_warn = 0;
408
ce54a8b9 409 (*s)++;
5e0a247b 410
0b97d156
KW
411 if (send <= *s) {
412 if (strict) {
5763c818 413 *message = "Empty \\x";
0b97d156
KW
414 return FALSE;
415 }
416
417 /* Sadly, to preserve backcompat, an empty \x at the end of string is
418 * interpreted as a NUL */
419 *uv = 0;
420 return TRUE;
421 }
422
ce54a8b9 423 if (**s != '{') {
8d1e72f0
KW
424 numbers_len = (strict) ? 3 : 2;
425
426 *uv = grok_hex(*s, &numbers_len, &flags, NULL);
427 *s += numbers_len;
428
429 if (numbers_len != 2 && (strict || (flags & PERL_SCAN_NOTIFY_ILLDIGIT))) {
430 if (numbers_len == 3) { /* numbers_len 3 only happens with strict */
5763c818 431 *message = "Use \\x{...} for more than two hex characters";
8d1e72f0
KW
432 return FALSE;
433 }
434 else if (strict) {
435 *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1;
436 *message = "Non-hex character";
437 return FALSE;
438 }
439 else if (ckWARN(WARN_DIGIT)) {
440 const char * failure = form_alien_digit_msg(16, numbers_len, *s,
441 send, UTF, FALSE);
442
443 if (! packed_warn) {
444 Perl_warner(aTHX_ packWARN(WARN_DIGIT), "%s", failure);
445 }
446 else {
447 *message = failure;
448 *packed_warn = packWARN(WARN_DIGIT);
449 }
ce54a8b9 450 }
ce54a8b9
KW
451 }
452 return TRUE;
453 }
454
e8278639 455 e = (char *) memchr(*s, '}', send - *s);
ce54a8b9
KW
456 if (!e) {
457 (*s)++; /* Move past the '{' */
8d1e72f0 458 while (*s < send && isXDIGIT(**s)) { /* Position beyond legal digits */
ce54a8b9
KW
459 (*s)++;
460 }
5763c818 461 *message = "Missing right brace on \\x{}";
ce54a8b9
KW
462 return FALSE;
463 }
464
465 (*s)++; /* Point to expected first digit (could be first byte of utf8
466 sequence if not a digit) */
467 numbers_len = e - *s;
468 if (numbers_len == 0) {
469 if (strict) {
470 (*s)++; /* Move past the } */
5763c818 471 *message = "Empty \\x{}";
ce54a8b9
KW
472 return FALSE;
473 }
474 *s = e + 1;
475 *uv = 0;
476 return TRUE;
477 }
478
479 flags |= PERL_SCAN_ALLOW_UNDERSCORES;
ce54a8b9
KW
480
481 *uv = grok_hex(*s, &numbers_len, &flags, NULL);
8d1e72f0
KW
482 if (UNLIKELY( (flags & PERL_SCAN_GREATER_THAN_UV_MAX)
483 || (! allow_UV_MAX && *uv == UV_MAX)))
484 {
485 *message = form_cp_too_large_msg(16, *s, numbers_len, 0);
486 *s = e + 1;
487 return FALSE;
488 }
ce54a8b9 489
8d1e72f0 490 if (numbers_len != (STRLEN) (e - *s)) {
ce54a8b9 491 *s += numbers_len;
8d1e72f0
KW
492 if (strict) {
493 *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1;
494 *message = "Non-hex character";
495 return FALSE;
496 }
497
498 if (ckWARN(WARN_DIGIT)) {
499 const char * failure = form_alien_digit_msg(16, numbers_len, *s,
500 send, UTF, TRUE);
501 if (! packed_warn) {
502 Perl_warner(aTHX_ packWARN(WARN_DIGIT), "%s", failure);
503 }
504 else {
505 *message = failure;
506 *packed_warn = packWARN(WARN_DIGIT);
507 }
508 }
ce54a8b9
KW
509 }
510
511 /* Return past the '}' */
512 *s = e + 1;
513
514 return TRUE;
5e0a247b
KW
515}
516
04e98a4d 517/*
14d04a33 518 * ex: set ts=8 sts=4 sw=4 et:
04e98a4d 519 */