This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Restructure grok_bslash_c
[perl5.git] / dquote.c
1 /*    dquote.c
2  *
3  * This file contains functions that are related to
4  * parsing double-quotish expressions.
5  *
6 */
7
8 #include "EXTERN.h"
9 #define PERL_IN_DQUOTE_C
10 #include "perl.h"
11 #include "dquote_inline.h"
12
13 /* XXX Add documentation after final interface and behavior is decided */
14
15 bool
16 Perl_grok_bslash_c(pTHX_ const char   source,
17                          U8 *         result,
18                          const char** message,
19                          U32 *        packed_warn)
20 {
21     PERL_ARGS_ASSERT_GROK_BSLASH_C;
22
23     /* This returns TRUE if the \c? sequence is valid; FALSE otherwise.  If it
24      * is valid, the sequence evaluates to a single character, which will be
25      * stored into *result.
26      *
27      * source   is the character immediately after a '\c' sequence.
28      * result   points to a char variable into which this function will store
29      *          what the sequence evaluates to, if valid; unchanged otherwise.
30      * message  A pointer to any warning or error message will be stored into
31      *          this pointer; NULL if none.
32      * packed_warn if NULL on input asks that this routine display any warning
33      *          messages.  Otherwise, if the function found a warning, the
34      *          packed warning categories will be stored into *packed_warn (and
35      *          the corresponding message text into *message); 0 if none.
36      */
37
38     *message = NULL;
39     if (packed_warn) *packed_warn = 0;
40
41     if (! isPRINT_A(source)) {
42         *message = "Character following \"\\c\" must be printable ASCII";
43         return FALSE;
44     }
45
46     if (source == '{') {
47         const char control = toCTRL('{');
48         if (isPRINT_A(control)) {
49             /* diag_listed_as: Use "%s" instead of "%s" */
50             *message = Perl_form(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
51         }
52         else {
53             *message = "Sequence \"\\c{\" invalid";
54         }
55         return FALSE;
56     }
57
58     *result = toCTRL(source);
59     if (isPRINT_A(*result) && ckWARN(WARN_SYNTAX)) {
60         U8 clearer[3];
61         U8 i = 0;
62         char format[] = "\"\\c%c\" is more clearly written simply as \"%s\"";
63
64         if (! isWORDCHAR(*result)) {
65             clearer[i++] = '\\';
66         }
67         clearer[i++] = *result;
68         clearer[i++] = '\0';
69
70         if (packed_warn) {
71             *message = Perl_form(aTHX_ format, source, clearer);
72             *packed_warn = packWARN(WARN_SYNTAX);
73         }
74         else {
75             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), format, source, clearer);
76         }
77     }
78
79     return TRUE;
80 }
81
82 bool
83 Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv,
84                       const char** message,
85                       const bool output_warning, const bool strict,
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 string.  **s is 'o', and the
96  *          previous character was a backslash.  At exit, *s will be advanced
97  *          to the byte just after those absorbed by this function.  Hence the
98  *          caller can continue parsing from there.  In the case of an error,
99  *          this routine has generally positioned *s to point just to the right
100  *          of the first bad spot, so that a message that has a "<--" to mark
101  *          the spot will be correctly positioned.
102  *      send - 1  gives a limit in *s that this function is not permitted to
103  *          look beyond.  That is, the function may look at bytes only in the
104  *          range *s..send-1
105  *      uv  points to a UV that will hold the output value, valid only if the
106  *          return from the function is TRUE
107  *      message 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  *      UTF is true iff the string *s is encoded in UTF-8.
115  */
116     char* e;
117     STRLEN numbers_len;
118     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
119                 | PERL_SCAN_DISALLOW_PREFIX
120                 | PERL_SCAN_SILENT_NON_PORTABLE
121                 | PERL_SCAN_SILENT_ILLDIGIT;
122
123     PERL_ARGS_ASSERT_GROK_BSLASH_O;
124
125     assert(*(*s - 1) == '\\');
126     assert(* *s       == 'o');
127     (*s)++;
128
129     if (send <= *s || **s != '{') {
130         *message = "Missing braces on \\o{}";
131         return FALSE;
132     }
133
134     e = (char *) memchr(*s, '}', send - *s);
135     if (!e) {
136         (*s)++;  /* Move past the '{' */
137         while (isOCTAL(**s)) { /* Position beyond the legal digits */
138             (*s)++;
139         }
140         *message = "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         *message = "Empty \\o{}";
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) ? UTF8_SAFE_SKIP(*s, send) : 1;
161             *message = "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 bool
181 Perl_grok_bslash_x(pTHX_ char **s, const char * const send, UV *uv,
182                       const char** message,
183                       const bool output_warning, const bool strict,
184                       const bool UTF)
185 {
186
187 /*  Documentation to be supplied when interface nailed down finally
188  *  This returns FALSE if there is an error which the caller need not recover
189  *  from; otherwise TRUE.
190  *  It guarantees that the returned codepoint, *uv, when expressed as
191  *  utf8 bytes, would fit within the skipped "\x{...}" bytes.
192  *
193  *  On input:
194  *      s   is the address of a pointer to a string.  **s is 'x', and the
195  *          previous character was a backslash.  At exit, *s will be advanced
196  *          to the byte just after those absorbed by this function.  Hence the
197  *          caller can continue parsing from there.  In the case of an error,
198  *          this routine has generally positioned *s to point just to the right
199  *          of the first bad spot, so that a message that has a "<--" to mark
200  *          the spot will be correctly positioned.
201  *      send - 1  gives a limit in *s that this function is not permitted to
202  *          look beyond.  That is, the function may look at bytes only in the
203  *          range *s..send-1
204  *      uv  points to a UV that will hold the output value, valid only if the
205  *          return from the function is TRUE
206  *      message is a pointer that will be set to an internal buffer giving an
207  *          error message upon failure (the return is FALSE).  Untouched if
208  *          function succeeds
209  *      output_warning says whether to output any warning messages, or suppress
210  *          them
211  *      strict is true if anything out of the ordinary should cause this to
212  *          fail instead of warn or be silent.  For example, it requires
213  *          exactly 2 digits following the \x (when there are no braces).
214  *          3 digits could be a mistake, so is forbidden in this mode.
215  *      UTF is true iff the string *s is encoded in UTF-8.
216  */
217     char* e;
218     STRLEN numbers_len;
219     I32 flags = PERL_SCAN_DISALLOW_PREFIX
220               | PERL_SCAN_SILENT_NON_PORTABLE;
221
222
223     PERL_ARGS_ASSERT_GROK_BSLASH_X;
224
225     assert(*(*s - 1) == '\\');
226     assert(* *s      == 'x');
227
228     (*s)++;
229
230     if (send <= *s) {
231         if (strict) {
232             *message = "Empty \\x";
233             return FALSE;
234         }
235
236         /* Sadly, to preserve backcompat, an empty \x at the end of string is
237          * interpreted as a NUL */
238         *uv = 0;
239         return TRUE;
240     }
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) ? UTF8_SAFE_SKIP(*s, send) : 1;
254                 *message = "Non-hex character";
255             }
256             else {
257                 *message = "Use \\x{...} for more than two hex characters";
258             }
259             return FALSE;
260         }
261         return TRUE;
262     }
263
264     e = (char *) memchr(*s, '}', send - *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         *message = "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             *message = "Empty \\x{}";
284             return FALSE;
285         }
286         *s = e + 1;
287         *uv = 0;
288         return TRUE;
289     }
290
291     flags |= PERL_SCAN_ALLOW_UNDERSCORES;
292
293     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
294     /* Note that if has non-hex, will ignore everything starting with that up
295      * to the '}' */
296
297     if (strict && numbers_len != (STRLEN) (e - *s)) {
298         *s += numbers_len;
299         *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1;
300         *message = "Non-hex character";
301         return FALSE;
302     }
303
304     /* Return past the '}' */
305     *s = e + 1;
306
307     return TRUE;
308 }
309
310 /*
311  * ex: set ts=8 sts=4 sw=4 et:
312  */