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