dquote.c

   1 /*    dquote.c
   2  *
   3  * This file contains functions that are related to
   4  * parsing double-quotish expressions.
   5  *
   6 */
   7
   8 #include "EXTERN.h"
   9 #define PERL_IN_DQUOTE_C
  10 #include "perl.h"
  11 #include "dquote_inline.h"
  12
  13 /* XXX Add documentation after final interface and behavior is decided */
  14
  15 bool
  16 Perl_grok_bslash_c(pTHX_ const char   source,
  17                          U8 *         result,
  18                          const char** message,
  19                          U32 *        packed_warn)
  20 {
  21     PERL_ARGS_ASSERT_GROK_BSLASH_C;
  22
  23     /* This returns TRUE if the \c? sequence is valid; FALSE otherwise.  If it
  24      * is valid, the sequence evaluates to a single character, which will be
  25      * stored into *result.
  26      *
  27      * source   is the character immediately after a '\c' sequence.
  28      * result   points to a char variable into which this function will store
  29      *          what the sequence evaluates to, if valid; unchanged otherwise.
  30      * message  A pointer to any warning or error message will be stored into
  31      *          this pointer; NULL if none.
  32      * packed_warn if NULL on input asks that this routine display any warning
  33      *          messages.  Otherwise, if the function found a warning, the
  34      *          packed warning categories will be stored into *packed_warn (and
  35      *          the corresponding message text into *message); 0 if none.
  36      */
  37
  38     *message = NULL;
  39     if (packed_warn) *packed_warn = 0;
  40
  41     if (! isPRINT_A(source)) {
  42         *message = "Character following \"\\c\" must be printable ASCII";
  43         return FALSE;
  44     }
  45
  46     if (source == '{') {
  47         const char control = toCTRL('{');
  48         if (isPRINT_A(control)) {
  49             /* diag_listed_as: Use "%s" instead of "%s" */
  50             *message = Perl_form(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
  51         }
  52         else {
  53             *message = "Sequence \"\\c{\" invalid";
  54         }
  55         return FALSE;
  56     }
  57
  58     *result = toCTRL(source);
  59     if (isPRINT_A(*result) && ckWARN(WARN_SYNTAX)) {
  60         U8 clearer[3];
  61         U8 i = 0;
  62         char format[] = "\"\\c%c\" is more clearly written simply as \"%s\"";
  63
  64         if (! isWORDCHAR(*result)) {
  65             clearer[i++] = '\\';
  66         }
  67         clearer[i++] = *result;
  68         clearer[i++] = '\0';
  69
  70         if (packed_warn) {
  71             *message = Perl_form(aTHX_ format, source, clearer);
  72             *packed_warn = packWARN(WARN_SYNTAX);
  73         }
  74         else {
  75             Perl_warner(aTHX_ packWARN(WARN_SYNTAX), format, source, clearer);
  76         }
  77     }
  78
  79     return TRUE;
  80 }
  81
  82 const char *
  83 Perl_form_alien_digit_msg(pTHX_
  84         const U8 which,           /* 8 or 16 */
  85         const STRLEN valids_len,  /* length of input before first bad char */
  86         const char * const first_bad, /* Ptr to that bad char */
  87         const char * const send,      /* End of input string */
  88         const bool UTF,               /* Is it in UTF-8? */
  89         const bool braced)            /* Is it enclosed in {} */
  90 {
  91     /* Generate a mortal SV containing an appropriate warning message about
  92      * alien characters found in an octal or hex constant given by the inputs,
  93      * and return a pointer to that SV's string.  The message looks like:
  94      *
  95      * Non-hex character '?' terminates \x early.  Resolved as "\x{...}"
  96      *
  97      */
  98
  99     /* The usual worst case scenario: 2 chars to display per byte, plus \x{}
 100      * (leading zeros could take up more space, and the scalar will
 101      * automatically grow if necessary).  Space for NUL is added by the newSV()
 102      * function */
 103     SV * display_char = newSV(2 * UTF8_MAXBYTES + 4);
 104     SV * message_sv = sv_newmortal();
 105     char symbol;
 106
 107     PERL_ARGS_ASSERT_FORM_ALIEN_DIGIT_MSG;
 108     assert(which == 8 || which == 16);
 109
 110     /* Calculate the display form of the character */
 111     if (    UVCHR_IS_INVARIANT(*first_bad)
 112         || (UTF && isUTF8_CHAR((U8 *) first_bad, (U8 *) send)))
 113     {
 114         pv_uni_display(display_char, (U8 *) first_bad, UTF8SKIP(first_bad),
 115                                                     (STRLEN) -1, UNI_DISPLAY_QQ);
 116     }
 117     else {  /* Is not UTF-8, or is illegal UTF-8.  Show just the one byte */
 118
 119         /* It also isn't a UTF-8 invariant character, so no display shortcuts
 120          * are available.  Use \\x{...} */
 121         Perl_sv_setpvf(aTHX_ display_char, "\\x{%02x}", *first_bad);
 122     }
 123
 124     /* Ready to start building the message */
 125     sv_setpvs(message_sv, "Non-");
 126     if (which == 8) {
 127         sv_catpvs(message_sv, "octal");
 128         if (braced) {
 129             symbol = 'o';
 130         }
 131         else {
 132             symbol = '0';   /* \008, for example */
 133         }
 134     }
 135     else {
 136         sv_catpvs(message_sv, "hex");
 137         symbol = 'x';
 138     }
 139     sv_catpvs(message_sv, " character ");
 140
 141     if (isPRINT(*first_bad)) {
 142         sv_catpvs(message_sv, "'");
 143     }
 144     sv_catsv(message_sv, display_char);
 145     if (isPRINT(*first_bad)) {
 146         sv_catpvs(message_sv, "'");
 147     }
 148     Perl_sv_catpvf(aTHX_ message_sv, " terminates \\%c early.  Resolved as "
 149                                      "\"\\%c", symbol, symbol);
 150     if (braced) {
 151         sv_catpvs(message_sv, "{");
 152     }
 153
 154     /* Octal constants have an extra leading 0, but \0 already includes that */
 155     if (symbol == 'o' && valids_len < 3) {
 156         sv_catpvs(message_sv, "0");
 157     }
 158     if (valids_len == 0) {  /* No legal digits at all */
 159         sv_catpvs(message_sv, "00");
 160     }
 161     else if (valids_len == 1) { /* Just one is legal */
 162         sv_catpvs(message_sv, "0");
 163     }
 164     sv_catpvn(message_sv, first_bad - valids_len, valids_len);
 165
 166     if (braced) {
 167         sv_catpvs(message_sv, "}");
 168     }
 169     else {
 170         sv_catsv(message_sv, display_char);
 171     }
 172     sv_catpvs(message_sv, "\"");
 173
 174     SvREFCNT_dec_NN(display_char);
 175
 176     return SvPVX_const(message_sv);
 177 }
 178
 179 const char *
 180 Perl_form_cp_too_large_msg(pTHX_
 181         const U8 which,        /* 8 or 16 */
 182         const char * string,   /* NULL, or the text that is supposed to
 183                                   represent a code point */
 184         const Size_t len,      /* length of 'string' if not NULL; else 0 */
 185         const UV cp)           /* 0 if 'string' not NULL; else the too-large
 186                                   code point */
 187 {
 188     /* Generate a mortal SV containing an appropriate warning message about
 189      * code points that are too large for this system, given by the inputs,
 190      * and return a pointer to that SV's string.  Either the text of the string
 191      * to be converted to a code point is input, or a code point itself.  The
 192      * former is needed to accurately represent something that overflows.
 193      *
 194      * The message looks like:
 195      *
 196      * Use of code point %s is not allowed; the permissible max is %s
 197      *
 198      */
 199
 200     SV * message_sv = sv_newmortal();
 201     const char * format;
 202     const char * prefix;
 203
 204     PERL_ARGS_ASSERT_FORM_CP_TOO_LARGE_MSG;
 205     assert(which == 8 || which == 16);
 206
 207     /* One but not both must be non-zero */
 208     assert((string != NULL) ^ (cp != 0));
 209     assert((string == NULL) || len);
 210
 211     if (which == 8) {
 212         format = "%" UVof;
 213         prefix = "0";
 214     }
 215     else {
 216         format = "%" UVXf;
 217         prefix = "0x";
 218     }
 219
 220     Perl_sv_setpvf(aTHX_ message_sv, "Use of code point %s", prefix);
 221     if (string) {
 222         Perl_sv_catpvf(aTHX_ message_sv, "%.*s", (int) len, string);
 223     }
 224     else {
 225         Perl_sv_catpvf(aTHX_ message_sv, format, cp);
 226     }
 227     Perl_sv_catpvf(aTHX_ message_sv, " is not allowed; the permissible max is %s", prefix);
 228     Perl_sv_catpvf(aTHX_ message_sv, format, MAX_LEGAL_CP);
 229
 230     return SvPVX_const(message_sv);
 231 }
 232
 233 bool
 234 Perl_grok_bslash_o(pTHX_ char **s, const char * const send, UV *uv,
 235                       const char** message,
 236                       U32 *      packed_warn,
 237                       const bool strict,
 238                       const bool allow_UV_MAX,
 239                       const bool UTF)
 240 {
 241
 242 /*  Documentation to be supplied when interface nailed down finally
 243  *  This returns FALSE if there is an error the caller should probably die
 244  *  from; otherwise TRUE.
 245  *      s   is the address of a pointer to a string.  **s is 'o', and the
 246  *          previous character was a backslash.  At exit, *s will be advanced
 247  *          to the byte just after those absorbed by this function.  Hence the
 248  *          caller can continue parsing from there.  In the case of an error
 249  *          when this function returns FALSE, continuing to parse is not an
 250  *          option, this routine has generally positioned *s to point just to
 251  *          the right of the first bad spot, so that a message that has a "<--"
 252  *          to mark the spot will be correctly positioned.
 253  *      send - 1  gives a limit in *s that this function is not permitted to
 254  *          look beyond.  That is, the function may look at bytes only in the
 255  *          range *s..send-1
 256  *      uv  points to a UV that will hold the output value, valid only if the
 257  *          return from the function is TRUE; may be changed from the input
 258  *          value even when FALSE is returned.
 259  *      message  A pointer to any warning or error message will be stored into
 260  *          this pointer; NULL if none.
 261  *      packed_warn if NULL on input asks that this routine display any warning
 262  *          messages.  Otherwise, if the function found a warning, the packed
 263  *          warning categories will be stored into *packed_warn (and the
 264  *          corresponding message text into *message); 0 if none.
 265  *      strict is true if this should fail instead of warn if there are
 266  *          non-octal digits within the braces
 267  *      allow_UV_MAX is true if this shouldn't fail if the input code point is
 268  *          UV_MAX, which is normally illegal, reserved for internal use.
 269  *      UTF is true iff the string *s is encoded in UTF-8.
 270  */
 271     char* e;
 272     STRLEN numbers_len;
 273     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
 274               | PERL_SCAN_DISALLOW_PREFIX
 275               | PERL_SCAN_SILENT_NON_PORTABLE
 276               | PERL_SCAN_SILENT_ILLDIGIT
 277               | PERL_SCAN_SILENT_OVERFLOW;
 278
 279     PERL_ARGS_ASSERT_GROK_BSLASH_O;
 280
 281     assert(*(*s - 1) == '\\');
 282     assert(* *s       == 'o');
 283
 284     *message = NULL;
 285     if (packed_warn) *packed_warn = 0;
 286
 287     (*s)++;
 288
 289     if (send <= *s || **s != '{') {
 290         *message = "Missing braces on \\o{}";
 291         return FALSE;
 292     }
 293
 294     e = (char *) memchr(*s, '}', send - *s);
 295     if (!e) {
 296         (*s)++;  /* Move past the '{' */
 297         while (isOCTAL(**s)) { /* Position beyond the legal digits */
 298             (*s)++;
 299         }
 300         *message = "Missing right brace on \\o{}";
 301         return FALSE;
 302     }
 303
 304     (*s)++;    /* Point to expected first digit (could be first byte of utf8
 305                   sequence if not a digit) */
 306     numbers_len = e - *s;
 307     if (numbers_len == 0) {
 308         (*s)++;    /* Move past the '}' */
 309         *message = "Empty \\o{}";
 310         return FALSE;
 311     }
 312
 313     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
 314     if (UNLIKELY(   (flags & PERL_SCAN_GREATER_THAN_UV_MAX)
 315                  || (! allow_UV_MAX && *uv == UV_MAX)))
 316     {
 317         *message = form_cp_too_large_msg(8, *s, numbers_len, 0);
 318         *s = e + 1;
 319         return FALSE;
 320     }
 321
 322     /* Note that if has non-octal, will ignore everything starting with that up
 323      * to the '}' */
 324     if (numbers_len != (STRLEN) (e - *s)) {
 325         *s += numbers_len;
 326         if (strict) {
 327             *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1;
 328             *message = "Non-octal character";
 329             return FALSE;
 330         }
 331
 332         if (ckWARN(WARN_DIGIT)) {
 333             const char * failure = form_alien_digit_msg(8, numbers_len, *s, send,
 334                                                                       UTF, TRUE);
 335             if (packed_warn) {
 336                 *message = failure;
 337                 *packed_warn = packWARN(WARN_DIGIT);
 338             }
 339             else {
 340                 Perl_warner(aTHX_ packWARN(WARN_DIGIT), "%s", failure);
 341             }
 342         }
 343     }
 344
 345     /* Return past the '}' */
 346     *s = e + 1;
 347
 348     return TRUE;
 349 }
 350
 351 bool
 352 Perl_grok_bslash_x(pTHX_ char ** s, const char * const send, UV *uv,
 353                       const char** message,
 354                       U32 *      packed_warn,
 355                       const bool strict,
 356                       const bool allow_UV_MAX,
 357                       const bool UTF)
 358 {
 359
 360 /*  Documentation to be supplied when interface nailed down finally
 361  *  This returns FALSE if there is an error the caller should probably die
 362  *  from; otherwise TRUE.
 363  *  It guarantees that the returned codepoint, *uv, when expressed as
 364  *  utf8 bytes, would fit within the skipped "\x{...}" bytes.
 365  *
 366  *  On input:
 367  *      s   is the address of a pointer to a string.  **s is 'x', and the
 368  *          previous character was a backslash.  At exit, *s will be advanced
 369  *          to the byte just after those absorbed by this function.  Hence the
 370  *          caller can continue parsing from there.  In the case of an error,
 371  *          this routine has generally positioned *s to point just to the right
 372  *          of the first bad spot, so that a message that has a "<--" to mark
 373  *          the spot will be correctly positioned.
 374  *      send - 1  gives a limit in *s that this function is not permitted to
 375  *          look beyond.  That is, the function may look at bytes only in the
 376  *          range *s..send-1
 377  *      uv  points to a UV that will hold the output value, valid only if the
 378  *          return from the function is TRUE; may be changed from the input
 379  *          value even when FALSE is returned.
 380  *      message  A pointer to any warning or error message will be stored into
 381  *          this pointer; NULL if none.
 382  *      packed_warn if NULL on input asks that this routine display any warning
 383  *          messages.  Otherwise, if the function found a warning, the packed
 384  *          warning categories will be stored into *packed_warn (and the
 385  *          corresponding message text into *message); 0 if none.
 386  *      strict is true if anything out of the ordinary should cause this to
 387  *          fail instead of warn or be silent.  For example, it requires
 388  *          exactly 2 digits following the \x (when there are no braces).
 389  *          3 digits could be a mistake, so is forbidden in this mode.
 390  *      allow_UV_MAX is true if this shouldn't fail if the input code point is
 391  *          UV_MAX, which is normally illegal, reserved for internal use.
 392  *      UTF is true iff the string *s is encoded in UTF-8.
 393  */
 394     char* e;
 395     STRLEN numbers_len;
 396     I32 flags = PERL_SCAN_DISALLOW_PREFIX
 397               | PERL_SCAN_SILENT_ILLDIGIT
 398               | PERL_SCAN_NOTIFY_ILLDIGIT
 399               | PERL_SCAN_SILENT_NON_PORTABLE
 400               | PERL_SCAN_SILENT_OVERFLOW;
 401
 402     PERL_ARGS_ASSERT_GROK_BSLASH_X;
 403
 404     assert(*(*s - 1) == '\\');
 405     assert(* *s      == 'x');
 406
 407     *message = NULL;
 408     if (packed_warn) *packed_warn = 0;
 409
 410     (*s)++;
 411
 412     if (send <= *s) {
 413         if (strict) {
 414             *message = "Empty \\x";
 415             return FALSE;
 416         }
 417
 418         /* Sadly, to preserve backcompat, an empty \x at the end of string is
 419          * interpreted as a NUL */
 420         *uv = 0;
 421         return TRUE;
 422     }
 423
 424     if (**s != '{') {
 425         numbers_len = (strict) ? 3 : 2;
 426
 427         *uv = grok_hex(*s, &numbers_len, &flags, NULL);
 428         *s += numbers_len;
 429
 430         if (numbers_len != 2 && (strict || (flags & PERL_SCAN_NOTIFY_ILLDIGIT))) {
 431             if (numbers_len == 3) { /* numbers_len 3 only happens with strict */
 432                 *message = "Use \\x{...} for more than two hex characters";
 433                 return FALSE;
 434             }
 435             else if (strict) {
 436                     *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1;
 437                     *message = "Non-hex character";
 438                     return FALSE;
 439             }
 440             else if (ckWARN(WARN_DIGIT)) {
 441                 const char * failure = form_alien_digit_msg(16, numbers_len, *s,
 442                                                               send, UTF, FALSE);
 443
 444                 if (! packed_warn) {
 445                     Perl_warner(aTHX_ packWARN(WARN_DIGIT), "%s", failure);
 446                 }
 447                 else {
 448                     *message = failure;
 449                     *packed_warn = packWARN(WARN_DIGIT);
 450                 }
 451             }
 452         }
 453         return TRUE;
 454     }
 455
 456     e = (char *) memchr(*s, '}', send - *s);
 457     if (!e) {
 458         (*s)++;  /* Move past the '{' */
 459         while (*s < send && isXDIGIT(**s)) { /* Position beyond legal digits */
 460             (*s)++;
 461         }
 462         *message = "Missing right brace on \\x{}";
 463         return FALSE;
 464     }
 465
 466     (*s)++;    /* Point to expected first digit (could be first byte of utf8
 467                   sequence if not a digit) */
 468     numbers_len = e - *s;
 469     if (numbers_len == 0) {
 470         if (strict) {
 471             (*s)++;    /* Move past the } */
 472             *message = "Empty \\x{}";
 473             return FALSE;
 474         }
 475         *s = e + 1;
 476         *uv = 0;
 477         return TRUE;
 478     }
 479
 480     flags |= PERL_SCAN_ALLOW_UNDERSCORES;
 481
 482     *uv = grok_hex(*s, &numbers_len, &flags, NULL);
 483     if (UNLIKELY(   (flags & PERL_SCAN_GREATER_THAN_UV_MAX)
 484                  || (! allow_UV_MAX && *uv == UV_MAX)))
 485     {
 486         *message = form_cp_too_large_msg(16, *s, numbers_len, 0);
 487         *s = e + 1;
 488         return FALSE;
 489     }
 490
 491     if (numbers_len != (STRLEN) (e - *s)) {
 492         *s += numbers_len;
 493         if (strict) {
 494             *s += (UTF) ? UTF8_SAFE_SKIP(*s, send) : 1;
 495             *message = "Non-hex character";
 496             return FALSE;
 497         }
 498
 499         if (ckWARN(WARN_DIGIT)) {
 500             const char * failure = form_alien_digit_msg(16, numbers_len, *s,
 501                                                                 send, UTF, TRUE);
 502             if (! packed_warn) {
 503                 Perl_warner(aTHX_ packWARN(WARN_DIGIT), "%s", failure);
 504             }
 505             else {
 506                 *message = failure;
 507                 *packed_warn = packWARN(WARN_DIGIT);
 508             }
 509         }
 510     }
 511
 512     /* Return past the '}' */
 513     *s = e + 1;
 514
 515     return TRUE;
 516 }
 517
 518 /*
 519  * ex: set ts=8 sts=4 sw=4 et:
 520  */