This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
locale.c: Tighten what is considered a LC variable
[perl5.git] / dquote.c
CommitLineData
a55c5245 1/* dquote.c
04e98a4d 2 *
a55c5245
JH
3 * This file contains functions that are related to
4 * parsing double-quotish expressions.
04e98a4d 5 *
04e98a4d
AD
6*/
7
a55c5245
JH
8#include "EXTERN.h"
9#define PERL_IN_DQUOTE_C
10#include "perl.h"
ce54a8b9 11#include "dquote_inline.h"
881ffab6 12
68b355dd 13/* XXX Add documentation after final interface and behavior is decided */
f7e03a10 14/* May want to show context for error, so would pass S_grok_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
68b355dd 15 U8 source = *current;
68b355dd
KW
16*/
17
a55c5245
JH
18char
19Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
68b355dd
KW
20{
21
22 U8 result;
23
421e43ba 24 if (! isPRINT_A(source)) {
7357bd17
KW
25 Perl_croak(aTHX_ "%s",
26 "Character following \"\\c\" must be printable ASCII");
68b355dd 27 }
421e43ba 28 else if (source == '{') {
a27ed980
KW
29 const char control = toCTRL('{');
30 if (isPRINT_A(control)) {
31 /* diag_listed_as: Use "%s" instead of "%s" */
32 Perl_croak(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
33 }
34 else {
35 Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
36 }
421e43ba 37 }
68b355dd
KW
38
39 result = toCTRL(source);
5e784d58 40 if (output_warning && isPRINT_A(result)) {
4d8be631
KW
41 U8 clearer[3];
42 U8 i = 0;
43 if (! isWORDCHAR(result)) {
44 clearer[i++] = '\\';
45 }
46 clearer[i++] = result;
47 clearer[i++] = '\0';
68b355dd 48
d4360efa
S
49 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
50 "\"\\c%c\" is more clearly written simply as \"%s\"",
51 source,
52 clearer);
68b355dd
KW
53 }
54
55 return result;
56}
57
a55c5245
JH
58bool
59Perl_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
80f4111b 60 const bool output_warning, const bool strict,
17896a85 61 const bool silence_non_portable,
80f4111b 62 const bool UTF)
db30362b
KW
63{
64
65/* Documentation to be supplied when interface nailed down finally
66 * This returns FALSE if there is an error which the caller need not recover
61caa4da
DM
67 * from; otherwise TRUE. In either case the caller should look at *len [???].
68 * It guarantees that the returned codepoint, *uv, when expressed as
7a4ca5b4 69 * utf8 bytes, would fit within the skipped "\o{...}" bytes.
db30362b 70 * On input:
00ce5563
KW
71 * s is the address of a pointer to a NULL terminated string that begins
72 * with 'o', and the previous character was a backslash. At exit, *s
73 * will be advanced to the byte just after those absorbed by this
74 * function. Hence the caller can continue parsing from there. In
75 * the case of an error, this routine has generally positioned *s to
76 * point just to the right of the first bad spot, so that a message
77 * that has a "<--" to mark the spot will be correctly positioned.
db30362b
KW
78 * uv points to a UV that will hold the output value, valid only if the
79 * return from the function is TRUE
db30362b
KW
80 * error_msg is a pointer that will be set to an internal buffer giving an
81 * error message upon failure (the return is FALSE). Untouched if
82 * function succeeds
83 * output_warning says whether to output any warning messages, or suppress
84 * them
80f4111b
KW
85 * strict is true if this should fail instead of warn if there are
86 * non-octal digits within the braces
17896a85
KW
87 * silence_non_portable is true if to suppress warnings about the code
88 * point returned being too large to fit on all platforms.
80f4111b 89 * UTF is true iff the string *s is encoded in UTF-8.
db30362b 90 */
00ce5563 91 char* e;
db30362b
KW
92 STRLEN numbers_len;
93 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
94 | PERL_SCAN_DISALLOW_PREFIX
95 /* XXX Until the message is improved in grok_oct, handle errors
96 * ourselves */
97 | PERL_SCAN_SILENT_ILLDIGIT;
98
99 PERL_ARGS_ASSERT_GROK_BSLASH_O;
100
7f4ec488
KW
101 assert(*(*s - 1) == '\\');
102 assert(* *s == 'o');
00ce5563 103 (*s)++;
db30362b 104
00ce5563 105 if (**s != '{') {
db30362b
KW
106 *error_msg = "Missing braces on \\o{}";
107 return FALSE;
108 }
109
00ce5563 110 e = strchr(*s, '}');
db30362b 111 if (!e) {
00ce5563 112 (*s)++; /* Move past the '{' */
b8de99ca
KW
113 while (isOCTAL(**s)) { /* Position beyond the legal digits */
114 (*s)++;
115 }
00ce5563 116 *error_msg = "Missing right brace on \\o{";
db30362b
KW
117 return FALSE;
118 }
119
00ce5563
KW
120 (*s)++; /* Point to expected first digit (could be first byte of utf8
121 sequence if not a digit) */
122 numbers_len = e - *s;
db30362b 123 if (numbers_len == 0) {
00ce5563 124 (*s)++; /* Move past the } */
db30362b
KW
125 *error_msg = "Number with no digits";
126 return FALSE;
127 }
128
17896a85
KW
129 if (silence_non_portable) {
130 flags |= PERL_SCAN_SILENT_NON_PORTABLE;
131 }
132
00ce5563 133 *uv = grok_oct(*s, &numbers_len, &flags, NULL);
db30362b
KW
134 /* Note that if has non-octal, will ignore everything starting with that up
135 * to the '}' */
136
80f4111b
KW
137 if (numbers_len != (STRLEN) (e - *s)) {
138 if (strict) {
139 *s += numbers_len;
140 *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
141 *error_msg = "Non-octal character";
142 return FALSE;
143 }
144 else if (output_warning) {
b67d718a
KW
145 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
146 /* diag_listed_as: Non-octal character '%c'. Resolved as "%s" */
147 "Non-octal character '%c'. Resolved as \"\\o{%.*s}\"",
148 *(*s + numbers_len),
149 (int) numbers_len,
150 *s);
80f4111b 151 }
db30362b
KW
152 }
153
00ce5563
KW
154 /* Return past the '}' */
155 *s = e + 1;
156
db30362b
KW
157 return TRUE;
158}
159
ce54a8b9
KW
160bool
161Perl_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
162 const bool output_warning, const bool strict,
163 const bool silence_non_portable,
164 const bool UTF)
165{
5e0a247b 166
ce54a8b9
KW
167/* Documentation to be supplied when interface nailed down finally
168 * This returns FALSE if there is an error which the caller need not recover
169 * from; otherwise TRUE.
170 * It guarantees that the returned codepoint, *uv, when expressed as
171 * utf8 bytes, would fit within the skipped "\x{...}" bytes.
172 *
173 * On input:
174 * s is the address of a pointer to a NULL terminated string that begins
175 * with 'x', and the previous character was a backslash. At exit, *s
176 * will be advanced to the byte just after those absorbed by this
177 * function. Hence the caller can continue parsing from there. In
178 * the case of an error, this routine has generally positioned *s to
179 * point just to the right of the first bad spot, so that a message
180 * that has a "<--" to mark the spot will be correctly positioned.
181 * uv points to a UV that will hold the output value, valid only if the
182 * return from the function is TRUE
183 * error_msg is a pointer that will be set to an internal buffer giving an
184 * error message upon failure (the return is FALSE). Untouched if
185 * function succeeds
186 * output_warning says whether to output any warning messages, or suppress
187 * them
188 * strict is true if anything out of the ordinary should cause this to
189 * fail instead of warn or be silent. For example, it requires
190 * exactly 2 digits following the \x (when there are no braces).
191 * 3 digits could be a mistake, so is forbidden in this mode.
192 * silence_non_portable is true if to suppress warnings about the code
193 * point returned being too large to fit on all platforms.
194 * UTF is true iff the string *s is encoded in UTF-8.
195 */
196 char* e;
197 STRLEN numbers_len;
198 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
7f4ec488 199
5e0a247b 200
ce54a8b9 201 PERL_ARGS_ASSERT_GROK_BSLASH_X;
5e0a247b 202
7f4ec488
KW
203 assert(*(*s - 1) == '\\');
204 assert(* *s == 'x');
ce54a8b9 205 (*s)++;
5e0a247b 206
ce54a8b9
KW
207 if (strict || ! output_warning) {
208 flags |= PERL_SCAN_SILENT_ILLDIGIT;
5e0a247b
KW
209 }
210
ce54a8b9
KW
211 if (**s != '{') {
212 STRLEN len = (strict) ? 3 : 2;
213
214 *uv = grok_hex(*s, &len, &flags, NULL);
215 *s += len;
216 if (strict && len != 2) {
217 if (len < 2) {
218 *s += (UTF) ? UTF8SKIP(*s) : 1;
219 *error_msg = "Non-hex character";
220 }
221 else {
222 *error_msg = "Use \\x{...} for more than two hex characters";
223 }
224 return FALSE;
225 }
226 return TRUE;
227 }
228
229 e = strchr(*s, '}');
230 if (!e) {
231 (*s)++; /* Move past the '{' */
232 while (isXDIGIT(**s)) { /* Position beyond the legal digits */
233 (*s)++;
234 }
235 /* XXX The corresponding message above for \o is just '\\o{'; other
236 * messages for other constructs include the '}', so are inconsistent.
237 */
238 *error_msg = "Missing right brace on \\x{}";
239 return FALSE;
240 }
241
242 (*s)++; /* Point to expected first digit (could be first byte of utf8
243 sequence if not a digit) */
244 numbers_len = e - *s;
245 if (numbers_len == 0) {
246 if (strict) {
247 (*s)++; /* Move past the } */
248 *error_msg = "Number with no digits";
249 return FALSE;
250 }
251 *s = e + 1;
252 *uv = 0;
253 return TRUE;
254 }
255
256 flags |= PERL_SCAN_ALLOW_UNDERSCORES;
257 if (silence_non_portable) {
258 flags |= PERL_SCAN_SILENT_NON_PORTABLE;
259 }
260
261 *uv = grok_hex(*s, &numbers_len, &flags, NULL);
262 /* Note that if has non-hex, will ignore everything starting with that up
263 * to the '}' */
264
265 if (strict && numbers_len != (STRLEN) (e - *s)) {
266 *s += numbers_len;
267 *s += (UTF) ? UTF8SKIP(*s) : 1;
268 *error_msg = "Non-hex character";
269 return FALSE;
270 }
271
272 /* Return past the '}' */
273 *s = e + 1;
274
275 return TRUE;
5e0a247b
KW
276}
277
04e98a4d 278/*
14d04a33 279 * ex: set ts=8 sts=4 sw=4 et:
04e98a4d 280 */