This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlxs.pod; rpc is considered obsolete
[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
12 /* XXX Add documentation after final interface and behavior is decided */
13
14 bool
15 Perl_grok_bslash_c(pTHX_ const char   source,
16                          U8 *         result,
17                          const char** message,
18                          U32 *        packed_warn)
19 {
20     PERL_ARGS_ASSERT_GROK_BSLASH_C;
21
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;
39
40     if (! isPRINT_A(source)) {
41         *message = "Character following \"\\c\" must be printable ASCII";
42         return FALSE;
43     }
44
45     if (source == '{') {
46         const char control = toCTRL('{');
47         if (isPRINT_A(control)) {
48             /* diag_listed_as: Use "%s" instead of "%s" */
49             *message = Perl_form(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
50         }
51         else {
52             *message = "Sequence \"\\c{\" invalid";
53         }
54         return FALSE;
55     }
56
57     *result = toCTRL(source);
58     if (isPRINT_A(*result) && ckWARN(WARN_SYNTAX)) {
59         U8 clearer[3];
60         U8 i = 0;
61         char format[] = "\"\\c%c\" is more clearly written simply as \"%s\"";
62
63         if (! isWORDCHAR(*result)) {
64             clearer[i++] = '\\';
65         }
66         clearer[i++] = *result;
67         clearer[i++] = '\0';
68
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         }
76     }
77
78     return TRUE;
79 }
80
81 const char *
82 Perl_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
178 const char *
179 Perl_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
232 bool
233 Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv,
234                       const char** message,
235                       U32 *      packed_warn,
236                       const bool strict,
237                       const bool allow_UV_MAX,
238                       const bool UTF)
239 {
240
241 /*  Documentation to be supplied when interface nailed down finally
242  *  This returns FALSE if there is an error the caller should probably die
243  *  from; otherwise TRUE.
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
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.
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
255  *      uv  points to a UV that will hold the output value, valid only if the
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.
264  *      strict is true if this should fail instead of warn if there are
265  *          non-octal digits within the braces
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.
268  *      UTF is true iff the string *s is encoded in UTF-8.
269  */
270     char* e;
271     STRLEN numbers_len;
272     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
273               | PERL_SCAN_DISALLOW_PREFIX
274               | PERL_SCAN_SILENT_NON_PORTABLE
275               | PERL_SCAN_SILENT_ILLDIGIT
276               | PERL_SCAN_SILENT_OVERFLOW;
277
278     PERL_ARGS_ASSERT_GROK_BSLASH_O;
279
280     assert(*(*s - 1) == '\\');
281     assert(* *s       == 'o');
282
283     *message = NULL;
284     if (packed_warn) *packed_warn = 0;
285
286     (*s)++;
287
288     if (send <= *s || **s != '{') {
289         *message = "Missing braces on \\o{}";
290         return FALSE;
291     }
292
293     e = (char *) memchr(*s, '}', send - *s);
294     if (!e) {
295         (*s)++;  /* Move past the '{' */
296         while (isOCTAL(**s)) { /* Position beyond the legal digits */
297             (*s)++;
298         }
299         *message = "Missing right brace on \\o{}";
300         return FALSE;
301     }
302
303     (*s)++;    /* Point to expected first digit (could be first byte of utf8
304                   sequence if not a digit) */
305     numbers_len = e - *s;
306     if (numbers_len == 0) {
307         (*s)++;    /* Move past the '}' */
308         *message = "Empty \\o{}";
309         return FALSE;
310     }
311
312     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
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
321     /* Note that if has non-octal, will ignore everything starting with that up
322      * to the '}' */
323     if (numbers_len != (STRLEN) (e - *s)) {
324         *s += numbers_len;
325         if (strict) {
326             *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1;
327             *message = "Non-octal character";
328             return FALSE;
329         }
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             }
341         }
342     }
343
344     /* Return past the '}' */
345     *s = e + 1;
346
347     return TRUE;
348 }
349
350 bool
351 Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv,
352                       const char** message,
353                       U32 *      packed_warn,
354                       const bool strict,
355                       const bool allow_UV_MAX,
356                       const bool UTF)
357 {
358
359 /*  Documentation to be supplied when interface nailed down finally
360  *  This returns FALSE if there is an error the caller should probably die
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:
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
376  *      uv  points to a UV that will hold the output value, valid only if the
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.
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.
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.
391  *      UTF is true iff the string *s is encoded in UTF-8.
392  */
393     char* e;
394     STRLEN numbers_len;
395     I32 flags = PERL_SCAN_DISALLOW_PREFIX
396               | PERL_SCAN_SILENT_ILLDIGIT
397               | PERL_SCAN_NOTIFY_ILLDIGIT
398               | PERL_SCAN_SILENT_NON_PORTABLE
399               | PERL_SCAN_SILENT_OVERFLOW;
400
401     PERL_ARGS_ASSERT_GROK_BSLASH_X;
402
403     assert(*(*s - 1) == '\\');
404     assert(* *s      == 'x');
405
406     *message = NULL;
407     if (packed_warn) *packed_warn = 0;
408
409     (*s)++;
410
411     if (send <= *s) {
412         if (strict) {
413             *message = "Empty \\x";
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
423     if (**s != '{') {
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 */
431                 *message = "Use \\x{...} for more than two hex characters";
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                 }
450             }
451         }
452         return TRUE;
453     }
454
455     e = (char *) memchr(*s, '}', send - *s);
456     if (!e) {
457         (*s)++;  /* Move past the '{' */
458         while (*s < send && isXDIGIT(**s)) { /* Position beyond legal digits */
459             (*s)++;
460         }
461         *message = "Missing right brace on \\x{}";
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 } */
471             *message = "Empty \\x{}";
472             return FALSE;
473         }
474         *s = e + 1;
475         *uv = 0;
476         return TRUE;
477     }
478
479     flags |= PERL_SCAN_ALLOW_UNDERSCORES;
480
481     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
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     }
489
490     if (numbers_len != (STRLEN) (e - *s)) {
491         *s += numbers_len;
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         }
509     }
510
511     /* Return past the '}' */
512     *s = e + 1;
513
514     return TRUE;
515 }
516
517 /*
518  * ex: set ts=8 sts=4 sw=4 et:
519  */