This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
fix handling of non-strict \x{}
[perl5.git] / dquote_static.c
1 /*    dquote_static.c
2  *
3  * This file contains static functions that are related to
4  * parsing double-quotish expressions, but are used in more than
5  * one file.
6  *
7  * It is currently #included by regcomp.c and toke.c.
8 */
9
10 #define PERL_IN_DQUOTE_STATIC_C
11 #include "embed.h"
12
13 /*
14  - regcurly - a little FSA that accepts {\d+,?\d*}
15     Pulled from regcomp.c.
16  */
17 PERL_STATIC_INLINE I32
18 S_regcurly(const char *s)
19 {
20     PERL_ARGS_ASSERT_REGCURLY;
21
22     if (*s++ != '{')
23         return FALSE;
24     if (!isDIGIT(*s))
25         return FALSE;
26     while (isDIGIT(*s))
27         s++;
28     if (*s == ',') {
29         s++;
30         while (isDIGIT(*s))
31             s++;
32     }
33
34     return *s == '}';
35 }
36
37 /* XXX Add documentation after final interface and behavior is decided */
38 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
39     U8 source = *current;
40 */
41
42 STATIC char
43 S_grok_bslash_c(pTHX_ const char source, const bool output_warning)
44 {
45
46     U8 result;
47
48     if (! isPRINT_A(source)) {
49         Perl_croak(aTHX_ "%s",
50                         "Character following \"\\c\" must be printable ASCII");
51     }
52     else if (source == '{') {
53         const char control = toCTRL('{');
54         if (isPRINT_A(control)) {
55             /* diag_listed_as: Use "%s" instead of "%s" */
56             Perl_croak(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
57         }
58         else {
59             Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
60         }
61     }
62
63     result = toCTRL(source);
64     if (output_warning && isPRINT_A(result)) {
65         U8 clearer[3];
66         U8 i = 0;
67         if (! isWORDCHAR(result)) {
68             clearer[i++] = '\\';
69         }
70         clearer[i++] = result;
71         clearer[i++] = '\0';
72
73         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
74                         "\"\\c%c\" is more clearly written simply as \"%s\"",
75                         source,
76                         clearer);
77     }
78
79     return result;
80 }
81
82 STATIC bool
83 S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
84                       const bool output_warning, const bool strict,
85                       const bool silence_non_portable,
86                       const bool UTF)
87 {
88
89 /*  Documentation to be supplied when interface nailed down finally
90  *  This returns FALSE if there is an error which the caller need not recover
91  *  from; , otherwise TRUE.  In either case the caller should look at *len
92  *  On input:
93  *      s   is the address of a pointer to a NULL terminated string that begins
94  *          with 'o', and the previous character was a backslash.  At exit, *s
95  *          will be advanced to the byte just after those absorbed by this
96  *          function.  Hence the caller can continue parsing from there.  In
97  *          the case of an error, this routine has generally positioned *s to
98  *          point just to the right of the first bad spot, so that a message
99  *          that has a "<--" to mark the spot will be correctly positioned.
100  *      uv  points to a UV that will hold the output value, valid only if the
101  *          return from the function is TRUE
102  *      error_msg is a pointer that will be set to an internal buffer giving an
103  *          error message upon failure (the return is FALSE).  Untouched if
104  *          function succeeds
105  *      output_warning says whether to output any warning messages, or suppress
106  *          them
107  *      strict is true if this should fail instead of warn if there are
108  *          non-octal digits within the braces
109  *      silence_non_portable is true if to suppress warnings about the code
110  *          point returned being too large to fit on all platforms.
111  *      UTF is true iff the string *s is encoded in UTF-8.
112  */
113     char* e;
114     STRLEN numbers_len;
115     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
116                 | PERL_SCAN_DISALLOW_PREFIX
117                 /* XXX Until the message is improved in grok_oct, handle errors
118                  * ourselves */
119                 | PERL_SCAN_SILENT_ILLDIGIT;
120
121     PERL_ARGS_ASSERT_GROK_BSLASH_O;
122
123
124     assert(**s == 'o');
125     (*s)++;
126
127     if (**s != '{') {
128         *error_msg = "Missing braces on \\o{}";
129         return FALSE;
130     }
131
132     e = strchr(*s, '}');
133     if (!e) {
134         (*s)++;  /* Move past the '{' */
135         while (isOCTAL(**s)) { /* Position beyond the legal digits */
136             (*s)++;
137         }
138         *error_msg = "Missing right brace on \\o{";
139         return FALSE;
140     }
141
142     (*s)++;    /* Point to expected first digit (could be first byte of utf8
143                   sequence if not a digit) */
144     numbers_len = e - *s;
145     if (numbers_len == 0) {
146         (*s)++;    /* Move past the } */
147         *error_msg = "Number with no digits";
148         return FALSE;
149     }
150
151     if (silence_non_portable) {
152         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
153     }
154
155     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
156     /* Note that if has non-octal, will ignore everything starting with that up
157      * to the '}' */
158
159     if (numbers_len != (STRLEN) (e - *s)) {
160         if (strict) {
161             *s += numbers_len;
162             *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
163             *error_msg = "Non-octal character";
164             return FALSE;
165         }
166         else if (output_warning) {
167             Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
168             /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
169                         "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
170                         *(*s + numbers_len),
171                         (int) numbers_len,
172                         *s);
173         }
174     }
175
176     /* Return past the '}' */
177     *s = e + 1;
178
179     return TRUE;
180 }
181
182 PERL_STATIC_INLINE bool
183 S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
184                       const bool output_warning, const bool strict,
185                       const bool silence_non_portable,
186                       const bool UTF)
187 {
188
189 /*  Documentation to be supplied when interface nailed down finally
190  *  This returns FALSE if there is an error which the caller need not recover
191  *  from; , otherwise TRUE.
192  *  On input:
193  *      s   is the address of a pointer to a NULL terminated string that begins
194  *          with 'x', and the previous character was a backslash.  At exit, *s
195  *          will be advanced to the byte just after those absorbed by this
196  *          function.  Hence the caller can continue parsing from there.  In
197  *          the case of an error, this routine has generally positioned *s to
198  *          point just to the right of the first bad spot, so that a message
199  *          that has a "<--" to mark the spot will be correctly positioned.
200  *      uv  points to a UV that will hold the output value, valid only if the
201  *          return from the function is TRUE
202  *      error_msg is a pointer that will be set to an internal buffer giving an
203  *          error message upon failure (the return is FALSE).  Untouched if
204  *          function succeeds
205  *      output_warning says whether to output any warning messages, or suppress
206  *          them
207  *      strict is true if anything out of the ordinary should cause this to
208  *          fail instead of warn or be silent.  For example, it requires
209  *          exactly 2 digits following the \x (when there are no braces).
210  *          3 digits could be a mistake, so is forbidden in this mode.
211  *      silence_non_portable is true if to suppress warnings about the code
212  *          point returned being too large to fit on all platforms.
213  *      UTF is true iff the string *s is encoded in UTF-8.
214  */
215     char* e;
216     STRLEN numbers_len;
217     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
218
219     PERL_ARGS_ASSERT_GROK_BSLASH_X;
220
221     PERL_UNUSED_ARG(output_warning);
222
223     assert(**s == 'x');
224     (*s)++;
225
226     if (strict || ! output_warning) {
227         flags |= PERL_SCAN_SILENT_ILLDIGIT;
228     }
229
230     if (**s != '{') {
231         STRLEN len = (strict) ? 3 : 2;
232
233         *uv = grok_hex(*s, &len, &flags, NULL);
234         *s += len;
235         if (strict && len != 2) {
236             if (len < 2) {
237                 *s += (UTF) ? UTF8SKIP(*s) : 1;
238                 *error_msg = "Non-hex character";
239             }
240             else {
241                 *error_msg = "Use \\x{...} for more than two hex characters";
242             }
243             return FALSE;
244         }
245         return TRUE;
246     }
247
248     e = strchr(*s, '}');
249     if (!e) {
250         (*s)++;  /* Move past the '{' */
251         while (isXDIGIT(**s)) { /* Position beyond the legal digits */
252             (*s)++;
253         }
254         /* XXX The corresponding message above for \o is just '\\o{'; other
255          * messages for other constructs include the '}', so are inconsistent.
256          */
257         *error_msg = "Missing right brace on \\x{}";
258         return FALSE;
259     }
260
261     (*s)++;    /* Point to expected first digit (could be first byte of utf8
262                   sequence if not a digit) */
263     numbers_len = e - *s;
264     if (numbers_len == 0) {
265         if (strict) {
266             (*s)++;    /* Move past the } */
267             *error_msg = "Number with no digits";
268             return FALSE;
269         }
270         *s = e + 1;
271         *uv = 0;
272         return TRUE;
273     }
274
275     flags |= PERL_SCAN_ALLOW_UNDERSCORES;
276     if (silence_non_portable) {
277         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
278     }
279
280     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
281     /* Note that if has non-hex, will ignore everything starting with that up
282      * to the '}' */
283
284     if (strict && numbers_len != (STRLEN) (e - *s)) {
285         *s += numbers_len;
286         *s += (UTF) ? UTF8SKIP(*s) : 1;
287         *error_msg = "Non-hex character";
288         return FALSE;
289     }
290
291     /* Return past the '}' */
292     *s = e + 1;
293
294     return TRUE;
295 }
296
297 STATIC char*
298 S_form_short_octal_warning(pTHX_
299                            const char * const s, /* Points to first non-octal */
300                            const STRLEN len      /* Length of octals string, so
301                                                     (s-len) points to first
302                                                     octal */
303 ) {
304     /* Return a character string consisting of a warning message for when a
305      * string constant in octal is weird, like "\078".  */
306
307     const char * sans_leading_zeros = s - len;
308
309     PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
310
311     assert(*s == '8' || *s == '9');
312
313     /* Remove the leading zeros, retaining one zero so won't be zero length */
314     while (*sans_leading_zeros == '0') sans_leading_zeros++;
315     if (sans_leading_zeros == s) {
316         sans_leading_zeros--;
317     }
318
319     return Perl_form(aTHX_
320                      "'%.*s' resolved to '\\o{%.*s}%c'",
321                      (int) (len + 2), s - len - 1,
322                      (int) (s - sans_leading_zeros), sans_leading_zeros,
323                      *s);
324 }
325
326 /*
327  * Local variables:
328  * c-indentation-style: bsd
329  * c-basic-offset: 4
330  * indent-tabs-mode: nil
331  * End:
332  *
333  * ex: set ts=8 sts=4 sw=4 et:
334  */