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