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