src/5018000/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   const bool rbrace_must_be_escaped /* Should the terminating '} be
  20             preceded by a backslash?  This
  21             is an abnormal case */
  22  )
  23 {
  24  PERL_ARGS_ASSERT_REGCURLY;
  25
  26  if (*s++ != '{')
  27   return FALSE;
  28  if (!isDIGIT(*s))
  29   return FALSE;
  30  while (isDIGIT(*s))
  31   s++;
  32  if (*s == ',') {
  33   s++;
  34   while (isDIGIT(*s))
  35    s++;
  36  }
  37
  38  return (rbrace_must_be_escaped)
  39   ? *s == '\\' && *(s+1) == '}'
  40   : *s == '}';
  41 }
  42
  43 /* XXX Add documentation after final interface and behavior is decided */
  44 /* May want to show context for error, so would pass Perl_bslash_c(pTHX_ const char* current, const char* start, const bool output_warning)
  45  U8 source = *current;
  46 */
  47
  48 STATIC char
  49 S_grok_bslash_c(pTHX_ const char source, const bool utf8, const bool output_warning)
  50 {
  51
  52  U8 result;
  53
  54  if (utf8) {
  55   /* Trying to deprecate non-ASCII usages.  This construct has never
  56   * worked for a utf8 variant.  So, even though are accepting non-ASCII
  57   * Latin1 in 5.14, no need to make them work under utf8 */
  58   if (! isASCII(source)) {
  59    Perl_croak(aTHX_ "Character following \"\\c\" must be ASCII");
  60   }
  61  }
  62
  63  result = toCTRL(source);
  64  if (! isASCII(source)) {
  65    Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
  66        "Character following \"\\c\" must be ASCII");
  67  }
  68  else if (! isCNTRL(result) && output_warning) {
  69   if (source == '{') {
  70    Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
  71        "\"\\c{\" is deprecated and is more clearly written as \";\"");
  72   }
  73   else {
  74    U8 clearer[3];
  75    U8 i = 0;
  76    if (! isWORDCHAR(result)) {
  77     clearer[i++] = '\\';
  78    }
  79    clearer[i++] = result;
  80    clearer[i++] = '\0';
  81
  82    Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
  83        "\"\\c%c\" is more clearly written simply as \"%s\"",
  84        source,
  85        clearer);
  86   }
  87  }
  88
  89  return result;
  90 }
  91
  92 STATIC bool
  93 S_grok_bslash_o(pTHX_ char **s, UV *uv, const char** error_msg,
  94      const bool output_warning, const bool strict,
  95      const bool silence_non_portable,
  96      const bool UTF)
  97 {
  98
  99 /*  Documentation to be supplied when interface nailed down finally
 100  *  This returns FALSE if there is an error which the caller need not recover
 101  *  from; , otherwise TRUE.  In either case the caller should look at *len
 102  *  On input:
 103  * s   is the address of a pointer to a NULL terminated string that begins
 104  *     with 'o', and the previous character was a backslash.  At exit, *s
 105  *     will be advanced to the byte just after those absorbed by this
 106  *     function.  Hence the caller can continue parsing from there.  In
 107  *     the case of an error, this routine has generally positioned *s to
 108  *     point just to the right of the first bad spot, so that a message
 109  *     that has a "<--" to mark the spot will be correctly positioned.
 110  * uv  points to a UV that will hold the output value, valid only if the
 111  *     return from the function is TRUE
 112  *      error_msg is a pointer that will be set to an internal buffer giving an
 113  *     error message upon failure (the return is FALSE).  Untouched if
 114  *     function succeeds
 115  * output_warning says whether to output any warning messages, or suppress
 116  *     them
 117  * strict is true if this should fail instead of warn if there are
 118  *     non-octal digits within the braces
 119  *      silence_non_portable is true if to suppress warnings about the code
 120  *          point returned being too large to fit on all platforms.
 121  * UTF is true iff the string *s is encoded in UTF-8.
 122  */
 123  char* e;
 124  STRLEN numbers_len;
 125  I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
 126     | PERL_SCAN_DISALLOW_PREFIX
 127     /* XXX Until the message is improved in grok_oct, handle errors
 128     * ourselves */
 129     | PERL_SCAN_SILENT_ILLDIGIT;
 130
 131  PERL_ARGS_ASSERT_GROK_BSLASH_O;
 132
 133
 134  assert(**s == 'o');
 135  (*s)++;
 136
 137  if (**s != '{') {
 138   *error_msg = "Missing braces on \\o{}";
 139   return FALSE;
 140  }
 141
 142  e = strchr(*s, '}');
 143  if (!e) {
 144   (*s)++;  /* Move past the '{' */
 145   while (isOCTAL(**s)) { /* Position beyond the legal digits */
 146    (*s)++;
 147   }
 148   *error_msg = "Missing right brace on \\o{";
 149   return FALSE;
 150  }
 151
 152  (*s)++;    /* Point to expected first digit (could be first byte of utf8
 153     sequence if not a digit) */
 154  numbers_len = e - *s;
 155  if (numbers_len == 0) {
 156   (*s)++;    /* Move past the } */
 157   *error_msg = "Number with no digits";
 158   return FALSE;
 159  }
 160
 161  if (silence_non_portable) {
 162   flags |= PERL_SCAN_SILENT_NON_PORTABLE;
 163  }
 164
 165  *uv = grok_oct(*s, &numbers_len, &flags, NULL);
 166  /* Note that if has non-octal, will ignore everything starting with that up
 167  * to the '}' */
 168
 169  if (numbers_len != (STRLEN) (e - *s)) {
 170   if (strict) {
 171    *s += numbers_len;
 172    *s += (UTF) ? UTF8SKIP(*s) : (STRLEN) 1;
 173    *error_msg = "Non-octal character";
 174    return FALSE;
 175   }
 176   else if (output_warning) {
 177    Perl_ck_warner(aTHX_ packWARN(WARN_DIGIT),
 178    /* diag_listed_as: Non-octal character '%c'.  Resolved as "%s" */
 179       "Non-octal character '%c'.  Resolved as \"\\o{%.*s}\"",
 180       *(*s + numbers_len),
 181       (int) numbers_len,
 182       *s);
 183   }
 184  }
 185
 186  /* Return past the '}' */
 187  *s = e + 1;
 188
 189  return TRUE;
 190 }
 191
 192 PERL_STATIC_INLINE bool
 193 S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
 194      const bool output_warning, const bool strict,
 195      const bool silence_non_portable,
 196      const bool UTF)
 197 {
 198
 199 /*  Documentation to be supplied when interface nailed down finally
 200  *  This returns FALSE if there is an error which the caller need not recover
 201  *  from; , otherwise TRUE.  In either case the caller should look at *len
 202  *  On input:
 203  * s   is the address of a pointer to a NULL terminated string that begins
 204  *     with 'x', and the previous character was a backslash.  At exit, *s
 205  *     will be advanced to the byte just after those absorbed by this
 206  *     function.  Hence the caller can continue parsing from there.  In
 207  *     the case of an error, this routine has generally positioned *s to
 208  *     point just to the right of the first bad spot, so that a message
 209  *     that has a "<--" to mark the spot will be correctly positioned.
 210  * uv  points to a UV that will hold the output value, valid only if the
 211  *     return from the function is TRUE
 212  *      error_msg is a pointer that will be set to an internal buffer giving an
 213  *     error message upon failure (the return is FALSE).  Untouched if
 214  *     function succeeds
 215  * output_warning says whether to output any warning messages, or suppress
 216  *     them
 217  * strict is true if anything out of the ordinary should cause this to
 218  *     fail instead of warn or be silent.  For example, it requires
 219  *     exactly 2 digits following the \x (when there are no braces).
 220  *     3 digits could be a mistake, so is forbidden in this mode.
 221  *      silence_non_portable is true if to suppress warnings about the code
 222  *          point returned being too large to fit on all platforms.
 223  * UTF is true iff the string *s is encoded in UTF-8.
 224  */
 225  char* e;
 226  STRLEN numbers_len;
 227  I32 flags = PERL_SCAN_DISALLOW_PREFIX;
 228
 229  PERL_ARGS_ASSERT_GROK_BSLASH_X;
 230
 231  PERL_UNUSED_ARG(output_warning);
 232
 233  assert(**s == 'x');
 234  (*s)++;
 235
 236  if (strict) {
 237   flags |= PERL_SCAN_SILENT_ILLDIGIT;
 238  }
 239
 240  if (**s != '{') {
 241   STRLEN len = (strict) ? 3 : 2;
 242
 243   *uv = grok_hex(*s, &len, &flags, NULL);
 244   *s += len;
 245   if (strict && len != 2) {
 246    if (len < 2) {
 247     *s += (UTF) ? UTF8SKIP(*s) : 1;
 248     *error_msg = "Non-hex character";
 249    }
 250    else {
 251     *error_msg = "Use \\x{...} for more than two hex characters";
 252    }
 253    return FALSE;
 254   }
 255   return TRUE;
 256  }
 257
 258  e = strchr(*s, '}');
 259  if (!e) {
 260   (*s)++;  /* Move past the '{' */
 261   while (isXDIGIT(**s)) { /* Position beyond the legal digits */
 262    (*s)++;
 263   }
 264   /* XXX The corresponding message above for \o is just '\\o{'; other
 265   * messages for other constructs include the '}', so are inconsistent.
 266   */
 267   *error_msg = "Missing right brace on \\x{}";
 268   return FALSE;
 269  }
 270
 271  (*s)++;    /* Point to expected first digit (could be first byte of utf8
 272     sequence if not a digit) */
 273  numbers_len = e - *s;
 274  if (numbers_len == 0) {
 275   if (strict) {
 276    (*s)++;    /* Move past the } */
 277    *error_msg = "Number with no digits";
 278    return FALSE;
 279   }
 280   return TRUE;
 281  }
 282
 283  flags |= PERL_SCAN_ALLOW_UNDERSCORES;
 284  if (silence_non_portable) {
 285   flags |= PERL_SCAN_SILENT_NON_PORTABLE;
 286  }
 287
 288  *uv = grok_hex(*s, &numbers_len, &flags, NULL);
 289  /* Note that if has non-hex, will ignore everything starting with that up
 290  * to the '}' */
 291
 292  if (strict && numbers_len != (STRLEN) (e - *s)) {
 293   *s += numbers_len;
 294   *s += (UTF) ? UTF8SKIP(*s) : 1;
 295   *error_msg = "Non-hex character";
 296   return FALSE;
 297  }
 298
 299  /* Return past the '}' */
 300  *s = e + 1;
 301
 302  return TRUE;
 303 }
 304
 305 STATIC char*
 306 S_form_short_octal_warning(pTHX_
 307       const char * const s, /* Points to first non-octal */
 308       const STRLEN len      /* Length of octals string, so
 309              (s-len) points to first
 310              octal */
 311 ) {
 312  /* Return a character string consisting of a warning message for when a
 313  * string constant in octal is weird, like "\078".  */
 314
 315  const char * sans_leading_zeros = s - len;
 316
 317  PERL_ARGS_ASSERT_FORM_SHORT_OCTAL_WARNING;
 318
 319  assert(*s == '8' || *s == '9');
 320
 321  /* Remove the leading zeros, retaining one zero so won't be zero length */
 322  while (*sans_leading_zeros == '0') sans_leading_zeros++;
 323  if (sans_leading_zeros == s) {
 324   sans_leading_zeros--;
 325  }
 326
 327  return Perl_form(aTHX_
 328      "'%.*s' resolved to '\\o{%.*s}%c'",
 329      (int) (len + 2), s - len - 1,
 330      (int) (s - sans_leading_zeros), sans_leading_zeros,
 331      *s);
 332 }
 333
 334 /*
 335  * Local variables:
 336  * c-indentation-style: bsd
 337  * c-basic-offset: 4
 338  * indent-tabs-mode: nil
 339  * End:
 340  *
 341  * ex: set ts=8 sts=4 sw=4 et:
 342  */