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