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
  12 /* XXX Add documentation after final interface and behavior is decided */
  13 /* May want to show context for error, so would pass S_grok_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
  14     U8 source = *current;
  15 */
  16
  17 char
  18 Perl_grok_bslash_c(pTHX_ const char source, const bool output_warning)
  19 {
  20
  21     U8 result;
  22
  23     if (! isPRINT_A(source)) {
  24         Perl_croak(aTHX_ "%s",
  25                         "Character following \"\\c\" must be printable ASCII");
  26     }
  27     else if (source == '{') {
  28         const char control = toCTRL('{');
  29         if (isPRINT_A(control)) {
  30             /* diag_listed_as: Use "%s" instead of "%s" */
  31             Perl_croak(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
  32         }
  33         else {
  34             Perl_croak(aTHX_ "Sequence \"\\c{\" invalid");
  35         }
  36     }
  37
  38     result = toCTRL(source);
  39     if (output_warning && isPRINT_A(result)) {
  40         U8 clearer[3];
  41         U8 i = 0;
  42         if (! isWORDCHAR(result)) {
  43             clearer[i++] = '\\';
  44         }
  45         clearer[i++] = result;
  46         clearer[i++] = '\0';
  47
  48         Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
  49                         "\"\\c%c\" is more clearly written simply as \"%s\"",
  50                         source,
  51                         clearer);
  52     }
  53
  54     return result;
  55 }
  56
  57 bool
  58 Perl_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
  59                       const bool output_warning, const bool strict,
  60                       const bool silence_non_portable,
  61                       const bool UTF)
  62 {
  63
  64 /*  Documentation to be supplied when interface nailed down finally
  65  *  This returns FALSE if there is an error which the caller need not recover
  66  *  from; otherwise TRUE.  In either case the caller should look at *len [???].
  67  *  It guarantees that the returned codepoint, *uv, when expressed as
  68  *  utf8 bytes, would fit within the skipped "\o{...}" bytes.
  69  *  On input:
  70  *      s   is the address of a pointer to a NULL terminated string that begins
  71  *          with 'o', and the previous character was a backslash.  At exit, *s
  72  *          will be advanced to the byte just after those absorbed by this
  73  *          function.  Hence the caller can continue parsing from there.  In
  74  *          the case of an error, this routine has generally positioned *s to
  75  *          point just to the right of the first bad spot, so that a message
  76  *          that has a "<--" to mark the spot will be correctly positioned.
  77  *      uv  points to a UV that will hold the output value, valid only if the
  78  *          return from the function is TRUE
  79  *      error_msg is a pointer that will be set to an internal buffer giving an
  80  *          error message upon failure (the return is FALSE).  Untouched if
  81  *          function succeeds
  82  *      output_warning says whether to output any warning messages, or suppress
  83  *          them
  84  *      strict is true if this should fail instead of warn if there are
  85  *          non-octal digits within the braces
  86  *      silence_non_portable is true if to suppress warnings about the code
  87  *          point returned being too large to fit on all platforms.
  88  *      UTF is true iff the string *s is encoded in UTF-8.
  89  */
  90     char* e;
  91     STRLEN numbers_len;
  92     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
  93                 | PERL_SCAN_DISALLOW_PREFIX
  94                 /* XXX Until the message is improved in grok_oct, handle errors
  95                  * ourselves */
  96                 | PERL_SCAN_SILENT_ILLDIGIT;
  97
  98 #ifdef DEBUGGING
  99     char *start = *s - 1;
 100     assert(*start == '\\');
 101 #endif
 102
 103     PERL_ARGS_ASSERT_GROK_BSLASH_O;
 104
 105
 106     assert(**s == 'o');
 107     (*s)++;
 108
 109     if (**s != '{') {
 110         *error_msg = "Missing braces on \\o{}";
 111         return FALSE;
 112     }
 113
 114     e = strchr(*s, '}');
 115     if (!e) {
 116         (*s)++;  /* Move past the '{' */
 117         while (isOCTAL(**s)) { /* Position beyond the legal digits */
 118             (*s)++;
 119         }
 120         *error_msg = "Missing right brace on \\o{";
 121         return FALSE;
 122     }
 123
 124     (*s)++;    /* Point to expected first digit (could be first byte of utf8
 125                   sequence if not a digit) */
 126     numbers_len = e - *s;
 127     if (numbers_len == 0) {
 128         (*s)++;    /* Move past the } */
 129         *error_msg = "Number with no digits";
 130         return FALSE;
 131     }
 132
 133     if (silence_non_portable) {
 134         flags |= PERL_SCAN_SILENT_NON_PORTABLE;
 135     }
 136
 137     *uv = grok_oct(*s, &numbers_len, &flags, NULL);
 138     /* Note that if has non-octal, will ignore everything starting with that up
 139      * to the '}' */
 140
 141     if (numbers_len != (STRLEN) (e - *s)) {
 142         if (strict) {
 143             *s += numbers_len;
 144             *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
 145             *error_msg = "Non-octal character";
 146             return FALSE;
 147         }
 148         else if (output_warning) {
 149             Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
 150             /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
 151                         "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
 152                         *(*s + numbers_len),
 153                         (int) numbers_len,
 154                         *s);
 155         }
 156     }
 157
 158     /* Return past the '}' */
 159     *s = e + 1;
 160
 161     /* guarantee replacing "\o{...}" with utf8 bytes fits within
 162      * existing space */
 163     assert(UVCHR_SKIP(*uv) < *s - start);
 164
 165     return TRUE;
 166 }
 167
 168 char*
 169 Perl_form_short_octal_warning(pTHX_
 170                            const char * const s, /* Points to first non-octal */
 171                            const STRLEN len      /* Length of octals string, so
 172                                                     (s-len) points to first
 173                                                     octal */
 174 ) {
 175     /* Return a character string consisting of a warning message for when a
 176      * string constant in octal is weird, like "\078".  */
 177
 178     const char * sans_leading_zeros = s - len;
 179
 180     PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
 181
 182     assert(*s == '8' || *s == '9');
 183
 184     /* Remove the leading zeros, retaining one zero so won't be zero length */
 185     while (*sans_leading_zeros == '0') sans_leading_zeros++;
 186     if (sans_leading_zeros == s) {
 187         sans_leading_zeros--;
 188     }
 189
 190     return Perl_form(aTHX_
 191                      "'%.*s' resolved to '\\o{%.*s}%c'",
 192                      (int) (len + 2), s - len - 1,
 193                      (int) (s - sans_leading_zeros), sans_leading_zeros,
 194                      *s);
 195 }
 196
 197 /*
 198  * ex: set ts=8 sts=4 sw=4 et:
 199  */