dquote_static.c

   1 /*    dquote_static.c
   2  *
   3  * This file contains static inline 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 "proto.h"
  12 #include "embed.h"
  13
  14 /*
  15  - regcurly - a little FSA that accepts {\d+,?\d*}
  16     Pulled from regcomp.c.
  17  */
  18 PERL_STATIC_INLINE I32
  19 S_regcurly(pTHX_ register const char *s)
  20 {
  21     PERL_ARGS_ASSERT_REGCURLY;
  22
  23     if (*s++ != '{')
  24         return FALSE;
  25     if (!isDIGIT(*s))
  26         return FALSE;
  27     while (isDIGIT(*s))
  28         s++;
  29     if (*s == ',') {
  30         s++;
  31         while (isDIGIT(*s))
  32             s++;
  33     }
  34     if (*s != '}')
  35         return FALSE;
  36     return TRUE;
  37 }
  38
  39 /* XXX Add documentation after final interface and behavior is decided */
  40 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
  41     U8 source = *current;
  42
  43     May want to add eg, WARN_REGEX
  44 */
  45
  46 STATIC char
  47 S_grok_bslash_c(pTHX_ const char source, const bool output_warning)
  48 {
  49
  50     U8 result;
  51
  52     if (! isASCII(source)) {
  53         Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
  54     }
  55
  56     result = toCTRL(source);
  57     if (! isCNTRL(result)) {
  58         if (source == '{') {
  59             Perl_croak(aTHX_ "It is proposed that \"\\c{\" no longer be valid. It has historically evaluated to\n \";\".  If you disagree with this proposal, send email to perl5-porters@perl.org\nOtherwise, or in the meantime, you can work around this failure by changing\n\"\\c{\" to \";\"");
  60         }
  61         else if (output_warning) {
  62             U8 clearer[3];
  63             U8 i = 0;
  64             if (! isALNUM(result)) {
  65                 clearer[i++] = '\\';
  66             }
  67             clearer[i++] = result;
  68             clearer[i++] = '\0';
  69
  70             Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
  71                             "\"\\c%c\" more clearly written simply as \"%s\"",
  72                             source,
  73                             clearer);
  74         }
  75     }
  76
  77     return result;
  78 }
  79
  80 STATIC bool
  81 S_grok_bslash_o(pTHX_ const char *s,
  82                          UV *uv,
  83                          STRLEN *len,
  84                          const char** error_msg,
  85                          const bool output_warning)
  86 {
  87
  88 /*  Documentation to be supplied when interface nailed down finally
  89  *  This returns FALSE if there is an error which the caller need not recover
  90  *  from; , otherwise TRUE.  In either case the caller should look at *len
  91  *  On input:
  92  *      s   points to a string that begins with 'o', and the previous character
  93  *          was a backslash.
  94  *      uv  points to a UV that will hold the output value, valid only if the
  95  *          return from the function is TRUE
  96  *      len on success will point to the next character in the string past the
  97  *                     end of this construct.
  98  *          on failure, it will point to the failure
  99  *      error_msg is a pointer that will be set to an internal buffer giving an
 100  *          error message upon failure (the return is FALSE).  Untouched if
 101  *          function succeeds
 102  *      output_warning says whether to output any warning messages, or suppress
 103  *          them
 104  */
 105     const char* e;
 106     STRLEN numbers_len;
 107     I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
 108                 | PERL_SCAN_DISALLOW_PREFIX
 109                 /* XXX Until the message is improved in grok_oct, handle errors
 110                  * ourselves */
 111                 | PERL_SCAN_SILENT_ILLDIGIT;
 112
 113     PERL_ARGS_ASSERT_GROK_BSLASH_O;
 114
 115
 116     assert(*s == 'o');
 117     s++;
 118
 119     if (*s != '{') {
 120         *len = 1;       /* Move past the o */
 121         *error_msg = "Missing braces on \\o{}";
 122         return FALSE;
 123     }
 124
 125     e = strchr(s, '}');
 126     if (!e) {
 127         *len = 2;       /* Move past the o{ */
 128         *error_msg = "Missing right brace on \\o{";
 129         return FALSE;
 130     }
 131
 132     /* Return past the '}' no matter what is inside the braces */
 133     *len = e - s + 2;   /* 2 = 1 for the o + 1 for the '}' */
 134
 135     s++;    /* Point to first digit */
 136
 137     numbers_len = e - s;
 138     if (numbers_len == 0) {
 139         *error_msg = "Number with no digits";
 140         return FALSE;
 141     }
 142
 143     *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
 144     /* Note that if has non-octal, will ignore everything starting with that up
 145      * to the '}' */
 146
 147     if (output_warning && numbers_len != (STRLEN) (e - s)) {
 148         Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
 149         /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
 150                        "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
 151                        *(s + numbers_len),
 152                        (int) numbers_len,
 153                        s);
 154     }
 155
 156     return TRUE;
 157 }
 158
 159 /*
 160  * Local variables:
 161  * c-indentation-style: bsd
 162  * c-basic-offset: 4
 163  * indent-tabs-mode: t
 164  * End:
 165  *
 166  * ex: set ts=8 sts=4 sw=4 noet:
 167  */