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