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 "embed.h"
  12
  13 /*
  14  - regcurly - a little FSA that accepts {\d+,?\d*}
  15     Pulled from regcomp.c.
  16  */
  17 PERL_STATIC_INLINE I32
  18 S_regcurly(pTHX_ const char *s)
  19 {
  20     PERL_ARGS_ASSERT_REGCURLY;
  21
  22     if (*s++ != '{')
  23         return FALSE;
  24     if (!isDIGIT(*s))
  25         return FALSE;
  26     while (isDIGIT(*s))
  27         s++;
  28     if (*s == ',') {
  29         s++;
  30         while (isDIGIT(*s))
  31             s++;
  32     }
  33     if (*s != '}')
  34         return FALSE;
  35     return TRUE;
  36 }
  37
  38 /* XXX Add documentation after final interface and behavior is decided */
  39 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
  40     U8 source = *current;
  41 */
  42
  43 STATIC char
  44 S_grok_bslash_c(pTHX_ const char source, const bool utf8, const bool output_warning)
  45 {
  46
  47     U8 result;
  48
  49     if (utf8) {
  50         /* Trying to deprecate non-ASCII usages.  This construct has never
  51          * worked for a utf8 variant.  So, even though are accepting non-ASCII
  52          * Latin1 in 5.14, no need to make them work under utf8 */
  53         if (! isASCII(source)) {
  54             Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
  55         }
  56     }
  57
  58     result = toCTRL(source);
  59     if (! isASCII(source)) {
  60             Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
  61                             "Character following \"\\c\" must be ASCII");
  62     }
  63     else if (! isCNTRL(result) && output_warning) {
  64         if (source == '{') {
  65             Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
  66                             "\"\\c{\" is deprecated and is more clearly written as \";\"");
  67         }
  68         else {
  69             U8 clearer[3];
  70             U8 i = 0;
  71             if (! isALNUM(result)) {
  72                 clearer[i++] = '\\';
  73             }
  74             clearer[i++] = result;
  75             clearer[i++] = '\0';
  76
  77             Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
  78                             "\"\\c%c\" is more clearly written simply as \"%s\"",
  79                             source,
  80                             clearer);
  81         }
  82     }
  83
  84     return result;
  85 }
  86
  87 STATIC bool
  88 S_grok_bslash_o(pTHX_ const char *s,
  89                          UV *uv,
  90                          STRLEN *len,
  91                          const char** error_msg,
  92                          const bool output_warning)
  93 {
  94
  95 /*  Documentation to be supplied when interface nailed down finally
  96  *  This returns FALSE if there is an error which the caller need not recover
  97  *  from; , otherwise TRUE.  In either case the caller should look at *len
  98  *  On input:
  99  *      s   points to a string that begins with 'o', and the previous character
 100  *          was a backslash.
 101  *      uv  points to a UV that will hold the output value, valid only if the
 102  *          return from the function is TRUE
 103  *      len on success will point to the next character in the string past the
 104  *                     end of this construct.
 105  *          on failure, it will point to the failure
 106  *      error_msg is a pointer that will be set to an internal buffer giving an
 107  *          error message upon failure (the return is FALSE).  Untouched if
 108  *          function succeeds
 109  *      output_warning says whether to output any warning messages, or suppress
 110  *          them
 111  */
 112     const char* e;
 113     STRLEN numbers_len;
 114     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
 115                 | PERL_SCAN_DISALLOW_PREFIX
 116                 /* XXX Until the message is improved in grok_oct, handle errors
 117                  * ourselves */
 118                 | PERL_SCAN_SILENT_ILLDIGIT;
 119
 120     PERL_ARGS_ASSERT_GROK_BSLASH_O;
 121
 122
 123     assert(*s == 'o');
 124     s++;
 125
 126     if (*s != '{') {
 127         *len = 1;       /* Move past the o */
 128         *error_msg = "Missing braces on \\o{}";
 129         return FALSE;
 130     }
 131
 132     e = strchr(s, '}');
 133     if (!e) {
 134         *len = 2;       /* Move past the o{ */
 135         *error_msg = "Missing right brace on \\o{";
 136         return FALSE;
 137     }
 138
 139     /* Return past the '}' no matter what is inside the braces */
 140     *len = e - s + 2;   /* 2 = 1 for the 'o' + 1 for the '}' */
 141
 142     s++;    /* Point to first digit */
 143
 144     numbers_len = e - s;
 145     if (numbers_len == 0) {
 146         *error_msg = "Number with no digits";
 147         return FALSE;
 148     }
 149
 150     *uv = grok_oct(s, &numbers_len, &flags, NULL);
 151     /* Note that if has non-octal, will ignore everything starting with that up
 152      * to the '}' */
 153
 154     if (output_warning && numbers_len != (STRLEN) (e - s)) {
 155         Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
 156         /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
 157                        "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
 158                        *(s + numbers_len),
 159                        (int) numbers_len,
 160                        s);
 161     }
 162
 163     return TRUE;
 164 }
 165
 166 PERL_STATIC_INLINE bool
 167 S_grok_bslash_x(pTHX_ const char *s,
 168                          UV *uv,
 169                          STRLEN *len,
 170                          const char** error_msg,
 171                          const bool output_warning)
 172 {
 173
 174 /*  Documentation to be supplied when interface nailed down finally
 175  *  This returns FALSE if there is an error which the caller need not recover
 176  *  from; , otherwise TRUE.  In either case the caller should look at *len
 177  *  On input:
 178  *      s   points to a string that begins with 'x', and the previous character
 179  *          was a backslash.
 180  *      uv  points to a UV that will hold the output value, valid only if the
 181  *          return from the function is TRUE
 182  *      len on success will point to the next character in the string past the
 183  *                     end of this construct.
 184  *          on failure, it will point to the failure
 185  *      error_msg is a pointer that will be set to an internal buffer giving an
 186  *          error message upon failure (the return is FALSE).  Untouched if
 187  *          function succeeds
 188  *      output_warning says whether to output any warning messages, or suppress
 189  *          them
 190  */
 191     const char* e;
 192     STRLEN numbers_len;
 193     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
 194                 | PERL_SCAN_DISALLOW_PREFIX;
 195
 196     PERL_ARGS_ASSERT_GROK_BSLASH_X;
 197
 198     PERL_UNUSED_ARG(output_warning);
 199
 200     assert(*s == 'x');
 201     s++;
 202
 203     if (*s != '{') {
 204         I32 flags = PERL_SCAN_DISALLOW_PREFIX;
 205         *len = 2;
 206         *uv = grok_hex(s, len, &flags, NULL);
 207         (*len)++;
 208         return TRUE;
 209     }
 210
 211     e = strchr(s, '}');
 212     if (!e) {
 213         *len = 2;       /* Move past the 'x{' */
 214         /* XXX The corresponding message above for \o is just '\\o{'; other
 215          * messages for other constructs include the '}', so are inconsistent.
 216          */
 217         *error_msg = "Missing right brace on \\x{}";
 218         return FALSE;
 219     }
 220
 221     /* Return past the '}' no matter what is inside the braces */
 222     *len = e - s + 2;   /* 2 = 1 for the 'x' + 1 for the '}' */
 223
 224     s++;    /* Point to first digit */
 225
 226     numbers_len = e - s;
 227     *uv = grok_hex(s, &numbers_len, &flags, NULL);
 228     /* Note that if has non-hex, will ignore everything starting with that up
 229      * to the '}' */
 230
 231     return TRUE;
 232 }
 233
 234 /*
 235  * Local variables:
 236  * c-indentation-style: bsd
 237  * c-basic-offset: 4
 238  * indent-tabs-mode: nil
 239  * End:
 240  *
 241  * ex: set ts=8 sts=4 sw=4 et:
 242  */