Update Pod-Simple to CPAN version 3.31
[perl.git] / dquote_inline.h
1 /*    dquote_inline.h
2  *
3  *    Copyright (C) 2015 by Larry Wall and others
4  *
5  *    You may distribute under the terms of either the GNU General Public
6  *    License or the Artistic License, as specified in the README file.
7  */
8
9 #ifndef DQUOTE_INLINE_H /* Guard against nested #inclusion */
10 #define DQUOTE_INLINE_H
11
12 /*
13  - regcurly - a little FSA that accepts {\d+,?\d*}
14     Pulled from reg.c.
15  */
16 PERL_STATIC_INLINE I32
17 S_regcurly(const char *s)
18 {
19     PERL_ARGS_ASSERT_REGCURLY;
20
21     if (*s++ != '{')
22         return FALSE;
23     if (!isDIGIT(*s))
24         return FALSE;
25     while (isDIGIT(*s))
26         s++;
27     if (*s == ',') {
28         s++;
29         while (isDIGIT(*s))
30             s++;
31     }
32
33     return *s == '}';
34 }
35
36 PERL_STATIC_INLINE bool
37 S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
38                       const bool output_warning, const bool strict,
39                       const bool silence_non_portable,
40                       const bool UTF)
41 {
42
43 /*  Documentation to be supplied when interface nailed down finally
44  *  This returns FALSE if there is an error which the caller need not recover
45  *  from; otherwise TRUE.
46  *  It guarantees that the returned codepoint, *uv, when expressed as
47  *  utf8 bytes, would fit within the skipped "\x{...}" bytes.
48  *
49  *  On input:
50  *      s   is the address of a pointer to a NULL terminated string that begins
51  *          with 'x', and the previous character was a backslash.  At exit, *s
52  *          will be advanced to the byte just after those absorbed by this
53  *          function.  Hence the caller can continue parsing from there.  In
54  *          the case of an error, this routine has generally positioned *s to
55  *          point just to the right of the first bad spot, so that a message
56  *          that has a "<--" to mark the spot will be correctly positioned.
57  *      uv  points to a UV that will hold the output value, valid only if the
58  *          return from the function is TRUE
59  *      error_msg is a pointer that will be set to an internal buffer giving an
60  *          error message upon failure (the return is FALSE).  Untouched if
61  *          function succeeds
62  *      output_warning says whether to output any warning messages, or suppress
63  *          them
64  *      strict is true if anything out of the ordinary should cause this to
65  *          fail instead of warn or be silent.  For example, it requires
66  *          exactly 2 digits following the \x (when there are no braces).
67  *          3 digits could be a mistake, so is forbidden in this mode.
68  *      silence_non_portable is true if to suppress warnings about the code
69  *          point returned being too large to fit on all platforms.
70  *      UTF is true iff the string *s is encoded in UTF-8.
71  */
72     char* e;
73     STRLEN numbers_len;
74     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
75 #ifdef DEBUGGING
76     char *start = *s - 1;
77     assert(*start == '\\');
78 #endif
79
80     PERL_ARGS_ASSERT_GROK_BSLASH_X;
81
82     assert(**s == 'x');
83     (*s)++;
84
85     if (strict || ! output_warning) {
86         flags |= PERL_SCAN_SILENT_ILLDIGIT;
87     }
88
89     if (**s != '{') {
90         STRLEN len = (strict) ? 3 : 2;
91
92         *uv = grok_hex(*s, &len, &flags, NULL);
93         *s += len;
94         if (strict && len != 2) {
95             if (len < 2) {
96                 *s += (UTF) ? UTF8SKIP(*s) : 1;
97                 *error_msg = "Non-hex character";
98             }
99             else {
100                 *error_msg = "Use \\x{...} for more than two hex characters";
101             }
102             return FALSE;
103         }
104         goto ok;
105     }
106
107     e = strchr(*s, '}');
108     if (!e) {
109         (*s)++;  /* Move past the '{' */
110         while (isXDIGIT(**s)) { /* Position beyond the legal digits */
111             (*s)++;
112         }
113         /* XXX The corresponding message above for \o is just '\\o{'; other
114          * messages for other constructs include the '}', so are inconsistent.
115          */
116         *error_msg = "Missing right brace on \\x{}";
117         return FALSE;
118     }
119
120     (*s)++;    /* Point to expected first digit (could be first byte of utf8
121                   sequence if not a digit) */
122     numbers_len = e - *s;
123     if (numbers_len == 0) {
124         if (strict) {
125             (*s)++;    /* Move past the } */
126             *error_msg = "Number with no digits";
127             return FALSE;
128         }
129         *s = e + 1;
130         *uv = 0;
131         goto ok;
132     }
133
134     flags |= PERL_SCAN_ALLOW_UNDERSCORES;
135     if (silence_non_portable) {
136         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
137     }
138
139     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
140     /* Note that if has non-hex, will ignore everything starting with that up
141      * to the '}' */
142
143     if (strict && numbers_len != (STRLEN) (e - *s)) {
144         *s += numbers_len;
145         *s += (UTF) ? UTF8SKIP(*s) : 1;
146         *error_msg = "Non-hex character";
147         return FALSE;
148     }
149
150     /* Return past the '}' */
151     *s = e + 1;
152
153   ok:
154     /* guarantee replacing "\x{...}" with utf8 bytes fits within
155      * existing space */
156     assert(OFFUNISKIP(*uv) < *s - start);
157     return TRUE;
158 }
159
160 #endif  /* DQUOTE_INLINE_H */