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