]> git.vpit.fr Git - perl/modules/re-engine-Hooks.git/blob - dquote_static.c
885ba06ffb630405b467c0be280195564bf8ef68
[perl/modules/re-engine-Hooks.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  *  It guarantees that the returned codepoint, *uv, when expressed as
93  *  utf8 bytes, would fit within the skipped "\o{...}" bytes.
94  *  On input:
95  *      s   is the address of a pointer to a NULL terminated string that begins
96  *          with 'o', and the previous character was a backslash.  At exit, *s
97  *          will be advanced to the byte just after those absorbed by this
98  *          function.  Hence the caller can continue parsing from there.  In
99  *          the case of an error, this routine has generally positioned *s to
100  *          point just to the right of the first bad spot, so that a message
101  *          that has a "<--" to mark the spot will be correctly positioned.
102  *      uv  points to a UV that will hold the output value, valid only if the
103  *          return from the function is TRUE
104  *      error_msg is a pointer that will be set to an internal buffer giving an
105  *          error message upon failure (the return is FALSE).  Untouched if
106  *          function succeeds
107  *      output_warning says whether to output any warning messages, or suppress
108  *          them
109  *      strict is true if this should fail instead of warn if there are
110  *          non-octal digits within the braces
111  *      silence_non_portable is true if to suppress warnings about the code
112  *          point returned being too large to fit on all platforms.
113  *      UTF is true iff the string *s is encoded in UTF-8.
114  */
115     char* e;
116     STRLEN numbers_len;
117     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
118                 | PERL_SCAN_DISALLOW_PREFIX
119                 /* XXX Until the message is improved in grok_oct, handle errors
120                  * ourselves */
121                 | PERL_SCAN_SILENT_ILLDIGIT;
122
123 #ifdef DEBUGGING
124     char *start = *s - 1;
125     assert(*start == '\\');
126 #endif
127
128     PERL_ARGS_ASSERT_GROK_BSLASH_O;
129
130
131     assert(**s == 'o');
132     (*s)++;
133
134     if (**s != '{') {
135         *error_msg = "Missing braces on \\o{}";
136         return FALSE;
137     }
138
139     e = strchr(*s, '}');
140     if (!e) {
141         (*s)++;  /* Move past the '{' */
142         while (isOCTAL(**s)) { /* Position beyond the legal digits */
143             (*s)++;
144         }
145         *error_msg = "Missing right brace on \\o{";
146         return FALSE;
147     }
148
149     (*s)++;    /* Point to expected first digit (could be first byte of utf8
150                   sequence if not a digit) */
151     numbers_len = e - *s;
152     if (numbers_len == 0) {
153         (*s)++;    /* Move past the } */
154         *error_msg = "Number with no digits";
155         return FALSE;
156     }
157
158     if (silence_non_portable) {
159         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
160     }
161
162     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
163     /* Note that if has non-octal, will ignore everything starting with that up
164      * to the '}' */
165
166     if (numbers_len != (STRLEN) (e - *s)) {
167         if (strict) {
168             *s += numbers_len;
169             *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
170             *error_msg = "Non-octal character";
171             return FALSE;
172         }
173         else if (output_warning) {
174             Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
175             /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
176                         "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
177                         *(*s + numbers_len),
178                         (int) numbers_len,
179                         *s);
180         }
181     }
182
183     /* Return past the '}' */
184     *s = e + 1;
185
186     /* guarantee replacing "\o{...}" with utf8 bytes fits within
187      * existing space */
188     assert(OFFUNISKIP(*uv) < *s - start);
189
190     return TRUE;
191 }
192
193 PERL_STATIC_INLINE bool
194 S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
195                       const bool output_warning, const bool strict,
196                       const bool silence_non_portable,
197                       const bool UTF)
198 {
199
200 /*  Documentation to be supplied when interface nailed down finally
201  *  This returns FALSE if there is an error which the caller need not recover
202  *  from; otherwise TRUE.
203  *  It guarantees that the returned codepoint, *uv, when expressed as
204  *  utf8 bytes, would fit within the skipped "\x{...}" bytes.
205  *
206  *  On input:
207  *      s   is the address of a pointer to a NULL terminated string that begins
208  *          with 'x', and the previous character was a backslash.  At exit, *s
209  *          will be advanced to the byte just after those absorbed by this
210  *          function.  Hence the caller can continue parsing from there.  In
211  *          the case of an error, this routine has generally positioned *s to
212  *          point just to the right of the first bad spot, so that a message
213  *          that has a "<--" to mark the spot will be correctly positioned.
214  *      uv  points to a UV that will hold the output value, valid only if the
215  *          return from the function is TRUE
216  *      error_msg is a pointer that will be set to an internal buffer giving an
217  *          error message upon failure (the return is FALSE).  Untouched if
218  *          function succeeds
219  *      output_warning says whether to output any warning messages, or suppress
220  *          them
221  *      strict is true if anything out of the ordinary should cause this to
222  *          fail instead of warn or be silent.  For example, it requires
223  *          exactly 2 digits following the \x (when there are no braces).
224  *          3 digits could be a mistake, so is forbidden in this mode.
225  *      silence_non_portable is true if to suppress warnings about the code
226  *          point returned being too large to fit on all platforms.
227  *      UTF is true iff the string *s is encoded in UTF-8.
228  */
229     char* e;
230     STRLEN numbers_len;
231     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
232 #ifdef DEBUGGING
233     char *start = *s - 1;
234     assert(*start == '\\');
235 #endif
236
237     PERL_ARGS_ASSERT_GROK_BSLASH_X;
238
239     assert(**s == 'x');
240     (*s)++;
241
242     if (strict || ! output_warning) {
243         flags |= PERL_SCAN_SILENT_ILLDIGIT;
244     }
245
246     if (**s != '{') {
247         STRLEN len = (strict) ? 3 : 2;
248
249         *uv = grok_hex(*s, &len, &flags, NULL);
250         *s += len;
251         if (strict && len != 2) {
252             if (len < 2) {
253                 *s += (UTF) ? UTF8SKIP(*s) : 1;
254                 *error_msg = "Non-hex character";
255             }
256             else {
257                 *error_msg = "Use \\x{...} for more than two hex characters";
258             }
259             return FALSE;
260         }
261         goto ok;
262     }
263
264     e = strchr(*s, '}');
265     if (!e) {
266         (*s)++;  /* Move past the '{' */
267         while (isXDIGIT(**s)) { /* Position beyond the legal digits */
268             (*s)++;
269         }
270         /* XXX The corresponding message above for \o is just '\\o{'; other
271          * messages for other constructs include the '}', so are inconsistent.
272          */
273         *error_msg = "Missing right brace on \\x{}";
274         return FALSE;
275     }
276
277     (*s)++;    /* Point to expected first digit (could be first byte of utf8
278                   sequence if not a digit) */
279     numbers_len = e - *s;
280     if (numbers_len == 0) {
281         if (strict) {
282             (*s)++;    /* Move past the } */
283             *error_msg = "Number with no digits";
284             return FALSE;
285         }
286         *s = e + 1;
287         *uv = 0;
288         goto ok;
289     }
290
291     flags |= PERL_SCAN_ALLOW_UNDERSCORES;
292     if (silence_non_portable) {
293         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
294     }
295
296     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
297     /* Note that if has non-hex, will ignore everything starting with that up
298      * to the '}' */
299
300     if (strict && numbers_len != (STRLEN) (e - *s)) {
301         *s += numbers_len;
302         *s += (UTF) ? UTF8SKIP(*s) : 1;
303         *error_msg = "Non-hex character";
304         return FALSE;
305     }
306
307     /* Return past the '}' */
308     *s = e + 1;
309
310   ok:
311     /* guarantee replacing "\x{...}" with utf8 bytes fits within
312      * existing space */
313     assert(OFFUNISKIP(*uv) < *s - start);
314     return TRUE;
315 }
316
317 STATIC char*
318 S_form_short_octal_warning(pTHX_
319                            const char * const s, /* Points to first non-octal */
320                            const STRLEN len      /* Length of octals string, so
321                                                     (s-len) points to first
322                                                     octal */
323 ) {
324     /* Return a character string consisting of a warning message for when a
325      * string constant in octal is weird, like "\078".  */
326
327     const char * sans_leading_zeros = s - len;
328
329     PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
330
331     assert(*s == '8' || *s == '9');
332
333     /* Remove the leading zeros, retaining one zero so won't be zero length */
334     while (*sans_leading_zeros == '0') sans_leading_zeros++;
335     if (sans_leading_zeros == s) {
336         sans_leading_zeros--;
337     }
338
339     return Perl_form(aTHX_
340                      "'%.*s' resolved to '\\o{%.*s}%c'",
341                      (int) (len + 2), s - len - 1,
342                      (int) (s - sans_leading_zeros), sans_leading_zeros,
343                      *s);
344 }
345
346 /*
347  * ex: set ts=8 sts=4 sw=4 et:
348  */