src/5018002/regexec.c

   1 /*    regexec.c
   2  */
   3
   4 /*
   5  *  One Ring to rule them all, One Ring to find them
   6  &
   7  *     [p.v of _The Lord of the Rings_, opening poem]
   8  *     [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
   9  *     [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
  10  */
  11
  12 /* This file contains functions for executing a regular expression.  See
  13  * also regcomp.c which funnily enough, contains functions for compiling
  14  * a regular expression.
  15  *
  16  * This file is also copied at build time to ext/re/re_exec.c, where
  17  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
  18  * This causes the main functions to be compiled under new names and with
  19  * debugging support added, which makes "use re 'debug'" work.
  20  */
  21
  22 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
  23  * confused with the original package (see point 3 below).  Thanks, Henry!
  24  */
  25
  26 /* Additional note: this code is very heavily munged from Henry's version
  27  * in places.  In some spots I've traded clarity for efficiency, so don't
  28  * blame Henry for some of the lack of readability.
  29  */
  30
  31 /* The names of the functions have been changed from regcomp and
  32  * regexec to  pregcomp and pregexec in order to avoid conflicts
  33  * with the POSIX routines of the same names.
  34 */
  35
  36 #ifdef PERL_EXT_RE_BUILD
  37 #include "re_top.h"
  38 #endif
  39
  40 /* At least one required character in the target string is expressible only in
  41  * UTF-8. */
  42 static const char* const non_utf8_target_but_utf8_required
  43     = "Can't match, because target string needs to be in UTF-8\n";
  44
  45 #define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \
  46  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\
  47  goto target; \
  48 } STMT_END
  49
  50 /*
  51  * pregcomp and pregexec -- regsub and regerror are not used in perl
  52  *
  53  * Copyright (c) 1986 by University of Toronto.
  54  * Written by Henry Spencer.  Not derived from licensed software.
  55  *
  56  * Permission is granted to anyone to use this software for any
  57  * purpose on any computer system, and to redistribute it freely,
  58  * subject to the following restrictions:
  59  *
  60  * 1. The author is not responsible for the consequences of use of
  61  *  this software, no matter how awful, even if they arise
  62  *  from defects in it.
  63  *
  64  * 2. The origin of this software must not be misrepresented, either
  65  *  by explicit claim or by omission.
  66  *
  67  * 3. Altered versions must be plainly marked as such, and must not
  68  *  be misrepresented as being the original software.
  69  *
  70  ****    Alterations to Henry's code are...
  71  ****
  72  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
  73  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
  74  ****    by Larry Wall and others
  75  ****
  76  ****    You may distribute under the terms of either the GNU General Public
  77  ****    License or the Artistic License, as specified in the README file.
  78  *
  79  * Beware that some of this code is subtly aware of the way operator
  80  * precedence is structured in regular expressions.  Serious changes in
  81  * regular-expression syntax might require a total rethink.
  82  */
  83 #include "EXTERN.h"
  84 #define PERL_IN_REGEXEC_C
  85 #include "perl.h"
  86 #include "re_defs.h"
  87
  88 #ifdef PERL_IN_XSUB_RE
  89 #  include "re_comp.h"
  90 #else
  91 #  include "regcomp.h"
  92 #endif
  93
  94 #include "inline_invlist.c"
  95 #include "unicode_constants.h"
  96
  97 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
  98
  99 #ifndef STATIC
 100 #define STATIC static
 101 #endif
 102
 103 /* Valid for non-utf8 strings: avoids the reginclass
 104  * call if there are no complications: i.e., if everything matchable is
 105  * straight forward in the bitmap */
 106 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0)   \
 107            : ANYOF_BITMAP_TEST(p,*(c)))
 108
 109 /*
 110  * Forwards.
 111  */
 112
 113 #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv))
 114 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
 115
 116 #define HOPc(pos,off) \
 117   (char *)(PL_reg_match_utf8 \
 118    ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
 119    : (U8*)(pos + off))
 120 #define HOPBACKc(pos, off) \
 121   (char*)(PL_reg_match_utf8\
 122    ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
 123    : (pos - off >= PL_bostr)  \
 124     ? (U8*)pos - off  \
 125     : NULL)
 126
 127 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
 128 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
 129
 130
 131 #define NEXTCHR_EOS -10 /* nextchr has fallen off the end */
 132 #define NEXTCHR_IS_EOS (nextchr < 0)
 133
 134 #define SET_nextchr \
 135  nextchr = ((locinput < PL_regeol) ? UCHARAT(locinput) : NEXTCHR_EOS)
 136
 137 #define SET_locinput(p) \
 138  locinput = (p);  \
 139  SET_nextchr
 140
 141
 142 #define LOAD_UTF8_CHARCLASS(swash_ptr, property_name) STMT_START {            \
 143   if (!swash_ptr) {                                                     \
 144    U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;                       \
 145    swash_ptr = _core_swash_init("utf8", property_name, &PL_sv_undef, \
 146           1, 0, NULL, &flags);                 \
 147    assert(swash_ptr);                                                \
 148   }                                                                     \
 149  } STMT_END
 150
 151 /* If in debug mode, we test that a known character properly matches */
 152 #ifdef DEBUGGING
 153 #   define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr,                          \
 154           property_name,                      \
 155           utf8_char_in_property)              \
 156   LOAD_UTF8_CHARCLASS(swash_ptr, property_name);                        \
 157   assert(swash_fetch(swash_ptr, (U8 *) utf8_char_in_property, TRUE));
 158 #else
 159 #   define LOAD_UTF8_CHARCLASS_DEBUG_TEST(swash_ptr,                          \
 160           property_name,                      \
 161           utf8_char_in_property)              \
 162   LOAD_UTF8_CHARCLASS(swash_ptr, property_name)
 163 #endif
 164
 165 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS_DEBUG_TEST(           \
 166           PL_utf8_swash_ptrs[_CC_WORDCHAR],     \
 167           swash_property_names[_CC_WORDCHAR],   \
 168           GREEK_SMALL_LETTER_IOTA_UTF8)
 169
 170 #define LOAD_UTF8_CHARCLASS_GCB()  /* Grapheme cluster boundaries */          \
 171  STMT_START {                                                              \
 172   LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_regular_begin,               \
 173          "_X_regular_begin",                    \
 174          GREEK_SMALL_LETTER_IOTA_UTF8);         \
 175   LOAD_UTF8_CHARCLASS_DEBUG_TEST(PL_utf8_X_extend,                      \
 176          "_X_extend",                           \
 177          COMBINING_GRAVE_ACCENT_UTF8);          \
 178  } STMT_END
 179
 180 #define PLACEHOLDER /* Something for the preprocessor to grab onto */
 181 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
 182
 183 /* for use after a quantifier and before an EXACT-like node -- japhy */
 184 /* it would be nice to rework regcomp.sym to generate this stuff. sigh
 185  *
 186  * NOTE that *nothing* that affects backtracking should be in here, specifically
 187  * VERBS must NOT be included. JUMPABLE is used to determine  if we can ignore a
 188  * node that is in between two EXACT like nodes when ascertaining what the required
 189  * "follow" character is. This should probably be moved to regex compile time
 190  * although it may be done at run time beause of the REF possibility - more
 191  * investigation required. -- demerphq
 192 */
 193 #define JUMPABLE(rn) (      \
 194  OP(rn) == OPEN ||       \
 195  (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
 196  OP(rn) == EVAL ||   \
 197  OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 198  OP(rn) == PLUS || OP(rn) == MINMOD || \
 199  OP(rn) == KEEPS || \
 200  (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
 201 )
 202 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
 203
 204 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
 205
 206 #if 0
 207 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
 208    we don't need this definition. */
 209 #define IS_TEXT(rn)   ( OP(rn)==EXACT   || OP(rn)==REF   || OP(rn)==NREF   )
 210 #define IS_TEXTF(rn)  ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFU_TRICKYFOLD || OP(rn)==EXACTFA || OP(rn)==EXACTF || OP(rn)==REFF  || OP(rn)==NREFF )
 211 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
 212
 213 #else
 214 /* ... so we use this as its faster. */
 215 #define IS_TEXT(rn)   ( OP(rn)==EXACT   )
 216 #define IS_TEXTFU(rn)  ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFU_TRICKYFOLD || OP(rn) == EXACTFA)
 217 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  )
 218 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
 219
 220 #endif
 221
 222 /*
 223   Search for mandatory following text node; for lookahead, the text must
 224   follow but for lookbehind (rn->flags != 0) we skip to the next step.
 225 */
 226 #define FIND_NEXT_IMPT(rn) STMT_START { \
 227  while (JUMPABLE(rn)) { \
 228   const OPCODE type = OP(rn); \
 229   if (type == SUSPEND || PL_regkind[type] == CURLY) \
 230    rn = NEXTOPER(NEXTOPER(rn)); \
 231   else if (type == PLUS) \
 232    rn = NEXTOPER(rn); \
 233   else if (type == IFMATCH) \
 234    rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
 235   else rn += NEXT_OFF(rn); \
 236  } \
 237 } STMT_END
 238
 239 /* These constants are for finding GCB=LV and GCB=LVT in the CLUMP regnode.
 240  * These are for the pre-composed Hangul syllables, which are all in a
 241  * contiguous block and arranged there in such a way so as to facilitate
 242  * alorithmic determination of their characteristics.  As such, they don't need
 243  * a swash, but can be determined by simple arithmetic.  Almost all are
 244  * GCB=LVT, but every 28th one is a GCB=LV */
 245 #define SBASE 0xAC00    /* Start of block */
 246 #define SCount 11172    /* Length of block */
 247 #define TCount 28
 248
 249 static void restore_pos(pTHX_ void *arg);
 250
 251 #define REGCP_PAREN_ELEMS 3
 252 #define REGCP_OTHER_ELEMS 3
 253 #define REGCP_FRAME_ELEMS 1
 254 /* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
 255  * are needed for the regexp context stack bookkeeping. */
 256
 257 STATIC CHECKPOINT
 258 S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen)
 259 {
 260  dVAR;
 261  const int retval = PL_savestack_ix;
 262  const int paren_elems_to_push =
 263     (maxopenparen - parenfloor) * REGCP_PAREN_ELEMS;
 264  const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
 265  const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
 266  I32 p;
 267  GET_RE_DEBUG_FLAGS_DECL;
 268
 269  PERL_ARGS_ASSERT_REGCPPUSH;
 270
 271  if (paren_elems_to_push < 0)
 272   Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0",
 273     paren_elems_to_push);
 274
 275  if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
 276   Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf
 277     " out of range (%lu-%ld)",
 278     total_elems,
 279     (unsigned long)maxopenparen,
 280     (long)parenfloor);
 281
 282  SSGROW(total_elems + REGCP_FRAME_ELEMS);
 283
 284  DEBUG_BUFFERS_r(
 285   if ((int)maxopenparen > (int)parenfloor)
 286    PerlIO_printf(Perl_debug_log,
 287     "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n",
 288     PTR2UV(rex),
 289     PTR2UV(rex->offs)
 290    );
 291  );
 292  for (p = parenfloor+1; p <= (I32)maxopenparen;  p++) {
 293 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 294   SSPUSHINT(rex->offs[p].end);
 295   SSPUSHINT(rex->offs[p].start);
 296   SSPUSHINT(rex->offs[p].start_tmp);
 297   DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
 298    "    \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n",
 299    (UV)p,
 300    (IV)rex->offs[p].start,
 301    (IV)rex->offs[p].start_tmp,
 302    (IV)rex->offs[p].end
 303   ));
 304  }
 305 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 306  SSPUSHINT(maxopenparen);
 307  SSPUSHINT(rex->lastparen);
 308  SSPUSHINT(rex->lastcloseparen);
 309  SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
 310
 311  return retval;
 312 }
 313
 314 /* These are needed since we do not localize EVAL nodes: */
 315 #define REGCP_SET(cp)                                           \
 316  DEBUG_STATE_r(                                              \
 317    PerlIO_printf(Perl_debug_log,          \
 318     "  Setting an EVAL scope, savestack=%"IVdf"\n", \
 319     (IV)PL_savestack_ix));                          \
 320  cp = PL_savestack_ix
 321
 322 #define REGCP_UNWIND(cp)                                        \
 323  DEBUG_STATE_r(                                              \
 324   if (cp != PL_savestack_ix)                   \
 325     PerlIO_printf(Perl_debug_log,          \
 326     "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 327     (IV)(cp), (IV)PL_savestack_ix));                \
 328  regcpblow(cp)
 329
 330 #define UNWIND_PAREN(lp, lcp)               \
 331  for (n = rex->lastparen; n > lp; n--)   \
 332   rex->offs[n].end = -1;              \
 333  rex->lastparen = n;                     \
 334  rex->lastcloseparen = lcp;
 335
 336
 337 STATIC void
 338 S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p)
 339 {
 340  dVAR;
 341  UV i;
 342  U32 paren;
 343  GET_RE_DEBUG_FLAGS_DECL;
 344
 345  PERL_ARGS_ASSERT_REGCPPOP;
 346
 347  /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 348  i = SSPOPUV;
 349  assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 350  i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
 351  rex->lastcloseparen = SSPOPINT;
 352  rex->lastparen = SSPOPINT;
 353  *maxopenparen_p = SSPOPINT;
 354
 355  i -= REGCP_OTHER_ELEMS;
 356  /* Now restore the parentheses context. */
 357  DEBUG_BUFFERS_r(
 358   if (i || rex->lastparen + 1 <= rex->nparens)
 359    PerlIO_printf(Perl_debug_log,
 360     "rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n",
 361     PTR2UV(rex),
 362     PTR2UV(rex->offs)
 363    );
 364  );
 365  paren = *maxopenparen_p;
 366  for ( ; i > 0; i -= REGCP_PAREN_ELEMS) {
 367   I32 tmps;
 368   rex->offs[paren].start_tmp = SSPOPINT;
 369   rex->offs[paren].start = SSPOPINT;
 370   tmps = SSPOPINT;
 371   if (paren <= rex->lastparen)
 372    rex->offs[paren].end = tmps;
 373   DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
 374    "    \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 375    (UV)paren,
 376    (IV)rex->offs[paren].start,
 377    (IV)rex->offs[paren].start_tmp,
 378    (IV)rex->offs[paren].end,
 379    (paren > rex->lastparen ? "(skipped)" : ""));
 380   );
 381   paren--;
 382  }
 383 #if 1
 384  /* It would seem that the similar code in regtry()
 385  * already takes care of this, and in fact it is in
 386  * a better location to since this code can #if 0-ed out
 387  * but the code in regtry() is needed or otherwise tests
 388  * requiring null fields (pat.t#187 and split.t#{13,14}
 389  * (as of patchlevel 7877)  will fail.  Then again,
 390  * this code seems to be necessary or otherwise
 391  * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
 392  * --jhi updated by dapm */
 393  for (i = rex->lastparen + 1; i <= rex->nparens; i++) {
 394   if (i > *maxopenparen_p)
 395    rex->offs[i].start = -1;
 396   rex->offs[i].end = -1;
 397   DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
 398    "    \\%"UVuf": %s   ..-1 undeffing\n",
 399    (UV)i,
 400    (i > *maxopenparen_p) ? "-1" : "  "
 401   ));
 402  }
 403 #endif
 404 }
 405
 406 /* restore the parens and associated vars at savestack position ix,
 407  * but without popping the stack */
 408
 409 STATIC void
 410 S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p)
 411 {
 412  I32 tmpix = PL_savestack_ix;
 413  PL_savestack_ix = ix;
 414  regcppop(rex, maxopenparen_p);
 415  PL_savestack_ix = tmpix;
 416 }
 417
 418 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
 419
 420 STATIC bool
 421 S_isFOO_lc(pTHX_ const U8 classnum, const U8 character)
 422 {
 423  /* Returns a boolean as to whether or not 'character' is a member of the
 424  * Posix character class given by 'classnum' that should be equivalent to a
 425  * value in the typedef '_char_class_number'.
 426  *
 427  * Ideally this could be replaced by a just an array of function pointers
 428  * to the C library functions that implement the macros this calls.
 429  * However, to compile, the precise function signatures are required, and
 430  * these may vary from platform to to platform.  To avoid having to figure
 431  * out what those all are on each platform, I (khw) am using this method,
 432  * which adds an extra layer of function call overhead (unless the C
 433  * optimizer strips it away).  But we don't particularly care about
 434  * performance with locales anyway. */
 435
 436  switch ((_char_class_number) classnum) {
 437   case _CC_ENUM_ALPHANUMERIC: return isALPHANUMERIC_LC(character);
 438   case _CC_ENUM_ALPHA:     return isALPHA_LC(character);
 439   case _CC_ENUM_ASCII:     return isASCII_LC(character);
 440   case _CC_ENUM_BLANK:     return isBLANK_LC(character);
 441   case _CC_ENUM_CASED:     return isLOWER_LC(character)
 442           || isUPPER_LC(character);
 443   case _CC_ENUM_CNTRL:     return isCNTRL_LC(character);
 444   case _CC_ENUM_DIGIT:     return isDIGIT_LC(character);
 445   case _CC_ENUM_GRAPH:     return isGRAPH_LC(character);
 446   case _CC_ENUM_LOWER:     return isLOWER_LC(character);
 447   case _CC_ENUM_PRINT:     return isPRINT_LC(character);
 448   case _CC_ENUM_PSXSPC:    return isPSXSPC_LC(character);
 449   case _CC_ENUM_PUNCT:     return isPUNCT_LC(character);
 450   case _CC_ENUM_SPACE:     return isSPACE_LC(character);
 451   case _CC_ENUM_UPPER:     return isUPPER_LC(character);
 452   case _CC_ENUM_WORDCHAR:  return isWORDCHAR_LC(character);
 453   case _CC_ENUM_XDIGIT:    return isXDIGIT_LC(character);
 454   default:    /* VERTSPACE should never occur in locales */
 455    Perl_croak(aTHX_ "panic: isFOO_lc() has an unexpected character class '%d'", classnum);
 456  }
 457
 458  assert(0); /* NOTREACHED */
 459  return FALSE;
 460 }
 461
 462 STATIC bool
 463 S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character)
 464 {
 465  /* Returns a boolean as to whether or not the (well-formed) UTF-8-encoded
 466  * 'character' is a member of the Posix character class given by 'classnum'
 467  * that should be equivalent to a value in the typedef
 468  * '_char_class_number'.
 469  *
 470  * This just calls isFOO_lc on the code point for the character if it is in
 471  * the range 0-255.  Outside that range, all characters avoid Unicode
 472  * rules, ignoring any locale.  So use the Unicode function if this class
 473  * requires a swash, and use the Unicode macro otherwise. */
 474
 475  PERL_ARGS_ASSERT_ISFOO_UTF8_LC;
 476
 477  if (UTF8_IS_INVARIANT(*character)) {
 478   return isFOO_lc(classnum, *character);
 479  }
 480  else if (UTF8_IS_DOWNGRADEABLE_START(*character)) {
 481   return isFOO_lc(classnum,
 482       TWO_BYTE_UTF8_TO_UNI(*character, *(character + 1)));
 483  }
 484
 485  if (classnum < _FIRST_NON_SWASH_CC) {
 486
 487   /* Initialize the swash unless done already */
 488   if (! PL_utf8_swash_ptrs[classnum]) {
 489    U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
 490    PL_utf8_swash_ptrs[classnum] = _core_swash_init("utf8",
 491     swash_property_names[classnum], &PL_sv_undef, 1, 0, NULL, &flags);
 492   }
 493
 494   return cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum], (U8 *)
 495         character,
 496         TRUE /* is UTF */ ));
 497  }
 498
 499  switch ((_char_class_number) classnum) {
 500   case _CC_ENUM_SPACE:
 501   case _CC_ENUM_PSXSPC:    return is_XPERLSPACE_high(character);
 502
 503   case _CC_ENUM_BLANK:     return is_HORIZWS_high(character);
 504   case _CC_ENUM_XDIGIT:    return is_XDIGIT_high(character);
 505   case _CC_ENUM_VERTSPACE: return is_VERTWS_high(character);
 506   default:                 return 0;  /* Things like CNTRL are always
 507            below 256 */
 508  }
 509
 510  assert(0); /* NOTREACHED */
 511  return FALSE;
 512 }
 513
 514 /*
 515  * pregexec and friends
 516  */
 517
 518 #ifndef PERL_IN_XSUB_RE
 519 /*
 520  - pregexec - match a regexp against a string
 521  */
 522 I32
 523 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend,
 524   char *strbeg, I32 minend, SV *screamer, U32 nosave)
 525 /* stringarg: the point in the string at which to begin matching */
 526 /* strend:    pointer to null at end of string */
 527 /* strbeg:    real beginning of string */
 528 /* minend:    end of match must be >= minend bytes after stringarg. */
 529 /* screamer:  SV being matched: only used for utf8 flag, pos() etc; string
 530  *            itself is accessed via the pointers above */
 531 /* nosave:    For optimizations. */
 532 {
 533  PERL_ARGS_ASSERT_PREGEXEC;
 534
 535  return
 536   regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 537      nosave ? 0 : REXEC_COPY_STR);
 538 }
 539 #endif
 540
 541 /*
 542  * Need to implement the following flags for reg_anch:
 543  *
 544  * USE_INTUIT_NOML  - Useful to call re_intuit_start() first
 545  * USE_INTUIT_ML
 546  * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
 547  * INTUIT_AUTORITATIVE_ML
 548  * INTUIT_ONCE_NOML  - Intuit can match in one location only.
 549  * INTUIT_ONCE_ML
 550  *
 551  * Another flag for this function: SECOND_TIME (so that float substrs
 552  * with giant delta may be not rechecked).
 553  */
 554
 555 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 556
 557 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
 558    Otherwise, only SvCUR(sv) is used to get strbeg. */
 559
 560 /* XXXX We assume that strpos is strbeg unless sv. */
 561
 562 /* XXXX Some places assume that there is a fixed substring.
 563   An update may be needed if optimizer marks as "INTUITable"
 564   RExen without fixed substrings.  Similarly, it is assumed that
 565   lengths of all the strings are no more than minlen, thus they
 566   cannot come from lookahead.
 567   (Or minlen should take into account lookahead.)
 568   NOTE: Some of this comment is not correct. minlen does now take account
 569   of lookahead/behind. Further research is required. -- demerphq
 570
 571 */
 572
 573 /* A failure to find a constant substring means that there is no need to make
 574    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 575    finding a substring too deep into the string means that fewer calls to
 576    regtry() should be needed.
 577
 578    REx compiler's optimizer found 4 possible hints:
 579   a) Anchored substring;
 580   b) Fixed substring;
 581   c) Whether we are anchored (beginning-of-line or \G);
 582   d) First node (of those at offset 0) which may distinguish positions;
 583    We use a)b)d) and multiline-part of c), and try to find a position in the
 584    string which does not contradict any of them.
 585  */
 586
 587 /* Most of decisions we do here should have been done at compile time.
 588    The nodes of the REx which we used for the search should have been
 589    deleted from the finite automaton. */
 590
 591 char *
 592 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
 593      char *strend, const U32 flags, re_scream_pos_data *data)
 594 {
 595  dVAR;
 596  struct regexp *const prog = ReANY(rx);
 597  I32 start_shift = 0;
 598  /* Should be nonnegative! */
 599  I32 end_shift   = 0;
 600  char *s;
 601  SV *check;
 602  char *strbeg;
 603  char *t;
 604  const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
 605  I32 ml_anch;
 606  char *other_last = NULL; /* other substr checked before this */
 607  char *check_at = NULL;  /* check substr found at this pos */
 608  char *checked_upto = NULL;          /* how far into the string we have already checked using find_byclass*/
 609  const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
 610  RXi_GET_DECL(prog,progi);
 611  bool is_utf8_pat;
 612 #ifdef DEBUGGING
 613  const char * const i_strpos = strpos;
 614 #endif
 615  GET_RE_DEBUG_FLAGS_DECL;
 616
 617  PERL_ARGS_ASSERT_RE_INTUIT_START;
 618  PERL_UNUSED_ARG(flags);
 619  PERL_UNUSED_ARG(data);
 620
 621  RX_MATCH_UTF8_set(rx,utf8_target);
 622
 623  is_utf8_pat = cBOOL(RX_UTF8(rx));
 624
 625  DEBUG_EXECUTE_r(
 626   debug_start_match(rx, utf8_target, strpos, strend,
 627    sv ? "Guessing start of match in sv for"
 628    : "Guessing start of match in string for");
 629    );
 630
 631  /* CHR_DIST() would be more correct here but it makes things slow. */
 632  if (prog->minlen > strend - strpos) {
 633   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 634        "String too short... [re_intuit_start]\n"));
 635   goto fail;
 636  }
 637
 638  /* XXX we need to pass strbeg as a separate arg: the following is
 639  * guesswork and can be wrong... */
 640  if (sv && SvPOK(sv)) {
 641   char * p   = SvPVX(sv);
 642   STRLEN cur = SvCUR(sv);
 643   if (p <= strpos && strpos < p + cur) {
 644    strbeg = p;
 645    assert(p <= strend && strend <= p + cur);
 646   }
 647   else
 648    strbeg = strend - cur;
 649  }
 650  else
 651   strbeg = strpos;
 652
 653  PL_regeol = strend;
 654  if (utf8_target) {
 655   if (!prog->check_utf8 && prog->check_substr)
 656    to_utf8_substr(prog);
 657   check = prog->check_utf8;
 658  } else {
 659   if (!prog->check_substr && prog->check_utf8) {
 660    if (! to_byte_substr(prog)) {
 661     NON_UTF8_TARGET_BUT_UTF8_REQUIRED(fail);
 662    }
 663   }
 664   check = prog->check_substr;
 665  }
 666  if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */
 667   ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
 668      || ( (prog->extflags & RXf_ANCH_BOL)
 669       && !multiline ) ); /* Check after \n? */
 670
 671   if (!ml_anch) {
 672   if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
 673     && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
 674    /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
 675    && sv && !SvROK(sv)
 676    && (strpos != strbeg)) {
 677    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 678    goto fail;
 679   }
 680   if (prog->check_offset_min == prog->check_offset_max
 681    && !(prog->extflags & RXf_CANY_SEEN)
 682    && ! multiline)   /* /m can cause \n's to match that aren't
 683         accounted for in the string max length.
 684         See [perl #115242] */
 685   {
 686    /* Substring at constant offset from beg-of-str... */
 687    I32 slen;
 688
 689    s = HOP3c(strpos, prog->check_offset_min, strend);
 690
 691    if (SvTAIL(check)) {
 692     slen = SvCUR(check); /* >= 1 */
 693
 694     if ( strend - s > slen || strend - s < slen - 1
 695      || (strend - s == slen && strend[-1] != '\n')) {
 696      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 697      goto fail_finish;
 698     }
 699     /* Now should match s[0..slen-2] */
 700     slen--;
 701     if (slen && (*SvPVX_const(check) != *s
 702        || (slen > 1
 703         && memNE(SvPVX_const(check), s, slen)))) {
 704     report_neq:
 705      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 706      goto fail_finish;
 707     }
 708    }
 709    else if (*SvPVX_const(check) != *s
 710      || ((slen = SvCUR(check)) > 1
 711       && memNE(SvPVX_const(check), s, slen)))
 712     goto report_neq;
 713    check_at = s;
 714    goto success_at_start;
 715   }
 716   }
 717   /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 718   s = strpos;
 719   start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 720   end_shift = prog->check_end_shift;
 721
 722   if (!ml_anch) {
 723    const I32 end = prog->check_offset_max + CHR_SVLEN(check)
 724           - (SvTAIL(check) != 0);
 725    const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 726
 727    if (end_shift < eshift)
 728     end_shift = eshift;
 729   }
 730  }
 731  else {    /* Can match at random position */
 732   ml_anch = 0;
 733   s = strpos;
 734   start_shift = prog->check_offset_min;  /* okay to underestimate on CC */
 735   end_shift = prog->check_end_shift;
 736
 737   /* end shift should be non negative here */
 738  }
 739
 740 #ifdef QDEBUGGING /* 7/99: reports of failure (with the older version) */
 741  if (end_shift < 0)
 742   Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
 743     (IV)end_shift, RX_PRECOMP(prog));
 744 #endif
 745
 746   restart:
 747  /* Find a possible match in the region s..strend by looking for
 748  the "check" substring in the region corrected by start/end_shift. */
 749
 750  {
 751   I32 srch_start_shift = start_shift;
 752   I32 srch_end_shift = end_shift;
 753   U8* start_point;
 754   U8* end_point;
 755   if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
 756    srch_end_shift -= ((strbeg - s) - srch_start_shift);
 757    srch_start_shift = strbeg - s;
 758   }
 759  DEBUG_OPTIMISE_MORE_r({
 760   PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
 761    (IV)prog->check_offset_min,
 762    (IV)srch_start_shift,
 763    (IV)srch_end_shift,
 764    (IV)prog->check_end_shift);
 765  });
 766
 767   if (prog->extflags & RXf_CANY_SEEN) {
 768    start_point= (U8*)(s + srch_start_shift);
 769    end_point= (U8*)(strend - srch_end_shift);
 770   } else {
 771    start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
 772    end_point= HOP3(strend, -srch_end_shift, strbeg);
 773   }
 774   DEBUG_OPTIMISE_MORE_r({
 775    PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
 776     (int)(end_point - start_point),
 777     (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
 778     start_point);
 779   });
 780
 781   s = fbm_instr( start_point, end_point,
 782      check, multiline ? FBMrf_MULTILINE : 0);
 783  }
 784  /* Update the count-of-usability, remove useless subpatterns,
 785   unshift s.  */
 786
 787  DEBUG_EXECUTE_r({
 788   RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
 789    SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
 790   PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
 791       (s ? "Found" : "Did not find"),
 792    (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr)
 793     ? "anchored" : "floating"),
 794    quoted,
 795    RE_SV_TAIL(check),
 796    (s ? " at offset " : "...\n") );
 797  });
 798
 799  if (!s)
 800   goto fail_finish;
 801  /* Finish the diagnostic message */
 802  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 803
 804  /* XXX dmq: first branch is for positive lookbehind...
 805  Our check string is offset from the beginning of the pattern.
 806  So we need to do any stclass tests offset forward from that
 807  point. I think. :-(
 808  */
 809
 810
 811
 812  check_at=s;
 813
 814
 815  /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 816  Start with the other substr.
 817  XXXX no SCREAM optimization yet - and a very coarse implementation
 818  XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
 819     *always* match.  Probably should be marked during compile...
 820  Probably it is right to do no SCREAM here...
 821  */
 822
 823  if (utf8_target ? (prog->float_utf8 && prog->anchored_utf8)
 824     : (prog->float_substr && prog->anchored_substr))
 825  {
 826   /* Take into account the "other" substring. */
 827   /* XXXX May be hopelessly wrong for UTF... */
 828   if (!other_last)
 829    other_last = strpos;
 830   if (check == (utf8_target ? prog->float_utf8 : prog->float_substr)) {
 831   do_other_anchored:
 832    {
 833     char * const last = HOP3c(s, -start_shift, strbeg);
 834     char *last1, *last2;
 835     char * const saved_s = s;
 836     SV* must;
 837
 838     t = s - prog->check_offset_max;
 839     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 840      && (!utf8_target
 841       || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
 842        && t > strpos)))
 843      NOOP;
 844     else
 845      t = strpos;
 846     t = HOP3c(t, prog->anchored_offset, strend);
 847     if (t < other_last) /* These positions already checked */
 848      t = other_last;
 849     last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 850     if (last < last1)
 851      last1 = last;
 852     /* XXXX It is not documented what units *_offsets are in.
 853     We assume bytes, but this is clearly wrong.
 854     Meaning this code needs to be carefully reviewed for errors.
 855     dmq.
 856     */
 857
 858     /* On end-of-str: see comment below. */
 859     must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
 860     if (must == &PL_sv_undef) {
 861      s = (char*)NULL;
 862      DEBUG_r(must = prog->anchored_utf8); /* for debug */
 863     }
 864     else
 865      s = fbm_instr(
 866       (unsigned char*)t,
 867       HOP3(HOP3(last1, prog->anchored_offset, strend)
 868         + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
 869       must,
 870       multiline ? FBMrf_MULTILINE : 0
 871      );
 872     DEBUG_EXECUTE_r({
 873      RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
 874       SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 875      PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
 876       (s ? "Found" : "Contradicts"),
 877       quoted, RE_SV_TAIL(must));
 878     });
 879
 880
 881     if (!s) {
 882      if (last1 >= last2) {
 883       DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 884             ", giving up...\n"));
 885       goto fail_finish;
 886      }
 887      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 888       ", trying floating at offset %ld...\n",
 889       (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
 890      other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 891      s = HOP3c(last, 1, strend);
 892      goto restart;
 893     }
 894     else {
 895      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 896       (long)(s - i_strpos)));
 897      t = HOP3c(s, -prog->anchored_offset, strbeg);
 898      other_last = HOP3c(s, 1, strend);
 899      s = saved_s;
 900      if (t == strpos)
 901       goto try_at_start;
 902      goto try_at_offset;
 903     }
 904    }
 905   }
 906   else {  /* Take into account the floating substring. */
 907    char *last, *last1;
 908    char * const saved_s = s;
 909    SV* must;
 910
 911    t = HOP3c(s, -start_shift, strbeg);
 912    last1 = last =
 913     HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 914    if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 915     last = HOP3c(t, prog->float_max_offset, strend);
 916    s = HOP3c(t, prog->float_min_offset, strend);
 917    if (s < other_last)
 918     s = other_last;
 919  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 920    must = utf8_target ? prog->float_utf8 : prog->float_substr;
 921    /* fbm_instr() takes into account exact value of end-of-str
 922    if the check is SvTAIL(ed).  Since false positives are OK,
 923    and end-of-str is not later than strend we are OK. */
 924    if (must == &PL_sv_undef) {
 925     s = (char*)NULL;
 926     DEBUG_r(must = prog->float_utf8); /* for debug message */
 927    }
 928    else
 929     s = fbm_instr((unsigned char*)s,
 930        (unsigned char*)last + SvCUR(must)
 931         - (SvTAIL(must)!=0),
 932        must, multiline ? FBMrf_MULTILINE : 0);
 933    DEBUG_EXECUTE_r({
 934     RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
 935      SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 936     PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
 937      (s ? "Found" : "Contradicts"),
 938      quoted, RE_SV_TAIL(must));
 939    });
 940    if (!s) {
 941     if (last1 == last) {
 942      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 943            ", giving up...\n"));
 944      goto fail_finish;
 945     }
 946     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 947      ", trying anchored starting at offset %ld...\n",
 948      (long)(saved_s + 1 - i_strpos)));
 949     other_last = last;
 950     s = HOP3c(t, 1, strend);
 951     goto restart;
 952    }
 953    else {
 954     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 955      (long)(s - i_strpos)));
 956     other_last = s; /* Fix this later. --Hugo */
 957     s = saved_s;
 958     if (t == strpos)
 959      goto try_at_start;
 960     goto try_at_offset;
 961    }
 962   }
 963  }
 964
 965
 966  t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
 967
 968  DEBUG_OPTIMISE_MORE_r(
 969   PerlIO_printf(Perl_debug_log,
 970    "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
 971    (IV)prog->check_offset_min,
 972    (IV)prog->check_offset_max,
 973    (IV)(s-strpos),
 974    (IV)(t-strpos),
 975    (IV)(t-s),
 976    (IV)(strend-strpos)
 977   )
 978  );
 979
 980  if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 981   && (!utf8_target
 982    || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
 983     && t > strpos)))
 984  {
 985   /* Fixed substring is found far enough so that the match
 986   cannot start at strpos. */
 987  try_at_offset:
 988   if (ml_anch && t[-1] != '\n') {
 989    /* Eventually fbm_*() should handle this, but often
 990    anchored_offset is not 0, so this check will not be wasted. */
 991    /* XXXX In the code below we prefer to look for "^" even in
 992    presence of anchored substrings.  And we search even
 993    beyond the found float position.  These pessimizations
 994    are historical artefacts only.  */
 995   find_anchor:
 996    while (t < strend - prog->minlen) {
 997     if (*t == '\n') {
 998      if (t < check_at - prog->check_offset_min) {
 999       if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
1000        /* Since we moved from the found position,
1001        we definitely contradict the found anchored
1002        substr.  Due to the above check we do not
1003        contradict "check" substr.
1004        Thus we can arrive here only if check substr
1005        is float.  Redo checking for "other"=="fixed".
1006        */
1007        strpos = t + 1;
1008        DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
1009         PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
1010        goto do_other_anchored;
1011       }
1012       /* We don't contradict the found floating substring. */
1013       /* XXXX Why not check for STCLASS? */
1014       s = t + 1;
1015       DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
1016        PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
1017       goto set_useful;
1018      }
1019      /* Position contradicts check-string */
1020      /* XXXX probably better to look for check-string
1021      than for "\n", so one should lower the limit for t? */
1022      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
1023       PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
1024      other_last = strpos = s = t + 1;
1025      goto restart;
1026     }
1027     t++;
1028    }
1029    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
1030       PL_colors[0], PL_colors[1]));
1031    goto fail_finish;
1032   }
1033   else {
1034    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
1035       PL_colors[0], PL_colors[1]));
1036   }
1037   s = t;
1038  set_useful:
1039   ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
1040  }
1041  else {
1042   /* The found string does not prohibit matching at strpos,
1043   - no optimization of calling REx engine can be performed,
1044   unless it was an MBOL and we are not after MBOL,
1045   or a future STCLASS check will fail this. */
1046  try_at_start:
1047   /* Even in this situation we may use MBOL flag if strpos is offset
1048   wrt the start of the string. */
1049   if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
1050    && (strpos != strbeg) && strpos[-1] != '\n'
1051    /* May be due to an implicit anchor of m{.*foo}  */
1052    && !(prog->intflags & PREGf_IMPLICIT))
1053   {
1054    t = strpos;
1055    goto find_anchor;
1056   }
1057   DEBUG_EXECUTE_r( if (ml_anch)
1058    PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
1059       (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
1060   );
1061  success_at_start:
1062   if (!(prog->intflags & PREGf_NAUGHTY) /* XXXX If strpos moved? */
1063    && (utf8_target ? (
1064     prog->check_utf8  /* Could be deleted already */
1065     && --BmUSEFUL(prog->check_utf8) < 0
1066     && (prog->check_utf8 == prog->float_utf8)
1067    ) : (
1068     prog->check_substr  /* Could be deleted already */
1069     && --BmUSEFUL(prog->check_substr) < 0
1070     && (prog->check_substr == prog->float_substr)
1071    )))
1072   {
1073    /* If flags & SOMETHING - do not do it many times on the same match */
1074    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
1075    /* XXX Does the destruction order has to change with utf8_target? */
1076    SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
1077    SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
1078    prog->check_substr = prog->check_utf8 = NULL; /* disable */
1079    prog->float_substr = prog->float_utf8 = NULL; /* clear */
1080    check = NULL;   /* abort */
1081    s = strpos;
1082    /* XXXX If the check string was an implicit check MBOL, then we need to unset the relevant flag
1083      see http://bugs.activestate.com/show_bug.cgi?id=87173 */
1084    if (prog->intflags & PREGf_IMPLICIT)
1085     prog->extflags &= ~RXf_ANCH_MBOL;
1086    /* XXXX This is a remnant of the old implementation.  It
1087      looks wasteful, since now INTUIT can use many
1088      other heuristics. */
1089    prog->extflags &= ~RXf_USE_INTUIT;
1090    /* XXXX What other flags might need to be cleared in this branch? */
1091   }
1092   else
1093    s = strpos;
1094  }
1095
1096  /* Last resort... */
1097  /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
1098  /* trie stclasses are too expensive to use here, we are better off to
1099  leave it to regmatch itself */
1100  if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1101   /* minlen == 0 is possible if regstclass is \b or \B,
1102   and the fixed substr is ''$.
1103   Since minlen is already taken into account, s+1 is before strend;
1104   accidentally, minlen >= 1 guaranties no false positives at s + 1
1105   even for \b or \B.  But (minlen? 1 : 0) below assumes that
1106   regstclass does not come from lookahead...  */
1107   /* If regstclass takes bytelength more than 1: If charlength==1, OK.
1108   This leaves EXACTF-ish only, which are dealt with in find_byclass().  */
1109   const U8* const str = (U8*)STRING(progi->regstclass);
1110   const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1111      ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
1112      : 1);
1113   char * endpos;
1114   if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1115    endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
1116   else if (prog->float_substr || prog->float_utf8)
1117    endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
1118   else
1119    endpos= strend;
1120
1121   if (checked_upto < s)
1122   checked_upto = s;
1123   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
1124          (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
1125
1126   t = s;
1127   s = find_byclass(prog, progi->regstclass, checked_upto, endpos,
1128        NULL, is_utf8_pat);
1129   if (s) {
1130    checked_upto = s;
1131   } else {
1132 #ifdef DEBUGGING
1133    const char *what = NULL;
1134 #endif
1135    if (endpos == strend) {
1136     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1137         "Could not match STCLASS...\n") );
1138     goto fail;
1139    }
1140    DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1141         "This position contradicts STCLASS...\n") );
1142    if ((prog->extflags & RXf_ANCH) && !ml_anch)
1143     goto fail;
1144    checked_upto = HOPBACKc(endpos, start_shift);
1145    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
1146          (IV)start_shift, (IV)(check_at - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
1147    /* Contradict one of substrings */
1148    if (prog->anchored_substr || prog->anchored_utf8) {
1149     if ((utf8_target ? prog->anchored_utf8 : prog->anchored_substr) == check) {
1150      DEBUG_EXECUTE_r( what = "anchored" );
1151     hop_and_restart:
1152      s = HOP3c(t, 1, strend);
1153      if (s + start_shift + end_shift > strend) {
1154       /* XXXX Should be taken into account earlier? */
1155       DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1156            "Could not match STCLASS...\n") );
1157       goto fail;
1158      }
1159      if (!check)
1160       goto giveup;
1161      DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1162         "Looking for %s substr starting at offset %ld...\n",
1163         what, (long)(s + start_shift - i_strpos)) );
1164      goto restart;
1165     }
1166     /* Have both, check_string is floating */
1167     if (t + start_shift >= check_at) /* Contradicts floating=check */
1168      goto retry_floating_check;
1169     /* Recheck anchored substring, but not floating... */
1170     s = check_at;
1171     if (!check)
1172      goto giveup;
1173     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1174       "Looking for anchored substr starting at offset %ld...\n",
1175       (long)(other_last - i_strpos)) );
1176     goto do_other_anchored;
1177    }
1178    /* Another way we could have checked stclass at the
1179    current position only: */
1180    if (ml_anch) {
1181     s = t = t + 1;
1182     if (!check)
1183      goto giveup;
1184     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1185       "Looking for /%s^%s/m starting at offset %ld...\n",
1186       PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
1187     goto try_at_offset;
1188    }
1189    if (!(utf8_target ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
1190     goto fail;
1191    /* Check is floating substring. */
1192   retry_floating_check:
1193    t = check_at - start_shift;
1194    DEBUG_EXECUTE_r( what = "floating" );
1195    goto hop_and_restart;
1196   }
1197   if (t != s) {
1198    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1199       "By STCLASS: moving %ld --> %ld\n",
1200         (long)(t - i_strpos), (long)(s - i_strpos))
1201     );
1202   }
1203   else {
1204    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1205         "Does not contradict STCLASS...\n");
1206     );
1207   }
1208  }
1209   giveup:
1210  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
1211       PL_colors[4], (check ? "Guessed" : "Giving up"),
1212       PL_colors[5], (long)(s - i_strpos)) );
1213  return s;
1214
1215   fail_finish:    /* Substring not found */
1216  if (prog->check_substr || prog->check_utf8)  /* could be removed already */
1217   BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1218   fail:
1219  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1220       PL_colors[4], PL_colors[5]));
1221  return NULL;
1222 }
1223
1224 #define DECL_TRIE_TYPE(scan) \
1225  const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
1226      trie_type = ((scan->flags == EXACT) \
1227        ? (utf8_target ? trie_utf8 : trie_plain) \
1228        : (utf8_target ? trie_utf8_fold : trie_latin_utf8_fold))
1229
1230 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \
1231 STMT_START {                               \
1232  STRLEN skiplen;                                                                 \
1233  switch (trie_type) {                                                            \
1234  case trie_utf8_fold:                                                            \
1235   if ( foldlen>0 ) {                                                          \
1236    uvc = utf8n_to_uvuni( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1237    foldlen -= len;                                                         \
1238    uscan += len;                                                           \
1239    len=0;                                                                  \
1240   } else {                                                                    \
1241    uvc = to_utf8_fold( (const U8*) uc, foldbuf, &foldlen );                \
1242    len = UTF8SKIP(uc);                                                     \
1243    skiplen = UNISKIP( uvc );                                               \
1244    foldlen -= skiplen;                                                     \
1245    uscan = foldbuf + skiplen;                                              \
1246   }                                                                           \
1247   break;                                                                      \
1248  case trie_latin_utf8_fold:                                                      \
1249   if ( foldlen>0 ) {                                                          \
1250    uvc = utf8n_to_uvuni( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1251    foldlen -= len;                                                         \
1252    uscan += len;                                                           \
1253    len=0;                                                                  \
1254   } else {                                                                    \
1255    len = 1;                                                                \
1256    uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                 \
1257    skiplen = UNISKIP( uvc );                                               \
1258    foldlen -= skiplen;                                                     \
1259    uscan = foldbuf + skiplen;                                              \
1260   }                                                                           \
1261   break;                                                                      \
1262  case trie_utf8:                                                                 \
1263   uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags );        \
1264   break;                                                                      \
1265  case trie_plain:                                                                \
1266   uvc = (UV)*uc;                                                              \
1267   len = 1;                                                                    \
1268  }                                                                               \
1269  if (uvc < 256) {                                                                \
1270   charid = trie->charmap[ uvc ];                                              \
1271  }                                                                               \
1272  else {                                                                          \
1273   charid = 0;                                                                 \
1274   if (widecharmap) {                                                          \
1275    SV** const svpp = hv_fetch(widecharmap,                                 \
1276       (char*)&uvc, sizeof(UV), 0);                                \
1277    if (svpp)                                                               \
1278     charid = (U16)SvIV(*svpp);                                          \
1279   }                                                                           \
1280  }                                                                               \
1281 } STMT_END
1282
1283 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1284 STMT_START {                                              \
1285  while (s <= e) {                                      \
1286   if ( (CoNd)                                       \
1287    && (ln == 1 || folder(s, pat_string, ln))    \
1288    && (!reginfo || regtry(reginfo, &s)) )       \
1289    goto got_it;                                  \
1290   s++;                                              \
1291  }                                                     \
1292 } STMT_END
1293
1294 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1295 STMT_START {                                          \
1296  while (s < strend) {                              \
1297   CoDe                                          \
1298   s += UTF8SKIP(s);                             \
1299  }                                                 \
1300 } STMT_END
1301
1302 #define REXEC_FBC_SCAN(CoDe)                          \
1303 STMT_START {                                          \
1304  while (s < strend) {                              \
1305   CoDe                                          \
1306   s++;                                          \
1307  }                                                 \
1308 } STMT_END
1309
1310 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1311 REXEC_FBC_UTF8_SCAN(                                  \
1312  if (CoNd) {                                       \
1313   if (tmp && (!reginfo || regtry(reginfo, &s))) \
1314    goto got_it;                              \
1315   else                                          \
1316    tmp = doevery;                            \
1317  }                                                 \
1318  else                                              \
1319   tmp = 1;                                      \
1320 )
1321
1322 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1323 REXEC_FBC_SCAN(                                       \
1324  if (CoNd) {                                       \
1325   if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1326    goto got_it;                              \
1327   else                                          \
1328    tmp = doevery;                            \
1329  }                                                 \
1330  else                                              \
1331   tmp = 1;                                      \
1332 )
1333
1334 #define REXEC_FBC_TRYIT               \
1335 if ((!reginfo || regtry(reginfo, &s))) \
1336  goto got_it
1337
1338 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd)                         \
1339  if (utf8_target) {                                             \
1340   REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1341  }                                                          \
1342  else {                                                     \
1343   REXEC_FBC_CLASS_SCAN(CoNd);                            \
1344  }
1345
1346 #define DUMP_EXEC_POS(li,s,doutf8) \
1347  dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1348
1349
1350 #define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1351   tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';                         \
1352   tmp = TEST_NON_UTF8(tmp);                                              \
1353   REXEC_FBC_UTF8_SCAN(                                                   \
1354    if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1355     tmp = !tmp;                                                    \
1356     IF_SUCCESS;                                                    \
1357    }                                                                  \
1358    else {                                                             \
1359     IF_FAIL;                                                       \
1360    }                                                                  \
1361   );                                                                     \
1362
1363 #define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \
1364   if (s == PL_bostr) {                                                   \
1365    tmp = '\n';                                                        \
1366   }                                                                      \
1367   else {                                                                 \
1368    U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);                 \
1369    tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);       \
1370   }                                                                      \
1371   tmp = TeSt1_UtF8;                                                      \
1372   LOAD_UTF8_CHARCLASS_ALNUM();                                                                \
1373   REXEC_FBC_UTF8_SCAN(                                                   \
1374    if (tmp == ! (TeSt2_UtF8)) { \
1375     tmp = !tmp;                                                    \
1376     IF_SUCCESS;                                                    \
1377    }                                                                  \
1378    else {                                                             \
1379     IF_FAIL;                                                       \
1380    }                                                                  \
1381   );                                                                     \
1382
1383 /* The only difference between the BOUND and NBOUND cases is that
1384  * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
1385  * NBOUND.  This is accomplished by passing it in either the if or else clause,
1386  * with the other one being empty */
1387 #define FBC_BOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1388  FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1389
1390 #define FBC_BOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1391  FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1392
1393 #define FBC_NBOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1394  FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1395
1396 #define FBC_NBOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1397  FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1398
1399
1400 /* Common to the BOUND and NBOUND cases.  Unfortunately the UTF8 tests need to
1401  * be passed in completely with the variable name being tested, which isn't
1402  * such a clean interface, but this is easier to read than it was before.  We
1403  * are looking for the boundary (or non-boundary between a word and non-word
1404  * character.  The utf8 and non-utf8 cases have the same logic, but the details
1405  * must be different.  Find the "wordness" of the character just prior to this
1406  * one, and compare it with the wordness of this one.  If they differ, we have
1407  * a boundary.  At the beginning of the string, pretend that the previous
1408  * character was a new-line */
1409 #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1410  if (utf8_target) {                                                         \
1411     UTF8_CODE \
1412  }                                                                          \
1413  else {  /* Not utf8 */                                                     \
1414   tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';                         \
1415   tmp = TEST_NON_UTF8(tmp);                                              \
1416   REXEC_FBC_SCAN(                                                        \
1417    if (tmp == ! TEST_NON_UTF8((U8) *s)) {                             \
1418     tmp = !tmp;                                                    \
1419     IF_SUCCESS;                                                    \
1420    }                                                                  \
1421    else {                                                             \
1422     IF_FAIL;                                                       \
1423    }                                                                  \
1424   );                                                                     \
1425  }                                                                          \
1426  if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))           \
1427   goto got_it;
1428
1429 /* We know what class REx starts with.  Try to find this position... */
1430 /* if reginfo is NULL, its a dryrun */
1431 /* annoyingly all the vars in this routine have different names from their counterparts
1432    in regmatch. /grrr */
1433
1434 STATIC char *
1435 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1436  const char *strend, regmatch_info *reginfo, bool is_utf8_pat)
1437 {
1438  dVAR;
1439  const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1440  char *pat_string;   /* The pattern's exactish string */
1441  char *pat_end;     /* ptr to end char of pat_string */
1442  re_fold_t folder; /* Function for computing non-utf8 folds */
1443  const U8 *fold_array;   /* array for folding ords < 256 */
1444  STRLEN ln;
1445  STRLEN lnc;
1446  U8 c1;
1447  U8 c2;
1448  char *e;
1449  I32 tmp = 1; /* Scratch variable? */
1450  const bool utf8_target = PL_reg_match_utf8;
1451  UV utf8_fold_flags = 0;
1452  bool to_complement = FALSE; /* Invert the result?  Taking the xor of this
1453         with a result inverts that result, as 0^1 =
1454         1 and 1^1 = 0 */
1455  _char_class_number classnum;
1456
1457  RXi_GET_DECL(prog,progi);
1458
1459  PERL_ARGS_ASSERT_FIND_BYCLASS;
1460
1461  /* We know what class it must start with. */
1462  switch (OP(c)) {
1463  case ANYOF:
1464  case ANYOF_SYNTHETIC:
1465  case ANYOF_WARN_SUPER:
1466   if (utf8_target) {
1467    REXEC_FBC_UTF8_CLASS_SCAN(
1468      reginclass(prog, c, (U8*)s, utf8_target));
1469   }
1470   else {
1471    REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
1472   }
1473   break;
1474  case CANY:
1475   REXEC_FBC_SCAN(
1476    if (tmp && (!reginfo || regtry(reginfo, &s)))
1477     goto got_it;
1478    else
1479     tmp = doevery;
1480   );
1481   break;
1482
1483  case EXACTFA:
1484   if (is_utf8_pat || utf8_target) {
1485    utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
1486    goto do_exactf_utf8;
1487   }
1488   fold_array = PL_fold_latin1;    /* Latin1 folds are not affected by */
1489   folder = foldEQ_latin1;         /* /a, except the sharp s one which */
1490   goto do_exactf_non_utf8; /* isn't dealt with by these */
1491
1492  case EXACTF:
1493   if (utf8_target) {
1494
1495    /* regcomp.c already folded this if pattern is in UTF-8 */
1496    utf8_fold_flags = 0;
1497    goto do_exactf_utf8;
1498   }
1499   fold_array = PL_fold;
1500   folder = foldEQ;
1501   goto do_exactf_non_utf8;
1502
1503  case EXACTFL:
1504   if (is_utf8_pat || utf8_target) {
1505    utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
1506    goto do_exactf_utf8;
1507   }
1508   fold_array = PL_fold_locale;
1509   folder = foldEQ_locale;
1510   goto do_exactf_non_utf8;
1511
1512  case EXACTFU_SS:
1513   if (is_utf8_pat) {
1514    utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
1515   }
1516   goto do_exactf_utf8;
1517
1518  case EXACTFU_TRICKYFOLD:
1519  case EXACTFU:
1520   if (is_utf8_pat || utf8_target) {
1521    utf8_fold_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
1522    goto do_exactf_utf8;
1523   }
1524
1525   /* Any 'ss' in the pattern should have been replaced by regcomp,
1526   * so we don't have to worry here about this single special case
1527   * in the Latin1 range */
1528   fold_array = PL_fold_latin1;
1529   folder = foldEQ_latin1;
1530
1531   /* FALL THROUGH */
1532
1533  do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there
1534       are no glitches with fold-length differences
1535       between the target string and pattern */
1536
1537   /* The idea in the non-utf8 EXACTF* cases is to first find the
1538   * first character of the EXACTF* node and then, if necessary,
1539   * case-insensitively compare the full text of the node.  c1 is the
1540   * first character.  c2 is its fold.  This logic will not work for
1541   * Unicode semantics and the german sharp ss, which hence should
1542   * not be compiled into a node that gets here. */
1543   pat_string = STRING(c);
1544   ln  = STR_LEN(c); /* length to match in octets/bytes */
1545
1546   /* We know that we have to match at least 'ln' bytes (which is the
1547   * same as characters, since not utf8).  If we have to match 3
1548   * characters, and there are only 2 availabe, we know without
1549   * trying that it will fail; so don't start a match past the
1550   * required minimum number from the far end */
1551   e = HOP3c(strend, -((I32)ln), s);
1552
1553   if (!reginfo && e < s) {
1554    e = s;   /* Due to minlen logic of intuit() */
1555   }
1556
1557   c1 = *pat_string;
1558   c2 = fold_array[c1];
1559   if (c1 == c2) { /* If char and fold are the same */
1560    REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1561   }
1562   else {
1563    REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1564   }
1565   break;
1566
1567  do_exactf_utf8:
1568  {
1569   unsigned expansion;
1570
1571   /* If one of the operands is in utf8, we can't use the simpler folding
1572   * above, due to the fact that many different characters can have the
1573   * same fold, or portion of a fold, or different- length fold */
1574   pat_string = STRING(c);
1575   ln  = STR_LEN(c); /* length to match in octets/bytes */
1576   pat_end = pat_string + ln;
1577   lnc = is_utf8_pat       /* length to match in characters */
1578     ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
1579     : ln;
1580
1581   /* We have 'lnc' characters to match in the pattern, but because of
1582   * multi-character folding, each character in the target can match
1583   * up to 3 characters (Unicode guarantees it will never exceed
1584   * this) if it is utf8-encoded; and up to 2 if not (based on the
1585   * fact that the Latin 1 folds are already determined, and the
1586   * only multi-char fold in that range is the sharp-s folding to
1587   * 'ss'.  Thus, a pattern character can match as little as 1/3 of a
1588   * string character.  Adjust lnc accordingly, rounding up, so that
1589   * if we need to match at least 4+1/3 chars, that really is 5. */
1590   expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2;
1591   lnc = (lnc + expansion - 1) / expansion;
1592
1593   /* As in the non-UTF8 case, if we have to match 3 characters, and
1594   * only 2 are left, it's guaranteed to fail, so don't start a
1595   * match that would require us to go beyond the end of the string
1596   */
1597   e = HOP3c(strend, -((I32)lnc), s);
1598
1599   if (!reginfo && e < s) {
1600    e = s;   /* Due to minlen logic of intuit() */
1601   }
1602
1603   /* XXX Note that we could recalculate e to stop the loop earlier,
1604   * as the worst case expansion above will rarely be met, and as we
1605   * go along we would usually find that e moves further to the left.
1606   * This would happen only after we reached the point in the loop
1607   * where if there were no expansion we should fail.  Unclear if
1608   * worth the expense */
1609
1610   while (s <= e) {
1611    char *my_strend= (char *)strend;
1612    if (foldEQ_utf8_flags(s, &my_strend, 0,  utf8_target,
1613     pat_string, NULL, ln, is_utf8_pat, utf8_fold_flags)
1614     && (!reginfo || regtry(reginfo, &s)) )
1615    {
1616     goto got_it;
1617    }
1618    s += (utf8_target) ? UTF8SKIP(s) : 1;
1619   }
1620   break;
1621  }
1622  case BOUNDL:
1623   RXp_MATCH_TAINTED_on(prog);
1624   FBC_BOUND(isWORDCHAR_LC,
1625     isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(tmp)),
1626     isWORDCHAR_LC_utf8((U8*)s));
1627   break;
1628  case NBOUNDL:
1629   RXp_MATCH_TAINTED_on(prog);
1630   FBC_NBOUND(isWORDCHAR_LC,
1631     isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(tmp)),
1632     isWORDCHAR_LC_utf8((U8*)s));
1633   break;
1634  case BOUND:
1635   FBC_BOUND(isWORDCHAR,
1636     isWORDCHAR_uni(tmp),
1637     cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
1638   break;
1639  case BOUNDA:
1640   FBC_BOUND_NOLOAD(isWORDCHAR_A,
1641       isWORDCHAR_A(tmp),
1642       isWORDCHAR_A((U8*)s));
1643   break;
1644  case NBOUND:
1645   FBC_NBOUND(isWORDCHAR,
1646     isWORDCHAR_uni(tmp),
1647     cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
1648   break;
1649  case NBOUNDA:
1650   FBC_NBOUND_NOLOAD(isWORDCHAR_A,
1651       isWORDCHAR_A(tmp),
1652       isWORDCHAR_A((U8*)s));
1653   break;
1654  case BOUNDU:
1655   FBC_BOUND(isWORDCHAR_L1,
1656     isWORDCHAR_uni(tmp),
1657     cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
1658   break;
1659  case NBOUNDU:
1660   FBC_NBOUND(isWORDCHAR_L1,
1661     isWORDCHAR_uni(tmp),
1662     cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
1663   break;
1664  case LNBREAK:
1665   REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend),
1666       is_LNBREAK_latin1_safe(s, strend)
1667   );
1668   break;
1669
1670  /* The argument to all the POSIX node types is the class number to pass to
1671  * _generic_isCC() to build a mask for searching in PL_charclass[] */
1672
1673  case NPOSIXL:
1674   to_complement = 1;
1675   /* FALLTHROUGH */
1676
1677  case POSIXL:
1678   RXp_MATCH_TAINTED_on(prog);
1679   REXEC_FBC_CSCAN(to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s)),
1680       to_complement ^ cBOOL(isFOO_lc(FLAGS(c), *s)));
1681   break;
1682
1683  case NPOSIXD:
1684   to_complement = 1;
1685   /* FALLTHROUGH */
1686
1687  case POSIXD:
1688   if (utf8_target) {
1689    goto posix_utf8;
1690   }
1691   goto posixa;
1692
1693  case NPOSIXA:
1694   if (utf8_target) {
1695    /* The complement of something that matches only ASCII matches all
1696    * UTF-8 variant code points, plus everything in ASCII that isn't
1697    * in the class */
1698    REXEC_FBC_UTF8_CLASS_SCAN(! UTF8_IS_INVARIANT(*s)
1699          || ! _generic_isCC_A(*s, FLAGS(c)));
1700    break;
1701   }
1702
1703   to_complement = 1;
1704   /* FALLTHROUGH */
1705
1706  case POSIXA:
1707  posixa:
1708   /* Don't need to worry about utf8, as it can match only a single
1709   * byte invariant character. */
1710   REXEC_FBC_CLASS_SCAN(
1711       to_complement ^ cBOOL(_generic_isCC_A(*s, FLAGS(c))));
1712   break;
1713
1714  case NPOSIXU:
1715   to_complement = 1;
1716   /* FALLTHROUGH */
1717
1718  case POSIXU:
1719   if (! utf8_target) {
1720    REXEC_FBC_CLASS_SCAN(to_complement ^ cBOOL(_generic_isCC(*s,
1721                  FLAGS(c))));
1722   }
1723   else {
1724
1725  posix_utf8:
1726    classnum = (_char_class_number) FLAGS(c);
1727    if (classnum < _FIRST_NON_SWASH_CC) {
1728     while (s < strend) {
1729
1730      /* We avoid loading in the swash as long as possible, but
1731      * should we have to, we jump to a separate loop.  This
1732      * extra 'if' statement is what keeps this code from being
1733      * just a call to REXEC_FBC_UTF8_CLASS_SCAN() */
1734      if (UTF8_IS_ABOVE_LATIN1(*s)) {
1735       goto found_above_latin1;
1736      }
1737      if ((UTF8_IS_INVARIANT(*s)
1738       && to_complement ^ cBOOL(_generic_isCC((U8) *s,
1739                 classnum)))
1740       || (UTF8_IS_DOWNGRADEABLE_START(*s)
1741        && to_complement ^ cBOOL(
1742         _generic_isCC(TWO_BYTE_UTF8_TO_UNI(*s, *(s + 1)),
1743            classnum))))
1744      {
1745       if (tmp && (!reginfo || regtry(reginfo, &s)))
1746        goto got_it;
1747       else {
1748        tmp = doevery;
1749       }
1750      }
1751      else {
1752       tmp = 1;
1753      }
1754      s += UTF8SKIP(s);
1755     }
1756    }
1757    else switch (classnum) {    /* These classes are implemented as
1758           macros */
1759     case _CC_ENUM_SPACE: /* XXX would require separate code if we
1760           revert the change of \v matching this */
1761      /* FALL THROUGH */
1762
1763     case _CC_ENUM_PSXSPC:
1764      REXEC_FBC_UTF8_CLASS_SCAN(
1765           to_complement ^ cBOOL(isSPACE_utf8(s)));
1766      break;
1767
1768     case _CC_ENUM_BLANK:
1769      REXEC_FBC_UTF8_CLASS_SCAN(
1770           to_complement ^ cBOOL(isBLANK_utf8(s)));
1771      break;
1772
1773     case _CC_ENUM_XDIGIT:
1774      REXEC_FBC_UTF8_CLASS_SCAN(
1775          to_complement ^ cBOOL(isXDIGIT_utf8(s)));
1776      break;
1777
1778     case _CC_ENUM_VERTSPACE:
1779      REXEC_FBC_UTF8_CLASS_SCAN(
1780          to_complement ^ cBOOL(isVERTWS_utf8(s)));
1781      break;
1782
1783     case _CC_ENUM_CNTRL:
1784      REXEC_FBC_UTF8_CLASS_SCAN(
1785           to_complement ^ cBOOL(isCNTRL_utf8(s)));
1786      break;
1787
1788     default:
1789      Perl_croak(aTHX_ "panic: find_byclass() node %d='%s' has an unexpected character class '%d'", OP(c), PL_reg_name[OP(c)], classnum);
1790      assert(0); /* NOTREACHED */
1791    }
1792   }
1793   break;
1794
1795  found_above_latin1:   /* Here we have to load a swash to get the result
1796        for the current code point */
1797   if (! PL_utf8_swash_ptrs[classnum]) {
1798    U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
1799    PL_utf8_swash_ptrs[classnum] =
1800      _core_swash_init("utf8", swash_property_names[classnum],
1801          &PL_sv_undef, 1, 0, NULL, &flags);
1802   }
1803
1804   /* This is a copy of the loop above for swash classes, though using the
1805   * FBC macro instead of being expanded out.  Since we've loaded the
1806   * swash, we don't have to check for that each time through the loop */
1807   REXEC_FBC_UTF8_CLASS_SCAN(
1808     to_complement ^ cBOOL(_generic_utf8(
1809          classnum,
1810          s,
1811          swash_fetch(PL_utf8_swash_ptrs[classnum],
1812             (U8 *) s, TRUE))));
1813   break;
1814
1815  case AHOCORASICKC:
1816  case AHOCORASICK:
1817   {
1818    DECL_TRIE_TYPE(c);
1819    /* what trie are we using right now */
1820    reg_ac_data *aho = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1821    reg_trie_data *trie = (reg_trie_data*)progi->data->data[ aho->trie ];
1822    HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1823
1824    const char *last_start = strend - trie->minlen;
1825 #ifdef DEBUGGING
1826    const char *real_start = s;
1827 #endif
1828    STRLEN maxlen = trie->maxlen;
1829    SV *sv_points;
1830    U8 **points; /* map of where we were in the input string
1831        when reading a given char. For ASCII this
1832        is unnecessary overhead as the relationship
1833        is always 1:1, but for Unicode, especially
1834        case folded Unicode this is not true. */
1835    U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1836    U8 *bitmap=NULL;
1837
1838
1839    GET_RE_DEBUG_FLAGS_DECL;
1840
1841    /* We can't just allocate points here. We need to wrap it in
1842    * an SV so it gets freed properly if there is a croak while
1843    * running the match */
1844    ENTER;
1845    SAVETMPS;
1846    sv_points=newSV(maxlen * sizeof(U8 *));
1847    SvCUR_set(sv_points,
1848     maxlen * sizeof(U8 *));
1849    SvPOK_on(sv_points);
1850    sv_2mortal(sv_points);
1851    points=(U8**)SvPV_nolen(sv_points );
1852    if ( trie_type != trie_utf8_fold
1853     && (trie->bitmap || OP(c)==AHOCORASICKC) )
1854    {
1855     if (trie->bitmap)
1856      bitmap=(U8*)trie->bitmap;
1857     else
1858      bitmap=(U8*)ANYOF_BITMAP(c);
1859    }
1860    /* this is the Aho-Corasick algorithm modified a touch
1861    to include special handling for long "unknown char" sequences.
1862    The basic idea being that we use AC as long as we are dealing
1863    with a possible matching char, when we encounter an unknown char
1864    (and we have not encountered an accepting state) we scan forward
1865    until we find a legal starting char.
1866    AC matching is basically that of trie matching, except that when
1867    we encounter a failing transition, we fall back to the current
1868    states "fail state", and try the current char again, a process
1869    we repeat until we reach the root state, state 1, or a legal
1870    transition. If we fail on the root state then we can either
1871    terminate if we have reached an accepting state previously, or
1872    restart the entire process from the beginning if we have not.
1873
1874    */
1875    while (s <= last_start) {
1876     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1877     U8 *uc = (U8*)s;
1878     U16 charid = 0;
1879     U32 base = 1;
1880     U32 state = 1;
1881     UV uvc = 0;
1882     STRLEN len = 0;
1883     STRLEN foldlen = 0;
1884     U8 *uscan = (U8*)NULL;
1885     U8 *leftmost = NULL;
1886 #ifdef DEBUGGING
1887     U32 accepted_word= 0;
1888 #endif
1889     U32 pointpos = 0;
1890
1891     while ( state && uc <= (U8*)strend ) {
1892      int failed=0;
1893      U32 word = aho->states[ state ].wordnum;
1894
1895      if( state==1 ) {
1896       if ( bitmap ) {
1897        DEBUG_TRIE_EXECUTE_r(
1898         if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1899          dump_exec_pos( (char *)uc, c, strend, real_start,
1900           (char *)uc, utf8_target );
1901          PerlIO_printf( Perl_debug_log,
1902           " Scanning for legal start char...\n");
1903         }
1904        );
1905        if (utf8_target) {
1906         while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1907          uc += UTF8SKIP(uc);
1908         }
1909        } else {
1910         while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1911          uc++;
1912         }
1913        }
1914        s= (char *)uc;
1915       }
1916       if (uc >(U8*)last_start) break;
1917      }
1918
1919      if ( word ) {
1920       U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
1921       if (!leftmost || lpos < leftmost) {
1922        DEBUG_r(accepted_word=word);
1923        leftmost= lpos;
1924       }
1925       if (base==0) break;
1926
1927      }
1928      points[pointpos++ % maxlen]= uc;
1929      if (foldlen || uc < (U8*)strend) {
1930       REXEC_TRIE_READ_CHAR(trie_type, trie,
1931           widecharmap, uc,
1932           uscan, len, uvc, charid, foldlen,
1933           foldbuf, uniflags);
1934       DEBUG_TRIE_EXECUTE_r({
1935        dump_exec_pos( (char *)uc, c, strend,
1936           real_start, s, utf8_target);
1937        PerlIO_printf(Perl_debug_log,
1938         " Charid:%3u CP:%4"UVxf" ",
1939         charid, uvc);
1940       });
1941      }
1942      else {
1943       len = 0;
1944       charid = 0;
1945      }
1946
1947
1948      do {
1949 #ifdef DEBUGGING
1950       word = aho->states[ state ].wordnum;
1951 #endif
1952       base = aho->states[ state ].trans.base;
1953
1954       DEBUG_TRIE_EXECUTE_r({
1955        if (failed)
1956         dump_exec_pos( (char *)uc, c, strend, real_start,
1957          s,   utf8_target );
1958        PerlIO_printf( Perl_debug_log,
1959         "%sState: %4"UVxf", word=%"UVxf,
1960         failed ? " Fail transition to " : "",
1961         (UV)state, (UV)word);
1962       });
1963       if ( base ) {
1964        U32 tmp;
1965        I32 offset;
1966        if (charid &&
1967         ( ((offset = base + charid
1968          - 1 - trie->uniquecharcount)) >= 0)
1969         && ((U32)offset < trie->lasttrans)
1970         && trie->trans[offset].check == state
1971         && (tmp=trie->trans[offset].next))
1972        {
1973         DEBUG_TRIE_EXECUTE_r(
1974          PerlIO_printf( Perl_debug_log," - legal\n"));
1975         state = tmp;
1976         break;
1977        }
1978        else {
1979         DEBUG_TRIE_EXECUTE_r(
1980          PerlIO_printf( Perl_debug_log," - fail\n"));
1981         failed = 1;
1982         state = aho->fail[state];
1983        }
1984       }
1985       else {
1986        /* we must be accepting here */
1987        DEBUG_TRIE_EXECUTE_r(
1988          PerlIO_printf( Perl_debug_log," - accepting\n"));
1989        failed = 1;
1990        break;
1991       }
1992      } while(state);
1993      uc += len;
1994      if (failed) {
1995       if (leftmost)
1996        break;
1997       if (!state) state = 1;
1998      }
1999     }
2000     if ( aho->states[ state ].wordnum ) {
2001      U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
2002      if (!leftmost || lpos < leftmost) {
2003       DEBUG_r(accepted_word=aho->states[ state ].wordnum);
2004       leftmost = lpos;
2005      }
2006     }
2007     if (leftmost) {
2008      s = (char*)leftmost;
2009      DEBUG_TRIE_EXECUTE_r({
2010       PerlIO_printf(
2011        Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
2012        (UV)accepted_word, (IV)(s - real_start)
2013       );
2014      });
2015      if (!reginfo || regtry(reginfo, &s)) {
2016       FREETMPS;
2017       LEAVE;
2018       goto got_it;
2019      }
2020      s = HOPc(s,1);
2021      DEBUG_TRIE_EXECUTE_r({
2022       PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
2023      });
2024     } else {
2025      DEBUG_TRIE_EXECUTE_r(
2026       PerlIO_printf( Perl_debug_log,"No match.\n"));
2027      break;
2028     }
2029    }
2030    FREETMPS;
2031    LEAVE;
2032   }
2033   break;
2034  default:
2035   Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
2036   break;
2037  }
2038  return 0;
2039   got_it:
2040  return s;
2041 }
2042
2043
2044 /*
2045  - regexec_flags - match a regexp against a string
2046  */
2047 I32
2048 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
2049    char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
2050 /* stringarg: the point in the string at which to begin matching */
2051 /* strend:    pointer to null at end of string */
2052 /* strbeg:    real beginning of string */
2053 /* minend:    end of match must be >= minend bytes after stringarg. */
2054 /* sv:        SV being matched: only used for utf8 flag, pos() etc; string
2055  *            itself is accessed via the pointers above */
2056 /* data:      May be used for some additional optimizations.
2057    Currently its only used, with a U32 cast, for transmitting
2058    the ganch offset when doing a /g match. This will change */
2059 /* nosave:    For optimizations. */
2060
2061 {
2062  dVAR;
2063  struct regexp *const prog = ReANY(rx);
2064  char *s;
2065  regnode *c;
2066  char *startpos = stringarg;
2067  I32 minlen;  /* must match at least this many chars */
2068  I32 dontbother = 0; /* how many characters not to try at end */
2069  I32 end_shift = 0;   /* Same for the end. */  /* CC */
2070  I32 scream_pos = -1;  /* Internal iterator of scream. */
2071  char *scream_olds = NULL;
2072  const bool utf8_target = cBOOL(DO_UTF8(sv));
2073  I32 multiline;
2074  RXi_GET_DECL(prog,progi);
2075  regmatch_info reginfo;  /* create some info to pass to regtry etc */
2076  regexp_paren_pair *swap = NULL;
2077  GET_RE_DEBUG_FLAGS_DECL;
2078
2079  PERL_ARGS_ASSERT_REGEXEC_FLAGS;
2080  PERL_UNUSED_ARG(data);
2081
2082  /* Be paranoid... */
2083  if (prog == NULL || startpos == NULL) {
2084   Perl_croak(aTHX_ "NULL regexp parameter");
2085   return 0;
2086  }
2087
2088  multiline = prog->extflags & RXf_PMf_MULTILINE;
2089  reginfo.prog = rx;  /* Yes, sorry that this is confusing.  */
2090
2091  RX_MATCH_UTF8_set(rx, utf8_target);
2092  DEBUG_EXECUTE_r(
2093   debug_start_match(rx, utf8_target, startpos, strend,
2094   "Matching");
2095  );
2096
2097  minlen = prog->minlen;
2098
2099  if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
2100   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2101        "String too short [regexec_flags]...\n"));
2102   goto phooey;
2103  }
2104
2105
2106  /* Check validity of program. */
2107  if (UCHARAT(progi->program) != REG_MAGIC) {
2108   Perl_croak(aTHX_ "corrupted regexp program");
2109  }
2110
2111  RX_MATCH_TAINTED_off(rx);
2112  PL_reg_state.re_state_eval_setup_done = FALSE;
2113  PL_reg_maxiter = 0;
2114
2115  reginfo.is_utf8_pat = cBOOL(RX_UTF8(rx));
2116  reginfo.warned = FALSE;
2117  /* Mark beginning of line for ^ and lookbehind. */
2118  reginfo.bol = startpos; /* XXX not used ??? */
2119  PL_bostr  = strbeg;
2120  reginfo.sv = sv;
2121
2122  /* Mark end of line for $ (and such) */
2123  PL_regeol = strend;
2124
2125  /* see how far we have to get to not match where we matched before */
2126  reginfo.till = startpos+minend;
2127
2128  /* If there is a "must appear" string, look for it. */
2129  s = startpos;
2130
2131  if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
2132   MAGIC *mg;
2133   if (flags & REXEC_IGNOREPOS){ /* Means: check only at start */
2134    reginfo.ganch = startpos + prog->gofs;
2135    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2136    "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
2137   } else if (sv && SvTYPE(sv) >= SVt_PVMG
2138     && SvMAGIC(sv)
2139     && (mg = mg_find(sv, PERL_MAGIC_regex_global))
2140     && mg->mg_len >= 0) {
2141    reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
2142    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2143     "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
2144
2145    if (prog->extflags & RXf_ANCH_GPOS) {
2146     if (s > reginfo.ganch)
2147      goto phooey;
2148     s = reginfo.ganch - prog->gofs;
2149     DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2150      "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
2151     if (s < strbeg)
2152      goto phooey;
2153    }
2154   }
2155   else if (data) {
2156    reginfo.ganch = strbeg + PTR2UV(data);
2157    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2158     "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
2159
2160   } else {    /* pos() not defined */
2161    reginfo.ganch = strbeg;
2162    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2163     "GPOS: reginfo.ganch = strbeg\n"));
2164   }
2165  }
2166  if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
2167   /* We have to be careful. If the previous successful match
2168   was from this regex we don't want a subsequent partially
2169   successful match to clobber the old results.
2170   So when we detect this possibility we add a swap buffer
2171   to the re, and switch the buffer each match. If we fail,
2172   we switch it back; otherwise we leave it swapped.
2173   */
2174   swap = prog->offs;
2175   /* do we need a save destructor here for eval dies? */
2176   Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
2177   DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
2178    "rex=0x%"UVxf" saving  offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
2179    PTR2UV(prog),
2180    PTR2UV(swap),
2181    PTR2UV(prog->offs)
2182   ));
2183  }
2184  if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
2185   re_scream_pos_data d;
2186
2187   d.scream_olds = &scream_olds;
2188   d.scream_pos = &scream_pos;
2189   s = re_intuit_start(rx, sv, s, strend, flags, &d);
2190   if (!s) {
2191    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
2192    goto phooey; /* not present */
2193   }
2194  }
2195
2196
2197
2198  /* Simplest case:  anchored match need be tried only once. */
2199  /*  [unless only anchor is BOL and multiline is set] */
2200  if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
2201   if (s == startpos && regtry(&reginfo, &startpos))
2202    goto got_it;
2203   else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2204     || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
2205   {
2206    char *end;
2207
2208    if (minlen)
2209     dontbother = minlen - 1;
2210    end = HOP3c(strend, -dontbother, strbeg) - 1;
2211    /* for multiline we only have to try after newlines */
2212    if (prog->check_substr || prog->check_utf8) {
2213     /* because of the goto we can not easily reuse the macros for bifurcating the
2214     unicode/non-unicode match modes here like we do elsewhere - demerphq */
2215     if (utf8_target) {
2216      if (s == startpos)
2217       goto after_try_utf8;
2218      while (1) {
2219       if (regtry(&reginfo, &s)) {
2220        goto got_it;
2221       }
2222      after_try_utf8:
2223       if (s > end) {
2224        goto phooey;
2225       }
2226       if (prog->extflags & RXf_USE_INTUIT) {
2227        s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL);
2228        if (!s) {
2229         goto phooey;
2230        }
2231       }
2232       else {
2233        s += UTF8SKIP(s);
2234       }
2235      }
2236     } /* end search for check string in unicode */
2237     else {
2238      if (s == startpos) {
2239       goto after_try_latin;
2240      }
2241      while (1) {
2242       if (regtry(&reginfo, &s)) {
2243        goto got_it;
2244       }
2245      after_try_latin:
2246       if (s > end) {
2247        goto phooey;
2248       }
2249       if (prog->extflags & RXf_USE_INTUIT) {
2250        s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2251        if (!s) {
2252         goto phooey;
2253        }
2254       }
2255       else {
2256        s++;
2257       }
2258      }
2259     } /* end search for check string in latin*/
2260    } /* end search for check string */
2261    else { /* search for newline */
2262     if (s > startpos) {
2263      /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
2264      s--;
2265     }
2266     /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
2267     while (s <= end) { /* note it could be possible to match at the end of the string */
2268      if (*s++ == '\n') { /* don't need PL_utf8skip here */
2269       if (regtry(&reginfo, &s))
2270        goto got_it;
2271      }
2272     }
2273    } /* end search for newline */
2274   } /* end anchored/multiline check string search */
2275   goto phooey;
2276  } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
2277  {
2278   /* the warning about reginfo.ganch being used without initialization
2279   is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
2280   and we only enter this block when the same bit is set. */
2281   char *tmp_s = reginfo.ganch - prog->gofs;
2282
2283   if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
2284    goto got_it;
2285   goto phooey;
2286  }
2287
2288  /* Messy cases:  unanchored match. */
2289  if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2290   /* we have /x+whatever/ */
2291   /* it must be a one character string (XXXX Except is_utf8_pat?) */
2292   char ch;
2293 #ifdef DEBUGGING
2294   int did_match = 0;
2295 #endif
2296   if (utf8_target) {
2297    if (! prog->anchored_utf8) {
2298     to_utf8_substr(prog);
2299    }
2300    ch = SvPVX_const(prog->anchored_utf8)[0];
2301    REXEC_FBC_SCAN(
2302     if (*s == ch) {
2303      DEBUG_EXECUTE_r( did_match = 1 );
2304      if (regtry(&reginfo, &s)) goto got_it;
2305      s += UTF8SKIP(s);
2306      while (s < strend && *s == ch)
2307       s += UTF8SKIP(s);
2308     }
2309    );
2310
2311   }
2312   else {
2313    if (! prog->anchored_substr) {
2314     if (! to_byte_substr(prog)) {
2315      NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2316     }
2317    }
2318    ch = SvPVX_const(prog->anchored_substr)[0];
2319    REXEC_FBC_SCAN(
2320     if (*s == ch) {
2321      DEBUG_EXECUTE_r( did_match = 1 );
2322      if (regtry(&reginfo, &s)) goto got_it;
2323      s++;
2324      while (s < strend && *s == ch)
2325       s++;
2326     }
2327    );
2328   }
2329   DEBUG_EXECUTE_r(if (!did_match)
2330     PerlIO_printf(Perl_debug_log,
2331         "Did not find anchored character...\n")
2332    );
2333  }
2334  else if (prog->anchored_substr != NULL
2335    || prog->anchored_utf8 != NULL
2336    || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2337     && prog->float_max_offset < strend - s)) {
2338   SV *must;
2339   I32 back_max;
2340   I32 back_min;
2341   char *last;
2342   char *last1;  /* Last position checked before */
2343 #ifdef DEBUGGING
2344   int did_match = 0;
2345 #endif
2346   if (prog->anchored_substr || prog->anchored_utf8) {
2347    if (utf8_target) {
2348     if (! prog->anchored_utf8) {
2349      to_utf8_substr(prog);
2350     }
2351     must = prog->anchored_utf8;
2352    }
2353    else {
2354     if (! prog->anchored_substr) {
2355      if (! to_byte_substr(prog)) {
2356       NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2357      }
2358     }
2359     must = prog->anchored_substr;
2360    }
2361    back_max = back_min = prog->anchored_offset;
2362   } else {
2363    if (utf8_target) {
2364     if (! prog->float_utf8) {
2365      to_utf8_substr(prog);
2366     }
2367     must = prog->float_utf8;
2368    }
2369    else {
2370     if (! prog->float_substr) {
2371      if (! to_byte_substr(prog)) {
2372       NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2373      }
2374     }
2375     must = prog->float_substr;
2376    }
2377    back_max = prog->float_max_offset;
2378    back_min = prog->float_min_offset;
2379   }
2380
2381   if (back_min<0) {
2382    last = strend;
2383   } else {
2384    last = HOP3c(strend, /* Cannot start after this */
2385     -(I32)(CHR_SVLEN(must)
2386       - (SvTAIL(must) != 0) + back_min), strbeg);
2387   }
2388   if (s > PL_bostr)
2389    last1 = HOPc(s, -1);
2390   else
2391    last1 = s - 1; /* bogus */
2392
2393   /* XXXX check_substr already used to find "s", can optimize if
2394   check_substr==must. */
2395   scream_pos = -1;
2396   dontbother = end_shift;
2397   strend = HOPc(strend, -dontbother);
2398   while ( (s <= last) &&
2399     (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2400         (unsigned char*)strend, must,
2401         multiline ? FBMrf_MULTILINE : 0)) ) {
2402    DEBUG_EXECUTE_r( did_match = 1 );
2403    if (HOPc(s, -back_max) > last1) {
2404     last1 = HOPc(s, -back_min);
2405     s = HOPc(s, -back_max);
2406    }
2407    else {
2408     char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2409
2410     last1 = HOPc(s, -back_min);
2411     s = t;
2412    }
2413    if (utf8_target) {
2414     while (s <= last1) {
2415      if (regtry(&reginfo, &s))
2416       goto got_it;
2417      if (s >= last1) {
2418       s++; /* to break out of outer loop */
2419       break;
2420      }
2421      s += UTF8SKIP(s);
2422     }
2423    }
2424    else {
2425     while (s <= last1) {
2426      if (regtry(&reginfo, &s))
2427       goto got_it;
2428      s++;
2429     }
2430    }
2431   }
2432   DEBUG_EXECUTE_r(if (!did_match) {
2433    RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
2434     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2435    PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2436        ((must == prog->anchored_substr || must == prog->anchored_utf8)
2437        ? "anchored" : "floating"),
2438     quoted, RE_SV_TAIL(must));
2439   });
2440   goto phooey;
2441  }
2442  else if ( (c = progi->regstclass) ) {
2443   if (minlen) {
2444    const OPCODE op = OP(progi->regstclass);
2445    /* don't bother with what can't match */
2446    if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2447     strend = HOPc(strend, -(minlen - 1));
2448   }
2449   DEBUG_EXECUTE_r({
2450    SV * const prop = sv_newmortal();
2451    regprop(prog, prop, c);
2452    {
2453     RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
2454      s,strend-s,60);
2455     PerlIO_printf(Perl_debug_log,
2456      "Matching stclass %.*s against %s (%d bytes)\n",
2457      (int)SvCUR(prop), SvPVX_const(prop),
2458      quoted, (int)(strend - s));
2459    }
2460   });
2461   if (find_byclass(prog, c, s, strend, &reginfo, reginfo.is_utf8_pat))
2462    goto got_it;
2463   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2464  }
2465  else {
2466   dontbother = 0;
2467   if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2468    /* Trim the end. */
2469    char *last= NULL;
2470    SV* float_real;
2471    STRLEN len;
2472    const char *little;
2473
2474    if (utf8_target) {
2475     if (! prog->float_utf8) {
2476      to_utf8_substr(prog);
2477     }
2478     float_real = prog->float_utf8;
2479    }
2480    else {
2481     if (! prog->float_substr) {
2482      if (! to_byte_substr(prog)) {
2483       NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2484      }
2485     }
2486     float_real = prog->float_substr;
2487    }
2488
2489    little = SvPV_const(float_real, len);
2490    if (SvTAIL(float_real)) {
2491      /* This means that float_real contains an artificial \n on
2492      * the end due to the presence of something like this:
2493      * /foo$/ where we can match both "foo" and "foo\n" at the
2494      * end of the string.  So we have to compare the end of the
2495      * string first against the float_real without the \n and
2496      * then against the full float_real with the string.  We
2497      * have to watch out for cases where the string might be
2498      * smaller than the float_real or the float_real without
2499      * the \n. */
2500      char *checkpos= strend - len;
2501      DEBUG_OPTIMISE_r(
2502       PerlIO_printf(Perl_debug_log,
2503        "%sChecking for float_real.%s\n",
2504        PL_colors[4], PL_colors[5]));
2505      if (checkpos + 1 < strbeg) {
2506       /* can't match, even if we remove the trailing \n
2507       * string is too short to match */
2508       DEBUG_EXECUTE_r(
2509        PerlIO_printf(Perl_debug_log,
2510         "%sString shorter than required trailing substring, cannot match.%s\n",
2511         PL_colors[4], PL_colors[5]));
2512       goto phooey;
2513      } else if (memEQ(checkpos + 1, little, len - 1)) {
2514       /* can match, the end of the string matches without the
2515       * "\n" */
2516       last = checkpos + 1;
2517      } else if (checkpos < strbeg) {
2518       /* cant match, string is too short when the "\n" is
2519       * included */
2520       DEBUG_EXECUTE_r(
2521        PerlIO_printf(Perl_debug_log,
2522         "%sString does not contain required trailing substring, cannot match.%s\n",
2523         PL_colors[4], PL_colors[5]));
2524       goto phooey;
2525      } else if (!multiline) {
2526       /* non multiline match, so compare with the "\n" at the
2527       * end of the string */
2528       if (memEQ(checkpos, little, len)) {
2529        last= checkpos;
2530       } else {
2531        DEBUG_EXECUTE_r(
2532         PerlIO_printf(Perl_debug_log,
2533          "%sString does not contain required trailing substring, cannot match.%s\n",
2534          PL_colors[4], PL_colors[5]));
2535        goto phooey;
2536       }
2537      } else {
2538       /* multiline match, so we have to search for a place
2539       * where the full string is located */
2540       goto find_last;
2541      }
2542    } else {
2543     find_last:
2544      if (len)
2545       last = rninstr(s, strend, little, little + len);
2546      else
2547       last = strend; /* matching "$" */
2548    }
2549    if (!last) {
2550     /* at one point this block contained a comment which was
2551     * probably incorrect, which said that this was a "should not
2552     * happen" case.  Even if it was true when it was written I am
2553     * pretty sure it is not anymore, so I have removed the comment
2554     * and replaced it with this one. Yves */
2555     DEBUG_EXECUTE_r(
2556      PerlIO_printf(Perl_debug_log,
2557       "String does not contain required substring, cannot match.\n"
2558      ));
2559     goto phooey;
2560    }
2561    dontbother = strend - last + prog->float_min_offset;
2562   }
2563   if (minlen && (dontbother < minlen))
2564    dontbother = minlen - 1;
2565   strend -= dontbother;      /* this one's always in bytes! */
2566   /* We don't know much -- general case. */
2567   if (utf8_target) {
2568    for (;;) {
2569     if (regtry(&reginfo, &s))
2570      goto got_it;
2571     if (s >= strend)
2572      break;
2573     s += UTF8SKIP(s);
2574    };
2575   }
2576   else {
2577    do {
2578     if (regtry(&reginfo, &s))
2579      goto got_it;
2580    } while (s++ < strend);
2581   }
2582  }
2583
2584  /* Failure. */
2585  goto phooey;
2586
2587 got_it:
2588  DEBUG_BUFFERS_r(
2589   if (swap)
2590    PerlIO_printf(Perl_debug_log,
2591     "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
2592     PTR2UV(prog),
2593     PTR2UV(swap)
2594    );
2595  );
2596  Safefree(swap);
2597
2598  if (PL_reg_state.re_state_eval_setup_done)
2599   restore_pos(aTHX_ prog);
2600  if (RXp_PAREN_NAMES(prog))
2601   (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2602
2603  /* make sure $`, $&, $', and $digit will work later */
2604  if ( !(flags & REXEC_NOT_FIRST) ) {
2605   if (flags & REXEC_COPY_STR) {
2606 #ifdef PERL_ANY_COW
2607    if (SvCANCOW(sv)) {
2608     if (DEBUG_C_TEST) {
2609      PerlIO_printf(Perl_debug_log,
2610         "Copy on write: regexp capture, type %d\n",
2611         (int) SvTYPE(sv));
2612     }
2613     RX_MATCH_COPY_FREE(rx);
2614     prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2615     prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2616     assert (SvPOKp(prog->saved_copy));
2617     prog->sublen  = PL_regeol - strbeg;
2618     prog->suboffset = 0;
2619     prog->subcoffset = 0;
2620    } else
2621 #endif
2622    {
2623     I32 min = 0;
2624     I32 max = PL_regeol - strbeg;
2625     I32 sublen;
2626
2627     if (    (flags & REXEC_COPY_SKIP_POST)
2628      && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
2629      && !(PL_sawampersand & SAWAMPERSAND_RIGHT)
2630     ) { /* don't copy $' part of string */
2631      U32 n = 0;
2632      max = -1;
2633      /* calculate the right-most part of the string covered
2634      * by a capture. Due to look-ahead, this may be to
2635      * the right of $&, so we have to scan all captures */
2636      while (n <= prog->lastparen) {
2637       if (prog->offs[n].end > max)
2638        max = prog->offs[n].end;
2639       n++;
2640      }
2641      if (max == -1)
2642       max = (PL_sawampersand & SAWAMPERSAND_LEFT)
2643         ? prog->offs[0].start
2644         : 0;
2645      assert(max >= 0 && max <= PL_regeol - strbeg);
2646     }
2647
2648     if (    (flags & REXEC_COPY_SKIP_PRE)
2649      && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
2650      && !(PL_sawampersand & SAWAMPERSAND_LEFT)
2651     ) { /* don't copy $` part of string */
2652      U32 n = 0;
2653      min = max;
2654      /* calculate the left-most part of the string covered
2655      * by a capture. Due to look-behind, this may be to
2656      * the left of $&, so we have to scan all captures */
2657      while (min && n <= prog->lastparen) {
2658       if (   prog->offs[n].start != -1
2659        && prog->offs[n].start < min)
2660       {
2661        min = prog->offs[n].start;
2662       }
2663       n++;
2664      }
2665      if ((PL_sawampersand & SAWAMPERSAND_RIGHT)
2666       && min >  prog->offs[0].end
2667      )
2668       min = prog->offs[0].end;
2669
2670     }
2671
2672     assert(min >= 0 && min <= max && min <= PL_regeol - strbeg);
2673     sublen = max - min;
2674
2675     if (RX_MATCH_COPIED(rx)) {
2676      if (sublen > prog->sublen)
2677       prog->subbeg =
2678         (char*)saferealloc(prog->subbeg, sublen+1);
2679     }
2680     else
2681      prog->subbeg = (char*)safemalloc(sublen+1);
2682     Copy(strbeg + min, prog->subbeg, sublen, char);
2683     prog->subbeg[sublen] = '\0';
2684     prog->suboffset = min;
2685     prog->sublen = sublen;
2686     RX_MATCH_COPIED_on(rx);
2687    }
2688    prog->subcoffset = prog->suboffset;
2689    if (prog->suboffset && utf8_target) {
2690     /* Convert byte offset to chars.
2691     * XXX ideally should only compute this if @-/@+
2692     * has been seen, a la PL_sawampersand ??? */
2693
2694     /* If there's a direct correspondence between the
2695     * string which we're matching and the original SV,
2696     * then we can use the utf8 len cache associated with
2697     * the SV. In particular, it means that under //g,
2698     * sv_pos_b2u() will use the previously cached
2699     * position to speed up working out the new length of
2700     * subcoffset, rather than counting from the start of
2701     * the string each time. This stops
2702     *   $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g;
2703     * from going quadratic */
2704     if (SvPOKp(sv) && SvPVX(sv) == strbeg)
2705      sv_pos_b2u(sv, &(prog->subcoffset));
2706     else
2707      prog->subcoffset = utf8_length((U8*)strbeg,
2708           (U8*)(strbeg+prog->suboffset));
2709    }
2710   }
2711   else {
2712    RX_MATCH_COPY_FREE(rx);
2713    prog->subbeg = strbeg;
2714    prog->suboffset = 0;
2715    prog->subcoffset = 0;
2716    prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2717   }
2718  }
2719
2720  return 1;
2721
2722 phooey:
2723  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2724       PL_colors[4], PL_colors[5]));
2725  if (PL_reg_state.re_state_eval_setup_done)
2726   restore_pos(aTHX_ prog);
2727  if (swap) {
2728   /* we failed :-( roll it back */
2729   DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
2730    "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
2731    PTR2UV(prog),
2732    PTR2UV(prog->offs),
2733    PTR2UV(swap)
2734   ));
2735   Safefree(prog->offs);
2736   prog->offs = swap;
2737  }
2738  return 0;
2739 }
2740
2741
2742 /* Set which rex is pointed to by PL_reg_state, handling ref counting.
2743  * Do inc before dec, in case old and new rex are the same */
2744 #define SET_reg_curpm(Re2) \
2745  if (PL_reg_state.re_state_eval_setup_done) {    \
2746   (void)ReREFCNT_inc(Re2);      \
2747   ReREFCNT_dec(PM_GETRE(PL_reg_curpm));     \
2748   PM_SETRE((PL_reg_curpm), (Re2));     \
2749  }
2750
2751
2752 /*
2753  - regtry - try match at specific point
2754  */
2755 STATIC I32   /* 0 failure, 1 success */
2756 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
2757 {
2758  dVAR;
2759  CHECKPOINT lastcp;
2760  REGEXP *const rx = reginfo->prog;
2761  regexp *const prog = ReANY(rx);
2762  I32 result;
2763  RXi_GET_DECL(prog,progi);
2764  GET_RE_DEBUG_FLAGS_DECL;
2765
2766  PERL_ARGS_ASSERT_REGTRY;
2767
2768  reginfo->cutpoint=NULL;
2769
2770  if ((prog->extflags & RXf_EVAL_SEEN)
2771   && !PL_reg_state.re_state_eval_setup_done)
2772  {
2773   MAGIC *mg;
2774
2775   PL_reg_state.re_state_eval_setup_done = TRUE;
2776   if (reginfo->sv) {
2777    /* Make $_ available to executed code. */
2778    if (reginfo->sv != DEFSV) {
2779     SAVE_DEFSV;
2780     DEFSV_set(reginfo->sv);
2781    }
2782
2783    if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2784     && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2785     /* prepare for quick setting of pos */
2786 #ifdef PERL_OLD_COPY_ON_WRITE
2787     if (SvIsCOW(reginfo->sv))
2788      sv_force_normal_flags(reginfo->sv, 0);
2789 #endif
2790     mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2791         &PL_vtbl_mglob, NULL, 0);
2792     mg->mg_len = -1;
2793    }
2794    PL_reg_magic    = mg;
2795    PL_reg_oldpos   = mg->mg_len;
2796    SAVEDESTRUCTOR_X(restore_pos, prog);
2797   }
2798   if (!PL_reg_curpm) {
2799    Newxz(PL_reg_curpm, 1, PMOP);
2800 #ifdef USE_ITHREADS
2801    {
2802     SV* const repointer = &PL_sv_undef;
2803     /* this regexp is also owned by the new PL_reg_curpm, which
2804     will try to free it.  */
2805     av_push(PL_regex_padav, repointer);
2806     PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2807     PL_regex_pad = AvARRAY(PL_regex_padav);
2808    }
2809 #endif
2810   }
2811   SET_reg_curpm(rx);
2812   PL_reg_oldcurpm = PL_curpm;
2813   PL_curpm = PL_reg_curpm;
2814   if (RXp_MATCH_COPIED(prog)) {
2815    /*  Here is a serious problem: we cannot rewrite subbeg,
2816     since it may be needed if this match fails.  Thus
2817     $` inside (?{}) could fail... */
2818    PL_reg_oldsaved = prog->subbeg;
2819    PL_reg_oldsavedlen = prog->sublen;
2820    PL_reg_oldsavedoffset = prog->suboffset;
2821    PL_reg_oldsavedcoffset = prog->suboffset;
2822 #ifdef PERL_ANY_COW
2823    PL_nrs = prog->saved_copy;
2824 #endif
2825    RXp_MATCH_COPIED_off(prog);
2826   }
2827   else
2828    PL_reg_oldsaved = NULL;
2829   prog->subbeg = PL_bostr;
2830   prog->suboffset = 0;
2831   prog->subcoffset = 0;
2832   prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2833  }
2834 #ifdef DEBUGGING
2835  PL_reg_starttry = *startposp;
2836 #endif
2837  prog->offs[0].start = *startposp - PL_bostr;
2838  prog->lastparen = 0;
2839  prog->lastcloseparen = 0;
2840
2841  /* XXXX What this code is doing here?!!!  There should be no need
2842  to do this again and again, prog->lastparen should take care of
2843  this!  --ilya*/
2844
2845  /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2846  * Actually, the code in regcppop() (which Ilya may be meaning by
2847  * prog->lastparen), is not needed at all by the test suite
2848  * (op/regexp, op/pat, op/split), but that code is needed otherwise
2849  * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2850  * Meanwhile, this code *is* needed for the
2851  * above-mentioned test suite tests to succeed.  The common theme
2852  * on those tests seems to be returning null fields from matches.
2853  * --jhi updated by dapm */
2854 #if 1
2855  if (prog->nparens) {
2856   regexp_paren_pair *pp = prog->offs;
2857   I32 i;
2858   for (i = prog->nparens; i > (I32)prog->lastparen; i--) {
2859    ++pp;
2860    pp->start = -1;
2861    pp->end = -1;
2862   }
2863  }
2864 #endif
2865  REGCP_SET(lastcp);
2866  result = regmatch(reginfo, *startposp, progi->program + 1);
2867  if (result != -1) {
2868   prog->offs[0].end = result;
2869   return 1;
2870  }
2871  if (reginfo->cutpoint)
2872   *startposp= reginfo->cutpoint;
2873  REGCP_UNWIND(lastcp);
2874  return 0;
2875 }
2876
2877
2878 #define sayYES goto yes
2879 #define sayNO goto no
2880 #define sayNO_SILENT goto no_silent
2881
2882 /* we dont use STMT_START/END here because it leads to
2883    "unreachable code" warnings, which are bogus, but distracting. */
2884 #define CACHEsayNO \
2885  if (ST.cache_mask) \
2886  PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2887  sayNO
2888
2889 /* this is used to determine how far from the left messages like
2890    'failed...' are printed. It should be set such that messages
2891    are inline with the regop output that created them.
2892 */
2893 #define REPORT_CODE_OFF 32
2894
2895
2896 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2897 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2898 #define CHRTEST_NOT_A_CP_1 -999
2899 #define CHRTEST_NOT_A_CP_2 -998
2900
2901 #define SLAB_FIRST(s) (&(s)->states[0])
2902 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2903
2904 /* grab a new slab and return the first slot in it */
2905
2906 STATIC regmatch_state *
2907 S_push_slab(pTHX)
2908 {
2909 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2910  dMY_CXT;
2911 #endif
2912  regmatch_slab *s = PL_regmatch_slab->next;
2913  if (!s) {
2914   Newx(s, 1, regmatch_slab);
2915   s->prev = PL_regmatch_slab;
2916   s->next = NULL;
2917   PL_regmatch_slab->next = s;
2918  }
2919  PL_regmatch_slab = s;
2920  return SLAB_FIRST(s);
2921 }
2922
2923
2924 /* push a new state then goto it */
2925
2926 #define PUSH_STATE_GOTO(state, node, input) \
2927  pushinput = input; \
2928  scan = node; \
2929  st->resume_state = state; \
2930  goto push_state;
2931
2932 /* push a new state with success backtracking, then goto it */
2933
2934 #define PUSH_YES_STATE_GOTO(state, node, input) \
2935  pushinput = input; \
2936  scan = node; \
2937  st->resume_state = state; \
2938  goto push_yes_state;
2939
2940
2941
2942
2943 /*
2944
2945 regmatch() - main matching routine
2946
2947 This is basically one big switch statement in a loop. We execute an op,
2948 set 'next' to point the next op, and continue. If we come to a point which
2949 we may need to backtrack to on failure such as (A|B|C), we push a
2950 backtrack state onto the backtrack stack. On failure, we pop the top
2951 state, and re-enter the loop at the state indicated. If there are no more
2952 states to pop, we return failure.
2953
2954 Sometimes we also need to backtrack on success; for example /A+/, where
2955 after successfully matching one A, we need to go back and try to
2956 match another one; similarly for lookahead assertions: if the assertion
2957 completes successfully, we backtrack to the state just before the assertion
2958 and then carry on.  In these cases, the pushed state is marked as
2959 'backtrack on success too'. This marking is in fact done by a chain of
2960 pointers, each pointing to the previous 'yes' state. On success, we pop to
2961 the nearest yes state, discarding any intermediate failure-only states.
2962 Sometimes a yes state is pushed just to force some cleanup code to be
2963 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2964 it to free the inner regex.
2965
2966 Note that failure backtracking rewinds the cursor position, while
2967 success backtracking leaves it alone.
2968
2969 A pattern is complete when the END op is executed, while a subpattern
2970 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2971 ops trigger the "pop to last yes state if any, otherwise return true"
2972 behaviour.
2973
2974 A common convention in this function is to use A and B to refer to the two
2975 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2976 the subpattern to be matched possibly multiple times, while B is the entire
2977 rest of the pattern. Variable and state names reflect this convention.
2978
2979 The states in the main switch are the union of ops and failure/success of
2980 substates associated with with that op.  For example, IFMATCH is the op
2981 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2982 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2983 successfully matched A and IFMATCH_A_fail is a state saying that we have
2984 just failed to match A. Resume states always come in pairs. The backtrack
2985 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2986 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2987 on success or failure.
2988
2989 The struct that holds a backtracking state is actually a big union, with
2990 one variant for each major type of op. The variable st points to the
2991 top-most backtrack struct. To make the code clearer, within each
2992 block of code we #define ST to alias the relevant union.
2993
2994 Here's a concrete example of a (vastly oversimplified) IFMATCH
2995 implementation:
2996
2997  switch (state) {
2998  ....
2999
3000 #define ST st->u.ifmatch
3001
3002  case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3003   ST.foo = ...; // some state we wish to save
3004   ...
3005   // push a yes backtrack state with a resume value of
3006   // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
3007   // first node of A:
3008   PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput);
3009   // NOTREACHED
3010
3011  case IFMATCH_A: // we have successfully executed A; now continue with B
3012   next = B;
3013   bar = ST.foo; // do something with the preserved value
3014   break;
3015
3016  case IFMATCH_A_fail: // A failed, so the assertion failed
3017   ...;   // do some housekeeping, then ...
3018   sayNO; // propagate the failure
3019
3020 #undef ST
3021
3022  ...
3023  }
3024
3025 For any old-timers reading this who are familiar with the old recursive
3026 approach, the code above is equivalent to:
3027
3028  case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3029  {
3030   int foo = ...
3031   ...
3032   if (regmatch(A)) {
3033    next = B;
3034    bar = foo;
3035    break;
3036   }
3037   ...;   // do some housekeeping, then ...
3038   sayNO; // propagate the failure
3039  }
3040
3041 The topmost backtrack state, pointed to by st, is usually free. If you
3042 want to claim it, populate any ST.foo fields in it with values you wish to
3043 save, then do one of
3044
3045   PUSH_STATE_GOTO(resume_state, node, newinput);
3046   PUSH_YES_STATE_GOTO(resume_state, node, newinput);
3047
3048 which sets that backtrack state's resume value to 'resume_state', pushes a
3049 new free entry to the top of the backtrack stack, then goes to 'node'.
3050 On backtracking, the free slot is popped, and the saved state becomes the
3051 new free state. An ST.foo field in this new top state can be temporarily
3052 accessed to retrieve values, but once the main loop is re-entered, it
3053 becomes available for reuse.
3054
3055 Note that the depth of the backtrack stack constantly increases during the
3056 left-to-right execution of the pattern, rather than going up and down with
3057 the pattern nesting. For example the stack is at its maximum at Z at the
3058 end of the pattern, rather than at X in the following:
3059
3060  /(((X)+)+)+....(Y)+....Z/
3061
3062 The only exceptions to this are lookahead/behind assertions and the cut,
3063 (?>A), which pop all the backtrack states associated with A before
3064 continuing.
3065
3066 Backtrack state structs are allocated in slabs of about 4K in size.
3067 PL_regmatch_state and st always point to the currently active state,
3068 and PL_regmatch_slab points to the slab currently containing
3069 PL_regmatch_state.  The first time regmatch() is called, the first slab is
3070 allocated, and is never freed until interpreter destruction. When the slab
3071 is full, a new one is allocated and chained to the end. At exit from
3072 regmatch(), slabs allocated since entry are freed.
3073
3074 */
3075
3076
3077 #define DEBUG_STATE_pp(pp)        \
3078  DEBUG_STATE_r({         \
3079   DUMP_EXEC_POS(locinput, scan, utf8_target);      \
3080   PerlIO_printf(Perl_debug_log,       \
3081    "    %*s"pp" %s%s%s%s%s\n",       \
3082    depth*2, "",        \
3083    PL_reg_name[st->resume_state],                     \
3084    ((st==yes_state||st==mark_state) ? "[" : ""),   \
3085    ((st==yes_state) ? "Y" : ""),                   \
3086    ((st==mark_state) ? "M" : ""),                  \
3087    ((st==yes_state||st==mark_state) ? "]" : "")    \
3088   );                                                  \
3089  });
3090
3091
3092 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
3093
3094 #ifdef DEBUGGING
3095
3096 STATIC void
3097 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
3098  const char *start, const char *end, const char *blurb)
3099 {
3100  const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
3101
3102  PERL_ARGS_ASSERT_DEBUG_START_MATCH;
3103
3104  if (!PL_colorset)
3105    reginitcolors();
3106  {
3107   RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
3108    RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
3109
3110   RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
3111    start, end - start, 60);
3112
3113   PerlIO_printf(Perl_debug_log,
3114    "%s%s REx%s %s against %s\n",
3115      PL_colors[4], blurb, PL_colors[5], s0, s1);
3116
3117   if (utf8_target||utf8_pat)
3118    PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
3119     utf8_pat ? "pattern" : "",
3120     utf8_pat && utf8_target ? " and " : "",
3121     utf8_target ? "string" : ""
3122    );
3123  }
3124 }
3125
3126 STATIC void
3127 S_dump_exec_pos(pTHX_ const char *locinput,
3128      const regnode *scan,
3129      const char *loc_regeol,
3130      const char *loc_bostr,
3131      const char *loc_reg_starttry,
3132      const bool utf8_target)
3133 {
3134  const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
3135  const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
3136  int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
3137  /* The part of the string before starttry has one color
3138  (pref0_len chars), between starttry and current
3139  position another one (pref_len - pref0_len chars),
3140  after the current position the third one.
3141  We assume that pref0_len <= pref_len, otherwise we
3142  decrease pref0_len.  */
3143  int pref_len = (locinput - loc_bostr) > (5 + taill) - l
3144   ? (5 + taill) - l : locinput - loc_bostr;
3145  int pref0_len;
3146
3147  PERL_ARGS_ASSERT_DUMP_EXEC_POS;
3148
3149  while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
3150   pref_len++;
3151  pref0_len = pref_len  - (locinput - loc_reg_starttry);
3152  if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
3153   l = ( loc_regeol - locinput > (5 + taill) - pref_len
3154    ? (5 + taill) - pref_len : loc_regeol - locinput);
3155  while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
3156   l--;
3157  if (pref0_len < 0)
3158   pref0_len = 0;
3159  if (pref0_len > pref_len)
3160   pref0_len = pref_len;
3161  {
3162   const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
3163
3164   RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
3165    (locinput - pref_len),pref0_len, 60, 4, 5);
3166
3167   RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3168      (locinput - pref_len + pref0_len),
3169      pref_len - pref0_len, 60, 2, 3);
3170
3171   RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
3172      locinput, loc_regeol - locinput, 10, 0, 1);
3173
3174   const STRLEN tlen=len0+len1+len2;
3175   PerlIO_printf(Perl_debug_log,
3176      "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
3177      (IV)(locinput - loc_bostr),
3178      len0, s0,
3179      len1, s1,
3180      (docolor ? "" : "> <"),
3181      len2, s2,
3182      (int)(tlen > 19 ? 0 :  19 - tlen),
3183      "");
3184  }
3185 }
3186
3187 #endif
3188
3189 /* reg_check_named_buff_matched()
3190  * Checks to see if a named buffer has matched. The data array of
3191  * buffer numbers corresponding to the buffer is expected to reside
3192  * in the regexp->data->data array in the slot stored in the ARG() of
3193  * node involved. Note that this routine doesn't actually care about the
3194  * name, that information is not preserved from compilation to execution.
3195  * Returns the index of the leftmost defined buffer with the given name
3196  * or 0 if non of the buffers matched.
3197  */
3198 STATIC I32
3199 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
3200 {
3201  I32 n;
3202  RXi_GET_DECL(rex,rexi);
3203  SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
3204  I32 *nums=(I32*)SvPVX(sv_dat);
3205
3206  PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3207
3208  for ( n=0; n<SvIVX(sv_dat); n++ ) {
3209   if ((I32)rex->lastparen >= nums[n] &&
3210    rex->offs[nums[n]].end != -1)
3211   {
3212    return nums[n];
3213   }
3214  }
3215  return 0;
3216 }
3217
3218
3219 /* free all slabs above current one  - called during LEAVE_SCOPE */
3220
3221 STATIC void
3222 S_clear_backtrack_stack(pTHX_ void *p)
3223 {
3224  regmatch_slab *s = PL_regmatch_slab->next;
3225  PERL_UNUSED_ARG(p);
3226
3227  if (!s)
3228   return;
3229  PL_regmatch_slab->next = NULL;
3230  while (s) {
3231   regmatch_slab * const osl = s;
3232   s = s->next;
3233   Safefree(osl);
3234  }
3235 }
3236 static bool
3237 S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p,
3238   U8* c1_utf8, int *c2p, U8* c2_utf8, bool is_utf8_pat)
3239 {
3240  /* This function determines if there are one or two characters that match
3241  * the first character of the passed-in EXACTish node <text_node>, and if
3242  * so, returns them in the passed-in pointers.
3243  *
3244  * If it determines that no possible character in the target string can
3245  * match, it returns FALSE; otherwise TRUE.  (The FALSE situation occurs if
3246  * the first character in <text_node> requires UTF-8 to represent, and the
3247  * target string isn't in UTF-8.)
3248  *
3249  * If there are more than two characters that could match the beginning of
3250  * <text_node>, or if more context is required to determine a match or not,
3251  * it sets both *<c1p> and *<c2p> to CHRTEST_VOID.
3252  *
3253  * The motiviation behind this function is to allow the caller to set up
3254  * tight loops for matching.  If <text_node> is of type EXACT, there is
3255  * only one possible character that can match its first character, and so
3256  * the situation is quite simple.  But things get much more complicated if
3257  * folding is involved.  It may be that the first character of an EXACTFish
3258  * node doesn't participate in any possible fold, e.g., punctuation, so it
3259  * can be matched only by itself.  The vast majority of characters that are
3260  * in folds match just two things, their lower and upper-case equivalents.
3261  * But not all are like that; some have multiple possible matches, or match
3262  * sequences of more than one character.  This function sorts all that out.
3263  *
3264  * Consider the patterns A*B or A*?B where A and B are arbitrary.  In a
3265  * loop of trying to match A*, we know we can't exit where the thing
3266  * following it isn't a B.  And something can't be a B unless it is the
3267  * beginning of B.  By putting a quick test for that beginning in a tight
3268  * loop, we can rule out things that can't possibly be B without having to
3269  * break out of the loop, thus avoiding work.  Similarly, if A is a single
3270  * character, we can make a tight loop matching A*, using the outputs of
3271  * this function.
3272  *
3273  * If the target string to match isn't in UTF-8, and there aren't
3274  * complications which require CHRTEST_VOID, *<c1p> and *<c2p> are set to
3275  * the one or two possible octets (which are characters in this situation)
3276  * that can match.  In all cases, if there is only one character that can
3277  * match, *<c1p> and *<c2p> will be identical.
3278  *
3279  * If the target string is in UTF-8, the buffers pointed to by <c1_utf8>
3280  * and <c2_utf8> will contain the one or two UTF-8 sequences of bytes that
3281  * can match the beginning of <text_node>.  They should be declared with at
3282  * least length UTF8_MAXBYTES+1.  (If the target string isn't in UTF-8, it is
3283  * undefined what these contain.)  If one or both of the buffers are
3284  * invariant under UTF-8, *<c1p>, and *<c2p> will also be set to the
3285  * corresponding invariant.  If variant, the corresponding *<c1p> and/or
3286  * *<c2p> will be set to a negative number(s) that shouldn't match any code
3287  * point (unless inappropriately coerced to unsigned).   *<c1p> will equal
3288  * *<c2p> if and only if <c1_utf8> and <c2_utf8> are the same. */
3289
3290  const bool utf8_target = PL_reg_match_utf8;
3291
3292  UV c1 = CHRTEST_NOT_A_CP_1;
3293  UV c2 = CHRTEST_NOT_A_CP_2;
3294  bool use_chrtest_void = FALSE;
3295
3296  /* Used when we have both utf8 input and utf8 output, to avoid converting
3297  * to/from code points */
3298  bool utf8_has_been_setup = FALSE;
3299
3300  dVAR;
3301
3302  U8 *pat = (U8*)STRING(text_node);
3303
3304  if (OP(text_node) == EXACT) {
3305
3306   /* In an exact node, only one thing can be matched, that first
3307   * character.  If both the pat and the target are UTF-8, we can just
3308   * copy the input to the output, avoiding finding the code point of
3309   * that character */
3310   if (!is_utf8_pat) {
3311    c2 = c1 = *pat;
3312   }
3313   else if (utf8_target) {
3314    Copy(pat, c1_utf8, UTF8SKIP(pat), U8);
3315    Copy(pat, c2_utf8, UTF8SKIP(pat), U8);
3316    utf8_has_been_setup = TRUE;
3317   }
3318   else {
3319    c2 = c1 = valid_utf8_to_uvchr(pat, NULL);
3320   }
3321  }
3322  else /* an EXACTFish node */
3323   if ((is_utf8_pat
3324      && is_MULTI_CHAR_FOLD_utf8_safe(pat,
3325              pat + STR_LEN(text_node)))
3326    || (!is_utf8_pat
3327      && is_MULTI_CHAR_FOLD_latin1_safe(pat,
3328              pat + STR_LEN(text_node))))
3329  {
3330   /* Multi-character folds require more context to sort out.  Also
3331   * PL_utf8_foldclosures used below doesn't handle them, so have to be
3332   * handled outside this routine */
3333   use_chrtest_void = TRUE;
3334  }
3335  else { /* an EXACTFish node which doesn't begin with a multi-char fold */
3336   c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
3337   if (c1 > 256) {
3338    /* Load the folds hash, if not already done */
3339    SV** listp;
3340    if (! PL_utf8_foldclosures) {
3341     if (! PL_utf8_tofold) {
3342      U8 dummy[UTF8_MAXBYTES+1];
3343
3344      /* Force loading this by folding an above-Latin1 char */
3345      to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
3346      assert(PL_utf8_tofold); /* Verify that worked */
3347     }
3348     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
3349    }
3350
3351    /* The fold closures data structure is a hash with the keys being
3352    * the UTF-8 of every character that is folded to, like 'k', and
3353    * the values each an array of all code points that fold to its
3354    * key.  e.g. [ 'k', 'K', KELVIN_SIGN ].  Multi-character folds are
3355    * not included */
3356    if ((! (listp = hv_fetch(PL_utf8_foldclosures,
3357          (char *) pat,
3358          UTF8SKIP(pat),
3359          FALSE))))
3360    {
3361     /* Not found in the hash, therefore there are no folds
3362     * containing it, so there is only a single character that
3363     * could match */
3364     c2 = c1;
3365    }
3366    else {  /* Does participate in folds */
3367     AV* list = (AV*) *listp;
3368     if (av_len(list) != 1) {
3369
3370      /* If there aren't exactly two folds to this, it is outside
3371      * the scope of this function */
3372      use_chrtest_void = TRUE;
3373     }
3374     else {  /* There are two.  Get them */
3375      SV** c_p = av_fetch(list, 0, FALSE);
3376      if (c_p == NULL) {
3377       Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
3378      }
3379      c1 = SvUV(*c_p);
3380
3381      c_p = av_fetch(list, 1, FALSE);
3382      if (c_p == NULL) {
3383       Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
3384      }
3385      c2 = SvUV(*c_p);
3386
3387      /* Folds that cross the 255/256 boundary are forbidden if
3388      * EXACTFL, or EXACTFA and one is ASCIII.  Since the
3389      * pattern character is above 256, and its only other match
3390      * is below 256, the only legal match will be to itself.
3391      * We have thrown away the original, so have to compute
3392      * which is the one above 255 */
3393      if ((c1 < 256) != (c2 < 256)) {
3394       if (OP(text_node) == EXACTFL
3395        || (OP(text_node) == EXACTFA
3396         && (isASCII(c1) || isASCII(c2))))
3397       {
3398        if (c1 < 256) {
3399         c1 = c2;
3400        }
3401        else {
3402         c2 = c1;
3403        }
3404       }
3405      }
3406     }
3407    }
3408   }
3409   else /* Here, c1 is < 255 */
3410    if (utf8_target
3411     && HAS_NONLATIN1_FOLD_CLOSURE(c1)
3412     && OP(text_node) != EXACTFL
3413     && (OP(text_node) != EXACTFA || ! isASCII(c1)))
3414   {
3415    /* Here, there could be something above Latin1 in the target which
3416    * folds to this character in the pattern.  All such cases except
3417    * LATIN SMALL LETTER Y WITH DIAERESIS have more than two characters
3418    * involved in their folds, so are outside the scope of this
3419    * function */
3420    if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3421     c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
3422    }
3423    else {
3424     use_chrtest_void = TRUE;
3425    }
3426   }
3427   else { /* Here nothing above Latin1 can fold to the pattern character */
3428    switch (OP(text_node)) {
3429
3430     case EXACTFL:   /* /l rules */
3431      c2 = PL_fold_locale[c1];
3432      break;
3433
3434     case EXACTF:
3435      if (! utf8_target) {    /* /d rules */
3436       c2 = PL_fold[c1];
3437       break;
3438      }
3439      /* FALLTHROUGH */
3440      /* /u rules for all these.  This happens to work for
3441      * EXACTFA as nothing in Latin1 folds to ASCII */
3442     case EXACTFA:
3443     case EXACTFU_TRICKYFOLD:
3444     case EXACTFU_SS:
3445     case EXACTFU:
3446      c2 = PL_fold_latin1[c1];
3447      break;
3448
3449     default:
3450      Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
3451      assert(0); /* NOTREACHED */
3452    }
3453   }
3454  }
3455
3456  /* Here have figured things out.  Set up the returns */
3457  if (use_chrtest_void) {
3458   *c2p = *c1p = CHRTEST_VOID;
3459  }
3460  else if (utf8_target) {
3461   if (! utf8_has_been_setup) {    /* Don't have the utf8; must get it */
3462    uvchr_to_utf8(c1_utf8, c1);
3463    uvchr_to_utf8(c2_utf8, c2);
3464   }
3465
3466   /* Invariants are stored in both the utf8 and byte outputs; Use
3467   * negative numbers otherwise for the byte ones.  Make sure that the
3468   * byte ones are the same iff the utf8 ones are the same */
3469   *c1p = (UTF8_IS_INVARIANT(*c1_utf8)) ? *c1_utf8 : CHRTEST_NOT_A_CP_1;
3470   *c2p = (UTF8_IS_INVARIANT(*c2_utf8))
3471     ? *c2_utf8
3472     : (c1 == c2)
3473     ? CHRTEST_NOT_A_CP_1
3474     : CHRTEST_NOT_A_CP_2;
3475  }
3476  else if (c1 > 255) {
3477  if (c2 > 255) {  /* both possibilities are above what a non-utf8 string
3478       can represent */
3479   return FALSE;
3480  }
3481
3482  *c1p = *c2p = c2;    /* c2 is the only representable value */
3483  }
3484  else {  /* c1 is representable; see about c2 */
3485  *c1p = c1;
3486  *c2p = (c2 < 256) ? c2 : c1;
3487  }
3488
3489  return TRUE;
3490 }
3491
3492 /* returns -1 on failure, $+[0] on success */
3493 STATIC I32
3494 S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
3495 {
3496 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3497  dMY_CXT;
3498 #endif
3499  dVAR;
3500  const bool utf8_target = PL_reg_match_utf8;
3501  const U32 uniflags = UTF8_ALLOW_DEFAULT;
3502  REGEXP *rex_sv = reginfo->prog;
3503  regexp *rex = ReANY(rex_sv);
3504  RXi_GET_DECL(rex,rexi);
3505  I32 oldsave;
3506  /* the current state. This is a cached copy of PL_regmatch_state */
3507  regmatch_state *st;
3508  /* cache heavy used fields of st in registers */
3509  regnode *scan;
3510  regnode *next;
3511  U32 n = 0; /* general value; init to avoid compiler warning */
3512  I32 ln = 0; /* len or last;  init to avoid compiler warning */
3513  char *locinput = startpos;
3514  char *pushinput; /* where to continue after a PUSH */
3515  I32 nextchr;   /* is always set to UCHARAT(locinput) */
3516
3517  bool result = 0;     /* return value of S_regmatch */
3518  int depth = 0;     /* depth of backtrack stack */
3519  U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
3520  const U32 max_nochange_depth =
3521   (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
3522   3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
3523  regmatch_state *yes_state = NULL; /* state to pop to on success of
3524                subpattern */
3525  /* mark_state piggy backs on the yes_state logic so that when we unwind
3526  the stack on success we can update the mark_state as we go */
3527  regmatch_state *mark_state = NULL; /* last mark state we have seen */
3528  regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
3529  struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
3530  U32 state_num;
3531  bool no_final = 0;      /* prevent failure from backtracking? */
3532  bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
3533  char *startpoint = locinput;
3534  SV *popmark = NULL;     /* are we looking for a mark? */
3535  SV *sv_commit = NULL;   /* last mark name seen in failure */
3536  SV *sv_yes_mark = NULL; /* last mark name we have seen
3537        during a successful match */
3538  U32 lastopen = 0;       /* last open we saw */
3539  bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
3540  SV* const oreplsv = GvSV(PL_replgv);
3541  /* these three flags are set by various ops to signal information to
3542  * the very next op. They have a useful lifetime of exactly one loop
3543  * iteration, and are not preserved or restored by state pushes/pops
3544  */
3545  bool sw = 0;     /* the condition value in (?(cond)a|b) */
3546  bool minmod = 0;     /* the next "{n,m}" is a "{n,m}?" */
3547  int logical = 0;     /* the following EVAL is:
3548         0: (?{...})
3549         1: (?(?{...})X|Y)
3550         2: (??{...})
3551        or the following IFMATCH/UNLESSM is:
3552         false: plain (?=foo)
3553         true:  used as a condition: (?(?=foo))
3554        */
3555  PAD* last_pad = NULL;
3556  dMULTICALL;
3557  I32 gimme = G_SCALAR;
3558  CV *caller_cv = NULL; /* who called us */
3559  CV *last_pushed_cv = NULL; /* most recently called (?{}) CV */
3560  CHECKPOINT runops_cp; /* savestack position before executing EVAL */
3561  U32 maxopenparen = 0;       /* max '(' index seen so far */
3562  int to_complement;  /* Invert the result? */
3563  _char_class_number classnum;
3564  bool is_utf8_pat = reginfo->is_utf8_pat;
3565
3566 #ifdef DEBUGGING
3567  GET_RE_DEBUG_FLAGS_DECL;
3568 #endif
3569
3570  /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
3571  multicall_oldcatch = 0;
3572  multicall_cv = NULL;
3573  cx = NULL;
3574  PERL_UNUSED_VAR(multicall_cop);
3575  PERL_UNUSED_VAR(newsp);
3576
3577
3578  PERL_ARGS_ASSERT_REGMATCH;
3579
3580  DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
3581    PerlIO_printf(Perl_debug_log,"regmatch start\n");
3582  }));
3583  /* on first ever call to regmatch, allocate first slab */
3584  if (!PL_regmatch_slab) {
3585   Newx(PL_regmatch_slab, 1, regmatch_slab);
3586   PL_regmatch_slab->prev = NULL;
3587   PL_regmatch_slab->next = NULL;
3588   PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
3589  }
3590
3591  oldsave = PL_savestack_ix;
3592  SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
3593  SAVEVPTR(PL_regmatch_slab);
3594  SAVEVPTR(PL_regmatch_state);
3595
3596  /* grab next free state slot */
3597  st = ++PL_regmatch_state;
3598  if (st >  SLAB_LAST(PL_regmatch_slab))
3599   st = PL_regmatch_state = S_push_slab(aTHX);
3600
3601  /* Note that nextchr is a byte even in UTF */
3602  SET_nextchr;
3603  scan = prog;
3604  while (scan != NULL) {
3605
3606   DEBUG_EXECUTE_r( {
3607    SV * const prop = sv_newmortal();
3608    regnode *rnext=regnext(scan);
3609    DUMP_EXEC_POS( locinput, scan, utf8_target );
3610    regprop(rex, prop, scan);
3611
3612    PerlIO_printf(Perl_debug_log,
3613      "%3"IVdf":%*s%s(%"IVdf")\n",
3614      (IV)(scan - rexi->program), depth*2, "",
3615      SvPVX_const(prop),
3616      (PL_regkind[OP(scan)] == END || !rnext) ?
3617       0 : (IV)(rnext - rexi->program));
3618   });
3619
3620   next = scan + NEXT_OFF(scan);
3621   if (next == scan)
3622    next = NULL;
3623   state_num = OP(scan);
3624
3625   REH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);
3626  reenter_switch:
3627   to_complement = 0;
3628
3629   SET_nextchr;
3630   assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS));
3631
3632   switch (state_num) {
3633   case BOL: /*  /^../  */
3634    if (locinput == PL_bostr)
3635    {
3636     /* reginfo->till = reginfo->bol; */
3637     break;
3638    }
3639    sayNO;
3640
3641   case MBOL: /*  /^../m  */
3642    if (locinput == PL_bostr ||
3643     (!NEXTCHR_IS_EOS && locinput[-1] == '\n'))
3644    {
3645     break;
3646    }
3647    sayNO;
3648
3649   case SBOL: /*  /^../s  */
3650    if (locinput == PL_bostr)
3651     break;
3652    sayNO;
3653
3654   case GPOS: /*  \G  */
3655    if (locinput == reginfo->ganch)
3656     break;
3657    sayNO;
3658
3659   case KEEPS: /*   \K  */
3660    /* update the startpoint */
3661    st->u.keeper.val = rex->offs[0].start;
3662    rex->offs[0].start = locinput - PL_bostr;
3663    PUSH_STATE_GOTO(KEEPS_next, next, locinput);
3664    assert(0); /*NOTREACHED*/
3665   case KEEPS_next_fail:
3666    /* rollback the start point change */
3667    rex->offs[0].start = st->u.keeper.val;
3668    sayNO_SILENT;
3669    assert(0); /*NOTREACHED*/
3670
3671   case EOL: /* /..$/  */
3672     goto seol;
3673
3674   case MEOL: /* /..$/m  */
3675    if (!NEXTCHR_IS_EOS && nextchr != '\n')
3676     sayNO;
3677    break;
3678
3679   case SEOL: /* /..$/s  */
3680   seol:
3681    if (!NEXTCHR_IS_EOS && nextchr != '\n')
3682     sayNO;
3683    if (PL_regeol - locinput > 1)
3684     sayNO;
3685    break;
3686
3687   case EOS: /*  \z  */
3688    if (!NEXTCHR_IS_EOS)
3689     sayNO;
3690    break;
3691
3692   case SANY: /*  /./s  */
3693    if (NEXTCHR_IS_EOS)
3694     sayNO;
3695    goto increment_locinput;
3696
3697   case CANY: /*  \C  */
3698    if (NEXTCHR_IS_EOS)
3699     sayNO;
3700    locinput++;
3701    break;
3702
3703   case REG_ANY: /*  /./  */
3704    if ((NEXTCHR_IS_EOS) || nextchr == '\n')
3705     sayNO;
3706    goto increment_locinput;
3707
3708
3709 #undef  ST
3710 #define ST st->u.trie
3711   case TRIEC: /* (ab|cd) with known charclass */
3712    /* In this case the charclass data is available inline so
3713    we can fail fast without a lot of extra overhead.
3714    */
3715    if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) {
3716     DEBUG_EXECUTE_r(
3717      PerlIO_printf(Perl_debug_log,
3718        "%*s  %sfailed to match trie start class...%s\n",
3719        REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3720     );
3721     sayNO_SILENT;
3722     assert(0); /* NOTREACHED */
3723    }
3724    /* FALL THROUGH */
3725   case TRIE:  /* (ab|cd)  */
3726    /* the basic plan of execution of the trie is:
3727    * At the beginning, run though all the states, and
3728    * find the longest-matching word. Also remember the position
3729    * of the shortest matching word. For example, this pattern:
3730    *    1  2 3 4    5
3731    *    ab|a|x|abcd|abc
3732    * when matched against the string "abcde", will generate
3733    * accept states for all words except 3, with the longest
3734    * matching word being 4, and the shortest being 2 (with
3735    * the position being after char 1 of the string).
3736    *
3737    * Then for each matching word, in word order (i.e. 1,2,4,5),
3738    * we run the remainder of the pattern; on each try setting
3739    * the current position to the character following the word,
3740    * returning to try the next word on failure.
3741    *
3742    * We avoid having to build a list of words at runtime by
3743    * using a compile-time structure, wordinfo[].prev, which
3744    * gives, for each word, the previous accepting word (if any).
3745    * In the case above it would contain the mappings 1->2, 2->0,
3746    * 3->0, 4->5, 5->1.  We can use this table to generate, from
3747    * the longest word (4 above), a list of all words, by
3748    * following the list of prev pointers; this gives us the
3749    * unordered list 4,5,1,2. Then given the current word we have
3750    * just tried, we can go through the list and find the
3751    * next-biggest word to try (so if we just failed on word 2,
3752    * the next in the list is 4).
3753    *
3754    * Since at runtime we don't record the matching position in
3755    * the string for each word, we have to work that out for
3756    * each word we're about to process. The wordinfo table holds
3757    * the character length of each word; given that we recorded
3758    * at the start: the position of the shortest word and its
3759    * length in chars, we just need to move the pointer the
3760    * difference between the two char lengths. Depending on
3761    * Unicode status and folding, that's cheap or expensive.
3762    *
3763    * This algorithm is optimised for the case where are only a
3764    * small number of accept states, i.e. 0,1, or maybe 2.
3765    * With lots of accepts states, and having to try all of them,
3766    * it becomes quadratic on number of accept states to find all
3767    * the next words.
3768    */
3769
3770    {
3771     /* what type of TRIE am I? (utf8 makes this contextual) */
3772     DECL_TRIE_TYPE(scan);
3773
3774     /* what trie are we using right now */
3775     reg_trie_data * const trie
3776      = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3777     HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3778     U32 state = trie->startstate;
3779
3780     if (   trie->bitmap
3781      && (NEXTCHR_IS_EOS || !TRIE_BITMAP_TEST(trie, nextchr)))
3782     {
3783      if (trie->states[ state ].wordnum) {
3784       DEBUG_EXECUTE_r(
3785        PerlIO_printf(Perl_debug_log,
3786           "%*s  %smatched empty string...%s\n",
3787           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3788       );
3789       if (!trie->jump)
3790        break;
3791      } else {
3792       DEBUG_EXECUTE_r(
3793        PerlIO_printf(Perl_debug_log,
3794           "%*s  %sfailed to match trie start class...%s\n",
3795           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3796       );
3797       sayNO_SILENT;
3798     }
3799     }
3800
3801    {
3802     U8 *uc = ( U8* )locinput;
3803
3804     STRLEN len = 0;
3805     STRLEN foldlen = 0;
3806     U8 *uscan = (U8*)NULL;
3807     U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3808     U32 charcount = 0; /* how many input chars we have matched */
3809     U32 accepted = 0; /* have we seen any accepting states? */
3810
3811     ST.jump = trie->jump;
3812     ST.me = scan;
3813     ST.firstpos = NULL;
3814     ST.longfold = FALSE; /* char longer if folded => it's harder */
3815     ST.nextword = 0;
3816
3817     /* fully traverse the TRIE; note the position of the
3818     shortest accept state and the wordnum of the longest
3819     accept state */
3820
3821     while ( state && uc <= (U8*)PL_regeol ) {
3822      U32 base = trie->states[ state ].trans.base;
3823      UV uvc = 0;
3824      U16 charid = 0;
3825      U16 wordnum;
3826      wordnum = trie->states[ state ].wordnum;
3827
3828      if (wordnum) { /* it's an accept state */
3829       if (!accepted) {
3830        accepted = 1;
3831        /* record first match position */
3832        if (ST.longfold) {
3833         ST.firstpos = (U8*)locinput;
3834         ST.firstchars = 0;
3835        }
3836        else {
3837         ST.firstpos = uc;
3838         ST.firstchars = charcount;
3839        }
3840       }
3841       if (!ST.nextword || wordnum < ST.nextword)
3842        ST.nextword = wordnum;
3843       ST.topword = wordnum;
3844      }
3845
3846      DEBUG_TRIE_EXECUTE_r({
3847         DUMP_EXEC_POS( (char *)uc, scan, utf8_target );
3848         PerlIO_printf( Perl_debug_log,
3849          "%*s  %sState: %4"UVxf" Accepted: %c ",
3850          2+depth * 2, "", PL_colors[4],
3851          (UV)state, (accepted ? 'Y' : 'N'));
3852      });
3853
3854      /* read a char and goto next state */
3855      if ( base && (foldlen || uc < (U8*)PL_regeol)) {
3856       I32 offset;
3857       REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3858            uscan, len, uvc, charid, foldlen,
3859            foldbuf, uniflags);
3860       charcount++;
3861       if (foldlen>0)
3862        ST.longfold = TRUE;
3863       if (charid &&
3864        ( ((offset =
3865        base + charid - 1 - trie->uniquecharcount)) >= 0)
3866
3867        && ((U32)offset < trie->lasttrans)
3868        && trie->trans[offset].check == state)
3869       {
3870        state = trie->trans[offset].next;
3871       }
3872       else {
3873        state = 0;
3874       }
3875       uc += len;
3876
3877      }
3878      else {
3879       state = 0;
3880      }
3881      DEBUG_TRIE_EXECUTE_r(
3882       PerlIO_printf( Perl_debug_log,
3883        "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3884        charid, uvc, (UV)state, PL_colors[5] );
3885      );
3886     }
3887     if (!accepted)
3888     sayNO;
3889
3890     /* calculate total number of accept states */
3891     {
3892      U16 w = ST.topword;
3893      accepted = 0;
3894      while (w) {
3895       w = trie->wordinfo[w].prev;
3896       accepted++;
3897      }
3898      ST.accepted = accepted;
3899     }
3900
3901     DEBUG_EXECUTE_r(
3902      PerlIO_printf( Perl_debug_log,
3903       "%*s  %sgot %"IVdf" possible matches%s\n",
3904       REPORT_CODE_OFF + depth * 2, "",
3905       PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3906     );
3907     goto trie_first_try; /* jump into the fail handler */
3908    }}
3909    assert(0); /* NOTREACHED */
3910
3911   case TRIE_next_fail: /* we failed - try next alternative */
3912   {
3913    U8 *uc;
3914    if ( ST.jump) {
3915     REGCP_UNWIND(ST.cp);
3916     UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
3917    }
3918    if (!--ST.accepted) {
3919     DEBUG_EXECUTE_r({
3920      PerlIO_printf( Perl_debug_log,
3921       "%*s  %sTRIE failed...%s\n",
3922       REPORT_CODE_OFF+depth*2, "",
3923       PL_colors[4],
3924       PL_colors[5] );
3925     });
3926     sayNO_SILENT;
3927    }
3928    {
3929     /* Find next-highest word to process.  Note that this code
3930     * is O(N^2) per trie run (O(N) per branch), so keep tight */
3931     U16 min = 0;
3932     U16 word;
3933     U16 const nextword = ST.nextword;
3934     reg_trie_wordinfo * const wordinfo
3935      = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo;
3936     for (word=ST.topword; word; word=wordinfo[word].prev) {
3937      if (word > nextword && (!min || word < min))
3938       min = word;
3939     }
3940     ST.nextword = min;
3941    }
3942
3943   trie_first_try:
3944    if (do_cutgroup) {
3945     do_cutgroup = 0;
3946     no_final = 0;
3947    }
3948
3949    if ( ST.jump) {
3950     ST.lastparen = rex->lastparen;
3951     ST.lastcloseparen = rex->lastcloseparen;
3952     REGCP_SET(ST.cp);
3953    }
3954
3955    /* find start char of end of current word */
3956    {
3957     U32 chars; /* how many chars to skip */
3958     reg_trie_data * const trie
3959      = (reg_trie_data*)rexi->data->data[ARG(ST.me)];
3960
3961     assert((trie->wordinfo[ST.nextword].len - trie->prefixlen)
3962        >=  ST.firstchars);
3963     chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen)
3964        - ST.firstchars;
3965     uc = ST.firstpos;
3966
3967     if (ST.longfold) {
3968      /* the hard option - fold each char in turn and find
3969      * its folded length (which may be different */
3970      U8 foldbuf[UTF8_MAXBYTES_CASE + 1];
3971      STRLEN foldlen;
3972      STRLEN len;
3973      UV uvc;
3974      U8 *uscan;
3975
3976      while (chars) {
3977       if (utf8_target) {
3978        uvc = utf8n_to_uvuni((U8*)uc, UTF8_MAXLEN, &len,
3979              uniflags);
3980        uc += len;
3981       }
3982       else {
3983        uvc = *uc;
3984        uc++;
3985       }
3986       uvc = to_uni_fold(uvc, foldbuf, &foldlen);
3987       uscan = foldbuf;
3988       while (foldlen) {
3989        if (!--chars)
3990         break;
3991        uvc = utf8n_to_uvuni(uscan, UTF8_MAXLEN, &len,
3992            uniflags);
3993        uscan += len;
3994        foldlen -= len;
3995       }
3996      }
3997     }
3998     else {
3999      if (utf8_target)
4000       while (chars--)
4001        uc += UTF8SKIP(uc);
4002      else
4003       uc += chars;
4004     }
4005    }
4006
4007    scan = ST.me + ((ST.jump && ST.jump[ST.nextword])
4008        ? ST.jump[ST.nextword]
4009        : NEXT_OFF(ST.me));
4010
4011    DEBUG_EXECUTE_r({
4012     PerlIO_printf( Perl_debug_log,
4013      "%*s  %sTRIE matched word #%d, continuing%s\n",
4014      REPORT_CODE_OFF+depth*2, "",
4015      PL_colors[4],
4016      ST.nextword,
4017      PL_colors[5]
4018      );
4019    });
4020
4021    if (ST.accepted > 1 || has_cutgroup) {
4022     PUSH_STATE_GOTO(TRIE_next, scan, (char*)uc);
4023     assert(0); /* NOTREACHED */
4024    }
4025    /* only one choice left - just continue */
4026    DEBUG_EXECUTE_r({
4027     AV *const trie_words
4028      = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
4029     SV ** const tmp = av_fetch( trie_words,
4030      ST.nextword-1, 0 );
4031     SV *sv= tmp ? sv_newmortal() : NULL;
4032
4033     PerlIO_printf( Perl_debug_log,
4034      "%*s  %sonly one match left, short-circuiting: #%d <%s>%s\n",
4035      REPORT_CODE_OFF+depth*2, "", PL_colors[4],
4036      ST.nextword,
4037      tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
4038        PL_colors[0], PL_colors[1],
4039        (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII
4040       )
4041      : "not compiled under -Dr",
4042      PL_colors[5] );
4043    });
4044
4045    locinput = (char*)uc;
4046    continue; /* execute rest of RE */
4047    assert(0); /* NOTREACHED */
4048   }
4049 #undef  ST
4050
4051   case EXACT: {            /*  /abc/        */
4052    char *s = STRING(scan);
4053    ln = STR_LEN(scan);
4054    if (utf8_target != is_utf8_pat) {
4055     /* The target and the pattern have differing utf8ness. */
4056     char *l = locinput;
4057     const char * const e = s + ln;
4058
4059     if (utf8_target) {
4060      /* The target is utf8, the pattern is not utf8.
4061      * Above-Latin1 code points can't match the pattern;
4062      * invariants match exactly, and the other Latin1 ones need
4063      * to be downgraded to a single byte in order to do the
4064      * comparison.  (If we could be confident that the target
4065      * is not malformed, this could be refactored to have fewer
4066      * tests by just assuming that if the first bytes match, it
4067      * is an invariant, but there are tests in the test suite
4068      * dealing with (??{...}) which violate this) */
4069      while (s < e) {
4070       if (l >= PL_regeol || UTF8_IS_ABOVE_LATIN1(* (U8*) l)) {
4071        sayNO;
4072       }
4073       if (UTF8_IS_INVARIANT(*(U8*)l)) {
4074        if (*l != *s) {
4075         sayNO;
4076        }
4077        l++;
4078       }
4079       else {
4080        if (TWO_BYTE_UTF8_TO_UNI(*l, *(l+1)) != * (U8*) s) {
4081         sayNO;
4082        }
4083        l += 2;
4084       }
4085       s++;
4086      }
4087     }
4088     else {
4089      /* The target is not utf8, the pattern is utf8. */
4090      while (s < e) {
4091       if (l >= PL_regeol || UTF8_IS_ABOVE_LATIN1(* (U8*) s))
4092       {
4093        sayNO;
4094       }
4095       if (UTF8_IS_INVARIANT(*(U8*)s)) {
4096        if (*s != *l) {
4097         sayNO;
4098        }
4099        s++;
4100       }
4101       else {
4102        if (TWO_BYTE_UTF8_TO_UNI(*s, *(s+1)) != * (U8*) l) {
4103         sayNO;
4104        }
4105        s += 2;
4106       }
4107       l++;
4108      }
4109     }
4110     locinput = l;
4111    }
4112    else {
4113     /* The target and the pattern have the same utf8ness. */
4114     /* Inline the first character, for speed. */
4115     if (PL_regeol - locinput < ln
4116      || UCHARAT(s) != nextchr
4117      || (ln > 1 && memNE(s, locinput, ln)))
4118     {
4119      sayNO;
4120     }
4121     locinput += ln;
4122    }
4123    break;
4124    }
4125
4126   case EXACTFL: {          /*  /abc/il      */
4127    re_fold_t folder;
4128    const U8 * fold_array;
4129    const char * s;
4130    U32 fold_utf8_flags;
4131
4132    RX_MATCH_TAINTED_on(reginfo->prog);
4133    folder = foldEQ_locale;
4134    fold_array = PL_fold_locale;
4135    fold_utf8_flags = FOLDEQ_UTF8_LOCALE;
4136    goto do_exactf;
4137
4138   case EXACTFU_SS:         /*  /\x{df}/iu   */
4139   case EXACTFU_TRICKYFOLD: /*  /\x{390}/iu  */
4140   case EXACTFU:            /*  /abc/iu      */
4141    folder = foldEQ_latin1;
4142    fold_array = PL_fold_latin1;
4143    fold_utf8_flags = is_utf8_pat ? FOLDEQ_S1_ALREADY_FOLDED : 0;
4144    goto do_exactf;
4145
4146   case EXACTFA:            /*  /abc/iaa     */
4147    folder = foldEQ_latin1;
4148    fold_array = PL_fold_latin1;
4149    fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4150    goto do_exactf;
4151
4152   case EXACTF:             /*  /abc/i       */
4153    folder = foldEQ;
4154    fold_array = PL_fold;
4155    fold_utf8_flags = 0;
4156
4157   do_exactf:
4158    s = STRING(scan);
4159    ln = STR_LEN(scan);
4160
4161    if (utf8_target || is_utf8_pat || state_num == EXACTFU_SS) {
4162    /* Either target or the pattern are utf8, or has the issue where
4163    * the fold lengths may differ. */
4164     const char * const l = locinput;
4165     char *e = PL_regeol;
4166
4167     if (! foldEQ_utf8_flags(s, 0,  ln, is_utf8_pat,
4168           l, &e, 0,  utf8_target, fold_utf8_flags))
4169     {
4170      sayNO;
4171     }
4172     locinput = e;
4173     break;
4174    }
4175
4176    /* Neither the target nor the pattern are utf8 */
4177    if (UCHARAT(s) != nextchr
4178     && !NEXTCHR_IS_EOS
4179     && UCHARAT(s) != fold_array[nextchr])
4180    {
4181     sayNO;
4182    }
4183    if (PL_regeol - locinput < ln)
4184     sayNO;
4185    if (ln > 1 && ! folder(s, locinput, ln))
4186     sayNO;
4187    locinput += ln;
4188    break;
4189   }
4190
4191   /* XXX Could improve efficiency by separating these all out using a
4192   * macro or in-line function.  At that point regcomp.c would no longer
4193   * have to set the FLAGS fields of these */
4194   case BOUNDL:  /*  /\b/l  */
4195   case NBOUNDL: /*  /\B/l  */
4196    RX_MATCH_TAINTED_on(reginfo->prog);
4197    /* FALL THROUGH */
4198   case BOUND:   /*  /\b/   */
4199   case BOUNDU:  /*  /\b/u  */
4200   case BOUNDA:  /*  /\b/a  */
4201   case NBOUND:  /*  /\B/   */
4202   case NBOUNDU: /*  /\B/u  */
4203   case NBOUNDA: /*  /\B/a  */
4204    /* was last char in word? */
4205    if (utf8_target
4206     && FLAGS(scan) != REGEX_ASCII_RESTRICTED_CHARSET
4207     && FLAGS(scan) != REGEX_ASCII_MORE_RESTRICTED_CHARSET)
4208    {
4209     if (locinput == PL_bostr)
4210      ln = '\n';
4211     else {
4212      const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
4213
4214      ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
4215     }
4216     if (FLAGS(scan) != REGEX_LOCALE_CHARSET) {
4217      ln = isWORDCHAR_uni(ln);
4218      if (NEXTCHR_IS_EOS)
4219       n = 0;
4220      else {
4221       LOAD_UTF8_CHARCLASS_ALNUM();
4222       n = swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)locinput,
4223                 utf8_target);
4224      }
4225     }
4226     else {
4227      ln = isWORDCHAR_LC_uvchr(UNI_TO_NATIVE(ln));
4228      n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_LC_utf8((U8*)locinput);
4229     }
4230    }
4231    else {
4232
4233     /* Here the string isn't utf8, or is utf8 and only ascii
4234     * characters are to match \w.  In the latter case looking at
4235     * the byte just prior to the current one may be just the final
4236     * byte of a multi-byte character.  This is ok.  There are two
4237     * cases:
4238     * 1) it is a single byte character, and then the test is doing
4239     * just what it's supposed to.
4240     * 2) it is a multi-byte character, in which case the final
4241     * byte is never mistakable for ASCII, and so the test
4242     * will say it is not a word character, which is the
4243     * correct answer. */
4244     ln = (locinput != PL_bostr) ?
4245      UCHARAT(locinput - 1) : '\n';
4246     switch (FLAGS(scan)) {
4247      case REGEX_UNICODE_CHARSET:
4248       ln = isWORDCHAR_L1(ln);
4249       n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_L1(nextchr);
4250       break;
4251      case REGEX_LOCALE_CHARSET:
4252       ln = isWORDCHAR_LC(ln);
4253       n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_LC(nextchr);
4254       break;
4255      case REGEX_DEPENDS_CHARSET:
4256       ln = isWORDCHAR(ln);
4257       n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR(nextchr);
4258       break;
4259      case REGEX_ASCII_RESTRICTED_CHARSET:
4260      case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
4261       ln = isWORDCHAR_A(ln);
4262       n = NEXTCHR_IS_EOS ? 0 : isWORDCHAR_A(nextchr);
4263       break;
4264      default:
4265       Perl_croak(aTHX_ "panic: Unexpected FLAGS %u in op %u", FLAGS(scan), OP(scan));
4266       break;
4267     }
4268    }
4269    /* Note requires that all BOUNDs be lower than all NBOUNDs in
4270    * regcomp.sym */
4271    if (((!ln) == (!n)) == (OP(scan) < NBOUND))
4272      sayNO;
4273    break;
4274
4275   case ANYOF:  /*  /[abc]/       */
4276   case ANYOF_WARN_SUPER:
4277    if (NEXTCHR_IS_EOS)
4278     sayNO;
4279    if (utf8_target) {
4280     if (!reginclass(rex, scan, (U8*)locinput, utf8_target))
4281      sayNO;
4282     locinput += UTF8SKIP(locinput);
4283    }
4284    else {
4285     if (!REGINCLASS(rex, scan, (U8*)locinput))
4286      sayNO;
4287     locinput++;
4288    }
4289    break;
4290
4291   /* The argument (FLAGS) to all the POSIX node types is the class number
4292   * */
4293
4294   case NPOSIXL:   /* \W or [:^punct:] etc. under /l */
4295    to_complement = 1;
4296    /* FALLTHROUGH */
4297
4298   case POSIXL:    /* \w or [:punct:] etc. under /l */
4299    if (NEXTCHR_IS_EOS)
4300     sayNO;
4301
4302    /* The locale hasn't influenced the outcome before this, so defer
4303    * tainting until now */
4304    RX_MATCH_TAINTED_on(reginfo->prog);
4305
4306    /* Use isFOO_lc() for characters within Latin1.  (Note that
4307    * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else
4308    * wouldn't be invariant) */
4309    if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) {
4310     if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan), (U8) nextchr)))) {
4311      sayNO;
4312     }
4313    }
4314    else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
4315     if (! (to_complement ^ cBOOL(isFOO_lc(FLAGS(scan),
4316           (U8) TWO_BYTE_UTF8_TO_UNI(nextchr,
4317                *(locinput + 1))))))
4318     {
4319      sayNO;
4320     }
4321    }
4322    else { /* Here, must be an above Latin-1 code point */
4323     goto utf8_posix_not_eos;
4324    }
4325
4326    /* Here, must be utf8 */
4327    locinput += UTF8SKIP(locinput);
4328    break;
4329
4330   case NPOSIXD:   /* \W or [:^punct:] etc. under /d */
4331    to_complement = 1;
4332    /* FALLTHROUGH */
4333
4334   case POSIXD:    /* \w or [:punct:] etc. under /d */
4335    if (utf8_target) {
4336     goto utf8_posix;
4337    }
4338    goto posixa;
4339
4340   case NPOSIXA:   /* \W or [:^punct:] etc. under /a */
4341
4342    if (NEXTCHR_IS_EOS) {
4343     sayNO;
4344    }
4345
4346    /* All UTF-8 variants match */
4347    if (! UTF8_IS_INVARIANT(nextchr)) {
4348     goto increment_locinput;
4349    }
4350
4351    to_complement = 1;
4352    /* FALLTHROUGH */
4353
4354   case POSIXA:    /* \w or [:punct:] etc. under /a */
4355
4356   posixa:
4357    /* We get here through POSIXD, NPOSIXD, and NPOSIXA when not in
4358    * UTF-8, and also from NPOSIXA even in UTF-8 when the current
4359    * character is a single byte */
4360
4361    if (NEXTCHR_IS_EOS
4362     || ! (to_complement ^ cBOOL(_generic_isCC_A(nextchr,
4363                FLAGS(scan)))))
4364    {
4365     sayNO;
4366    }
4367
4368    /* Here we are either not in utf8, or we matched a utf8-invariant,
4369    * so the next char is the next byte */
4370    locinput++;
4371    break;
4372
4373   case NPOSIXU:   /* \W or [:^punct:] etc. under /u */
4374    to_complement = 1;
4375    /* FALLTHROUGH */
4376
4377   case POSIXU:    /* \w or [:punct:] etc. under /u */
4378   utf8_posix:
4379    if (NEXTCHR_IS_EOS) {
4380     sayNO;
4381    }
4382   utf8_posix_not_eos:
4383
4384    /* Use _generic_isCC() for characters within Latin1.  (Note that
4385    * UTF8_IS_INVARIANT works even on non-UTF-8 strings, or else
4386    * wouldn't be invariant) */
4387    if (UTF8_IS_INVARIANT(nextchr) || ! utf8_target) {
4388     if (! (to_complement ^ cBOOL(_generic_isCC(nextchr,
4389               FLAGS(scan)))))
4390     {
4391      sayNO;
4392     }
4393     locinput++;
4394    }
4395    else if (UTF8_IS_DOWNGRADEABLE_START(nextchr)) {
4396     if (! (to_complement
4397      ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_UNI(nextchr,
4398                *(locinput + 1)),
4399            FLAGS(scan)))))
4400     {
4401      sayNO;
4402     }
4403     locinput += 2;
4404    }
4405    else {  /* Handle above Latin-1 code points */
4406     classnum = (_char_class_number) FLAGS(scan);
4407     if (classnum < _FIRST_NON_SWASH_CC) {
4408
4409      /* Here, uses a swash to find such code points.  Load if if
4410      * not done already */
4411      if (! PL_utf8_swash_ptrs[classnum]) {
4412       U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
4413       PL_utf8_swash_ptrs[classnum]
4414         = _core_swash_init("utf8",
4415           swash_property_names[classnum],
4416           &PL_sv_undef, 1, 0, NULL, &flags);
4417      }
4418      if (! (to_complement
4419       ^ cBOOL(swash_fetch(PL_utf8_swash_ptrs[classnum],
4420            (U8 *) locinput, TRUE))))
4421      {
4422       sayNO;
4423      }
4424     }
4425     else {  /* Here, uses macros to find above Latin-1 code points */
4426      switch (classnum) {
4427       case _CC_ENUM_SPACE:    /* XXX would require separate
4428             code if we revert the change
4429             of \v matching this */
4430       case _CC_ENUM_PSXSPC:
4431        if (! (to_complement
4432           ^ cBOOL(is_XPERLSPACE_high(locinput))))
4433        {
4434         sayNO;
4435        }
4436        break;
4437       case _CC_ENUM_BLANK:
4438        if (! (to_complement
4439            ^ cBOOL(is_HORIZWS_high(locinput))))
4440        {
4441         sayNO;
4442        }
4443        break;
4444       case _CC_ENUM_XDIGIT:
4445        if (! (to_complement
4446            ^ cBOOL(is_XDIGIT_high(locinput))))
4447        {
4448         sayNO;
4449        }
4450        break;
4451       case _CC_ENUM_VERTSPACE:
4452        if (! (to_complement
4453            ^ cBOOL(is_VERTWS_high(locinput))))
4454        {
4455         sayNO;
4456        }
4457        break;
4458       default:    /* The rest, e.g. [:cntrl:], can't match
4459          above Latin1 */
4460        if (! to_complement) {
4461         sayNO;
4462        }
4463        break;
4464      }
4465     }
4466     locinput += UTF8SKIP(locinput);
4467    }
4468    break;
4469
4470   case CLUMP: /* Match \X: logical Unicode character.  This is defined as
4471      a Unicode extended Grapheme Cluster */
4472    /* From http://www.unicode.org/reports/tr29 (5.2 version).  An
4473    extended Grapheme Cluster is:
4474
4475    CR LF
4476    | Prepend* Begin Extend*
4477    | .
4478
4479    Begin is:           ( Special_Begin | ! Control )
4480    Special_Begin is:   ( Regional-Indicator+ | Hangul-syllable )
4481    Extend is:          ( Grapheme_Extend | Spacing_Mark )
4482    Control is:         [ GCB_Control | CR | LF ]
4483    Hangul-syllable is: ( T+ | ( L* ( L | ( LVT | ( V | LV ) V* ) T* ) ))
4484
4485    If we create a 'Regular_Begin' = Begin - Special_Begin, then
4486    we can rewrite
4487
4488     Begin is ( Regular_Begin + Special Begin )
4489
4490    It turns out that 98.4% of all Unicode code points match
4491    Regular_Begin.  Doing it this way eliminates a table match in
4492    the previous implementation for almost all Unicode code points.
4493
4494    There is a subtlety with Prepend* which showed up in testing.
4495    Note that the Begin, and only the Begin is required in:
4496     | Prepend* Begin Extend*
4497    Also, Begin contains '! Control'.  A Prepend must be a
4498    '!  Control', which means it must also be a Begin.  What it
4499    comes down to is that if we match Prepend* and then find no
4500    suitable Begin afterwards, that if we backtrack the last
4501    Prepend, that one will be a suitable Begin.
4502    */
4503
4504    if (NEXTCHR_IS_EOS)
4505     sayNO;
4506    if  (! utf8_target) {
4507
4508     /* Match either CR LF  or '.', as all the other possibilities
4509     * require utf8 */
4510     locinput++;     /* Match the . or CR */
4511     if (nextchr == '\r' /* And if it was CR, and the next is LF,
4512          match the LF */
4513      && locinput < PL_regeol
4514      && UCHARAT(locinput) == '\n')
4515     {
4516      locinput++;
4517     }
4518    }
4519    else {
4520
4521     /* Utf8: See if is ( CR LF ); already know that locinput <
4522     * PL_regeol, so locinput+1 is in bounds */
4523     if ( nextchr == '\r' && locinput+1 < PL_regeol
4524      && UCHARAT(locinput + 1) == '\n')
4525     {
4526      locinput += 2;
4527     }
4528     else {
4529      STRLEN len;
4530
4531      /* In case have to backtrack to beginning, then match '.' */
4532      char *starting = locinput;
4533
4534      /* In case have to backtrack the last prepend */
4535      char *previous_prepend = NULL;
4536
4537      LOAD_UTF8_CHARCLASS_GCB();
4538
4539      /* Match (prepend)*   */
4540      while (locinput < PL_regeol
4541       && (len = is_GCB_Prepend_utf8(locinput)))
4542      {
4543       previous_prepend = locinput;
4544       locinput += len;
4545      }
4546
4547      /* As noted above, if we matched a prepend character, but
4548      * the next thing won't match, back off the last prepend we
4549      * matched, as it is guaranteed to match the begin */
4550      if (previous_prepend
4551       && (locinput >=  PL_regeol
4552        || (! swash_fetch(PL_utf8_X_regular_begin,
4553            (U8*)locinput, utf8_target)
4554         && ! is_GCB_SPECIAL_BEGIN_START_utf8(locinput)))
4555       )
4556      {
4557       locinput = previous_prepend;
4558      }
4559
4560      /* Note that here we know PL_regeol > locinput, as we
4561      * tested that upon input to this switch case, and if we
4562      * moved locinput forward, we tested the result just above
4563      * and it either passed, or we backed off so that it will
4564      * now pass */
4565      if (swash_fetch(PL_utf8_X_regular_begin,
4566          (U8*)locinput, utf8_target)) {
4567       locinput += UTF8SKIP(locinput);
4568      }
4569      else if (! is_GCB_SPECIAL_BEGIN_START_utf8(locinput)) {
4570
4571       /* Here did not match the required 'Begin' in the
4572       * second term.  So just match the very first
4573       * character, the '.' of the final term of the regex */
4574       locinput = starting + UTF8SKIP(starting);
4575       goto exit_utf8;
4576      } else {
4577
4578       /* Here is a special begin.  It can be composed of
4579       * several individual characters.  One possibility is
4580       * RI+ */
4581       if ((len = is_GCB_RI_utf8(locinput))) {
4582        locinput += len;
4583        while (locinput < PL_regeol
4584         && (len = is_GCB_RI_utf8(locinput)))
4585        {
4586         locinput += len;
4587        }
4588       } else if ((len = is_GCB_T_utf8(locinput))) {
4589        /* Another possibility is T+ */
4590        locinput += len;
4591        while (locinput < PL_regeol
4592         && (len = is_GCB_T_utf8(locinput)))
4593        {
4594         locinput += len;
4595        }
4596       } else {
4597
4598        /* Here, neither RI+ nor T+; must be some other
4599        * Hangul.  That means it is one of the others: L,
4600        * LV, LVT or V, and matches:
4601        * L* (L | LVT T* | V * V* T* | LV  V* T*) */
4602
4603        /* Match L*           */
4604        while (locinput < PL_regeol
4605         && (len = is_GCB_L_utf8(locinput)))
4606        {
4607         locinput += len;
4608        }
4609
4610        /* Here, have exhausted L*.  If the next character
4611        * is not an LV, LVT nor V, it means we had to have
4612        * at least one L, so matches L+ in the original
4613        * equation, we have a complete hangul syllable.
4614        * Are done. */
4615
4616        if (locinput < PL_regeol
4617         && is_GCB_LV_LVT_V_utf8(locinput))
4618        {
4619         /* Otherwise keep going.  Must be LV, LVT or V.
4620         * See if LVT, by first ruling out V, then LV */
4621         if (! is_GCB_V_utf8(locinput)
4622           /* All but every TCount one is LV */
4623          && (valid_utf8_to_uvchr((U8 *) locinput,
4624                   NULL)
4625                   - SBASE)
4626           % TCount != 0)
4627         {
4628          locinput += UTF8SKIP(locinput);
4629         } else {
4630
4631          /* Must be  V or LV.  Take it, then match
4632          * V*     */
4633          locinput += UTF8SKIP(locinput);
4634          while (locinput < PL_regeol
4635           && (len = is_GCB_V_utf8(locinput)))
4636          {
4637           locinput += len;
4638          }
4639         }
4640
4641         /* And any of LV, LVT, or V can be followed
4642         * by T*            */
4643         while (locinput < PL_regeol
4644          && (len = is_GCB_T_utf8(locinput)))
4645         {
4646          locinput += len;
4647         }
4648        }
4649       }
4650      }
4651
4652      /* Match any extender */
4653      while (locinput < PL_regeol
4654        && swash_fetch(PL_utf8_X_extend,
4655            (U8*)locinput, utf8_target))
4656      {
4657       locinput += UTF8SKIP(locinput);
4658      }
4659     }
4660    exit_utf8:
4661     if (locinput > PL_regeol) sayNO;
4662    }
4663    break;
4664
4665   case NREFFL:  /*  /\g{name}/il  */
4666   {   /* The capture buffer cases.  The ones beginning with N for the
4667    named buffers just convert to the equivalent numbered and
4668    pretend they were called as the corresponding numbered buffer
4669    op.  */
4670    /* don't initialize these in the declaration, it makes C++
4671    unhappy */
4672    char *s;
4673    char type;
4674    re_fold_t folder;
4675    const U8 *fold_array;
4676    UV utf8_fold_flags;
4677
4678    RX_MATCH_TAINTED_on(reginfo->prog);
4679    folder = foldEQ_locale;
4680    fold_array = PL_fold_locale;
4681    type = REFFL;
4682    utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
4683    goto do_nref;
4684
4685   case NREFFA:  /*  /\g{name}/iaa  */
4686    folder = foldEQ_latin1;
4687    fold_array = PL_fold_latin1;
4688    type = REFFA;
4689    utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4690    goto do_nref;
4691
4692   case NREFFU:  /*  /\g{name}/iu  */
4693    folder = foldEQ_latin1;
4694    fold_array = PL_fold_latin1;
4695    type = REFFU;
4696    utf8_fold_flags = 0;
4697    goto do_nref;
4698
4699   case NREFF:  /*  /\g{name}/i  */
4700    folder = foldEQ;
4701    fold_array = PL_fold;
4702    type = REFF;
4703    utf8_fold_flags = 0;
4704    goto do_nref;
4705
4706   case NREF:  /*  /\g{name}/   */
4707    type = REF;
4708    folder = NULL;
4709    fold_array = NULL;
4710    utf8_fold_flags = 0;
4711   do_nref:
4712
4713    /* For the named back references, find the corresponding buffer
4714    * number */
4715    n = reg_check_named_buff_matched(rex,scan);
4716
4717    if ( ! n ) {
4718     sayNO;
4719    }
4720    goto do_nref_ref_common;
4721
4722   case REFFL:  /*  /\1/il  */
4723    RX_MATCH_TAINTED_on(reginfo->prog);
4724    folder = foldEQ_locale;
4725    fold_array = PL_fold_locale;
4726    utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
4727    goto do_ref;
4728
4729   case REFFA:  /*  /\1/iaa  */
4730    folder = foldEQ_latin1;
4731    fold_array = PL_fold_latin1;
4732    utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4733    goto do_ref;
4734
4735   case REFFU:  /*  /\1/iu  */
4736    folder = foldEQ_latin1;
4737    fold_array = PL_fold_latin1;
4738    utf8_fold_flags = 0;
4739    goto do_ref;
4740
4741   case REFF:  /*  /\1/i  */
4742    folder = foldEQ;
4743    fold_array = PL_fold;
4744    utf8_fold_flags = 0;
4745    goto do_ref;
4746
4747   case REF:  /*  /\1/    */
4748    folder = NULL;
4749    fold_array = NULL;
4750    utf8_fold_flags = 0;
4751
4752   do_ref:
4753    type = OP(scan);
4754    n = ARG(scan);  /* which paren pair */
4755
4756   do_nref_ref_common:
4757    ln = rex->offs[n].start;
4758    PL_reg_leftiter = PL_reg_maxiter;  /* Void cache */
4759    if (rex->lastparen < n || ln == -1)
4760     sayNO;   /* Do not match unless seen CLOSEn. */
4761    if (ln == rex->offs[n].end)
4762     break;
4763
4764    s = PL_bostr + ln;
4765    if (type != REF /* REF can do byte comparison */
4766     && (utf8_target || type == REFFU))
4767    { /* XXX handle REFFL better */
4768     char * limit = PL_regeol;
4769
4770     /* This call case insensitively compares the entire buffer
4771      * at s, with the current input starting at locinput, but
4772      * not going off the end given by PL_regeol, and returns in
4773      * <limit> upon success, how much of the current input was
4774      * matched */
4775     if (! foldEQ_utf8_flags(s, NULL, rex->offs[n].end - ln, utf8_target,
4776          locinput, &limit, 0, utf8_target, utf8_fold_flags))
4777     {
4778      sayNO;
4779     }
4780     locinput = limit;
4781     break;
4782    }
4783
4784    /* Not utf8:  Inline the first character, for speed. */
4785    if (!NEXTCHR_IS_EOS &&
4786     UCHARAT(s) != nextchr &&
4787     (type == REF ||
4788     UCHARAT(s) != fold_array[nextchr]))
4789     sayNO;
4790    ln = rex->offs[n].end - ln;
4791    if (locinput + ln > PL_regeol)
4792     sayNO;
4793    if (ln > 1 && (type == REF
4794       ? memNE(s, locinput, ln)
4795       : ! folder(s, locinput, ln)))
4796     sayNO;
4797    locinput += ln;
4798    break;
4799   }
4800
4801   case NOTHING: /* null op; e.g. the 'nothing' following
4802      * the '*' in m{(a+|b)*}' */
4803    break;
4804   case TAIL: /* placeholder while compiling (A|B|C) */
4805    break;
4806
4807   case BACK: /* ??? doesn't appear to be used ??? */
4808    break;
4809
4810 #undef  ST
4811 #define ST st->u.eval
4812   {
4813    SV *ret;
4814    REGEXP *re_sv;
4815    regexp *re;
4816    regexp_internal *rei;
4817    regnode *startpoint;
4818
4819   case GOSTART: /*  (?R)  */
4820   case GOSUB: /*    /(...(?1))/   /(...(?&foo))/   */
4821    if (cur_eval && cur_eval->locinput==locinput) {
4822     if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
4823      Perl_croak(aTHX_ "Infinite recursion in regex");
4824     if ( ++nochange_depth > max_nochange_depth )
4825      Perl_croak(aTHX_
4826       "Pattern subroutine nesting without pos change"
4827       " exceeded limit in regex");
4828    } else {
4829     nochange_depth = 0;
4830    }
4831    re_sv = rex_sv;
4832    re = rex;
4833    rei = rexi;
4834    if (OP(scan)==GOSUB) {
4835     startpoint = scan + ARG2L(scan);
4836     ST.close_paren = ARG(scan);
4837    } else {
4838     startpoint = rei->program+1;
4839     ST.close_paren = 0;
4840    }
4841    goto eval_recurse_doit;
4842    assert(0); /* NOTREACHED */
4843
4844   case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
4845    if (cur_eval && cur_eval->locinput==locinput) {
4846     if ( ++nochange_depth > max_nochange_depth )
4847      Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
4848    } else {
4849     nochange_depth = 0;
4850    }
4851    {
4852     /* execute the code in the {...} */
4853
4854     dSP;
4855     IV before;
4856     OP * const oop = PL_op;
4857     COP * const ocurcop = PL_curcop;
4858     OP *nop;
4859     char *saved_regeol = PL_regeol;
4860     struct re_save_state saved_state;
4861     CV *newcv;
4862
4863     /* save *all* paren positions */
4864     regcppush(rex, 0, maxopenparen);
4865     REGCP_SET(runops_cp);
4866
4867     /* To not corrupt the existing regex state while executing the
4868     * eval we would normally put it on the save stack, like with
4869     * save_re_context. However, re-evals have a weird scoping so we
4870     * can't just add ENTER/LEAVE here. With that, things like
4871     *
4872     *    (?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a})
4873     *
4874     * would break, as they expect the localisation to be unwound
4875     * only when the re-engine backtracks through the bit that
4876     * localised it.
4877     *
4878     * What we do instead is just saving the state in a local c
4879     * variable.
4880     */
4881     Copy(&PL_reg_state, &saved_state, 1, struct re_save_state);
4882
4883     if (!caller_cv)
4884      caller_cv = find_runcv(NULL);
4885
4886     n = ARG(scan);
4887
4888     if (rexi->data->what[n] == 'r') { /* code from an external qr */
4889      newcv = (ReANY(
4890             (REGEXP*)(rexi->data->data[n])
4891            ))->qr_anoncv
4892           ;
4893      nop = (OP*)rexi->data->data[n+1];
4894     }
4895     else if (rexi->data->what[n] == 'l') { /* literal code */
4896      newcv = caller_cv;
4897      nop = (OP*)rexi->data->data[n];
4898      assert(CvDEPTH(newcv));
4899     }
4900     else {
4901      /* literal with own CV */
4902      assert(rexi->data->what[n] == 'L');
4903      newcv = rex->qr_anoncv;
4904      nop = (OP*)rexi->data->data[n];
4905     }
4906
4907     /* normally if we're about to execute code from the same
4908     * CV that we used previously, we just use the existing
4909     * CX stack entry. However, its possible that in the
4910     * meantime we may have backtracked, popped from the save
4911     * stack, and undone the SAVECOMPPAD(s) associated with
4912     * PUSH_MULTICALL; in which case PL_comppad no longer
4913     * points to newcv's pad. */
4914     if (newcv != last_pushed_cv || PL_comppad != last_pad)
4915     {
4916      U8 flags = (CXp_SUB_RE |
4917         ((newcv == caller_cv) ? CXp_SUB_RE_FAKE : 0));
4918      if (last_pushed_cv) {
4919       CHANGE_MULTICALL_FLAGS(newcv, flags);
4920      }
4921      else {
4922       PUSH_MULTICALL_FLAGS(newcv, flags);
4923      }
4924      last_pushed_cv = newcv;
4925     }
4926     else {
4927      /* these assignments are just to silence compiler
4928      * warnings */
4929      multicall_cop = NULL;
4930      newsp = NULL;
4931     }
4932     last_pad = PL_comppad;
4933
4934     /* the initial nextstate you would normally execute
4935     * at the start of an eval (which would cause error
4936     * messages to come from the eval), may be optimised
4937     * away from the execution path in the regex code blocks;
4938     * so manually set PL_curcop to it initially */
4939     {
4940      OP *o = cUNOPx(nop)->op_first;
4941      assert(o->op_type == OP_NULL);
4942      if (o->op_targ == OP_SCOPE) {
4943       o = cUNOPo->op_first;
4944      }
4945      else {
4946       assert(o->op_targ == OP_LEAVE);
4947       o = cUNOPo->op_first;
4948       assert(o->op_type == OP_ENTER);
4949       o = o->op_sibling;
4950      }
4951
4952      if (o->op_type != OP_STUB) {
4953       assert(    o->op_type == OP_NEXTSTATE
4954         || o->op_type == OP_DBSTATE
4955         || (o->op_type == OP_NULL
4956          &&  (  o->op_targ == OP_NEXTSTATE
4957           || o->op_targ == OP_DBSTATE
4958           )
4959          )
4960       );
4961       PL_curcop = (COP*)o;
4962      }
4963     }
4964     nop = nop->op_next;
4965
4966     DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
4967      "  re EVAL PL_op=0x%"UVxf"\n", PTR2UV(nop)) );
4968
4969     rex->offs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
4970
4971     if (sv_yes_mark) {
4972      SV *sv_mrk = get_sv("REGMARK", 1);
4973      sv_setsv(sv_mrk, sv_yes_mark);
4974     }
4975
4976     /* we don't use MULTICALL here as we want to call the
4977     * first op of the block of interest, rather than the
4978     * first op of the sub */
4979     before = (IV)(SP-PL_stack_base);
4980     PL_op = nop;
4981     CALLRUNOPS(aTHX);   /* Scalar context. */
4982     SPAGAIN;
4983     if ((IV)(SP-PL_stack_base) == before)
4984      ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
4985     else {
4986      ret = POPs;
4987      PUTBACK;
4988     }
4989
4990     /* before restoring everything, evaluate the returned
4991     * value, so that 'uninit' warnings don't use the wrong
4992     * PL_op or pad. Also need to process any magic vars
4993     * (e.g. $1) *before* parentheses are restored */
4994
4995     PL_op = NULL;
4996
4997     re_sv = NULL;
4998     if (logical == 0)        /*   (?{})/   */
4999      sv_setsv(save_scalar(PL_replgv), ret); /* $^R */
5000     else if (logical == 1) { /*   /(?(?{...})X|Y)/    */
5001      sw = cBOOL(SvTRUE(ret));
5002      logical = 0;
5003     }
5004     else {                   /*  /(??{})  */
5005      /*  if its overloaded, let the regex compiler handle
5006      *  it; otherwise extract regex, or stringify  */
5007      if (!SvAMAGIC(ret)) {
5008       SV *sv = ret;
5009       if (SvROK(sv))
5010        sv = SvRV(sv);
5011       if (SvTYPE(sv) == SVt_REGEXP)
5012        re_sv = (REGEXP*) sv;
5013       else if (SvSMAGICAL(sv)) {
5014        MAGIC *mg = mg_find(sv, PERL_MAGIC_qr);
5015        if (mg)
5016         re_sv = (REGEXP *) mg->mg_obj;
5017       }
5018
5019       /* force any magic, undef warnings here */
5020       if (!re_sv) {
5021        ret = sv_mortalcopy(ret);
5022        (void) SvPV_force_nolen(ret);
5023       }
5024      }
5025
5026     }
5027
5028     Copy(&saved_state, &PL_reg_state, 1, struct re_save_state);
5029
5030     /* *** Note that at this point we don't restore
5031     * PL_comppad, (or pop the CxSUB) on the assumption it may
5032     * be used again soon. This is safe as long as nothing
5033     * in the regexp code uses the pad ! */
5034     PL_op = oop;
5035     PL_curcop = ocurcop;
5036     PL_regeol = saved_regeol;
5037     S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen);
5038
5039     if (logical != 2)
5040      break;
5041    }
5042
5043     /* only /(??{})/  from now on */
5044     logical = 0;
5045     {
5046      /* extract RE object from returned value; compiling if
5047      * necessary */
5048
5049      if (re_sv) {
5050       re_sv = reg_temp_copy(NULL, re_sv);
5051      }
5052      else {
5053       U32 pm_flags = 0;
5054
5055       if (SvUTF8(ret) && IN_BYTES) {
5056        /* In use 'bytes': make a copy of the octet
5057        * sequence, but without the flag on */
5058        STRLEN len;
5059        const char *const p = SvPV(ret, len);
5060        ret = newSVpvn_flags(p, len, SVs_TEMP);
5061       }
5062       if (rex->intflags & PREGf_USE_RE_EVAL)
5063        pm_flags |= PMf_USE_RE_EVAL;
5064
5065       /* if we got here, it should be an engine which
5066       * supports compiling code blocks and stuff */
5067       assert(rex->engine && rex->engine->op_comp);
5068       assert(!(scan->flags & ~RXf_PMf_COMPILETIME));
5069       re_sv = rex->engine->op_comp(aTHX_ &ret, 1, NULL,
5070          rex->engine, NULL, NULL,
5071          /* copy /msix etc to inner pattern */
5072          scan->flags,
5073          pm_flags);
5074
5075       if (!(SvFLAGS(ret)
5076        & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
5077         | SVs_GMG))) {
5078        /* This isn't a first class regexp. Instead, it's
5079        caching a regexp onto an existing, Perl visible
5080        scalar.  */
5081        sv_magic(ret, MUTABLE_SV(re_sv), PERL_MAGIC_qr, 0, 0);
5082       }
5083       /* safe to do now that any $1 etc has been
5084       * interpolated into the new pattern string and
5085       * compiled */
5086       S_regcp_restore(aTHX_ rex, runops_cp, &maxopenparen);
5087      }
5088      SAVEFREESV(re_sv);
5089      re = ReANY(re_sv);
5090     }
5091     RXp_MATCH_COPIED_off(re);
5092     re->subbeg = rex->subbeg;
5093     re->sublen = rex->sublen;
5094     re->suboffset = rex->suboffset;
5095     re->subcoffset = rex->subcoffset;
5096     rei = RXi_GET(re);
5097     DEBUG_EXECUTE_r(
5098      debug_start_match(re_sv, utf8_target, locinput, PL_regeol,
5099       "Matching embedded");
5100     );
5101     startpoint = rei->program + 1;
5102      ST.close_paren = 0; /* only used for GOSUB */
5103
5104   eval_recurse_doit: /* Share code with GOSUB below this line */
5105     /* run the pattern returned from (??{...}) */
5106
5107     /* Save *all* the positions. */
5108     ST.cp = regcppush(rex, 0, maxopenparen);
5109     REGCP_SET(ST.lastcp);
5110
5111     re->lastparen = 0;
5112     re->lastcloseparen = 0;
5113
5114     maxopenparen = 0;
5115
5116     /* XXXX This is too dramatic a measure... */
5117     PL_reg_maxiter = 0;
5118
5119     ST.saved_utf8_pat = is_utf8_pat;
5120     is_utf8_pat = cBOOL(RX_UTF8(re_sv));
5121
5122     ST.prev_rex = rex_sv;
5123     ST.prev_curlyx = cur_curlyx;
5124     rex_sv = re_sv;
5125     SET_reg_curpm(rex_sv);
5126     rex = re;
5127     rexi = rei;
5128     cur_curlyx = NULL;
5129     ST.B = next;
5130     ST.prev_eval = cur_eval;
5131     cur_eval = st;
5132     /* now continue from first node in postoned RE */
5133     PUSH_YES_STATE_GOTO(EVAL_AB, startpoint, locinput);
5134     assert(0); /* NOTREACHED */
5135   }
5136
5137   case EVAL_AB: /* cleanup after a successful (??{A})B */
5138    /* note: this is called twice; first after popping B, then A */
5139    is_utf8_pat = ST.saved_utf8_pat;
5140    rex_sv = ST.prev_rex;
5141    SET_reg_curpm(rex_sv);
5142    rex = ReANY(rex_sv);
5143    rexi = RXi_GET(rex);
5144    regcpblow(ST.cp);
5145    cur_eval = ST.prev_eval;
5146    cur_curlyx = ST.prev_curlyx;
5147
5148    /* XXXX This is too dramatic a measure... */
5149    PL_reg_maxiter = 0;
5150    if ( nochange_depth )
5151     nochange_depth--;
5152    sayYES;
5153
5154
5155   case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
5156    /* note: this is called twice; first after popping B, then A */
5157    is_utf8_pat = ST.saved_utf8_pat;
5158    rex_sv = ST.prev_rex;
5159    SET_reg_curpm(rex_sv);
5160    rex = ReANY(rex_sv);
5161    rexi = RXi_GET(rex);
5162
5163    REGCP_UNWIND(ST.lastcp);
5164    regcppop(rex, &maxopenparen);
5165    cur_eval = ST.prev_eval;
5166    cur_curlyx = ST.prev_curlyx;
5167    /* XXXX This is too dramatic a measure... */
5168    PL_reg_maxiter = 0;
5169    if ( nochange_depth )
5170     nochange_depth--;
5171    sayNO_SILENT;
5172 #undef ST
5173
5174   case OPEN: /*  (  */
5175    n = ARG(scan);  /* which paren pair */
5176    rex->offs[n].start_tmp = locinput - PL_bostr;
5177    if (n > maxopenparen)
5178     maxopenparen = n;
5179    DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
5180     "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf" tmp; maxopenparen=%"UVuf"\n",
5181     PTR2UV(rex),
5182     PTR2UV(rex->offs),
5183     (UV)n,
5184     (IV)rex->offs[n].start_tmp,
5185     (UV)maxopenparen
5186    ));
5187    lastopen = n;
5188    break;
5189
5190 /* XXX really need to log other places start/end are set too */
5191 #define CLOSE_CAPTURE \
5192  rex->offs[n].start = rex->offs[n].start_tmp; \
5193  rex->offs[n].end = locinput - PL_bostr; \
5194  DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log, \
5195   "rex=0x%"UVxf" offs=0x%"UVxf": \\%"UVuf": set %"IVdf"..%"IVdf"\n", \
5196   PTR2UV(rex), \
5197   PTR2UV(rex->offs), \
5198   (UV)n, \
5199   (IV)rex->offs[n].start, \
5200   (IV)rex->offs[n].end \
5201  ))
5202
5203   case CLOSE:  /*  )  */
5204    n = ARG(scan);  /* which paren pair */
5205    CLOSE_CAPTURE;
5206    if (n > rex->lastparen)
5207     rex->lastparen = n;
5208    rex->lastcloseparen = n;
5209    if (cur_eval && cur_eval->u.eval.close_paren == n) {
5210     goto fake_end;
5211    }
5212    break;
5213
5214   case ACCEPT:  /*  (*ACCEPT)  */
5215    if (ARG(scan)){
5216     regnode *cursor;
5217     for (cursor=scan;
5218      cursor && OP(cursor)!=END;
5219      cursor=regnext(cursor))
5220     {
5221      if ( OP(cursor)==CLOSE ){
5222       n = ARG(cursor);
5223       if ( n <= lastopen ) {
5224        CLOSE_CAPTURE;
5225        if (n > rex->lastparen)
5226         rex->lastparen = n;
5227        rex->lastcloseparen = n;
5228        if ( n == ARG(scan) || (cur_eval &&
5229         cur_eval->u.eval.close_paren == n))
5230         break;
5231       }
5232      }
5233     }
5234    }
5235    goto fake_end;
5236    /*NOTREACHED*/
5237
5238   case GROUPP:  /*  (?(1))  */
5239    n = ARG(scan);  /* which paren pair */
5240    sw = cBOOL(rex->lastparen >= n && rex->offs[n].end != -1);
5241    break;
5242
5243   case NGROUPP:  /*  (?(<name>))  */
5244    /* reg_check_named_buff_matched returns 0 for no match */
5245    sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
5246    break;
5247
5248   case INSUBP:   /*  (?(R))  */
5249    n = ARG(scan);
5250    sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
5251    break;
5252
5253   case DEFINEP:  /*  (?(DEFINE))  */
5254    sw = 0;
5255    break;
5256
5257   case IFTHEN:   /*  (?(cond)A|B)  */
5258    PL_reg_leftiter = PL_reg_maxiter;  /* Void cache */
5259    if (sw)
5260     next = NEXTOPER(NEXTOPER(scan));
5261    else {
5262     next = scan + ARG(scan);
5263     if (OP(next) == IFTHEN) /* Fake one. */
5264      next = NEXTOPER(NEXTOPER(next));
5265    }
5266    break;
5267
5268   case LOGICAL:  /* modifier for EVAL and IFMATCH */
5269    logical = scan->flags;
5270    break;
5271
5272 /*******************************************************************
5273
5274 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
5275 pattern, where A and B are subpatterns. (For simple A, CURLYM or
5276 STAR/PLUS/CURLY/CURLYN are used instead.)
5277
5278 A*B is compiled as <CURLYX><A><WHILEM><B>
5279
5280 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
5281 state, which contains the current count, initialised to -1. It also sets
5282 cur_curlyx to point to this state, with any previous value saved in the
5283 state block.
5284
5285 CURLYX then jumps straight to the WHILEM op, rather than executing A,
5286 since the pattern may possibly match zero times (i.e. it's a while {} loop
5287 rather than a do {} while loop).
5288
5289 Each entry to WHILEM represents a successful match of A. The count in the
5290 CURLYX block is incremented, another WHILEM state is pushed, and execution
5291 passes to A or B depending on greediness and the current count.
5292
5293 For example, if matching against the string a1a2a3b (where the aN are
5294 substrings that match /A/), then the match progresses as follows: (the
5295 pushed states are interspersed with the bits of strings matched so far):
5296
5297  <CURLYX cnt=-1>
5298  <CURLYX cnt=0><WHILEM>
5299  <CURLYX cnt=1><WHILEM> a1 <WHILEM>
5300  <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
5301  <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
5302  <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
5303
5304 (Contrast this with something like CURLYM, which maintains only a single
5305 backtrack state:
5306
5307  <CURLYM cnt=0> a1
5308  a1 <CURLYM cnt=1> a2
5309  a1 a2 <CURLYM cnt=2> a3
5310  a1 a2 a3 <CURLYM cnt=3> b
5311 )
5312
5313 Each WHILEM state block marks a point to backtrack to upon partial failure
5314 of A or B, and also contains some minor state data related to that
5315 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
5316 overall state, such as the count, and pointers to the A and B ops.
5317
5318 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
5319 must always point to the *current* CURLYX block, the rules are:
5320
5321 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
5322 and set cur_curlyx to point the new block.
5323
5324 When popping the CURLYX block after a successful or unsuccessful match,
5325 restore the previous cur_curlyx.
5326
5327 When WHILEM is about to execute B, save the current cur_curlyx, and set it
5328 to the outer one saved in the CURLYX block.
5329
5330 When popping the WHILEM block after a successful or unsuccessful B match,
5331 restore the previous cur_curlyx.
5332
5333 Here's an example for the pattern (AI* BI)*BO
5334 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
5335
5336 cur_
5337 curlyx backtrack stack
5338 ------ ---------------
5339 NULL
5340 CO     <CO prev=NULL> <WO>
5341 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
5342 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
5343 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
5344
5345 At this point the pattern succeeds, and we work back down the stack to
5346 clean up, restoring as we go:
5347
5348 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
5349 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
5350 CO     <CO prev=NULL> <WO>
5351 NULL
5352
5353 *******************************************************************/
5354
5355 #define ST st->u.curlyx
5356
5357   case CURLYX:    /* start of /A*B/  (for complex A) */
5358   {
5359    /* No need to save/restore up to this paren */
5360    I32 parenfloor = scan->flags;
5361
5362    assert(next); /* keep Coverity happy */
5363    if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
5364     next += ARG(next);
5365
5366    /* XXXX Probably it is better to teach regpush to support
5367    parenfloor > maxopenparen ... */
5368    if (parenfloor > (I32)rex->lastparen)
5369     parenfloor = rex->lastparen; /* Pessimization... */
5370
5371    ST.prev_curlyx= cur_curlyx;
5372    cur_curlyx = st;
5373    ST.cp = PL_savestack_ix;
5374
5375    /* these fields contain the state of the current curly.
5376    * they are accessed by subsequent WHILEMs */
5377    ST.parenfloor = parenfloor;
5378    ST.me = scan;
5379    ST.B = next;
5380    ST.minmod = minmod;
5381    minmod = 0;
5382    ST.count = -1; /* this will be updated by WHILEM */
5383    ST.lastloc = NULL;  /* this will be updated by WHILEM */
5384
5385    PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next), locinput);
5386    assert(0); /* NOTREACHED */
5387   }
5388
5389   case CURLYX_end: /* just finished matching all of A*B */
5390    cur_curlyx = ST.prev_curlyx;
5391    sayYES;
5392    assert(0); /* NOTREACHED */
5393
5394   case CURLYX_end_fail: /* just failed to match all of A*B */
5395    regcpblow(ST.cp);
5396    cur_curlyx = ST.prev_curlyx;
5397    sayNO;
5398    assert(0); /* NOTREACHED */
5399
5400
5401 #undef ST
5402 #define ST st->u.whilem
5403
5404   case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
5405   {
5406    /* see the discussion above about CURLYX/WHILEM */
5407    I32 n;
5408    int min = ARG1(cur_curlyx->u.curlyx.me);
5409    int max = ARG2(cur_curlyx->u.curlyx.me);
5410    regnode *A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS;
5411
5412    assert(cur_curlyx); /* keep Coverity happy */
5413    n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
5414    ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
5415    ST.cache_offset = 0;
5416    ST.cache_mask = 0;
5417
5418
5419    DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
5420     "%*s  whilem: matched %ld out of %d..%d\n",
5421     REPORT_CODE_OFF+depth*2, "", (long)n, min, max)
5422    );
5423
5424    /* First just match a string of min A's. */
5425
5426    if (n < min) {
5427     ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
5428          maxopenparen);
5429     cur_curlyx->u.curlyx.lastloc = locinput;
5430     REGCP_SET(ST.lastcp);
5431
5432     PUSH_STATE_GOTO(WHILEM_A_pre, A, locinput);
5433     assert(0); /* NOTREACHED */
5434    }
5435
5436    /* If degenerate A matches "", assume A done. */
5437
5438    if (locinput == cur_curlyx->u.curlyx.lastloc) {
5439     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
5440     "%*s  whilem: empty match detected, trying continuation...\n",
5441     REPORT_CODE_OFF+depth*2, "")
5442     );
5443     goto do_whilem_B_max;
5444    }
5445
5446    /* super-linear cache processing */
5447
5448    if (scan->flags) {
5449
5450     if (!PL_reg_maxiter) {
5451      /* start the countdown: Postpone detection until we
5452      * know the match is not *that* much linear. */
5453      PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
5454      /* possible overflow for long strings and many CURLYX's */
5455      if (PL_reg_maxiter < 0)
5456       PL_reg_maxiter = I32_MAX;
5457      PL_reg_leftiter = PL_reg_maxiter;
5458     }
5459
5460     if (PL_reg_leftiter-- == 0) {
5461      /* initialise cache */
5462      const I32 size = (PL_reg_maxiter + 7)/8;
5463      if (PL_reg_poscache) {
5464       if ((I32)PL_reg_poscache_size < size) {
5465        Renew(PL_reg_poscache, size, char);
5466        PL_reg_poscache_size = size;
5467       }
5468       Zero(PL_reg_poscache, size, char);
5469      }
5470      else {
5471       PL_reg_poscache_size = size;
5472       Newxz(PL_reg_poscache, size, char);
5473      }
5474      DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
5475  "%swhilem: Detected a super-linear match, switching on caching%s...\n",
5476        PL_colors[4], PL_colors[5])
5477      );
5478     }
5479
5480     if (PL_reg_leftiter < 0) {
5481      /* have we already failed at this position? */
5482      I32 offset, mask;
5483      offset  = (scan->flags & 0xf) - 1
5484         + (locinput - PL_bostr)  * (scan->flags>>4);
5485      mask    = 1 << (offset % 8);
5486      offset /= 8;
5487      if (PL_reg_poscache[offset] & mask) {
5488       DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
5489        "%*s  whilem: (cache) already tried at this position...\n",
5490        REPORT_CODE_OFF+depth*2, "")
5491       );
5492       sayNO; /* cache records failure */
5493      }
5494      ST.cache_offset = offset;
5495      ST.cache_mask   = mask;
5496     }
5497    }
5498
5499    /* Prefer B over A for minimal matching. */
5500
5501    if (cur_curlyx->u.curlyx.minmod) {
5502     ST.save_curlyx = cur_curlyx;
5503     cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
5504     ST.cp = regcppush(rex, ST.save_curlyx->u.curlyx.parenfloor,
5505        maxopenparen);
5506     REGCP_SET(ST.lastcp);
5507     PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B,
5508          locinput);
5509     assert(0); /* NOTREACHED */
5510    }
5511
5512    /* Prefer A over B for maximal matching. */
5513
5514    if (n < max) { /* More greed allowed? */
5515     ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
5516        maxopenparen);
5517     cur_curlyx->u.curlyx.lastloc = locinput;
5518     REGCP_SET(ST.lastcp);
5519     PUSH_STATE_GOTO(WHILEM_A_max, A, locinput);
5520     assert(0); /* NOTREACHED */
5521    }
5522    goto do_whilem_B_max;
5523   }
5524   assert(0); /* NOTREACHED */
5525
5526   case WHILEM_B_min: /* just matched B in a minimal match */
5527   case WHILEM_B_max: /* just matched B in a maximal match */
5528    cur_curlyx = ST.save_curlyx;
5529    sayYES;
5530    assert(0); /* NOTREACHED */
5531
5532   case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
5533    cur_curlyx = ST.save_curlyx;
5534    cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
5535    cur_curlyx->u.curlyx.count--;
5536    CACHEsayNO;
5537    assert(0); /* NOTREACHED */
5538
5539   case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
5540    /* FALL THROUGH */
5541   case WHILEM_A_pre_fail: /* just failed to match even minimal A */
5542    REGCP_UNWIND(ST.lastcp);
5543    regcppop(rex, &maxopenparen);
5544    cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
5545    cur_curlyx->u.curlyx.count--;
5546    CACHEsayNO;
5547    assert(0); /* NOTREACHED */
5548
5549   case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
5550    REGCP_UNWIND(ST.lastcp);
5551    regcppop(rex, &maxopenparen); /* Restore some previous $<digit>s? */
5552    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5553     "%*s  whilem: failed, trying continuation...\n",
5554     REPORT_CODE_OFF+depth*2, "")
5555    );
5556   do_whilem_B_max:
5557    if (cur_curlyx->u.curlyx.count >= REG_INFTY
5558     && ckWARN(WARN_REGEXP)
5559     && !reginfo->warned)
5560    {
5561     reginfo->warned = TRUE;
5562     Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5563      "Complex regular subexpression recursion limit (%d) "
5564      "exceeded",
5565      REG_INFTY - 1);
5566    }
5567
5568    /* now try B */
5569    ST.save_curlyx = cur_curlyx;
5570    cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
5571    PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B,
5572         locinput);
5573    assert(0); /* NOTREACHED */
5574
5575   case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
5576    cur_curlyx = ST.save_curlyx;
5577    REGCP_UNWIND(ST.lastcp);
5578    regcppop(rex, &maxopenparen);
5579
5580    if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
5581     /* Maximum greed exceeded */
5582     if (cur_curlyx->u.curlyx.count >= REG_INFTY
5583      && ckWARN(WARN_REGEXP)
5584      && !reginfo->warned)
5585     {
5586      reginfo->warned = TRUE;
5587      Perl_warner(aTHX_ packWARN(WARN_REGEXP),
5588       "Complex regular subexpression recursion "
5589       "limit (%d) exceeded",
5590       REG_INFTY - 1);
5591     }
5592     cur_curlyx->u.curlyx.count--;
5593     CACHEsayNO;
5594    }
5595
5596    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5597     "%*s  trying longer...\n", REPORT_CODE_OFF+depth*2, "")
5598    );
5599    /* Try grabbing another A and see if it helps. */
5600    cur_curlyx->u.curlyx.lastloc = locinput;
5601    ST.cp = regcppush(rex, cur_curlyx->u.curlyx.parenfloor,
5602        maxopenparen);
5603    REGCP_SET(ST.lastcp);
5604    PUSH_STATE_GOTO(WHILEM_A_min,
5605     /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS,
5606     locinput);
5607    assert(0); /* NOTREACHED */
5608
5609 #undef  ST
5610 #define ST st->u.branch
5611
5612   case BRANCHJ:     /*  /(...|A|...)/ with long next pointer */
5613    next = scan + ARG(scan);
5614    if (next == scan)
5615     next = NULL;
5616    scan = NEXTOPER(scan);
5617    /* FALL THROUGH */
5618
5619   case BRANCH:     /*  /(...|A|...)/ */
5620    scan = NEXTOPER(scan); /* scan now points to inner node */
5621    ST.lastparen = rex->lastparen;
5622    ST.lastcloseparen = rex->lastcloseparen;
5623    ST.next_branch = next;
5624    REGCP_SET(ST.cp);
5625
5626    /* Now go into the branch */
5627    if (has_cutgroup) {
5628     PUSH_YES_STATE_GOTO(BRANCH_next, scan, locinput);
5629    } else {
5630     PUSH_STATE_GOTO(BRANCH_next, scan, locinput);
5631    }
5632    assert(0); /* NOTREACHED */
5633
5634   case CUTGROUP:  /*  /(*THEN)/  */
5635    sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
5636     MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5637    PUSH_STATE_GOTO(CUTGROUP_next, next, locinput);
5638    assert(0); /* NOTREACHED */
5639
5640   case CUTGROUP_next_fail:
5641    do_cutgroup = 1;
5642    no_final = 1;
5643    if (st->u.mark.mark_name)
5644     sv_commit = st->u.mark.mark_name;
5645    sayNO;
5646    assert(0); /* NOTREACHED */
5647
5648   case BRANCH_next:
5649    sayYES;
5650    assert(0); /* NOTREACHED */
5651
5652   case BRANCH_next_fail: /* that branch failed; try the next, if any */
5653    if (do_cutgroup) {
5654     do_cutgroup = 0;
5655     no_final = 0;
5656    }
5657    REGCP_UNWIND(ST.cp);
5658    UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
5659    scan = ST.next_branch;
5660    /* no more branches? */
5661    if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
5662     DEBUG_EXECUTE_r({
5663      PerlIO_printf( Perl_debug_log,
5664       "%*s  %sBRANCH failed...%s\n",
5665       REPORT_CODE_OFF+depth*2, "",
5666       PL_colors[4],
5667       PL_colors[5] );
5668     });
5669     sayNO_SILENT;
5670    }
5671    continue; /* execute next BRANCH[J] op */
5672    assert(0); /* NOTREACHED */
5673
5674   case MINMOD: /* next op will be non-greedy, e.g. A*?  */
5675    minmod = 1;
5676    break;
5677
5678 #undef  ST
5679 #define ST st->u.curlym
5680
5681   case CURLYM: /* /A{m,n}B/ where A is fixed-length */
5682
5683    /* This is an optimisation of CURLYX that enables us to push
5684    * only a single backtracking state, no matter how many matches
5685    * there are in {m,n}. It relies on the pattern being constant
5686    * length, with no parens to influence future backrefs
5687    */
5688
5689    ST.me = scan;
5690    scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
5691
5692    ST.lastparen      = rex->lastparen;
5693    ST.lastcloseparen = rex->lastcloseparen;
5694
5695    /* if paren positive, emulate an OPEN/CLOSE around A */
5696    if (ST.me->flags) {
5697     U32 paren = ST.me->flags;
5698     if (paren > maxopenparen)
5699      maxopenparen = paren;
5700     scan += NEXT_OFF(scan); /* Skip former OPEN. */
5701    }
5702    ST.A = scan;
5703    ST.B = next;
5704    ST.alen = 0;
5705    ST.count = 0;
5706    ST.minmod = minmod;
5707    minmod = 0;
5708    ST.c1 = CHRTEST_UNINIT;
5709    REGCP_SET(ST.cp);
5710
5711    if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
5712     goto curlym_do_B;
5713
5714   curlym_do_A: /* execute the A in /A{m,n}B/  */
5715    PUSH_YES_STATE_GOTO(CURLYM_A, ST.A, locinput); /* match A */
5716    assert(0); /* NOTREACHED */
5717
5718   case CURLYM_A: /* we've just matched an A */
5719    ST.count++;
5720    /* after first match, determine A's length: u.curlym.alen */
5721    if (ST.count == 1) {
5722     if (PL_reg_match_utf8) {
5723      char *s = st->locinput;
5724      while (s < locinput) {
5725       ST.alen++;
5726       s += UTF8SKIP(s);
5727      }
5728     }
5729     else {
5730      ST.alen = locinput - st->locinput;
5731     }
5732     if (ST.alen == 0)
5733      ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
5734    }
5735    DEBUG_EXECUTE_r(
5736     PerlIO_printf(Perl_debug_log,
5737       "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
5738       (int)(REPORT_CODE_OFF+(depth*2)), "",
5739       (IV) ST.count, (IV)ST.alen)
5740    );
5741
5742    if (cur_eval && cur_eval->u.eval.close_paren &&
5743     cur_eval->u.eval.close_paren == (U32)ST.me->flags)
5744     goto fake_end;
5745
5746    {
5747     I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
5748     if ( max == REG_INFTY || ST.count < max )
5749      goto curlym_do_A; /* try to match another A */
5750    }
5751    goto curlym_do_B; /* try to match B */
5752
5753   case CURLYM_A_fail: /* just failed to match an A */
5754    REGCP_UNWIND(ST.cp);
5755
5756    if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
5757     || (cur_eval && cur_eval->u.eval.close_paren &&
5758      cur_eval->u.eval.close_paren == (U32)ST.me->flags))
5759     sayNO;
5760
5761   curlym_do_B: /* execute the B in /A{m,n}B/  */
5762    if (ST.c1 == CHRTEST_UNINIT) {
5763     /* calculate c1 and c2 for possible match of 1st char
5764     * following curly */
5765     ST.c1 = ST.c2 = CHRTEST_VOID;
5766     if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
5767      regnode *text_node = ST.B;
5768      if (! HAS_TEXT(text_node))
5769       FIND_NEXT_IMPT(text_node);
5770      /* this used to be
5771
5772       (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
5773
5774        But the former is redundant in light of the latter.
5775
5776        if this changes back then the macro for
5777        IS_TEXT and friends need to change.
5778      */
5779      if (PL_regkind[OP(text_node)] == EXACT) {
5780       if (! S_setup_EXACTISH_ST_c1_c2(aTHX_
5781       text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8,
5782       is_utf8_pat))
5783       {
5784        sayNO;
5785       }
5786      }
5787     }
5788    }
5789
5790    DEBUG_EXECUTE_r(
5791     PerlIO_printf(Perl_debug_log,
5792      "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
5793      (int)(REPORT_CODE_OFF+(depth*2)),
5794      "", (IV)ST.count)
5795     );
5796    if (! NEXTCHR_IS_EOS && ST.c1 != CHRTEST_VOID) {
5797     if (! UTF8_IS_INVARIANT(nextchr) && utf8_target) {
5798      if (memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput))
5799       && memNE(locinput, ST.c2_utf8, UTF8SKIP(locinput)))
5800      {
5801       /* simulate B failing */
5802       DEBUG_OPTIMISE_r(
5803        PerlIO_printf(Perl_debug_log,
5804         "%*s  CURLYM Fast bail next target=U+%"UVXf" c1=U+%"UVXf" c2=U+%"UVXf"\n",
5805         (int)(REPORT_CODE_OFF+(depth*2)),"",
5806         valid_utf8_to_uvchr((U8 *) locinput, NULL),
5807         valid_utf8_to_uvchr(ST.c1_utf8, NULL),
5808         valid_utf8_to_uvchr(ST.c2_utf8, NULL))
5809       );
5810       state_num = CURLYM_B_fail;
5811       goto reenter_switch;
5812      }
5813     }
5814     else if (nextchr != ST.c1 && nextchr != ST.c2) {
5815      /* simulate B failing */
5816      DEBUG_OPTIMISE_r(
5817       PerlIO_printf(Perl_debug_log,
5818        "%*s  CURLYM Fast bail next target=U+%X c1=U+%X c2=U+%X\n",
5819        (int)(REPORT_CODE_OFF+(depth*2)),"",
5820        (int) nextchr, ST.c1, ST.c2)
5821      );
5822      state_num = CURLYM_B_fail;
5823      goto reenter_switch;
5824     }
5825    }
5826
5827    if (ST.me->flags) {
5828     /* emulate CLOSE: mark current A as captured */
5829     I32 paren = ST.me->flags;
5830     if (ST.count) {
5831      rex->offs[paren].start
5832       = HOPc(locinput, -ST.alen) - PL_bostr;
5833      rex->offs[paren].end = locinput - PL_bostr;
5834      if ((U32)paren > rex->lastparen)
5835       rex->lastparen = paren;
5836      rex->lastcloseparen = paren;
5837     }
5838     else
5839      rex->offs[paren].end = -1;
5840     if (cur_eval && cur_eval->u.eval.close_paren &&
5841      cur_eval->u.eval.close_paren == (U32)ST.me->flags)
5842     {
5843      if (ST.count)
5844       goto fake_end;
5845      else
5846       sayNO;
5847     }
5848    }
5849
5850    PUSH_STATE_GOTO(CURLYM_B, ST.B, locinput); /* match B */
5851    assert(0); /* NOTREACHED */
5852
5853   case CURLYM_B_fail: /* just failed to match a B */
5854    REGCP_UNWIND(ST.cp);
5855    UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
5856    if (ST.minmod) {
5857     I32 max = ARG2(ST.me);
5858     if (max != REG_INFTY && ST.count == max)
5859      sayNO;
5860     goto curlym_do_A; /* try to match a further A */
5861    }
5862    /* backtrack one A */
5863    if (ST.count == ARG1(ST.me) /* min */)
5864     sayNO;
5865    ST.count--;
5866    SET_locinput(HOPc(locinput, -ST.alen));
5867    goto curlym_do_B; /* try to match B */
5868
5869 #undef ST
5870 #define ST st->u.curly
5871
5872 #define CURLY_SETPAREN(paren, success) \
5873  if (paren) { \
5874   if (success) { \
5875    rex->offs[paren].start = HOPc(locinput, -1) - PL_bostr; \
5876    rex->offs[paren].end = locinput - PL_bostr; \
5877    if (paren > rex->lastparen) \
5878     rex->lastparen = paren; \
5879    rex->lastcloseparen = paren; \
5880   } \
5881   else { \
5882    rex->offs[paren].end = -1; \
5883    rex->lastparen      = ST.lastparen; \
5884    rex->lastcloseparen = ST.lastcloseparen; \
5885   } \
5886  }
5887
5888   case STAR:  /*  /A*B/ where A is width 1 char */
5889    ST.paren = 0;
5890    ST.min = 0;
5891    ST.max = REG_INFTY;
5892    scan = NEXTOPER(scan);
5893    goto repeat;
5894
5895   case PLUS:  /*  /A+B/ where A is width 1 char */
5896    ST.paren = 0;
5897    ST.min = 1;
5898    ST.max = REG_INFTY;
5899    scan = NEXTOPER(scan);
5900    goto repeat;
5901
5902   case CURLYN:  /*  /(A){m,n}B/ where A is width 1 char */
5903    ST.paren = scan->flags; /* Which paren to set */
5904    ST.lastparen      = rex->lastparen;
5905    ST.lastcloseparen = rex->lastcloseparen;
5906    if (ST.paren > maxopenparen)
5907     maxopenparen = ST.paren;
5908    ST.min = ARG1(scan);  /* min to match */
5909    ST.max = ARG2(scan);  /* max to match */
5910    if (cur_eval && cur_eval->u.eval.close_paren &&
5911     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5912     ST.min=1;
5913     ST.max=1;
5914    }
5915    scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
5916    goto repeat;
5917
5918   case CURLY:  /*  /A{m,n}B/ where A is width 1 char */
5919    ST.paren = 0;
5920    ST.min = ARG1(scan);  /* min to match */
5921    ST.max = ARG2(scan);  /* max to match */
5922    scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
5923   repeat:
5924    /*
5925    * Lookahead to avoid useless match attempts
5926    * when we know what character comes next.
5927    *
5928    * Used to only do .*x and .*?x, but now it allows
5929    * for )'s, ('s and (?{ ... })'s to be in the way
5930    * of the quantifier and the EXACT-like node.  -- japhy
5931    */
5932
5933    assert(ST.min <= ST.max);
5934    if (! HAS_TEXT(next) && ! JUMPABLE(next)) {
5935     ST.c1 = ST.c2 = CHRTEST_VOID;
5936    }
5937    else {
5938     regnode *text_node = next;
5939
5940     if (! HAS_TEXT(text_node))
5941      FIND_NEXT_IMPT(text_node);
5942
5943     if (! HAS_TEXT(text_node))
5944      ST.c1 = ST.c2 = CHRTEST_VOID;
5945     else {
5946      if ( PL_regkind[OP(text_node)] != EXACT ) {
5947       ST.c1 = ST.c2 = CHRTEST_VOID;
5948      }
5949      else {
5950
5951      /*  Currently we only get here when
5952
5953       PL_rekind[OP(text_node)] == EXACT
5954
5955       if this changes back then the macro for IS_TEXT and
5956       friends need to change. */
5957       if (! S_setup_EXACTISH_ST_c1_c2(aTHX_
5958       text_node, &ST.c1, ST.c1_utf8, &ST.c2, ST.c2_utf8,
5959       is_utf8_pat))
5960       {
5961        sayNO;
5962       }
5963      }
5964     }
5965    }
5966
5967    ST.A = scan;
5968    ST.B = next;
5969    if (minmod) {
5970     char *li = locinput;
5971     minmod = 0;
5972     if (ST.min &&
5973       regrepeat(rex, &li, ST.A, ST.min, depth, is_utf8_pat)
5974        < ST.min)
5975      sayNO;
5976     SET_locinput(li);
5977     ST.count = ST.min;
5978     REGCP_SET(ST.cp);
5979     if (ST.c1 == CHRTEST_VOID)
5980      goto curly_try_B_min;
5981
5982     ST.oldloc = locinput;
5983
5984     /* set ST.maxpos to the furthest point along the
5985     * string that could possibly match */
5986     if  (ST.max == REG_INFTY) {
5987      ST.maxpos = PL_regeol - 1;
5988      if (utf8_target)
5989       while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
5990        ST.maxpos--;
5991     }
5992     else if (utf8_target) {
5993      int m = ST.max - ST.min;
5994      for (ST.maxpos = locinput;
5995       m >0 && ST.maxpos < PL_regeol; m--)
5996       ST.maxpos += UTF8SKIP(ST.maxpos);
5997     }
5998     else {
5999      ST.maxpos = locinput + ST.max - ST.min;
6000      if (ST.maxpos >= PL_regeol)
6001       ST.maxpos = PL_regeol - 1;
6002     }
6003     goto curly_try_B_min_known;
6004
6005    }
6006    else {
6007     /* avoid taking address of locinput, so it can remain
6008     * a register var */
6009     char *li = locinput;
6010     ST.count = regrepeat(rex, &li, ST.A, ST.max, depth,
6011           is_utf8_pat);
6012     if (ST.count < ST.min)
6013      sayNO;
6014     SET_locinput(li);
6015     if ((ST.count > ST.min)
6016      && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
6017     {
6018      /* A{m,n} must come at the end of the string, there's
6019      * no point in backing off ... */
6020      ST.min = ST.count;
6021      /* ...except that $ and \Z can match before *and* after
6022      newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
6023      We may back off by one in this case. */
6024      if (UCHARAT(locinput - 1) == '\n' && OP(ST.B) != EOS)
6025       ST.min--;
6026     }
6027     REGCP_SET(ST.cp);
6028     goto curly_try_B_max;
6029    }
6030    assert(0); /* NOTREACHED */
6031
6032
6033   case CURLY_B_min_known_fail:
6034    /* failed to find B in a non-greedy match where c1,c2 valid */
6035
6036    REGCP_UNWIND(ST.cp);
6037    if (ST.paren) {
6038     UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
6039    }
6040    /* Couldn't or didn't -- move forward. */
6041    ST.oldloc = locinput;
6042    if (utf8_target)
6043     locinput += UTF8SKIP(locinput);
6044    else
6045     locinput++;
6046    ST.count++;
6047   curly_try_B_min_known:
6048    /* find the next place where 'B' could work, then call B */
6049    {
6050     int n;
6051     if (utf8_target) {
6052      n = (ST.oldloc == locinput) ? 0 : 1;
6053      if (ST.c1 == ST.c2) {
6054       /* set n to utf8_distance(oldloc, locinput) */
6055       while (locinput <= ST.maxpos
6056        && memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput)))
6057       {
6058        locinput += UTF8SKIP(locinput);
6059        n++;
6060       }
6061      }
6062      else {
6063       /* set n to utf8_distance(oldloc, locinput) */
6064       while (locinput <= ST.maxpos
6065        && memNE(locinput, ST.c1_utf8, UTF8SKIP(locinput))
6066        && memNE(locinput, ST.c2_utf8, UTF8SKIP(locinput)))
6067       {
6068        locinput += UTF8SKIP(locinput);
6069        n++;
6070       }
6071      }
6072     }
6073     else {  /* Not utf8_target */
6074      if (ST.c1 == ST.c2) {
6075       while (locinput <= ST.maxpos &&
6076        UCHARAT(locinput) != ST.c1)
6077        locinput++;
6078      }
6079      else {
6080       while (locinput <= ST.maxpos
6081        && UCHARAT(locinput) != ST.c1
6082        && UCHARAT(locinput) != ST.c2)
6083        locinput++;
6084      }
6085      n = locinput - ST.oldloc;
6086     }
6087     if (locinput > ST.maxpos)
6088      sayNO;
6089     if (n) {
6090      /* In /a{m,n}b/, ST.oldloc is at "a" x m, locinput is
6091      * at b; check that everything between oldloc and
6092      * locinput matches */
6093      char *li = ST.oldloc;
6094      ST.count += n;
6095      if (regrepeat(rex, &li, ST.A, n, depth, is_utf8_pat) < n)
6096       sayNO;
6097      assert(n == REG_INFTY || locinput == li);
6098     }
6099     CURLY_SETPAREN(ST.paren, ST.count);
6100     if (cur_eval && cur_eval->u.eval.close_paren &&
6101      cur_eval->u.eval.close_paren == (U32)ST.paren) {
6102      goto fake_end;
6103     }
6104     PUSH_STATE_GOTO(CURLY_B_min_known, ST.B, locinput);
6105    }
6106    assert(0); /* NOTREACHED */
6107
6108
6109   case CURLY_B_min_fail:
6110    /* failed to find B in a non-greedy match where c1,c2 invalid */
6111
6112    REGCP_UNWIND(ST.cp);
6113    if (ST.paren) {
6114     UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
6115    }
6116    /* failed -- move forward one */
6117    {
6118     char *li = locinput;
6119     if (!regrepeat(rex, &li, ST.A, 1, depth, is_utf8_pat)) {
6120      sayNO;
6121     }
6122     locinput = li;
6123    }
6124    {
6125     ST.count++;
6126     if (ST.count <= ST.max || (ST.max == REG_INFTY &&
6127       ST.count > 0)) /* count overflow ? */
6128     {
6129     curly_try_B_min:
6130      CURLY_SETPAREN(ST.paren, ST.count);
6131      if (cur_eval && cur_eval->u.eval.close_paren &&
6132       cur_eval->u.eval.close_paren == (U32)ST.paren) {
6133       goto fake_end;
6134      }
6135      PUSH_STATE_GOTO(CURLY_B_min, ST.B, locinput);
6136     }
6137    }
6138    sayNO;
6139    assert(0); /* NOTREACHED */
6140
6141
6142   curly_try_B_max:
6143    /* a successful greedy match: now try to match B */
6144    if (cur_eval && cur_eval->u.eval.close_paren &&
6145     cur_eval->u.eval.close_paren == (U32)ST.paren) {
6146     goto fake_end;
6147    }
6148    {
6149     bool could_match = locinput < PL_regeol;
6150
6151     /* If it could work, try it. */
6152     if (ST.c1 != CHRTEST_VOID && could_match) {
6153      if (! UTF8_IS_INVARIANT(UCHARAT(locinput)) && utf8_target)
6154      {
6155       could_match = memEQ(locinput,
6156            ST.c1_utf8,
6157            UTF8SKIP(locinput))
6158          || memEQ(locinput,
6159            ST.c2_utf8,
6160            UTF8SKIP(locinput));
6161      }
6162      else {
6163       could_match = UCHARAT(locinput) == ST.c1
6164          || UCHARAT(locinput) == ST.c2;
6165      }
6166     }
6167     if (ST.c1 == CHRTEST_VOID || could_match) {
6168      CURLY_SETPAREN(ST.paren, ST.count);
6169      PUSH_STATE_GOTO(CURLY_B_max, ST.B, locinput);
6170      assert(0); /* NOTREACHED */
6171     }
6172    }
6173    /* FALL THROUGH */
6174
6175   case CURLY_B_max_fail:
6176    /* failed to find B in a greedy match */
6177
6178    REGCP_UNWIND(ST.cp);
6179    if (ST.paren) {
6180     UNWIND_PAREN(ST.lastparen, ST.lastcloseparen);
6181    }
6182    /*  back up. */
6183    if (--ST.count < ST.min)
6184     sayNO;
6185    locinput = HOPc(locinput, -1);
6186    goto curly_try_B_max;
6187
6188 #undef ST
6189
6190   case END: /*  last op of main pattern  */
6191    fake_end:
6192    if (cur_eval) {
6193     /* we've just finished A in /(??{A})B/; now continue with B */
6194     st->u.eval.saved_utf8_pat = is_utf8_pat;
6195     is_utf8_pat = cur_eval->u.eval.saved_utf8_pat;
6196
6197     st->u.eval.prev_rex = rex_sv;  /* inner */
6198
6199     /* Save *all* the positions. */
6200     st->u.eval.cp = regcppush(rex, 0, maxopenparen);
6201     rex_sv = cur_eval->u.eval.prev_rex;
6202     SET_reg_curpm(rex_sv);
6203     rex = ReANY(rex_sv);
6204     rexi = RXi_GET(rex);
6205     cur_curlyx = cur_eval->u.eval.prev_curlyx;
6206
6207     REGCP_SET(st->u.eval.lastcp);
6208
6209     /* Restore parens of the outer rex without popping the
6210     * savestack */
6211     S_regcp_restore(aTHX_ rex, cur_eval->u.eval.lastcp,
6212           &maxopenparen);
6213
6214     st->u.eval.prev_eval = cur_eval;
6215     cur_eval = cur_eval->u.eval.prev_eval;
6216     DEBUG_EXECUTE_r(
6217      PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ... %"UVxf"\n",
6218          REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
6219     if ( nochange_depth )
6220      nochange_depth--;
6221
6222     PUSH_YES_STATE_GOTO(EVAL_AB, st->u.eval.prev_eval->u.eval.B,
6223          locinput); /* match B */
6224    }
6225
6226    if (locinput < reginfo->till) {
6227     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
6228          "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
6229          PL_colors[4],
6230          (long)(locinput - PL_reg_starttry),
6231          (long)(reginfo->till - PL_reg_starttry),
6232          PL_colors[5]));
6233
6234     sayNO_SILENT;  /* Cannot match: too short. */
6235    }
6236    sayYES;   /* Success! */
6237
6238   case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
6239    DEBUG_EXECUTE_r(
6240    PerlIO_printf(Perl_debug_log,
6241     "%*s  %ssubpattern success...%s\n",
6242     REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
6243    sayYES;   /* Success! */
6244
6245 #undef  ST
6246 #define ST st->u.ifmatch
6247
6248   {
6249    char *newstart;
6250
6251   case SUSPEND: /* (?>A) */
6252    ST.wanted = 1;
6253    newstart = locinput;
6254    goto do_ifmatch;
6255
6256   case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
6257    ST.wanted = 0;
6258    goto ifmatch_trivial_fail_test;
6259
6260   case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
6261    ST.wanted = 1;
6262   ifmatch_trivial_fail_test:
6263    if (scan->flags) {
6264     char * const s = HOPBACKc(locinput, scan->flags);
6265     if (!s) {
6266      /* trivial fail */
6267      if (logical) {
6268       logical = 0;
6269       sw = 1 - cBOOL(ST.wanted);
6270      }
6271      else if (ST.wanted)
6272       sayNO;
6273      next = scan + ARG(scan);
6274      if (next == scan)
6275       next = NULL;
6276      break;
6277     }
6278     newstart = s;
6279    }
6280    else
6281     newstart = locinput;
6282
6283   do_ifmatch:
6284    ST.me = scan;
6285    ST.logical = logical;
6286    logical = 0; /* XXX: reset state of logical once it has been saved into ST */
6287
6288    /* execute body of (?...A) */
6289    PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)), newstart);
6290    assert(0); /* NOTREACHED */
6291   }
6292
6293   case IFMATCH_A_fail: /* body of (?...A) failed */
6294    ST.wanted = !ST.wanted;
6295    /* FALL THROUGH */
6296
6297   case IFMATCH_A: /* body of (?...A) succeeded */
6298    if (ST.logical) {
6299     sw = cBOOL(ST.wanted);
6300    }
6301    else if (!ST.wanted)
6302     sayNO;
6303
6304    if (OP(ST.me) != SUSPEND) {
6305     /* restore old position except for (?>...) */
6306     locinput = st->locinput;
6307    }
6308    scan = ST.me + ARG(ST.me);
6309    if (scan == ST.me)
6310     scan = NULL;
6311    continue; /* execute B */
6312
6313 #undef ST
6314
6315   case LONGJMP: /*  alternative with many branches compiles to
6316      * (BRANCHJ; EXACT ...; LONGJMP ) x N */
6317    next = scan + ARG(scan);
6318    if (next == scan)
6319     next = NULL;
6320    break;
6321
6322   case COMMIT:  /*  (*COMMIT)  */
6323    reginfo->cutpoint = PL_regeol;
6324    /* FALLTHROUGH */
6325
6326   case PRUNE:   /*  (*PRUNE)   */
6327    if (!scan->flags)
6328     sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
6329    PUSH_STATE_GOTO(COMMIT_next, next, locinput);
6330    assert(0); /* NOTREACHED */
6331
6332   case COMMIT_next_fail:
6333    no_final = 1;
6334    /* FALLTHROUGH */
6335
6336   case OPFAIL:   /* (*FAIL)  */
6337    sayNO;
6338    assert(0); /* NOTREACHED */
6339
6340 #define ST st->u.mark
6341   case MARKPOINT: /*  (*MARK:foo)  */
6342    ST.prev_mark = mark_state;
6343    ST.mark_name = sv_commit = sv_yes_mark
6344     = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
6345    mark_state = st;
6346    ST.mark_loc = locinput;
6347    PUSH_YES_STATE_GOTO(MARKPOINT_next, next, locinput);
6348    assert(0); /* NOTREACHED */
6349
6350   case MARKPOINT_next:
6351    mark_state = ST.prev_mark;
6352    sayYES;
6353    assert(0); /* NOTREACHED */
6354
6355   case MARKPOINT_next_fail:
6356    if (popmark && sv_eq(ST.mark_name,popmark))
6357    {
6358     if (ST.mark_loc > startpoint)
6359      reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
6360     popmark = NULL; /* we found our mark */
6361     sv_commit = ST.mark_name;
6362
6363     DEBUG_EXECUTE_r({
6364       PerlIO_printf(Perl_debug_log,
6365        "%*s  %ssetting cutpoint to mark:%"SVf"...%s\n",
6366        REPORT_CODE_OFF+depth*2, "",
6367        PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
6368     });
6369    }
6370    mark_state = ST.prev_mark;
6371    sv_yes_mark = mark_state ?
6372     mark_state->u.mark.mark_name : NULL;
6373    sayNO;
6374    assert(0); /* NOTREACHED */
6375
6376   case SKIP:  /*  (*SKIP)  */
6377    if (scan->flags) {
6378     /* (*SKIP) : if we fail we cut here*/
6379     ST.mark_name = NULL;
6380     ST.mark_loc = locinput;
6381     PUSH_STATE_GOTO(SKIP_next,next, locinput);
6382    } else {
6383     /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
6384     otherwise do nothing.  Meaning we need to scan
6385     */
6386     regmatch_state *cur = mark_state;
6387     SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
6388
6389     while (cur) {
6390      if ( sv_eq( cur->u.mark.mark_name,
6391         find ) )
6392      {
6393       ST.mark_name = find;
6394       PUSH_STATE_GOTO( SKIP_next, next, locinput);
6395      }
6396      cur = cur->u.mark.prev_mark;
6397     }
6398    }
6399    /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
6400    break;
6401
6402   case SKIP_next_fail:
6403    if (ST.mark_name) {
6404     /* (*CUT:NAME) - Set up to search for the name as we
6405     collapse the stack*/
6406     popmark = ST.mark_name;
6407    } else {
6408     /* (*CUT) - No name, we cut here.*/
6409     if (ST.mark_loc > startpoint)
6410      reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
6411     /* but we set sv_commit to latest mark_name if there
6412     is one so they can test to see how things lead to this
6413     cut */
6414     if (mark_state)
6415      sv_commit=mark_state->u.mark.mark_name;
6416    }
6417    no_final = 1;
6418    sayNO;
6419    assert(0); /* NOTREACHED */
6420 #undef ST
6421
6422   case LNBREAK: /* \R */
6423    if ((n=is_LNBREAK_safe(locinput, PL_regeol, utf8_target))) {
6424     locinput += n;
6425    } else
6426     sayNO;
6427    break;
6428
6429   default:
6430    PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
6431       PTR2UV(scan), OP(scan));
6432    Perl_croak(aTHX_ "regexp memory corruption");
6433
6434   /* this is a point to jump to in order to increment
6435   * locinput by one character */
6436   increment_locinput:
6437    assert(!NEXTCHR_IS_EOS);
6438    if (utf8_target) {
6439     locinput += PL_utf8skip[nextchr];
6440     /* locinput is allowed to go 1 char off the end, but not 2+ */
6441     if (locinput > PL_regeol)
6442      sayNO;
6443    }
6444    else
6445     locinput++;
6446    break;
6447
6448   } /* end switch */
6449
6450   /* switch break jumps here */
6451   scan = next; /* prepare to execute the next op and ... */
6452   continue;    /* ... jump back to the top, reusing st */
6453   assert(0); /* NOTREACHED */
6454
6455  push_yes_state:
6456   /* push a state that backtracks on success */
6457   st->u.yes.prev_yes_state = yes_state;
6458   yes_state = st;
6459   /* FALL THROUGH */
6460  push_state:
6461   /* push a new regex state, then continue at scan  */
6462   {
6463    regmatch_state *newst;
6464
6465    DEBUG_STACK_r({
6466     regmatch_state *cur = st;
6467     regmatch_state *curyes = yes_state;
6468     int curd = depth;
6469     regmatch_slab *slab = PL_regmatch_slab;
6470     for (;curd > -1;cur--,curd--) {
6471      if (cur < SLAB_FIRST(slab)) {
6472       slab = slab->prev;
6473       cur = SLAB_LAST(slab);
6474      }
6475      PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
6476       REPORT_CODE_OFF + 2 + depth * 2,"",
6477       curd, PL_reg_name[cur->resume_state],
6478       (curyes == cur) ? "yes" : ""
6479      );
6480      if (curyes == cur)
6481       curyes = cur->u.yes.prev_yes_state;
6482     }
6483    } else
6484     DEBUG_STATE_pp("push")
6485    );
6486    depth++;
6487    st->locinput = locinput;
6488    newst = st+1;
6489    if (newst >  SLAB_LAST(PL_regmatch_slab))
6490     newst = S_push_slab(aTHX);
6491    PL_regmatch_state = newst;
6492
6493    locinput = pushinput;
6494    st = newst;
6495    continue;
6496    assert(0); /* NOTREACHED */
6497   }
6498  }
6499
6500  /*
6501  * We get here only if there's trouble -- normally "case END" is
6502  * the terminating point.
6503  */
6504  Perl_croak(aTHX_ "corrupted regexp pointers");
6505  /*NOTREACHED*/
6506  sayNO;
6507
6508 yes:
6509  if (yes_state) {
6510   /* we have successfully completed a subexpression, but we must now
6511   * pop to the state marked by yes_state and continue from there */
6512   assert(st != yes_state);
6513 #ifdef DEBUGGING
6514   while (st != yes_state) {
6515    st--;
6516    if (st < SLAB_FIRST(PL_regmatch_slab)) {
6517     PL_regmatch_slab = PL_regmatch_slab->prev;
6518     st = SLAB_LAST(PL_regmatch_slab);
6519    }
6520    DEBUG_STATE_r({
6521     if (no_final) {
6522      DEBUG_STATE_pp("pop (no final)");
6523     } else {
6524      DEBUG_STATE_pp("pop (yes)");
6525     }
6526    });
6527    depth--;
6528   }
6529 #else
6530   while (yes_state < SLAB_FIRST(PL_regmatch_slab)
6531    || yes_state > SLAB_LAST(PL_regmatch_slab))
6532   {
6533    /* not in this slab, pop slab */
6534    depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
6535    PL_regmatch_slab = PL_regmatch_slab->prev;
6536    st = SLAB_LAST(PL_regmatch_slab);
6537   }
6538   depth -= (st - yes_state);
6539 #endif
6540   st = yes_state;
6541   yes_state = st->u.yes.prev_yes_state;
6542   PL_regmatch_state = st;
6543
6544   if (no_final)
6545    locinput= st->locinput;
6546   state_num = st->resume_state + no_final;
6547   goto reenter_switch;
6548  }
6549
6550  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
6551       PL_colors[4], PL_colors[5]));
6552
6553  if (PL_reg_state.re_state_eval_setup_done) {
6554   /* each successfully executed (?{...}) block does the equivalent of
6555   *   local $^R = do {...}
6556   * When popping the save stack, all these locals would be undone;
6557   * bypass this by setting the outermost saved $^R to the latest
6558   * value */
6559   if (oreplsv != GvSV(PL_replgv))
6560    sv_setsv(oreplsv, GvSV(PL_replgv));
6561  }
6562  result = 1;
6563  goto final_exit;
6564
6565 no:
6566  DEBUG_EXECUTE_r(
6567   PerlIO_printf(Perl_debug_log,
6568    "%*s  %sfailed...%s\n",
6569    REPORT_CODE_OFF+depth*2, "",
6570    PL_colors[4], PL_colors[5])
6571   );
6572
6573 no_silent:
6574  if (no_final) {
6575   if (yes_state) {
6576    goto yes;
6577   } else {
6578    goto final_exit;
6579   }
6580  }
6581  if (depth) {
6582   /* there's a previous state to backtrack to */
6583   st--;
6584   if (st < SLAB_FIRST(PL_regmatch_slab)) {
6585    PL_regmatch_slab = PL_regmatch_slab->prev;
6586    st = SLAB_LAST(PL_regmatch_slab);
6587   }
6588   PL_regmatch_state = st;
6589   locinput= st->locinput;
6590
6591   DEBUG_STATE_pp("pop");
6592   depth--;
6593   if (yes_state == st)
6594    yes_state = st->u.yes.prev_yes_state;
6595
6596   state_num = st->resume_state + 1; /* failure = success + 1 */
6597   goto reenter_switch;
6598  }
6599  result = 0;
6600
6601   final_exit:
6602  if (rex->intflags & PREGf_VERBARG_SEEN) {
6603   SV *sv_err = get_sv("REGERROR", 1);
6604   SV *sv_mrk = get_sv("REGMARK", 1);
6605   if (result) {
6606    sv_commit = &PL_sv_no;
6607    if (!sv_yes_mark)
6608     sv_yes_mark = &PL_sv_yes;
6609   } else {
6610    if (!sv_commit)
6611     sv_commit = &PL_sv_yes;
6612    sv_yes_mark = &PL_sv_no;
6613   }
6614   sv_setsv(sv_err, sv_commit);
6615   sv_setsv(sv_mrk, sv_yes_mark);
6616  }
6617
6618
6619  if (last_pushed_cv) {
6620   dSP;
6621   POP_MULTICALL;
6622   PERL_UNUSED_VAR(SP);
6623  }
6624
6625  /* clean up; in particular, free all slabs above current one */
6626  LEAVE_SCOPE(oldsave);
6627
6628  assert(!result ||  locinput - PL_bostr >= 0);
6629  return result ?  locinput - PL_bostr : -1;
6630 }
6631
6632 /*
6633  - regrepeat - repeatedly match something simple, report how many
6634  *
6635  * What 'simple' means is a node which can be the operand of a quantifier like
6636  * '+', or {1,3}
6637  *
6638  * startposp - pointer a pointer to the start position.  This is updated
6639  *             to point to the byte following the highest successful
6640  *             match.
6641  * p         - the regnode to be repeatedly matched against.
6642  * max       - maximum number of things to match.
6643  * depth     - (for debugging) backtracking depth.
6644  */
6645 STATIC I32
6646 S_regrepeat(pTHX_ regexp *prog, char **startposp, const regnode *p,
6647     I32 max, int depth, bool is_utf8_pat)
6648 {
6649  dVAR;
6650  char *scan;     /* Pointer to current position in target string */
6651  I32 c;
6652  char *loceol = PL_regeol;   /* local version */
6653  I32 hardcount = 0;  /* How many matches so far */
6654  bool utf8_target = PL_reg_match_utf8;
6655  int to_complement = 0;  /* Invert the result? */
6656  UV utf8_flags;
6657  _char_class_number classnum;
6658 #ifndef DEBUGGING
6659  PERL_UNUSED_ARG(depth);
6660 #endif
6661
6662  PERL_ARGS_ASSERT_REGREPEAT;
6663
6664  scan = *startposp;
6665  if (max == REG_INFTY)
6666   max = I32_MAX;
6667  else if (! utf8_target && loceol - scan > max)
6668   loceol = scan + max;
6669
6670  /* Here, for the case of a non-UTF-8 target we have adjusted <loceol> down
6671  * to the maximum of how far we should go in it (leaving it set to the real
6672  * end, if the maximum permissible would take us beyond that).  This allows
6673  * us to make the loop exit condition that we haven't gone past <loceol> to
6674  * also mean that we haven't exceeded the max permissible count, saving a
6675  * test each time through the loop.  But it assumes that the OP matches a
6676  * single byte, which is true for most of the OPs below when applied to a
6677  * non-UTF-8 target.  Those relatively few OPs that don't have this
6678  * characteristic will have to compensate.
6679  *
6680  * There is no adjustment for UTF-8 targets, as the number of bytes per
6681  * character varies.  OPs will have to test both that the count is less
6682  * than the max permissible (using <hardcount> to keep track), and that we
6683  * are still within the bounds of the string (using <loceol>.  A few OPs
6684  * match a single byte no matter what the encoding.  They can omit the max
6685  * test if, for the UTF-8 case, they do the adjustment that was skipped
6686  * above.
6687  *
6688  * Thus, the code above sets things up for the common case; and exceptional
6689  * cases need extra work; the common case is to make sure <scan> doesn't
6690  * go past <loceol>, and for UTF-8 to also use <hardcount> to make sure the
6691  * count doesn't exceed the maximum permissible */
6692
6693  switch (OP(p)) {
6694  case REG_ANY:
6695   if (utf8_target) {
6696    while (scan < loceol && hardcount < max && *scan != '\n') {
6697     scan += UTF8SKIP(scan);
6698     hardcount++;
6699    }
6700   } else {
6701    while (scan < loceol && *scan != '\n')
6702     scan++;
6703   }
6704   break;
6705  case SANY:
6706   if (utf8_target) {
6707    while (scan < loceol && hardcount < max) {
6708     scan += UTF8SKIP(scan);
6709     hardcount++;
6710    }
6711   }
6712   else
6713    scan = loceol;
6714   break;
6715  case CANY:  /* Move <scan> forward <max> bytes, unless goes off end */
6716   if (utf8_target && loceol - scan > max) {
6717
6718    /* <loceol> hadn't been adjusted in the UTF-8 case */
6719    scan +=  max;
6720   }
6721   else {
6722    scan = loceol;
6723   }
6724   break;
6725  case EXACT:
6726   assert(STR_LEN(p) == is_utf8_pat ? UTF8SKIP(STRING(p)) : 1);
6727
6728   c = (U8)*STRING(p);
6729
6730   /* Can use a simple loop if the pattern char to match on is invariant
6731   * under UTF-8, or both target and pattern aren't UTF-8.  Note that we
6732   * can use UTF8_IS_INVARIANT() even if the pattern isn't UTF-8, as it's
6733   * true iff it doesn't matter if the argument is in UTF-8 or not */
6734   if (UTF8_IS_INVARIANT(c) || (! utf8_target && ! is_utf8_pat)) {
6735    if (utf8_target && loceol - scan > max) {
6736     /* We didn't adjust <loceol> because is UTF-8, but ok to do so,
6737     * since here, to match at all, 1 char == 1 byte */
6738     loceol = scan + max;
6739    }
6740    while (scan < loceol && UCHARAT(scan) == c) {
6741     scan++;
6742    }
6743   }
6744   else if (is_utf8_pat) {
6745    if (utf8_target) {
6746     STRLEN scan_char_len;
6747
6748     /* When both target and pattern are UTF-8, we have to do
6749     * string EQ */
6750     while (hardcount < max
6751      && scan < loceol
6752      && (scan_char_len = UTF8SKIP(scan)) <= STR_LEN(p)
6753      && memEQ(scan, STRING(p), scan_char_len))
6754     {
6755      scan += scan_char_len;
6756      hardcount++;
6757     }
6758    }
6759    else if (! UTF8_IS_ABOVE_LATIN1(c)) {
6760
6761     /* Target isn't utf8; convert the character in the UTF-8
6762     * pattern to non-UTF8, and do a simple loop */
6763     c = TWO_BYTE_UTF8_TO_UNI(c, *(STRING(p) + 1));
6764     while (scan < loceol && UCHARAT(scan) == c) {
6765      scan++;
6766     }
6767    } /* else pattern char is above Latin1, can't possibly match the
6768     non-UTF-8 target */
6769   }
6770   else {
6771
6772    /* Here, the string must be utf8; pattern isn't, and <c> is
6773    * different in utf8 than not, so can't compare them directly.
6774    * Outside the loop, find the two utf8 bytes that represent c, and
6775    * then look for those in sequence in the utf8 string */
6776    U8 high = UTF8_TWO_BYTE_HI(c);
6777    U8 low = UTF8_TWO_BYTE_LO(c);
6778
6779    while (hardcount < max
6780      && scan + 1 < loceol
6781      && UCHARAT(scan) == high
6782      && UCHARAT(scan + 1) == low)
6783    {
6784     scan += 2;
6785     hardcount++;
6786    }
6787   }
6788   break;
6789
6790  case EXACTFA:
6791   utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
6792   goto do_exactf;
6793
6794  case EXACTFL:
6795   RXp_MATCH_TAINTED_on(prog);
6796   utf8_flags = FOLDEQ_UTF8_LOCALE;
6797   goto do_exactf;
6798
6799  case EXACTF:
6800    utf8_flags = 0;
6801    goto do_exactf;
6802
6803  case EXACTFU_SS:
6804  case EXACTFU_TRICKYFOLD:
6805  case EXACTFU:
6806   utf8_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
6807
6808  do_exactf: {
6809   int c1, c2;
6810   U8 c1_utf8[UTF8_MAXBYTES+1], c2_utf8[UTF8_MAXBYTES+1];
6811
6812   assert(STR_LEN(p) == is_utf8_pat ? UTF8SKIP(STRING(p)) : 1);
6813
6814   if (S_setup_EXACTISH_ST_c1_c2(aTHX_ p, &c1, c1_utf8, &c2, c2_utf8,
6815           is_utf8_pat))
6816   {
6817    if (c1 == CHRTEST_VOID) {
6818     /* Use full Unicode fold matching */
6819     char *tmpeol = PL_regeol;
6820     STRLEN pat_len = is_utf8_pat ? UTF8SKIP(STRING(p)) : 1;
6821     while (hardcount < max
6822       && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target,
6823            STRING(p), NULL, pat_len,
6824            is_utf8_pat, utf8_flags))
6825     {
6826      scan = tmpeol;
6827      tmpeol = PL_regeol;
6828      hardcount++;
6829     }
6830    }
6831    else if (utf8_target) {
6832     if (c1 == c2) {
6833      while (scan < loceol
6834       && hardcount < max
6835       && memEQ(scan, c1_utf8, UTF8SKIP(scan)))
6836      {
6837       scan += UTF8SKIP(scan);
6838       hardcount++;
6839      }
6840     }
6841     else {
6842      while (scan < loceol
6843       && hardcount < max
6844       && (memEQ(scan, c1_utf8, UTF8SKIP(scan))
6845        || memEQ(scan, c2_utf8, UTF8SKIP(scan))))
6846      {
6847       scan += UTF8SKIP(scan);
6848       hardcount++;
6849      }
6850     }
6851    }
6852    else if (c1 == c2) {
6853     while (scan < loceol && UCHARAT(scan) == c1) {
6854      scan++;
6855     }
6856    }
6857    else {
6858     while (scan < loceol &&
6859      (UCHARAT(scan) == c1 || UCHARAT(scan) == c2))
6860     {
6861      scan++;
6862     }
6863    }
6864   }
6865   break;
6866  }
6867  case ANYOF:
6868  case ANYOF_WARN_SUPER:
6869   if (utf8_target) {
6870    while (hardcount < max
6871     && scan < loceol
6872     && reginclass(prog, p, (U8*)scan, utf8_target))
6873    {
6874     scan += UTF8SKIP(scan);
6875     hardcount++;
6876    }
6877   } else {
6878    while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
6879     scan++;
6880   }
6881   break;
6882
6883  /* The argument (FLAGS) to all the POSIX node types is the class number */
6884
6885  case NPOSIXL:
6886   to_complement = 1;
6887   /* FALLTHROUGH */
6888
6889  case POSIXL:
6890   RXp_MATCH_TAINTED_on(prog);
6891   if (! utf8_target) {
6892    while (scan < loceol && to_complement ^ cBOOL(isFOO_lc(FLAGS(p),
6893                 *scan)))
6894    {
6895     scan++;
6896    }
6897   } else {
6898    while (hardcount < max && scan < loceol
6899     && to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(p),
6900                 (U8 *) scan)))
6901    {
6902     scan += UTF8SKIP(scan);
6903     hardcount++;
6904    }
6905   }
6906   break;
6907
6908  case POSIXD:
6909   if (utf8_target) {
6910    goto utf8_posix;
6911   }
6912   /* FALLTHROUGH */
6913
6914  case POSIXA:
6915   if (utf8_target && loceol - scan > max) {
6916
6917    /* We didn't adjust <loceol> at the beginning of this routine
6918    * because is UTF-8, but it is actually ok to do so, since here, to
6919    * match, 1 char == 1 byte. */
6920    loceol = scan + max;
6921   }
6922   while (scan < loceol && _generic_isCC_A((U8) *scan, FLAGS(p))) {
6923    scan++;
6924   }
6925   break;
6926
6927  case NPOSIXD:
6928   if (utf8_target) {
6929    to_complement = 1;
6930    goto utf8_posix;
6931   }
6932   /* FALL THROUGH */
6933
6934  case NPOSIXA:
6935   if (! utf8_target) {
6936    while (scan < loceol && ! _generic_isCC_A((U8) *scan, FLAGS(p))) {
6937     scan++;
6938    }
6939   }
6940   else {
6941
6942    /* The complement of something that matches only ASCII matches all
6943    * UTF-8 variant code points, plus everything in ASCII that isn't
6944    * in the class. */
6945    while (hardcount < max && scan < loceol
6946     && (! UTF8_IS_INVARIANT(*scan)
6947      || ! _generic_isCC_A((U8) *scan, FLAGS(p))))
6948    {
6949     scan += UTF8SKIP(scan);
6950     hardcount++;
6951    }
6952   }
6953   break;
6954
6955  case NPOSIXU:
6956   to_complement = 1;
6957   /* FALLTHROUGH */
6958
6959  case POSIXU:
6960   if (! utf8_target) {
6961    while (scan < loceol && to_complement
6962         ^ cBOOL(_generic_isCC((U8) *scan, FLAGS(p))))
6963    {
6964     scan++;
6965    }
6966   }
6967   else {
6968  utf8_posix:
6969    classnum = (_char_class_number) FLAGS(p);
6970    if (classnum < _FIRST_NON_SWASH_CC) {
6971
6972     /* Here, a swash is needed for above-Latin1 code points.
6973     * Process as many Latin1 code points using the built-in rules.
6974     * Go to another loop to finish processing upon encountering
6975     * the first Latin1 code point.  We could do that in this loop
6976     * as well, but the other way saves having to test if the swash
6977     * has been loaded every time through the loop: extra space to
6978     * save a test. */
6979     while (hardcount < max && scan < loceol) {
6980      if (UTF8_IS_INVARIANT(*scan)) {
6981       if (! (to_complement ^ cBOOL(_generic_isCC((U8) *scan,
6982                 classnum))))
6983       {
6984        break;
6985       }
6986       scan++;
6987      }
6988      else if (UTF8_IS_DOWNGRADEABLE_START(*scan)) {
6989       if (! (to_complement
6990        ^ cBOOL(_generic_isCC(TWO_BYTE_UTF8_TO_UNI(*scan,
6991                 *(scan + 1)),
6992              classnum))))
6993       {
6994        break;
6995       }
6996       scan += 2;
6997      }
6998      else {
6999       goto found_above_latin1;
7000      }
7001
7002      hardcount++;
7003     }
7004    }
7005    else {
7006     /* For these character classes, the knowledge of how to handle
7007     * every code point is compiled in to Perl via a macro.  This
7008     * code is written for making the loops as tight as possible.
7009     * It could be refactored to save space instead */
7010     switch (classnum) {
7011      case _CC_ENUM_SPACE:    /* XXX would require separate code
7012            if we revert the change of \v
7013            matching this */
7014       /* FALL THROUGH */
7015      case _CC_ENUM_PSXSPC:
7016       while (hardcount < max
7017        && scan < loceol
7018        && (to_complement ^ cBOOL(isSPACE_utf8(scan))))
7019       {
7020        scan += UTF8SKIP(scan);
7021        hardcount++;
7022       }
7023       break;
7024      case _CC_ENUM_BLANK:
7025       while (hardcount < max
7026        && scan < loceol
7027        && (to_complement ^ cBOOL(isBLANK_utf8(scan))))
7028       {
7029        scan += UTF8SKIP(scan);
7030        hardcount++;
7031       }
7032       break;
7033      case _CC_ENUM_XDIGIT:
7034       while (hardcount < max
7035        && scan < loceol
7036        && (to_complement ^ cBOOL(isXDIGIT_utf8(scan))))
7037       {
7038        scan += UTF8SKIP(scan);
7039        hardcount++;
7040       }
7041       break;
7042      case _CC_ENUM_VERTSPACE:
7043       while (hardcount < max
7044        && scan < loceol
7045        && (to_complement ^ cBOOL(isVERTWS_utf8(scan))))
7046       {
7047        scan += UTF8SKIP(scan);
7048        hardcount++;
7049       }
7050       break;
7051      case _CC_ENUM_CNTRL:
7052       while (hardcount < max
7053        && scan < loceol
7054        && (to_complement ^ cBOOL(isCNTRL_utf8(scan))))
7055       {
7056        scan += UTF8SKIP(scan);
7057        hardcount++;
7058       }
7059       break;
7060      default:
7061       Perl_croak(aTHX_ "panic: regrepeat() node %d='%s' has an unexpected character class '%d'", OP(p), PL_reg_name[OP(p)], classnum);
7062     }
7063    }
7064   }
7065   break;
7066
7067  found_above_latin1:   /* Continuation of POSIXU and NPOSIXU */
7068
7069   /* Load the swash if not already present */
7070   if (! PL_utf8_swash_ptrs[classnum]) {
7071    U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
7072    PL_utf8_swash_ptrs[classnum] = _core_swash_init(
7073           "utf8", swash_property_names[classnum],
7074           &PL_sv_undef, 1, 0, NULL, &flags);
7075   }
7076
7077   while (hardcount < max && scan < loceol
7078    && to_complement ^ cBOOL(_generic_utf8(
7079          classnum,
7080          scan,
7081          swash_fetch(PL_utf8_swash_ptrs[classnum],
7082             (U8 *) scan,
7083             TRUE))))
7084   {
7085    scan += UTF8SKIP(scan);
7086    hardcount++;
7087   }
7088   break;
7089
7090  case LNBREAK:
7091   if (utf8_target) {
7092    while (hardcount < max && scan < loceol &&
7093      (c=is_LNBREAK_utf8_safe(scan, loceol))) {
7094     scan += c;
7095     hardcount++;
7096    }
7097   } else {
7098    /* LNBREAK can match one or two latin chars, which is ok, but we
7099    * have to use hardcount in this situation, and throw away the
7100    * adjustment to <loceol> done before the switch statement */
7101    loceol = PL_regeol;
7102    while (scan < loceol && (c=is_LNBREAK_latin1_safe(scan, loceol))) {
7103     scan+=c;
7104     hardcount++;
7105    }
7106   }
7107   break;
7108
7109  case BOUND:
7110  case BOUNDA:
7111  case BOUNDL:
7112  case BOUNDU:
7113  case EOS:
7114  case GPOS:
7115  case KEEPS:
7116  case NBOUND:
7117  case NBOUNDA:
7118  case NBOUNDL:
7119  case NBOUNDU:
7120  case OPFAIL:
7121  case SBOL:
7122  case SEOL:
7123   /* These are all 0 width, so match right here or not at all. */
7124   break;
7125
7126  default:
7127   Perl_croak(aTHX_ "panic: regrepeat() called with unrecognized node type %d='%s'", OP(p), PL_reg_name[OP(p)]);
7128   assert(0); /* NOTREACHED */
7129
7130  }
7131
7132  if (hardcount)
7133   c = hardcount;
7134  else
7135   c = scan - *startposp;
7136  *startposp = scan;
7137
7138  DEBUG_r({
7139   GET_RE_DEBUG_FLAGS_DECL;
7140   DEBUG_EXECUTE_r({
7141    SV * const prop = sv_newmortal();
7142    regprop(prog, prop, p);
7143    PerlIO_printf(Perl_debug_log,
7144       "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
7145       REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
7146   });
7147  });
7148
7149  return(c);
7150 }
7151
7152
7153 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
7154 /*
7155 - regclass_swash - prepare the utf8 swash.  Wraps the shared core version to
7156 create a copy so that changes the caller makes won't change the shared one.
7157 If <altsvp> is non-null, will return NULL in it, for back-compat.
7158  */
7159 SV *
7160 Perl_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
7161 {
7162  PERL_ARGS_ASSERT_REGCLASS_SWASH;
7163
7164  if (altsvp) {
7165   *altsvp = NULL;
7166  }
7167
7168  return newSVsv(core_regclass_swash(prog, node, doinit, listsvp));
7169 }
7170 #endif
7171
7172 STATIC SV *
7173 S_core_regclass_swash(pTHX_ const regexp *prog, const regnode* node, bool doinit, SV** listsvp)
7174 {
7175  /* Returns the swash for the input 'node' in the regex 'prog'.
7176  * If <doinit> is true, will attempt to create the swash if not already
7177  *   done.
7178  * If <listsvp> is non-null, will return the swash initialization string in
7179  *   it.
7180  * Tied intimately to how regcomp.c sets up the data structure */
7181
7182  dVAR;
7183  SV *sw  = NULL;
7184  SV *si  = NULL;
7185  SV*  invlist = NULL;
7186
7187  RXi_GET_DECL(prog,progi);
7188  const struct reg_data * const data = prog ? progi->data : NULL;
7189
7190  PERL_ARGS_ASSERT_CORE_REGCLASS_SWASH;
7191
7192  assert(ANYOF_NONBITMAP(node));
7193
7194  if (data && data->count) {
7195   const U32 n = ARG(node);
7196
7197   if (data->what[n] == 's') {
7198    SV * const rv = MUTABLE_SV(data->data[n]);
7199    AV * const av = MUTABLE_AV(SvRV(rv));
7200    SV **const ary = AvARRAY(av);
7201    U8 swash_init_flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
7202
7203    si = *ary; /* ary[0] = the string to initialize the swash with */
7204
7205    /* Elements 2 and 3 are either both present or both absent. [2] is
7206    * any inversion list generated at compile time; [3] indicates if
7207    * that inversion list has any user-defined properties in it. */
7208    if (av_len(av) >= 2) {
7209     invlist = ary[2];
7210     if (SvUV(ary[3])) {
7211      swash_init_flags |= _CORE_SWASH_INIT_USER_DEFINED_PROPERTY;
7212     }
7213    }
7214    else {
7215     invlist = NULL;
7216    }
7217
7218    /* Element [1] is reserved for the set-up swash.  If already there,
7219    * return it; if not, create it and store it there */
7220    if (SvROK(ary[1])) {
7221     sw = ary[1];
7222    }
7223    else if (si && doinit) {
7224
7225     sw = _core_swash_init("utf8", /* the utf8 package */
7226          "", /* nameless */
7227          si,
7228          1, /* binary */
7229          0, /* not from tr/// */
7230          invlist,
7231          &swash_init_flags);
7232     (void)av_store(av, 1, sw);
7233    }
7234   }
7235  }
7236
7237  if (listsvp) {
7238   SV* matches_string = newSVpvn("", 0);
7239
7240   /* Use the swash, if any, which has to have incorporated into it all
7241   * possibilities */
7242   if ((! sw || (invlist = _get_swash_invlist(sw)) == NULL)
7243    && (si && si != &PL_sv_undef))
7244   {
7245
7246    /* If no swash, use the input initialization string, if available */
7247    sv_catsv(matches_string, si);
7248   }
7249
7250   /* Add the inversion list to whatever we have.  This may have come from
7251   * the swash, or from an input parameter */
7252   if (invlist) {
7253    sv_catsv(matches_string, _invlist_contents(invlist));
7254   }
7255   *listsvp = matches_string;
7256  }
7257
7258  return sw;
7259 }
7260
7261 /*
7262  - reginclass - determine if a character falls into a character class
7263
7264   n is the ANYOF regnode
7265   p is the target string
7266   utf8_target tells whether p is in UTF-8.
7267
7268   Returns true if matched; false otherwise.
7269
7270   Note that this can be a synthetic start class, a combination of various
7271   nodes, so things you think might be mutually exclusive, such as locale,
7272   aren't.  It can match both locale and non-locale
7273
7274  */
7275
7276 STATIC bool
7277 S_reginclass(pTHX_ regexp * const prog, const regnode * const n, const U8* const p, const bool utf8_target)
7278 {
7279  dVAR;
7280  const char flags = ANYOF_FLAGS(n);
7281  bool match = FALSE;
7282  UV c = *p;
7283
7284  PERL_ARGS_ASSERT_REGINCLASS;
7285
7286  /* If c is not already the code point, get it.  Note that
7287  * UTF8_IS_INVARIANT() works even if not in UTF-8 */
7288  if (! UTF8_IS_INVARIANT(c) && utf8_target) {
7289   STRLEN c_len = 0;
7290   c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &c_len,
7291     (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
7292     | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
7293     /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
7294     * UTF8_ALLOW_FFFF */
7295   if (c_len == (STRLEN)-1)
7296    Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
7297  }
7298
7299  /* If this character is potentially in the bitmap, check it */
7300  if (c < 256) {
7301   if (ANYOF_BITMAP_TEST(n, c))
7302    match = TRUE;
7303   else if (flags & ANYOF_NON_UTF8_LATIN1_ALL
7304     && ! utf8_target
7305     && ! isASCII(c))
7306   {
7307    match = TRUE;
7308   }
7309   else if (flags & ANYOF_LOCALE) {
7310    RXp_MATCH_TAINTED_on(prog);
7311
7312    if ((flags & ANYOF_LOC_FOLD)
7313     && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
7314    {
7315     match = TRUE;
7316    }
7317    else if (ANYOF_CLASS_TEST_ANY_SET(n)) {
7318
7319     /* The data structure is arranged so bits 0, 2, 4, ... are set
7320     * if the class includes the Posix character class given by
7321     * bit/2; and 1, 3, 5, ... are set if the class includes the
7322     * complemented Posix class given by int(bit/2).  So we loop
7323     * through the bits, each time changing whether we complement
7324     * the result or not.  Suppose for the sake of illustration
7325     * that bits 0-3 mean respectively, \w, \W, \s, \S.  If bit 0
7326     * is set, it means there is a match for this ANYOF node if the
7327     * character is in the class given by the expression (0 / 2 = 0
7328     * = \w).  If it is in that class, isFOO_lc() will return 1,
7329     * and since 'to_complement' is 0, the result will stay TRUE,
7330     * and we exit the loop.  Suppose instead that bit 0 is 0, but
7331     * bit 1 is 1.  That means there is a match if the character
7332     * matches \W.  We won't bother to call isFOO_lc() on bit 0,
7333     * but will on bit 1.  On the second iteration 'to_complement'
7334     * will be 1, so the exclusive or will reverse things, so we
7335     * are testing for \W.  On the third iteration, 'to_complement'
7336     * will be 0, and we would be testing for \s; the fourth
7337     * iteration would test for \S, etc.
7338     *
7339     * Note that this code assumes that all the classes are closed
7340     * under folding.  For example, if a character matches \w, then
7341     * its fold does too; and vice versa.  This should be true for
7342     * any well-behaved locale for all the currently defined Posix
7343     * classes, except for :lower: and :upper:, which are handled
7344     * by the pseudo-class :cased: which matches if either of the
7345     * other two does.  To get rid of this assumption, an outer
7346     * loop could be used below to iterate over both the source
7347     * character, and its fold (if different) */
7348
7349     int count = 0;
7350     int to_complement = 0;
7351     while (count < ANYOF_MAX) {
7352      if (ANYOF_CLASS_TEST(n, count)
7353       && to_complement ^ cBOOL(isFOO_lc(count/2, (U8) c)))
7354      {
7355       match = TRUE;
7356       break;
7357      }
7358      count++;
7359      to_complement ^= 1;
7360     }
7361    }
7362   }
7363  }
7364
7365  /* If the bitmap didn't (or couldn't) match, and something outside the
7366  * bitmap could match, try that.  Locale nodes specify completely the
7367  * behavior of code points in the bit map (otherwise, a utf8 target would
7368  * cause them to be treated as Unicode and not locale), except in
7369  * the very unlikely event when this node is a synthetic start class, which
7370  * could be a combination of locale and non-locale nodes.  So allow locale
7371  * to match for the synthetic start class, which will give a false
7372  * positive that will be resolved when the match is done again as not part
7373  * of the synthetic start class */
7374  if (!match) {
7375   if (utf8_target && (flags & ANYOF_UNICODE_ALL) && c >= 256) {
7376    match = TRUE; /* Everything above 255 matches */
7377   }
7378   else if (ANYOF_NONBITMAP(n)
7379     && ((flags & ANYOF_NONBITMAP_NON_UTF8)
7380      || (utf8_target
7381       && (c >=256
7382        || (! (flags & ANYOF_LOCALE))
7383        || OP(n) == ANYOF_SYNTHETIC))))
7384   {
7385    SV * const sw = core_regclass_swash(prog, n, TRUE, 0);
7386    if (sw) {
7387     U8 * utf8_p;
7388     if (utf8_target) {
7389      utf8_p = (U8 *) p;
7390     } else { /* Convert to utf8 */
7391      STRLEN len = 1;
7392      utf8_p = bytes_to_utf8(p, &len);
7393     }
7394
7395     if (swash_fetch(sw, utf8_p, TRUE)) {
7396      match = TRUE;
7397     }
7398
7399     /* If we allocated a string above, free it */
7400     if (! utf8_target) Safefree(utf8_p);
7401    }
7402   }
7403
7404   if (UNICODE_IS_SUPER(c)
7405    && OP(n) == ANYOF_WARN_SUPER
7406    && ckWARN_d(WARN_NON_UNICODE))
7407   {
7408    Perl_warner(aTHX_ packWARN(WARN_NON_UNICODE),
7409     "Code point 0x%04"UVXf" is not Unicode, all \\p{} matches fail; all \\P{} matches succeed", c);
7410   }
7411  }
7412
7413  /* The xor complements the return if to invert: 1^1 = 0, 1^0 = 1 */
7414  return cBOOL(flags & ANYOF_INVERT) ^ match;
7415 }
7416
7417 STATIC U8 *
7418 S_reghop3(U8 *s, I32 off, const U8* lim)
7419 {
7420  /* return the position 'off' UTF-8 characters away from 's', forward if
7421  * 'off' >= 0, backwards if negative.  But don't go outside of position
7422  * 'lim', which better be < s  if off < 0 */
7423
7424  dVAR;
7425
7426  PERL_ARGS_ASSERT_REGHOP3;
7427
7428  if (off >= 0) {
7429   while (off-- && s < lim) {
7430    /* XXX could check well-formedness here */
7431    s += UTF8SKIP(s);
7432   }
7433  }
7434  else {
7435   while (off++ && s > lim) {
7436    s--;
7437    if (UTF8_IS_CONTINUED(*s)) {
7438     while (s > lim && UTF8_IS_CONTINUATION(*s))
7439      s--;
7440    }
7441    /* XXX could check well-formedness here */
7442   }
7443  }
7444  return s;
7445 }
7446
7447 #ifdef XXX_dmq
7448 /* there are a bunch of places where we use two reghop3's that should
7449    be replaced with this routine. but since thats not done yet
7450    we ifdef it out - dmq
7451 */
7452 STATIC U8 *
7453 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
7454 {
7455  dVAR;
7456
7457  PERL_ARGS_ASSERT_REGHOP4;
7458
7459  if (off >= 0) {
7460   while (off-- && s < rlim) {
7461    /* XXX could check well-formedness here */
7462    s += UTF8SKIP(s);
7463   }
7464  }
7465  else {
7466   while (off++ && s > llim) {
7467    s--;
7468    if (UTF8_IS_CONTINUED(*s)) {
7469     while (s > llim && UTF8_IS_CONTINUATION(*s))
7470      s--;
7471    }
7472    /* XXX could check well-formedness here */
7473   }
7474  }
7475  return s;
7476 }
7477 #endif
7478
7479 STATIC U8 *
7480 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
7481 {
7482  dVAR;
7483
7484  PERL_ARGS_ASSERT_REGHOPMAYBE3;
7485
7486  if (off >= 0) {
7487   while (off-- && s < lim) {
7488    /* XXX could check well-formedness here */
7489    s += UTF8SKIP(s);
7490   }
7491   if (off >= 0)
7492    return NULL;
7493  }
7494  else {
7495   while (off++ && s > lim) {
7496    s--;
7497    if (UTF8_IS_CONTINUED(*s)) {
7498     while (s > lim && UTF8_IS_CONTINUATION(*s))
7499      s--;
7500    }
7501    /* XXX could check well-formedness here */
7502   }
7503   if (off <= 0)
7504    return NULL;
7505  }
7506  return s;
7507 }
7508
7509 static void
7510 restore_pos(pTHX_ void *arg)
7511 {
7512  dVAR;
7513  regexp * const rex = (regexp *)arg;
7514  if (PL_reg_state.re_state_eval_setup_done) {
7515   if (PL_reg_oldsaved) {
7516    rex->subbeg = PL_reg_oldsaved;
7517    rex->sublen = PL_reg_oldsavedlen;
7518    rex->suboffset = PL_reg_oldsavedoffset;
7519    rex->subcoffset = PL_reg_oldsavedcoffset;
7520 #ifdef PERL_ANY_COW
7521    rex->saved_copy = PL_nrs;
7522 #endif
7523    RXp_MATCH_COPIED_on(rex);
7524   }
7525   PL_reg_magic->mg_len = PL_reg_oldpos;
7526   PL_reg_state.re_state_eval_setup_done = FALSE;
7527   PL_curpm = PL_reg_oldcurpm;
7528  }
7529 }
7530
7531 STATIC void
7532 S_to_utf8_substr(pTHX_ regexp *prog)
7533 {
7534  /* Converts substr fields in prog from bytes to UTF-8, calling fbm_compile
7535  * on the converted value */
7536
7537  int i = 1;
7538
7539  PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
7540
7541  do {
7542   if (prog->substrs->data[i].substr
7543    && !prog->substrs->data[i].utf8_substr) {
7544    SV* const sv = newSVsv(prog->substrs->data[i].substr);
7545    prog->substrs->data[i].utf8_substr = sv;
7546    sv_utf8_upgrade(sv);
7547    if (SvVALID(prog->substrs->data[i].substr)) {
7548     if (SvTAIL(prog->substrs->data[i].substr)) {
7549      /* Trim the trailing \n that fbm_compile added last
7550      time.  */
7551      SvCUR_set(sv, SvCUR(sv) - 1);
7552      /* Whilst this makes the SV technically "invalid" (as its
7553      buffer is no longer followed by "\0") when fbm_compile()
7554      adds the "\n" back, a "\0" is restored.  */
7555      fbm_compile(sv, FBMcf_TAIL);
7556     } else
7557      fbm_compile(sv, 0);
7558    }
7559    if (prog->substrs->data[i].substr == prog->check_substr)
7560     prog->check_utf8 = sv;
7561   }
7562  } while (i--);
7563 }
7564
7565 STATIC bool
7566 S_to_byte_substr(pTHX_ regexp *prog)
7567 {
7568  /* Converts substr fields in prog from UTF-8 to bytes, calling fbm_compile
7569  * on the converted value; returns FALSE if can't be converted. */
7570
7571  dVAR;
7572  int i = 1;
7573
7574  PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
7575
7576  do {
7577   if (prog->substrs->data[i].utf8_substr
7578    && !prog->substrs->data[i].substr) {
7579    SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
7580    if (! sv_utf8_downgrade(sv, TRUE)) {
7581     return FALSE;
7582    }
7583    if (SvVALID(prog->substrs->data[i].utf8_substr)) {
7584     if (SvTAIL(prog->substrs->data[i].utf8_substr)) {
7585      /* Trim the trailing \n that fbm_compile added last
7586       time.  */
7587      SvCUR_set(sv, SvCUR(sv) - 1);
7588      fbm_compile(sv, FBMcf_TAIL);
7589     } else
7590      fbm_compile(sv, 0);
7591    }
7592    prog->substrs->data[i].substr = sv;
7593    if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
7594     prog->check_substr = sv;
7595   }
7596  } while (i--);
7597
7598  return TRUE;
7599 }
7600
7601 /*
7602  * Local variables:
7603  * c-indentation-style: bsd
7604  * c-basic-offset: 4
7605  * indent-tabs-mode: nil
7606  * End:
7607  *
7608  * ex: set ts=8 sts=4 sw=4 et:
7609  */