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(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
  34     return *s == '}';
  35 }
  36
  37 /* XXX Add documentation after final interface and behavior is decided */
  38 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
  39     U8 source = *current;
  40 */
  41
  42 STATIC char
  43 S_grok_bslash_c(pTHX_ const char source, const bool output_warning)
  44 {
  45
  46     U8 result;
  47
  48     if (! isPRINT_A(source)) {
  49         Perl_croak(aTHX_ "%s",
  50                         "Character following \"\\c\" must be printable ASCII");
  51     }
  52     else if (source == '{') {
  53         const char control = toCTRL('{');
  54         if (isPRINT_A(control)) {
  55             /* diag_listed_as: Use "%s" instead of "%s" */
  56             Perl_croak(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
  57         }
  58         else {
  59             Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
  60         }
  61     }
  62
  63     result = toCTRL(source);
  64     if (output_warning && isPRINT_A(result)) {
  65         U8 clearer[3];
  66         U8 i = 0;
  67         if (! isWORDCHAR(result)) {
  68             clearer[i++] = '\\';
  69         }
  70         clearer[i++] = result;
  71         clearer[i++] = '\0';
  72
  73         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
  74                         "\"\\c%c\" is more clearly written simply as \"%s\"",
  75                         source,
  76                         clearer);
  77     }
  78
  79     return result;
  80 }
  81
  82 STATIC bool
  83 S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
  84                       const bool output_warning, const bool strict,
  85                       const bool silence_non_portable,
  86                       const bool UTF)
  87 {
  88
  89 /*  Documentation to be supplied when interface nailed down finally
  90  *  This returns FALSE if there is an error which the caller need not recover
  91  *  from; , otherwise TRUE.  In either case the caller should look at *len
  92  *  On input:
  93  *      s   is the address of a pointer to a NULL terminated string that begins
  94  *          with 'o', and the previous character was a backslash.  At exit, *s
  95  *          will be advanced to the byte just after those absorbed by this
  96  *          function.  Hence the caller can continue parsing from there.  In
  97  *          the case of an error, this routine has generally positioned *s to
  98  *          point just to the right of the first bad spot, so that a message
  99  *          that has a "<--" to mark the spot will be correctly positioned.
 100  *      uv  points to a UV that will hold the output value, valid only if the
 101  *          return from the function is TRUE
 102  *      error_msg is a pointer that will be set to an internal buffer giving an
 103  *          error message upon failure (the return is FALSE).  Untouched if
 104  *          function succeeds
 105  *      output_warning says whether to output any warning messages, or suppress
 106  *          them
 107  *      strict is true if this should fail instead of warn if there are
 108  *          non-octal digits within the braces
 109  *      silence_non_portable is true if to suppress warnings about the code
 110  *          point returned being too large to fit on all platforms.
 111  *      UTF is true iff the string *s is encoded in UTF-8.
 112  */
 113     char* e;
 114     STRLEN numbers_len;
 115     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
 116                 | PERL_SCAN_DISALLOW_PREFIX
 117                 /* XXX Until the message is improved in grok_oct, handle errors
 118                  * ourselves */
 119                 | PERL_SCAN_SILENT_ILLDIGIT;
 120
 121     PERL_ARGS_ASSERT_GROK_BSLASH_O;
 122
 123
 124     assert(**s == 'o');
 125     (*s)++;
 126
 127     if (**s != '{') {
 128         *error_msg = "Missing braces on \\o{}";
 129         return FALSE;
 130     }
 131
 132     e = strchr(*s, '}');
 133     if (!e) {
 134         (*s)++;  /* Move past the '{' */
 135         while (isOCTAL(**s)) { /* Position beyond the legal digits */
 136             (*s)++;
 137         }
 138         *error_msg = "Missing right brace on \\o{";
 139         return FALSE;
 140     }
 141
 142     (*s)++;    /* Point to expected first digit (could be first byte of utf8
 143                   sequence if not a digit) */
 144     numbers_len = e - *s;
 145     if (numbers_len == 0) {
 146         (*s)++;    /* Move past the } */
 147         *error_msg = "Number with no digits";
 148         return FALSE;
 149     }
 150
 151     if (silence_non_portable) {
 152         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
 153     }
 154
 155     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
 156     /* Note that if has non-octal, will ignore everything starting with that up
 157      * to the '}' */
 158
 159     if (numbers_len != (STRLEN) (e - *s)) {
 160         if (strict) {
 161             *s += numbers_len;
 162             *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
 163             *error_msg = "Non-octal character";
 164             return FALSE;
 165         }
 166         else if (output_warning) {
 167             Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
 168             /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
 169                         "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
 170                         *(*s + numbers_len),
 171                         (int) numbers_len,
 172                         *s);
 173         }
 174     }
 175
 176     /* Return past the '}' */
 177     *s = e + 1;
 178
 179     return TRUE;
 180 }
 181
 182 PERL_STATIC_INLINE bool
 183 S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
 184                       const bool output_warning, const bool strict,
 185                       const bool silence_non_portable,
 186                       const bool UTF)
 187 {
 188
 189 /*  Documentation to be supplied when interface nailed down finally
 190  *  This returns FALSE if there is an error which the caller need not recover
 191  *  from; , otherwise TRUE.
 192  *  On input:
 193  *      s   is the address of a pointer to a NULL terminated string that begins
 194  *          with 'x', and the previous character was a backslash.  At exit, *s
 195  *          will be advanced to the byte just after those absorbed by this
 196  *          function.  Hence the caller can continue parsing from there.  In
 197  *          the case of an error, this routine has generally positioned *s to
 198  *          point just to the right of the first bad spot, so that a message
 199  *          that has a "<--" to mark the spot will be correctly positioned.
 200  *      uv  points to a UV that will hold the output value, valid only if the
 201  *          return from the function is TRUE
 202  *      error_msg is a pointer that will be set to an internal buffer giving an
 203  *          error message upon failure (the return is FALSE).  Untouched if
 204  *          function succeeds
 205  *      output_warning says whether to output any warning messages, or suppress
 206  *          them
 207  *      strict is true if anything out of the ordinary should cause this to
 208  *          fail instead of warn or be silent.  For example, it requires
 209  *          exactly 2 digits following the \x (when there are no braces).
 210  *          3 digits could be a mistake, so is forbidden in this mode.
 211  *      silence_non_portable is true if to suppress warnings about the code
 212  *          point returned being too large to fit on all platforms.
 213  *      UTF is true iff the string *s is encoded in UTF-8.
 214  */
 215     char* e;
 216     STRLEN numbers_len;
 217     I32 flags = PERL_SCAN_DISALLOW_PREFIX;
 218
 219     PERL_ARGS_ASSERT_GROK_BSLASH_X;
 220
 221     assert(**s == 'x');
 222     (*s)++;
 223
 224     if (strict || ! output_warning) {
 225         flags |= PERL_SCAN_SILENT_ILLDIGIT;
 226     }
 227
 228     if (**s != '{') {
 229         STRLEN len = (strict) ? 3 : 2;
 230
 231         *uv = grok_hex(*s, &len, &flags, NULL);
 232         *s += len;
 233         if (strict && len != 2) {
 234             if (len < 2) {
 235                 *s += (UTF) ? UTF8SKIP(*s) : 1;
 236                 *error_msg = "Non-hex character";
 237             }
 238             else {
 239                 *error_msg = "Use \\x{...} for more than two hex characters";
 240             }
 241             return FALSE;
 242         }
 243         return TRUE;
 244     }
 245
 246     e = strchr(*s, '}');
 247     if (!e) {
 248         (*s)++;  /* Move past the '{' */
 249         while (isXDIGIT(**s)) { /* Position beyond the legal digits */
 250             (*s)++;
 251         }
 252         /* XXX The corresponding message above for \o is just '\\o{'; other
 253          * messages for other constructs include the '}', so are inconsistent.
 254          */
 255         *error_msg = "Missing right brace on \\x{}";
 256         return FALSE;
 257     }
 258
 259     (*s)++;    /* Point to expected first digit (could be first byte of utf8
 260                   sequence if not a digit) */
 261     numbers_len = e - *s;
 262     if (numbers_len == 0) {
 263         if (strict) {
 264             (*s)++;    /* Move past the } */
 265             *error_msg = "Number with no digits";
 266             return FALSE;
 267         }
 268         *s = e + 1;
 269         *uv = 0;
 270         return TRUE;
 271     }
 272
 273     flags |= PERL_SCAN_ALLOW_UNDERSCORES;
 274     if (silence_non_portable) {
 275         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
 276     }
 277
 278     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
 279     /* Note that if has non-hex, will ignore everything starting with that up
 280      * to the '}' */
 281
 282     if (strict && numbers_len != (STRLEN) (e - *s)) {
 283         *s += numbers_len;
 284         *s += (UTF) ? UTF8SKIP(*s) : 1;
 285         *error_msg = "Non-hex character";
 286         return FALSE;
 287     }
 288
 289     /* Return past the '}' */
 290     *s = e + 1;
 291
 292     return TRUE;
 293 }
 294
 295 STATIC char*
 296 S_form_short_octal_warning(pTHX_
 297                            const char * const s, /* Points to first non-octal */
 298                            const STRLEN len      /* Length of octals string, so
 299                                                     (s-len) points to first
 300                                                     octal */
 301 ) {
 302     /* Return a character string consisting of a warning message for when a
 303      * string constant in octal is weird, like "\078".  */
 304
 305     const char * sans_leading_zeros = s - len;
 306
 307     PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
 308
 309     assert(*s == '8' || *s == '9');
 310
 311     /* Remove the leading zeros, retaining one zero so won't be zero length */
 312     while (*sans_leading_zeros == '0') sans_leading_zeros++;
 313     if (sans_leading_zeros == s) {
 314         sans_leading_zeros--;
 315     }
 316
 317     return Perl_form(aTHX_
 318                      "'%.*s' resolved to '\\o{%.*s}%c'",
 319                      (int) (len + 2), s - len - 1,
 320                      (int) (s - sans_leading_zeros), sans_leading_zeros,
 321                      *s);
 322 }
 323
 324 /*
 325  * Local variables:
 326  * c-indentation-style: bsd
 327  * c-basic-offset: 4
 328  * indent-tabs-mode: nil
 329  * End:
 330  *
 331  * ex: set ts=8 sts=4 sw=4 et:
 332  */