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