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