3 * This file contains functions that are related to
4 * parsing double-quotish expressions.
9 #define PERL_IN_DQUOTE_C
12 /* XXX Add documentation after final interface and behavior is decided */
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)
18 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
23 if (! isPRINT_A(source)) {
24 Perl_croak(aTHX_ "%s",
25 "Character following \"\\c\" must be printable ASCII");
27 else if (source == '{') {
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);
34 Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
38 result = toCTRL(source);
39 if (output_warning && isPRINT_A(result)) {
42 if (! isWORDCHAR(result)) {
45 clearer[i++] = result;
48 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
49 "\"\\c%c\" is more clearly written simply as \"%s\"",
58 Perl_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
59 const bool output_warning, const bool strict,
60 const bool silence_non_portable,
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
66 * from; otherwise TRUE. In either case the caller should look at *len [???].
67 * It guarantees that the returned codepoint, *uv, when expressed as
68 * utf8 bytes, would fit within the skipped "\o{...}" bytes.
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.
77 * uv points to a UV that will hold the output value, valid only if the
78 * return from the function is TRUE
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
82 * output_warning says whether to output any warning messages, or suppress
84 * strict is true if this should fail instead of warn if there are
85 * non-octal digits within the braces
86 * silence_non_portable is true if to suppress warnings about the code
87 * point returned being too large to fit on all platforms.
88 * UTF is true iff the string *s is encoded in UTF-8.
92 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
93 | PERL_SCAN_DISALLOW_PREFIX
94 /* XXX Until the message is improved in grok_oct, handle errors
96 | PERL_SCAN_SILENT_ILLDIGIT;
100 assert(*start == '\\');
103 PERL_ARGS_ASSERT_GROK_BSLASH_O;
110 *error_msg = "Missing braces on \\o{}";
116 (*s)++; /* Move past the '{' */
117 while (isOCTAL(**s)) { /* Position beyond the legal digits */
120 *error_msg = "Missing right brace on \\o{";
124 (*s)++; /* Point to expected first digit (could be first byte of utf8
125 sequence if not a digit) */
126 numbers_len = e - *s;
127 if (numbers_len == 0) {
128 (*s)++; /* Move past the } */
129 *error_msg = "Number with no digits";
133 if (silence_non_portable) {
134 flags |= PERL_SCAN_SILENT_NON_PORTABLE;
137 *uv = grok_oct(*s, &numbers_len, &flags, NULL);
138 /* Note that if has non-octal, will ignore everything starting with that up
141 if (numbers_len != (STRLEN) (e - *s)) {
144 *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
145 *error_msg = "Non-octal character";
148 else if (output_warning) {
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}\"",
158 /* Return past the '}' */
161 /* guarantee replacing "\o{...}" with utf8 bytes fits within
163 assert(OFFUNISKIP(*uv) < *s - start);
169 Perl_form_short_octal_warning(pTHX_
170 const char * const s, /* Points to first non-octal */
171 const STRLEN len /* Length of octals string, so
172 (s-len) points to first
175 /* Return a character string consisting of a warning message for when a
176 * string constant in octal is weird, like "\078". */
178 const char * sans_leading_zeros = s - len;
180 PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
182 assert(*s == '8' || *s == '9');
184 /* Remove the leading zeros, retaining one zero so won't be zero length */
185 while (*sans_leading_zeros == '0') sans_leading_zeros++;
186 if (sans_leading_zeros == s) {
187 sans_leading_zeros--;
190 return Perl_form(aTHX_
191 "'%.*s' resolved to '\\o{%.*s}%c'",
192 (int) (len + 2), s - len - 1,
193 (int) (s - sans_leading_zeros), sans_leading_zeros,
198 * ex: set ts=8 sts=4 sw=4 et: