move Test dist from ./cpan to ./dist
[perl.git] / dquote.c
1 /*    dquote.c
2  *
3  * This file contains functions that are related to
4  * parsing double-quotish expressions.
5  *
6 */
7
8 #include "EXTERN.h"
9 #define PERL_IN_DQUOTE_C
10 #include "perl.h"
11
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)
14     U8 source = *current;
15 */
16
17 char
18 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
19 {
20
21     U8 result;
22
23     if (! isPRINT_A(source)) {
24         Perl_croak(aTHX_ "%s",
25                         "Character following \"\\c\" must be printable ASCII");
26     }
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);
32         }
33         else {
34             Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
35         }
36     }
37
38     result = toCTRL(source);
39     if (output_warning && isPRINT_A(result)) {
40         U8 clearer[3];
41         U8 i = 0;
42         if (! isWORDCHAR(result)) {
43             clearer[i++] = '\\';
44         }
45         clearer[i++] = result;
46         clearer[i++] = '\0';
47
48         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
49                         "\"\\c%c\" is more clearly written simply as \"%s\"",
50                         source,
51                         clearer);
52     }
53
54     return result;
55 }
56
57 bool
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,
61                       const bool UTF)
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
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.
69  *  On input:
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
81  *          function succeeds
82  *      output_warning says whether to output any warning messages, or suppress
83  *          them
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.
89  */
90     char* e;
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
98 #ifdef DEBUGGING
99     char *start = *s - 1;
100     assert(*start == '\\');
101 #endif
102
103     PERL_ARGS_ASSERT_GROK_BSLASH_O;
104
105
106     assert(**s == 'o');
107     (*s)++;
108
109     if (**s != '{') {
110         *error_msg = "Missing braces on \\o{}";
111         return FALSE;
112     }
113
114     e = strchr(*s, '}');
115     if (!e) {
116         (*s)++;  /* Move past the '{' */
117         while (isOCTAL(**s)) { /* Position beyond the legal digits */
118             (*s)++;
119         }
120         *error_msg = "Missing right brace on \\o{";
121         return FALSE;
122     }
123
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";
130         return FALSE;
131     }
132
133     if (silence_non_portable) {
134         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
135     }
136
137     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
138     /* Note that if has non-octal, will ignore everything starting with that up
139      * to the '}' */
140
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) {
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);
155         }
156     }
157
158     /* Return past the '}' */
159     *s = e + 1;
160
161     /* guarantee replacing "\o{...}" with utf8 bytes fits within
162      * existing space */
163     assert(UVCHR_SKIP(*uv) < *s - start);
164
165     return TRUE;
166 }
167
168 char*
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
173                                                     octal */
174 ) {
175     /* Return a character string consisting of a warning message for when a
176      * string constant in octal is weird, like "\078".  */
177
178     const char * sans_leading_zeros = s - len;
179
180     PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
181
182     assert(*s == '8' || *s == '9');
183
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--;
188     }
189
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,
194                      *s);
195 }
196
197 /*
198  * ex: set ts=8 sts=4 sw=4 et:
199  */