This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Cast correctly to U8, not char
[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"
881ffab6 11
68b355dd 12/* XXX Add documentation after final interface and behavior is decided */
f7e03a10 13/* 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 14 U8 source = *current;
68b355dd
KW
15*/
16
a55c5245
JH
17char
18Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
68b355dd
KW
19{
20
21 U8 result;
22
421e43ba 23 if (! isPRINT_A(source)) {
7357bd17
KW
24 Perl_croak(aTHX_ "%s",
25 "Character following \"\\c\" must be printable ASCII");
68b355dd 26 }
421e43ba 27 else if (source == '{') {
a27ed980
KW
28 const char control = toCTRL('{');
29 if (isPRINT_A(control)) {
30 /* diag_listed_as: Use "%s" instead of "%s" */
31 Perl_croak(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
32 }
33 else {
34 Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
35 }
421e43ba 36 }
68b355dd
KW
37
38 result = toCTRL(source);
5e784d58 39 if (output_warning && isPRINT_A(result)) {
4d8be631
KW
40 U8 clearer[3];
41 U8 i = 0;
42 if (! isWORDCHAR(result)) {
43 clearer[i++] = '\\';
44 }
45 clearer[i++] = result;
46 clearer[i++] = '\0';
68b355dd 47
4d8be631
KW
48 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
49 "\"\\c%c\" is more clearly written simply as \"%s\"",
50 source,
51 clearer);
68b355dd
KW
52 }
53
54 return result;
55}
56
a55c5245
JH
57bool
58Perl_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
80f4111b 59 const bool output_warning, const bool strict,
17896a85 60 const bool silence_non_portable,
80f4111b 61 const bool UTF)
db30362b
KW
62{
63
64/* Documentation to be supplied when interface nailed down finally
65 * This returns FALSE if there is an error which the caller need not recover
61caa4da
DM
66 * from; otherwise TRUE. In either case the caller should look at *len [???].
67 * It guarantees that the returned codepoint, *uv, when expressed as
7a4ca5b4 68 * utf8 bytes, would fit within the skipped "\o{...}" bytes.
db30362b 69 * On input:
00ce5563
KW
70 * s is the address of a pointer to a NULL terminated string that begins
71 * with 'o', and the previous character was a backslash. At exit, *s
72 * will be advanced to the byte just after those absorbed by this
73 * function. Hence the caller can continue parsing from there. In
74 * the case of an error, this routine has generally positioned *s to
75 * point just to the right of the first bad spot, so that a message
76 * that has a "<--" to mark the spot will be correctly positioned.
db30362b
KW
77 * uv points to a UV that will hold the output value, valid only if the
78 * return from the function is TRUE
db30362b
KW
79 * error_msg is a pointer that will be set to an internal buffer giving an
80 * error message upon failure (the return is FALSE). Untouched if
81 * function succeeds
82 * output_warning says whether to output any warning messages, or suppress
83 * them
80f4111b
KW
84 * strict is true if this should fail instead of warn if there are
85 * non-octal digits within the braces
17896a85
KW
86 * silence_non_portable is true if to suppress warnings about the code
87 * point returned being too large to fit on all platforms.
80f4111b 88 * UTF is true iff the string *s is encoded in UTF-8.
db30362b 89 */
00ce5563 90 char* e;
db30362b
KW
91 STRLEN numbers_len;
92 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
93 | PERL_SCAN_DISALLOW_PREFIX
94 /* XXX Until the message is improved in grok_oct, handle errors
95 * ourselves */
96 | PERL_SCAN_SILENT_ILLDIGIT;
97
61caa4da
DM
98#ifdef DEBUGGING
99 char *start = *s - 1;
100 assert(*start == '\\');
101#endif
102
db30362b
KW
103 PERL_ARGS_ASSERT_GROK_BSLASH_O;
104
105
00ce5563
KW
106 assert(**s == 'o');
107 (*s)++;
db30362b 108
00ce5563 109 if (**s != '{') {
db30362b
KW
110 *error_msg = "Missing braces on \\o{}";
111 return FALSE;
112 }
113
00ce5563 114 e = strchr(*s, '}');
db30362b 115 if (!e) {
00ce5563 116 (*s)++; /* Move past the '{' */
b8de99ca
KW
117 while (isOCTAL(**s)) { /* Position beyond the legal digits */
118 (*s)++;
119 }
00ce5563 120 *error_msg = "Missing right brace on \\o{";
db30362b
KW
121 return FALSE;
122 }
123
00ce5563
KW
124 (*s)++; /* Point to expected first digit (could be first byte of utf8
125 sequence if not a digit) */
126 numbers_len = e - *s;
db30362b 127 if (numbers_len == 0) {
00ce5563 128 (*s)++; /* Move past the } */
db30362b
KW
129 *error_msg = "Number with no digits";
130 return FALSE;
131 }
132
17896a85
KW
133 if (silence_non_portable) {
134 flags |= PERL_SCAN_SILENT_NON_PORTABLE;
135 }
136
00ce5563 137 *uv = grok_oct(*s, &numbers_len, &flags, NULL);
db30362b
KW
138 /* Note that if has non-octal, will ignore everything starting with that up
139 * to the '}' */
140
80f4111b
KW
141 if (numbers_len != (STRLEN) (e - *s)) {
142 if (strict) {
143 *s += numbers_len;
144 *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
145 *error_msg = "Non-octal character";
146 return FALSE;
147 }
148 else if (output_warning) {
b67d718a
KW
149 Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
150 /* diag_listed_as: Non-octal character '%c'. Resolved as "%s" */
151 "Non-octal character '%c'. Resolved as \"\\o{%.*s}\"",
152 *(*s + numbers_len),
153 (int) numbers_len,
154 *s);
80f4111b 155 }
db30362b
KW
156 }
157
00ce5563
KW
158 /* Return past the '}' */
159 *s = e + 1;
160
db30362b
KW
161 return TRUE;
162}
163
a55c5245
JH
164char*
165Perl_form_short_octal_warning(pTHX_
5e0a247b
KW
166 const char * const s, /* Points to first non-octal */
167 const STRLEN len /* Length of octals string, so
168 (s-len) points to first
169 octal */
170) {
171 /* Return a character string consisting of a warning message for when a
172 * string constant in octal is weird, like "\078". */
173
174 const char * sans_leading_zeros = s - len;
175
176 PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
177
178 assert(*s == '8' || *s == '9');
179
180 /* Remove the leading zeros, retaining one zero so won't be zero length */
181 while (*sans_leading_zeros == '0') sans_leading_zeros++;
182 if (sans_leading_zeros == s) {
183 sans_leading_zeros--;
184 }
185
186 return Perl_form(aTHX_
187 "'%.*s' resolved to '\\o{%.*s}%c'",
188 (int) (len + 2), s - len - 1,
189 (int) (s - sans_leading_zeros), sans_leading_zeros,
190 *s);
191}
192
04e98a4d 193/*
14d04a33 194 * ex: set ts=8 sts=4 sw=4 et:
04e98a4d 195 */