This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
b5a2cccee6d9db22e1691f436d356a3bb7127711
[perl5.git] / dquote_static.c
1 /*    dquote_static.c
2  *
3  * This file contains static functions that are related to
4  * parsing double-quotish expressions, but are used in more than
5  * one file.
6  *
7  * It is currently #included by regcomp.c and toke.c.
8 */
9
10 #define PERL_IN_DQUOTE_STATIC_C
11 #include "proto.h"
12 #include "embed.h"
13
14 /*
15  - regcurly - a little FSA that accepts {\d+,?\d*}
16     Pulled from regcomp.c.
17  */
18 PERL_STATIC_INLINE I32
19 S_regcurly(pTHX_ register const char *s)
20 {
21     PERL_ARGS_ASSERT_REGCURLY;
22
23     if (*s++ != '{')
24         return FALSE;
25     if (!isDIGIT(*s))
26         return FALSE;
27     while (isDIGIT(*s))
28         s++;
29     if (*s == ',') {
30         s++;
31         while (isDIGIT(*s))
32             s++;
33     }
34     if (*s != '}')
35         return FALSE;
36     return TRUE;
37 }
38
39 /* XXX Add documentation after final interface and behavior is decided */
40 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
41     U8 source = *current;
42
43     May want to add eg, WARN_REGEX
44 */
45
46 STATIC char
47 S_grok_bslash_c(pTHX_ const char source, const bool output_warning)
48 {
49
50     U8 result;
51
52     if (! isASCII(source)) {
53         Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
54     }
55
56     result = toCTRL(source);
57     if (! isCNTRL(result)) {
58         if (source == '{') {
59             Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
60         }
61         else if (output_warning) {
62             U8 clearer[3];
63             U8 i = 0;
64             if (! isALNUM(result)) {
65                 clearer[i++] = '\\';
66             }
67             clearer[i++] = result;
68             clearer[i++] = '\0';
69
70             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
71                             "\"\\c%c\" more clearly written simply as \"%s\"",
72                             source,
73                             clearer);
74         }
75     }
76
77     return result;
78 }
79
80 STATIC bool
81 S_grok_bslash_o(pTHX_ const char *s,
82                          UV *uv,
83                          STRLEN *len,
84                          const char** error_msg,
85                          const bool output_warning)
86 {
87
88 /*  Documentation to be supplied when interface nailed down finally
89  *  This returns FALSE if there is an error which the caller need not recover
90  *  from; , otherwise TRUE.  In either case the caller should look at *len
91  *  On input:
92  *      s   points to a string that begins with 'o', and the previous character
93  *          was a backslash.
94  *      uv  points to a UV that will hold the output value, valid only if the
95  *          return from the function is TRUE
96  *      len on success will point to the next character in the string past the
97  *                     end of this construct.
98  *          on failure, it will point to the failure
99  *      error_msg is a pointer that will be set to an internal buffer giving an
100  *          error message upon failure (the return is FALSE).  Untouched if
101  *          function succeeds
102  *      output_warning says whether to output any warning messages, or suppress
103  *          them
104  */
105     const char* e;
106     STRLEN numbers_len;
107     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
108                 | PERL_SCAN_DISALLOW_PREFIX
109                 /* XXX Until the message is improved in grok_oct, handle errors
110                  * ourselves */
111                 | PERL_SCAN_SILENT_ILLDIGIT;
112
113     PERL_ARGS_ASSERT_GROK_BSLASH_O;
114
115
116     assert(*s == 'o');
117     s++;
118
119     if (*s != '{') {
120         *len = 1;       /* Move past the o */
121         *error_msg = "Missing braces on \\o{}";
122         return FALSE;
123     }
124
125     e = strchr(s, '}');
126     if (!e) {
127         *len = 2;       /* Move past the o{ */
128         *error_msg = "Missing right brace on \\o{";
129         return FALSE;
130     }
131
132     /* Return past the '}' no matter what is inside the braces */
133     *len = e - s + 2;   /* 2 = 1 for the o + 1 for the '}' */
134
135     s++;    /* Point to first digit */
136
137     numbers_len = e - s;
138     if (numbers_len == 0) {
139         *error_msg = "Number with no digits";
140         return FALSE;
141     }
142
143     *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
144     /* Note that if has non-octal, will ignore everything starting with that up
145      * to the '}' */
146
147     if (output_warning && numbers_len != (STRLEN) (e - s)) {
148         Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
149         /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
150                        "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
151                        *(s + numbers_len),
152                        (int) numbers_len,
153                        s);
154     }
155
156     return TRUE;
157 }
158
159 /*
160  * Local variables:
161  * c-indentation-style: bsd
162  * c-basic-offset: 4
163  * indent-tabs-mode: t
164  * End:
165  *
166  * ex: set ts=8 sts=4 sw=4 noet:
167  */