This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
dquote_static.c: White-space only; no code changes
[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 {
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 UTF)
91 {
92
93 /*  Documentation to be supplied when interface nailed down finally
94  *  This returns FALSE if there is an error which the caller need not recover
95  *  from; , otherwise TRUE.  In either case the caller should look at *len
96  *  On input:
97  *      s   is the address of a pointer to a NULL terminated string that begins
98  *          with 'o', and the previous character was a backslash.  At exit, *s
99  *          will be advanced to the byte just after those absorbed by this
100  *          function.  Hence the caller can continue parsing from there.  In
101  *          the case of an error, this routine has generally positioned *s to
102  *          point just to the right of the first bad spot, so that a message
103  *          that has a "<--" to mark the spot will be correctly positioned.
104  *      uv  points to a UV that will hold the output value, valid only if the
105  *          return from the function is TRUE
106  *      error_msg is a pointer that will be set to an internal buffer giving an
107  *          error message upon failure (the return is FALSE).  Untouched if
108  *          function succeeds
109  *      output_warning says whether to output any warning messages, or suppress
110  *          them
111  *      strict is true if this should fail instead of warn if there are
112  *          non-octal digits within the braces
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     PERL_ARGS_ASSERT_GROK_BSLASH_O;
124
125
126     assert(**s == 'o');
127     (*s)++;
128
129     if (**s != '{') {
130         *error_msg = "Missing braces on \\o{}";
131         return FALSE;
132     }
133
134     e = strchr(*s, '}');
135     if (!e) {
136         (*s)++;  /* Move past the '{' */
137         while (isOCTAL(**s)) { /* Position beyond the legal digits */
138             (*s)++;
139         }
140         *error_msg = "Missing right brace on \\o{";
141         return FALSE;
142     }
143
144     (*s)++;    /* Point to expected first digit (could be first byte of utf8
145                   sequence if not a digit) */
146     numbers_len = e - *s;
147     if (numbers_len == 0) {
148         (*s)++;    /* Move past the } */
149         *error_msg = "Number with no digits";
150         return FALSE;
151     }
152
153     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
154     /* Note that if has non-octal, will ignore everything starting with that up
155      * to the '}' */
156
157     if (numbers_len != (STRLEN) (e - *s)) {
158         if (strict) {
159             *s += numbers_len;
160             *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
161             *error_msg = "Non-octal character";
162             return FALSE;
163         }
164         else if (output_warning) {
165             Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
166             /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
167                         "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
168                         *(*s + numbers_len),
169                         (int) numbers_len,
170                         *s);
171         }
172     }
173
174     /* Return past the '}' */
175     *s = e + 1;
176
177     return TRUE;
178 }
179
180 PERL_STATIC_INLINE bool
181 S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
182                       const bool output_warning, const bool strict,
183                       const bool UTF)
184 {
185
186 /*  Documentation to be supplied when interface nailed down finally
187  *  This returns FALSE if there is an error which the caller need not recover
188  *  from; , otherwise TRUE.  In either case the caller should look at *len
189  *  On input:
190  *      s   is the address of a pointer to a NULL terminated string that begins
191  *          with 'x', and the previous character was a backslash.  At exit, *s
192  *          will be advanced to the byte just after those absorbed by this
193  *          function.  Hence the caller can continue parsing from there.  In
194  *          the case of an error, this routine has generally positioned *s to
195  *          point just to the right of the first bad spot, so that a message
196  *          that has a "<--" to mark the spot will be correctly positioned.
197  *      uv  points to a UV that will hold the output value, valid only if the
198  *          return from the function is TRUE
199  *      error_msg is a pointer that will be set to an internal buffer giving an
200  *          error message upon failure (the return is FALSE).  Untouched if
201  *          function succeeds
202  *      output_warning says whether to output any warning messages, or suppress
203  *          them
204  *      strict is true if anything out of the ordinary should cause this to
205  *          fail instead of warn or be silent.  For example, it requires
206  *          exactly 2 digits following the \x (when there are no braces).
207  *          3 digits could be a mistake, so is forbidden in this mode.
208  *      UTF is true iff the string *s is encoded in UTF-8.
209  */
210     char* e;
211     STRLEN numbers_len;
212     I32 flags = 0;
213
214     PERL_ARGS_ASSERT_GROK_BSLASH_X;
215
216     PERL_UNUSED_ARG(output_warning);
217
218     assert(**s == 'x');
219     (*s)++;
220
221     if (strict) {
222         flags |= PERL_SCAN_SILENT_ILLDIGIT;
223     }
224
225     if (**s != '{') {
226         STRLEN len = (strict) ? 3 : 2;
227
228         flags |= PERL_SCAN_DISALLOW_PREFIX;
229         *uv = grok_hex(*s, &len, &flags, NULL);
230         *s += len;
231         if (strict && len != 2) {
232             if (len < 2) {
233                 *s += (UTF) ? UTF8SKIP(*s) : 1;
234                 *error_msg = "Non-hex character";
235             }
236             else {
237                 *error_msg = "Use \\x{...} for more than two hex characters";
238             }
239             return FALSE;
240         }
241         return TRUE;
242     }
243
244     e = strchr(*s, '}');
245     if (!e) {
246         (*s)++;  /* Move past the '{' */
247         while (isXDIGIT(**s)) { /* Position beyond the legal digits */
248             (*s)++;
249         }
250         /* XXX The corresponding message above for \o is just '\\o{'; other
251          * messages for other constructs include the '}', so are inconsistent.
252          */
253         *error_msg = "Missing right brace on \\x{}";
254         return FALSE;
255     }
256
257     (*s)++;    /* Point to expected first digit (could be first byte of utf8
258                   sequence if not a digit) */
259     numbers_len = e - *s;
260     if (numbers_len == 0) {
261         if (strict) {
262             (*s)++;    /* Move past the } */
263             *error_msg = "Number with no digits";
264             return FALSE;
265         }
266         return TRUE;
267     }
268
269     flags |= PERL_SCAN_ALLOW_UNDERSCORES|PERL_SCAN_DISALLOW_PREFIX;
270
271     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
272     /* Note that if has non-hex, will ignore everything starting with that up
273      * to the '}' */
274
275     if (strict && numbers_len != (STRLEN) (e - *s)) {
276         *s += numbers_len;
277         *s += (UTF) ? UTF8SKIP(*s) : 1;
278         *error_msg = "Non-hex character";
279         return FALSE;
280     }
281
282     /* Return past the '}' */
283     *s = e + 1;
284
285     return TRUE;
286 }
287
288 /*
289  * Local variables:
290  * c-indentation-style: bsd
291  * c-basic-offset: 4
292  * indent-tabs-mode: nil
293  * End:
294  *
295  * ex: set ts=8 sts=4 sw=4 et:
296  */