src/5014002/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 "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
  44 STATIC char
  45 S_grok_bslash_c(pTHX_ const char source, const bool utf8, const bool output_warning)
  46 {
  47
  48  U8 result;
  49
  50  if (utf8) {
  51   /* Trying to deprecate non-ASCII usages.  This construct has never
  52   * worked for a utf8 variant.  So, even though are accepting non-ASCII
  53   * Latin1 in 5.14, no need to make them work under utf8 */
  54   if (! isASCII(source)) {
  55    Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
  56   }
  57  }
  58
  59  result = toCTRL(source);
  60  if (! isASCII(source)) {
  61    Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
  62        "Character following \"\\c\" must be ASCII");
  63  }
  64  else if (! isCNTRL(result) && output_warning) {
  65   if (source == '{') {
  66    Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
  67        "\"\\c{\" is deprecated and is more clearly written as \";\"");
  68   }
  69   else {
  70    U8 clearer[3];
  71    U8 i = 0;
  72    if (! isALNUM(result)) {
  73     clearer[i++] = '\\';
  74    }
  75    clearer[i++] = result;
  76    clearer[i++] = '\0';
  77
  78    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
  79        "\"\\c%c\" is more clearly written simply as \"%s\"",
  80        source,
  81        clearer);
  82   }
  83  }
  84
  85  return result;
  86 }
  87
  88 STATIC bool
  89 S_grok_bslash_o(pTHX_ const char *s,
  90       UV *uv,
  91       STRLEN *len,
  92       const char** error_msg,
  93       const bool output_warning)
  94 {
  95
  96 /*  Documentation to be supplied when interface nailed down finally
  97  *  This returns FALSE if there is an error which the caller need not recover
  98  *  from; , otherwise TRUE.  In either case the caller should look at *len
  99  *  On input:
 100  * s   points to a string that begins with 'o', and the previous character
 101  *     was a backslash.
 102  * uv  points to a UV that will hold the output value, valid only if the
 103  *     return from the function is TRUE
 104  * len on success will point to the next character in the string past the
 105  *         end of this construct.
 106  *     on failure, it will point to the failure
 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  */
 113  const char* e;
 114  STRLEN numbers_len;
 115  I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
 116     | PERL_SCAN_DISALLOW_PREFIX
 117     /* XXX Until the message is improved in grok_oct, handle errors
 118     * ourselves */
 119     | PERL_SCAN_SILENT_ILLDIGIT;
 120
 121  PERL_ARGS_ASSERT_GROK_BSLASH_O;
 122
 123
 124  assert(*s == 'o');
 125  s++;
 126
 127  if (*s != '{') {
 128   *len = 1; /* Move past the o */
 129   *error_msg = "Missing braces on \\o{}";
 130   return FALSE;
 131  }
 132
 133  e = strchr(s, '}');
 134  if (!e) {
 135   *len = 2; /* Move past the o{ */
 136   *error_msg = "Missing right brace on \\o{";
 137   return FALSE;
 138  }
 139
 140  /* Return past the '}' no matter what is inside the braces */
 141  *len = e - s + 2; /* 2 = 1 for the o + 1 for the '}' */
 142
 143  s++;    /* Point to first digit */
 144
 145  numbers_len = e - s;
 146  if (numbers_len == 0) {
 147   *error_msg = "Number with no digits";
 148   return FALSE;
 149  }
 150
 151  *uv = NATIVE_TO_UNI(grok_oct(s, &numbers_len, &flags, NULL));
 152  /* Note that if has non-octal, will ignore everything starting with that up
 153  * to the '}' */
 154
 155  if (output_warning && numbers_len != (STRLEN) (e - s)) {
 156   Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
 157   /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
 158      "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
 159      *(s + numbers_len),
 160      (int) numbers_len,
 161      s);
 162  }
 163
 164  return TRUE;
 165 }
 166
 167 /*
 168  * Local variables:
 169  * c-indentation-style: bsd
 170  * c-basic-offset: 4
 171  * indent-tabs-mode: t
 172  * End:
 173  *
 174  * ex: set ts=8 sts=4 sw=4 noet:
 175  */