src/5014000/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 && FLAGS(scan) != REGEX_ASCII_RESTRICTED_CHARSET) {
3672     if (locinput == PL_bostr)
3673      ln = '\n';
3674     else {
3675      const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3676
3677      ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3678     }
3679     if (FLAGS(scan) != REGEX_LOCALE_CHARSET) {
3680      ln = isALNUM_uni(ln);
3681      LOAD_UTF8_CHARCLASS_ALNUM();
3682      n = swash_fetch(PL_utf8_alnum, (U8*)locinput, utf8_target);
3683     }
3684     else {
3685      ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3686      n = isALNUM_LC_utf8((U8*)locinput);
3687     }
3688    }
3689    else {
3690
3691     /* Here the string isn't utf8, or is utf8 and only ascii
3692     * characters are to match \w.  In the latter case looking at
3693     * the byte just prior to the current one may be just the final
3694     * byte of a multi-byte character.  This is ok.  There are two
3695     * cases:
3696     * 1) it is a single byte character, and then the test is doing
3697     * just what it's supposed to.
3698     * 2) it is a multi-byte character, in which case the final
3699     * byte is never mistakable for ASCII, and so the test
3700     * will say it is not a word character, which is the
3701     * correct answer. */
3702     ln = (locinput != PL_bostr) ?
3703      UCHARAT(locinput - 1) : '\n';
3704     switch (FLAGS(scan)) {
3705      case REGEX_UNICODE_CHARSET:
3706       ln = isWORDCHAR_L1(ln);
3707       n = isWORDCHAR_L1(nextchr);
3708       break;
3709      case REGEX_LOCALE_CHARSET:
3710       ln = isALNUM_LC(ln);
3711       n = isALNUM_LC(nextchr);
3712       break;
3713      case REGEX_DEPENDS_CHARSET:
3714       ln = isALNUM(ln);
3715       n = isALNUM(nextchr);
3716       break;
3717      case REGEX_ASCII_RESTRICTED_CHARSET:
3718       ln = isWORDCHAR_A(ln);
3719       n = isWORDCHAR_A(nextchr);
3720       break;
3721      default:
3722       Perl_croak(aTHX_ "panic: Unexpected FLAGS %u in op %u", FLAGS(scan), OP(scan));
3723       break;
3724     }
3725    }
3726    /* Note requires that all BOUNDs be lower than all NBOUNDs in
3727    * regcomp.sym */
3728    if (((!ln) == (!n)) == (OP(scan) < NBOUND))
3729      sayNO;
3730    break;
3731   case ANYOFV:
3732   case ANYOF:
3733    if (utf8_target || state_num == ANYOFV) {
3734     STRLEN inclasslen = PL_regeol - locinput;
3735     if (locinput >= PL_regeol)
3736      sayNO;
3737
3738     if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, utf8_target))
3739      sayNO;
3740     locinput += inclasslen;
3741     nextchr = UCHARAT(locinput);
3742     break;
3743    }
3744    else {
3745     if (nextchr < 0)
3746      nextchr = UCHARAT(locinput);
3747     if (!nextchr && locinput >= PL_regeol)
3748      sayNO;
3749     if (!REGINCLASS(rex, scan, (U8*)locinput))
3750      sayNO;
3751     nextchr = UCHARAT(++locinput);
3752     break;
3753    }
3754    break;
3755   /* Special char classes - The defines start on line 129 or so */
3756   CCC_TRY_U(ALNUM,  NALNUM,  isWORDCHAR,
3757     ALNUML, NALNUML, isALNUM_LC, isALNUM_LC_utf8,
3758     ALNUMU, NALNUMU, isWORDCHAR_L1,
3759     ALNUMA, NALNUMA, isWORDCHAR_A,
3760     alnum, "a");
3761
3762   CCC_TRY_U(SPACE,  NSPACE,  isSPACE,
3763     SPACEL, NSPACEL, isSPACE_LC, isSPACE_LC_utf8,
3764     SPACEU, NSPACEU, isSPACE_L1,
3765     SPACEA, NSPACEA, isSPACE_A,
3766     space, " ");
3767
3768   CCC_TRY(DIGIT,  NDIGIT,  isDIGIT,
3769     DIGITL, NDIGITL, isDIGIT_LC, isDIGIT_LC_utf8,
3770     DIGITA, NDIGITA, isDIGIT_A,
3771     digit, "0");
3772
3773   case CLUMP: /* Match \X: logical Unicode character.  This is defined as
3774      a Unicode extended Grapheme Cluster */
3775    /* From http://www.unicode.org/reports/tr29 (5.2 version).  An
3776    extended Grapheme Cluster is:
3777
3778    CR LF
3779    | Prepend* Begin Extend*
3780    | .
3781
3782    Begin is (Hangul-syllable | ! Control)
3783    Extend is (Grapheme_Extend | Spacing_Mark)
3784    Control is [ GCB_Control CR LF ]
3785
3786    The discussion below shows how the code for CLUMP is derived
3787    from this regex.  Note that most of these concepts are from
3788    property values of the Grapheme Cluster Boundary (GCB) property.
3789    No code point can have multiple property values for a given
3790    property.  Thus a code point in Prepend can't be in Control, but
3791    it must be in !Control.  This is why Control above includes
3792    GCB_Control plus CR plus LF.  The latter two are used in the GCB
3793    property separately, and so can't be in GCB_Control, even though
3794    they logically are controls.  Control is not the same as gc=cc,
3795    but includes format and other characters as well.
3796
3797    The Unicode definition of Hangul-syllable is:
3798     L+
3799     | (L* ( ( V | LV ) V* | LVT ) T*)
3800     | T+
3801     )
3802    Each of these is a value for the GCB property, and hence must be
3803    disjoint, so the order they are tested is immaterial, so the
3804    above can safely be changed to
3805     T+
3806     | L+
3807     | (L* ( LVT | ( V | LV ) V*) T*)
3808
3809    The last two terms can be combined like this:
3810     L* ( L
3811       | (( LVT | ( V | LV ) V*) T*))
3812
3813    And refactored into this:
3814     L* (L | LVT T* | V  V* T* | LV  V* T*)
3815
3816    That means that if we have seen any L's at all we can quit
3817    there, but if the next character is a LVT, a V or and LV we
3818    should keep going.
3819
3820    There is a subtlety with Prepend* which showed up in testing.
3821    Note that the Begin, and only the Begin is required in:
3822     | Prepend* Begin Extend*
3823    Also, Begin contains '! Control'.  A Prepend must be a '!
3824    Control', which means it must be a Begin.  What it comes down to
3825    is that if we match Prepend* and then find no suitable Begin
3826    afterwards, that if we backtrack the last Prepend, that one will
3827    be a suitable Begin.
3828    */
3829
3830    if (locinput >= PL_regeol)
3831     sayNO;
3832    if  (! utf8_target) {
3833
3834     /* Match either CR LF  or '.', as all the other possibilities
3835     * require utf8 */
3836     locinput++;     /* Match the . or CR */
3837     if (nextchr == '\r'
3838      && locinput < PL_regeol
3839      && UCHARAT(locinput) == '\n') locinput++;
3840    }
3841    else {
3842
3843     /* Utf8: See if is ( CR LF ); already know that locinput <
3844     * PL_regeol, so locinput+1 is in bounds */
3845     if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
3846      locinput += 2;
3847     }
3848     else {
3849      /* In case have to backtrack to beginning, then match '.' */
3850      char *starting = locinput;
3851
3852      /* In case have to backtrack the last prepend */
3853      char *previous_prepend = 0;
3854
3855      LOAD_UTF8_CHARCLASS_GCB();
3856
3857      /* Match (prepend)* */
3858      while (locinput < PL_regeol
3859       && swash_fetch(PL_utf8_X_prepend,
3860           (U8*)locinput, utf8_target))
3861      {
3862       previous_prepend = locinput;
3863       locinput += UTF8SKIP(locinput);
3864      }
3865
3866      /* As noted above, if we matched a prepend character, but
3867      * the next thing won't match, back off the last prepend we
3868      * matched, as it is guaranteed to match the begin */
3869      if (previous_prepend
3870       && (locinput >=  PL_regeol
3871        || ! swash_fetch(PL_utf8_X_begin,
3872            (U8*)locinput, utf8_target)))
3873      {
3874       locinput = previous_prepend;
3875      }
3876
3877      /* Note that here we know PL_regeol > locinput, as we
3878      * tested that upon input to this switch case, and if we
3879      * moved locinput forward, we tested the result just above
3880      * and it either passed, or we backed off so that it will
3881      * now pass */
3882      if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, utf8_target)) {
3883
3884       /* Here did not match the required 'Begin' in the
3885       * second term.  So just match the very first
3886       * character, the '.' of the final term of the regex */
3887       locinput = starting + UTF8SKIP(starting);
3888      } else {
3889
3890       /* Here is the beginning of a character that can have
3891       * an extender.  It is either a hangul syllable, or a
3892       * non-control */
3893       if (swash_fetch(PL_utf8_X_non_hangul,
3894           (U8*)locinput, utf8_target))
3895       {
3896
3897        /* Here not a Hangul syllable, must be a
3898        * ('!  * Control') */
3899        locinput += UTF8SKIP(locinput);
3900       } else {
3901
3902        /* Here is a Hangul syllable.  It can be composed
3903        * of several individual characters.  One
3904        * possibility is T+ */
3905        if (swash_fetch(PL_utf8_X_T,
3906            (U8*)locinput, utf8_target))
3907        {
3908         while (locinput < PL_regeol
3909           && swash_fetch(PL_utf8_X_T,
3910               (U8*)locinput, utf8_target))
3911         {
3912          locinput += UTF8SKIP(locinput);
3913         }
3914        } else {
3915
3916         /* Here, not T+, but is a Hangul.  That means
3917         * it is one of the others: L, LV, LVT or V,
3918         * and matches:
3919         * L* (L | LVT T* | V  V* T* | LV  V* T*) */
3920
3921         /* Match L*           */
3922         while (locinput < PL_regeol
3923           && swash_fetch(PL_utf8_X_L,
3924               (U8*)locinput, utf8_target))
3925         {
3926          locinput += UTF8SKIP(locinput);
3927         }
3928
3929         /* Here, have exhausted L*.  If the next
3930         * character is not an LV, LVT nor V, it means
3931         * we had to have at least one L, so matches L+
3932         * in the original equation, we have a complete
3933         * hangul syllable.  Are done. */
3934
3935         if (locinput < PL_regeol
3936          && swash_fetch(PL_utf8_X_LV_LVT_V,
3937              (U8*)locinput, utf8_target))
3938         {
3939
3940          /* Otherwise keep going.  Must be LV, LVT
3941          * or V.  See if LVT */
3942          if (swash_fetch(PL_utf8_X_LVT,
3943              (U8*)locinput, utf8_target))
3944          {
3945           locinput += UTF8SKIP(locinput);
3946          } else {
3947
3948           /* Must be  V or LV.  Take it, then
3949           * match V*     */
3950           locinput += UTF8SKIP(locinput);
3951           while (locinput < PL_regeol
3952             && swash_fetch(PL_utf8_X_V,
3953               (U8*)locinput, utf8_target))
3954           {
3955            locinput += UTF8SKIP(locinput);
3956           }
3957          }
3958
3959          /* And any of LV, LVT, or V can be followed
3960          * by T*            */
3961          while (locinput < PL_regeol
3962           && swash_fetch(PL_utf8_X_T,
3963               (U8*)locinput,
3964               utf8_target))
3965          {
3966           locinput += UTF8SKIP(locinput);
3967          }
3968         }
3969        }
3970       }
3971
3972       /* Match any extender */
3973       while (locinput < PL_regeol
3974         && swash_fetch(PL_utf8_X_extend,
3975             (U8*)locinput, utf8_target))
3976       {
3977        locinput += UTF8SKIP(locinput);
3978       }
3979      }
3980     }
3981     if (locinput > PL_regeol) sayNO;
3982    }
3983    nextchr = UCHARAT(locinput);
3984    break;
3985
3986   case NREFFL:
3987   {   /* The capture buffer cases.  The ones beginning with N for the
3988    named buffers just convert to the equivalent numbered and
3989    pretend they were called as the corresponding numbered buffer
3990    op.  */
3991    /* don't initialize these in the declaration, it makes C++
3992    unhappy */
3993    char *s;
3994    char type;
3995    re_fold_t folder;
3996    const U8 *fold_array;
3997    UV utf8_fold_flags;
3998
3999    PL_reg_flags |= RF_tainted;
4000    folder = foldEQ_locale;
4001    fold_array = PL_fold_locale;
4002    type = REFFL;
4003    utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
4004    goto do_nref;
4005
4006   case NREFFA:
4007    folder = foldEQ_latin1;
4008    fold_array = PL_fold_latin1;
4009    type = REFFA;
4010    utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4011    goto do_nref;
4012
4013   case NREFFU:
4014    folder = foldEQ_latin1;
4015    fold_array = PL_fold_latin1;
4016    type = REFFU;
4017    utf8_fold_flags = 0;
4018    goto do_nref;
4019
4020   case NREFF:
4021    folder = foldEQ;
4022    fold_array = PL_fold;
4023    type = REFF;
4024    utf8_fold_flags = 0;
4025    goto do_nref;
4026
4027   case NREF:
4028    type = REF;
4029    folder = NULL;
4030    fold_array = NULL;
4031    utf8_fold_flags = 0;
4032   do_nref:
4033
4034    /* For the named back references, find the corresponding buffer
4035    * number */
4036    n = reg_check_named_buff_matched(rex,scan);
4037
4038    if ( ! n ) {
4039     sayNO;
4040    }
4041    goto do_nref_ref_common;
4042
4043   case REFFL:
4044    PL_reg_flags |= RF_tainted;
4045    folder = foldEQ_locale;
4046    fold_array = PL_fold_locale;
4047    utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
4048    goto do_ref;
4049
4050   case REFFA:
4051    folder = foldEQ_latin1;
4052    fold_array = PL_fold_latin1;
4053    utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4054    goto do_ref;
4055
4056   case REFFU:
4057    folder = foldEQ_latin1;
4058    fold_array = PL_fold_latin1;
4059    utf8_fold_flags = 0;
4060    goto do_ref;
4061
4062   case REFF:
4063    folder = foldEQ;
4064    fold_array = PL_fold;
4065    utf8_fold_flags = 0;
4066    goto do_ref;
4067
4068   case REF:
4069    folder = NULL;
4070    fold_array = NULL;
4071    utf8_fold_flags = 0;
4072
4073   do_ref:
4074    type = OP(scan);
4075    n = ARG(scan);  /* which paren pair */
4076
4077   do_nref_ref_common:
4078    ln = PL_regoffs[n].start;
4079    PL_reg_leftiter = PL_reg_maxiter;  /* Void cache */
4080    if (*PL_reglastparen < n || ln == -1)
4081     sayNO;   /* Do not match unless seen CLOSEn. */
4082    if (ln == PL_regoffs[n].end)
4083     break;
4084
4085    s = PL_bostr + ln;
4086    if (type != REF /* REF can do byte comparison */
4087     && (utf8_target || type == REFFU))
4088    { /* XXX handle REFFL better */
4089     char * limit = PL_regeol;
4090
4091     /* This call case insensitively compares the entire buffer
4092      * at s, with the current input starting at locinput, but
4093      * not going off the end given by PL_regeol, and returns in
4094      * limit upon success, how much of the current input was
4095      * matched */
4096     if (! foldEQ_utf8_flags(s, NULL, PL_regoffs[n].end - ln, utf8_target,
4097          locinput, &limit, 0, utf8_target, utf8_fold_flags))
4098     {
4099      sayNO;
4100     }
4101     locinput = limit;
4102     nextchr = UCHARAT(locinput);
4103     break;
4104    }
4105
4106    /* Not utf8:  Inline the first character, for speed. */
4107    if (UCHARAT(s) != nextchr &&
4108     (type == REF ||
4109     UCHARAT(s) != fold_array[nextchr]))
4110     sayNO;
4111    ln = PL_regoffs[n].end - ln;
4112    if (locinput + ln > PL_regeol)
4113     sayNO;
4114    if (ln > 1 && (type == REF
4115       ? memNE(s, locinput, ln)
4116       : ! folder(s, locinput, ln)))
4117     sayNO;
4118    locinput += ln;
4119    nextchr = UCHARAT(locinput);
4120    break;
4121   }
4122   case NOTHING:
4123   case TAIL:
4124    break;
4125   case BACK:
4126    break;
4127
4128 #undef  ST
4129 #define ST st->u.eval
4130   {
4131    SV *ret;
4132    REGEXP *re_sv;
4133    regexp *re;
4134    regexp_internal *rei;
4135    regnode *startpoint;
4136
4137   case GOSTART:
4138   case GOSUB: /*    /(...(?1))/   /(...(?&foo))/   */
4139    if (cur_eval && cur_eval->locinput==locinput) {
4140     if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
4141      Perl_croak(aTHX_ "Infinite recursion in regex");
4142     if ( ++nochange_depth > max_nochange_depth )
4143      Perl_croak(aTHX_
4144       "Pattern subroutine nesting without pos change"
4145       " exceeded limit in regex");
4146    } else {
4147     nochange_depth = 0;
4148    }
4149    re_sv = rex_sv;
4150    re = rex;
4151    rei = rexi;
4152    (void)ReREFCNT_inc(rex_sv);
4153    if (OP(scan)==GOSUB) {
4154     startpoint = scan + ARG2L(scan);
4155     ST.close_paren = ARG(scan);
4156    } else {
4157     startpoint = rei->program+1;
4158     ST.close_paren = 0;
4159    }
4160    goto eval_recurse_doit;
4161    /* NOTREACHED */
4162   case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
4163    if (cur_eval && cur_eval->locinput==locinput) {
4164     if ( ++nochange_depth > max_nochange_depth )
4165      Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
4166    } else {
4167     nochange_depth = 0;
4168    }
4169    {
4170     /* execute the code in the {...} */
4171     dSP;
4172     SV ** const before = SP;
4173     OP_4tree * const oop = PL_op;
4174     COP * const ocurcop = PL_curcop;
4175     PAD *old_comppad;
4176     char *saved_regeol = PL_regeol;
4177     struct re_save_state saved_state;
4178
4179     /* To not corrupt the existing regex state while executing the
4180     * eval we would normally put it on the save stack, like with
4181     * save_re_context. However, re-evals have a weird scoping so we
4182     * can't just add ENTER/LEAVE here. With that, things like
4183     *
4184     *    (?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a})
4185     *
4186     * would break, as they expect the localisation to be unwound
4187     * only when the re-engine backtracks through the bit that
4188     * localised it.
4189     *
4190     * What we do instead is just saving the state in a local c
4191     * variable.
4192     */
4193     Copy(&PL_reg_state, &saved_state, 1, struct re_save_state);
4194
4195     n = ARG(scan);
4196     PL_op = (OP_4tree*)rexi->data->data[n];
4197     DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
4198      "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
4199     PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
4200     PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
4201
4202     if (sv_yes_mark) {
4203      SV *sv_mrk = get_sv("REGMARK", 1);
4204      sv_setsv(sv_mrk, sv_yes_mark);
4205     }
4206
4207     CALLRUNOPS(aTHX);   /* Scalar context. */
4208     SPAGAIN;
4209     if (SP == before)
4210      ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
4211     else {
4212      ret = POPs;
4213      PUTBACK;
4214     }
4215
4216     Copy(&saved_state, &PL_reg_state, 1, struct re_save_state);
4217
4218     PL_op = oop;
4219     PAD_RESTORE_LOCAL(old_comppad);
4220     PL_curcop = ocurcop;
4221     PL_regeol = saved_regeol;
4222     if (!logical) {
4223      /* /(?{...})/ */
4224      sv_setsv(save_scalar(PL_replgv), ret);
4225      break;
4226     }
4227    }
4228    if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
4229     logical = 0;
4230     {
4231      /* extract RE object from returned value; compiling if
4232      * necessary */
4233      MAGIC *mg = NULL;
4234      REGEXP *rx = NULL;
4235
4236      if (SvROK(ret)) {
4237       SV *const sv = SvRV(ret);
4238
4239       if (SvTYPE(sv) == SVt_REGEXP) {
4240        rx = (REGEXP*) sv;
4241       } else if (SvSMAGICAL(sv)) {
4242        mg = mg_find(sv, PERL_MAGIC_qr);
4243        assert(mg);
4244       }
4245      } else if (SvTYPE(ret) == SVt_REGEXP) {
4246       rx = (REGEXP*) ret;
4247      } else if (SvSMAGICAL(ret)) {
4248       if (SvGMAGICAL(ret)) {
4249        /* I don't believe that there is ever qr magic
4250        here.  */
4251        assert(!mg_find(ret, PERL_MAGIC_qr));
4252        sv_unmagic(ret, PERL_MAGIC_qr);
4253       }
4254       else {
4255        mg = mg_find(ret, PERL_MAGIC_qr);
4256        /* testing suggests mg only ends up non-NULL for
4257        scalars who were upgraded and compiled in the
4258        else block below. In turn, this is only
4259        triggered in the "postponed utf8 string" tests
4260        in t/op/pat.t  */
4261       }
4262      }
4263
4264      if (mg) {
4265       rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
4266       assert(rx);
4267      }
4268      if (rx) {
4269       rx = reg_temp_copy(NULL, rx);
4270      }
4271      else {
4272       U32 pm_flags = 0;
4273       const I32 osize = PL_regsize;
4274
4275       if (DO_UTF8(ret)) {
4276        assert (SvUTF8(ret));
4277       } else if (SvUTF8(ret)) {
4278        /* Not doing UTF-8, despite what the SV says. Is
4279        this only if we're trapped in use 'bytes'?  */
4280        /* Make a copy of the octet sequence, but without
4281        the flag on, as the compiler now honours the
4282        SvUTF8 flag on ret.  */
4283        STRLEN len;
4284        const char *const p = SvPV(ret, len);
4285        ret = newSVpvn_flags(p, len, SVs_TEMP);
4286       }
4287       rx = CALLREGCOMP(ret, pm_flags);
4288       if (!(SvFLAGS(ret)
4289        & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
4290         | SVs_GMG))) {
4291        /* This isn't a first class regexp. Instead, it's
4292        caching a regexp onto an existing, Perl visible
4293        scalar.  */
4294        sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
4295       }
4296       PL_regsize = osize;
4297      }
4298      re_sv = rx;
4299      re = (struct regexp *)SvANY(rx);
4300     }
4301     RXp_MATCH_COPIED_off(re);
4302     re->subbeg = rex->subbeg;
4303     re->sublen = rex->sublen;
4304     rei = RXi_GET(re);
4305     DEBUG_EXECUTE_r(
4306      debug_start_match(re_sv, utf8_target, locinput, PL_regeol,
4307       "Matching embedded");
4308     );
4309     startpoint = rei->program + 1;
4310      ST.close_paren = 0; /* only used for GOSUB */
4311      /* borrowed from regtry */
4312     if (PL_reg_start_tmpl <= re->nparens) {
4313      PL_reg_start_tmpl = re->nparens*3/2 + 3;
4314      if(PL_reg_start_tmp)
4315       Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4316      else
4317       Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4318     }
4319
4320   eval_recurse_doit: /* Share code with GOSUB below this line */
4321     /* run the pattern returned from (??{...}) */
4322     ST.cp = regcppush(0); /* Save *all* the positions. */
4323     REGCP_SET(ST.lastcp);
4324
4325     PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
4326
4327     /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
4328     PL_reglastparen = &re->lastparen;
4329     PL_reglastcloseparen = &re->lastcloseparen;
4330     re->lastparen = 0;
4331     re->lastcloseparen = 0;
4332
4333     PL_reginput = locinput;
4334     PL_regsize = 0;
4335
4336     /* XXXX This is too dramatic a measure... */
4337     PL_reg_maxiter = 0;
4338
4339     ST.toggle_reg_flags = PL_reg_flags;
4340     if (RX_UTF8(re_sv))
4341      PL_reg_flags |= RF_utf8;
4342     else
4343      PL_reg_flags &= ~RF_utf8;
4344     ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
4345
4346     ST.prev_rex = rex_sv;
4347     ST.prev_curlyx = cur_curlyx;
4348     SETREX(rex_sv,re_sv);
4349     rex = re;
4350     rexi = rei;
4351     cur_curlyx = NULL;
4352     ST.B = next;
4353     ST.prev_eval = cur_eval;
4354     cur_eval = st;
4355     /* now continue from first node in postoned RE */
4356     PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
4357     /* NOTREACHED */
4358    }
4359    /* logical is 1,   /(?(?{...})X|Y)/ */
4360    sw = cBOOL(SvTRUE(ret));
4361    logical = 0;
4362    break;
4363   }
4364
4365   case EVAL_AB: /* cleanup after a successful (??{A})B */
4366    /* note: this is called twice; first after popping B, then A */
4367    PL_reg_flags ^= ST.toggle_reg_flags;
4368    ReREFCNT_dec(rex_sv);
4369    SETREX(rex_sv,ST.prev_rex);
4370    rex = (struct regexp *)SvANY(rex_sv);
4371    rexi = RXi_GET(rex);
4372    regcpblow(ST.cp);
4373    cur_eval = ST.prev_eval;
4374    cur_curlyx = ST.prev_curlyx;
4375
4376    /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4377    PL_reglastparen = &rex->lastparen;
4378    PL_reglastcloseparen = &rex->lastcloseparen;
4379    /* also update PL_regoffs */
4380    PL_regoffs = rex->offs;
4381
4382    /* XXXX This is too dramatic a measure... */
4383    PL_reg_maxiter = 0;
4384    if ( nochange_depth )
4385     nochange_depth--;
4386    sayYES;
4387
4388
4389   case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
4390    /* note: this is called twice; first after popping B, then A */
4391    PL_reg_flags ^= ST.toggle_reg_flags;
4392    ReREFCNT_dec(rex_sv);
4393    SETREX(rex_sv,ST.prev_rex);
4394    rex = (struct regexp *)SvANY(rex_sv);
4395    rexi = RXi_GET(rex);
4396    /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4397    PL_reglastparen = &rex->lastparen;
4398    PL_reglastcloseparen = &rex->lastcloseparen;
4399
4400    PL_reginput = locinput;
4401    REGCP_UNWIND(ST.lastcp);
4402    regcppop(rex);
4403    cur_eval = ST.prev_eval;
4404    cur_curlyx = ST.prev_curlyx;
4405    /* XXXX This is too dramatic a measure... */
4406    PL_reg_maxiter = 0;
4407    if ( nochange_depth )
4408     nochange_depth--;
4409    sayNO_SILENT;
4410 #undef ST
4411
4412   case OPEN:
4413    n = ARG(scan);  /* which paren pair */
4414    PL_reg_start_tmp[n] = locinput;
4415    if (n > PL_regsize)
4416     PL_regsize = n;
4417    lastopen = n;
4418    break;
4419   case CLOSE:
4420    n = ARG(scan);  /* which paren pair */
4421    PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
4422    PL_regoffs[n].end = locinput - PL_bostr;
4423    /*if (n > PL_regsize)
4424     PL_regsize = n;*/
4425    if (n > *PL_reglastparen)
4426     *PL_reglastparen = n;
4427    *PL_reglastcloseparen = n;
4428    if (cur_eval && cur_eval->u.eval.close_paren == n) {
4429     goto fake_end;
4430    }
4431    break;
4432   case ACCEPT:
4433    if (ARG(scan)){
4434     regnode *cursor;
4435     for (cursor=scan;
4436      cursor && OP(cursor)!=END;
4437      cursor=regnext(cursor))
4438     {
4439      if ( OP(cursor)==CLOSE ){
4440       n = ARG(cursor);
4441       if ( n <= lastopen ) {
4442        PL_regoffs[n].start
4443         = PL_reg_start_tmp[n] - PL_bostr;
4444        PL_regoffs[n].end = locinput - PL_bostr;
4445        /*if (n > PL_regsize)
4446        PL_regsize = n;*/
4447        if (n > *PL_reglastparen)
4448         *PL_reglastparen = n;
4449        *PL_reglastcloseparen = n;
4450        if ( n == ARG(scan) || (cur_eval &&
4451         cur_eval->u.eval.close_paren == n))
4452         break;
4453       }
4454      }
4455     }
4456    }
4457    goto fake_end;
4458    /*NOTREACHED*/
4459   case GROUPP:
4460    n = ARG(scan);  /* which paren pair */
4461    sw = cBOOL(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
4462    break;
4463   case NGROUPP:
4464    /* reg_check_named_buff_matched returns 0 for no match */
4465    sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
4466    break;
4467   case INSUBP:
4468    n = ARG(scan);
4469    sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
4470    break;
4471   case DEFINEP:
4472    sw = 0;
4473    break;
4474   case IFTHEN:
4475    PL_reg_leftiter = PL_reg_maxiter;  /* Void cache */
4476    if (sw)
4477     next = NEXTOPER(NEXTOPER(scan));
4478    else {
4479     next = scan + ARG(scan);
4480     if (OP(next) == IFTHEN) /* Fake one. */
4481      next = NEXTOPER(NEXTOPER(next));
4482    }
4483    break;
4484   case LOGICAL:
4485    logical = scan->flags;
4486    break;
4487
4488 /*******************************************************************
4489
4490 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
4491 pattern, where A and B are subpatterns. (For simple A, CURLYM or
4492 STAR/PLUS/CURLY/CURLYN are used instead.)
4493
4494 A*B is compiled as <CURLYX><A><WHILEM><B>
4495
4496 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
4497 state, which contains the current count, initialised to -1. It also sets
4498 cur_curlyx to point to this state, with any previous value saved in the
4499 state block.
4500
4501 CURLYX then jumps straight to the WHILEM op, rather than executing A,
4502 since the pattern may possibly match zero times (i.e. it's a while {} loop
4503 rather than a do {} while loop).
4504
4505 Each entry to WHILEM represents a successful match of A. The count in the
4506 CURLYX block is incremented, another WHILEM state is pushed, and execution
4507 passes to A or B depending on greediness and the current count.
4508
4509 For example, if matching against the string a1a2a3b (where the aN are
4510 substrings that match /A/), then the match progresses as follows: (the
4511 pushed states are interspersed with the bits of strings matched so far):
4512
4513  <CURLYX cnt=-1>
4514  <CURLYX cnt=0><WHILEM>
4515  <CURLYX cnt=1><WHILEM> a1 <WHILEM>
4516  <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
4517  <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
4518  <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
4519
4520 (Contrast this with something like CURLYM, which maintains only a single
4521 backtrack state:
4522
4523  <CURLYM cnt=0> a1
4524  a1 <CURLYM cnt=1> a2
4525  a1 a2 <CURLYM cnt=2> a3
4526  a1 a2 a3 <CURLYM cnt=3> b
4527 )
4528
4529 Each WHILEM state block marks a point to backtrack to upon partial failure
4530 of A or B, and also contains some minor state data related to that
4531 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
4532 overall state, such as the count, and pointers to the A and B ops.
4533
4534 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
4535 must always point to the *current* CURLYX block, the rules are:
4536
4537 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
4538 and set cur_curlyx to point the new block.
4539
4540 When popping the CURLYX block after a successful or unsuccessful match,
4541 restore the previous cur_curlyx.
4542
4543 When WHILEM is about to execute B, save the current cur_curlyx, and set it
4544 to the outer one saved in the CURLYX block.
4545
4546 When popping the WHILEM block after a successful or unsuccessful B match,
4547 restore the previous cur_curlyx.
4548
4549 Here's an example for the pattern (AI* BI)*BO
4550 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
4551
4552 cur_
4553 curlyx backtrack stack
4554 ------ ---------------
4555 NULL
4556 CO     <CO prev=NULL> <WO>
4557 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4558 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4559 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
4560
4561 At this point the pattern succeeds, and we work back down the stack to
4562 clean up, restoring as we go:
4563
4564 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4565 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4566 CO     <CO prev=NULL> <WO>
4567 NULL
4568
4569 *******************************************************************/
4570
4571 #define ST st->u.curlyx
4572
4573   case CURLYX:    /* start of /A*B/  (for complex A) */
4574   {
4575    /* No need to save/restore up to this paren */
4576    I32 parenfloor = scan->flags;
4577
4578    assert(next); /* keep Coverity happy */
4579    if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4580     next += ARG(next);
4581
4582    /* XXXX Probably it is better to teach regpush to support
4583    parenfloor > PL_regsize... */
4584    if (parenfloor > (I32)*PL_reglastparen)
4585     parenfloor = *PL_reglastparen; /* Pessimization... */
4586
4587    ST.prev_curlyx= cur_curlyx;
4588    cur_curlyx = st;
4589    ST.cp = PL_savestack_ix;
4590
4591    /* these fields contain the state of the current curly.
4592    * they are accessed by subsequent WHILEMs */
4593    ST.parenfloor = parenfloor;
4594    ST.me = scan;
4595    ST.B = next;
4596    ST.minmod = minmod;
4597    minmod = 0;
4598    ST.count = -1; /* this will be updated by WHILEM */
4599    ST.lastloc = NULL;  /* this will be updated by WHILEM */
4600
4601    PL_reginput = locinput;
4602    PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4603    /* NOTREACHED */
4604   }
4605
4606   case CURLYX_end: /* just finished matching all of A*B */
4607    cur_curlyx = ST.prev_curlyx;
4608    sayYES;
4609    /* NOTREACHED */
4610
4611   case CURLYX_end_fail: /* just failed to match all of A*B */
4612    regcpblow(ST.cp);
4613    cur_curlyx = ST.prev_curlyx;
4614    sayNO;
4615    /* NOTREACHED */
4616
4617
4618 #undef ST
4619 #define ST st->u.whilem
4620
4621   case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
4622   {
4623    /* see the discussion above about CURLYX/WHILEM */
4624    I32 n;
4625    int min = ARG1(cur_curlyx->u.curlyx.me);
4626    int max = ARG2(cur_curlyx->u.curlyx.me);
4627    regnode *A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS;
4628
4629    assert(cur_curlyx); /* keep Coverity happy */
4630    n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4631    ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4632    ST.cache_offset = 0;
4633    ST.cache_mask = 0;
4634
4635    PL_reginput = locinput;
4636
4637    DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4638     "%*s  whilem: matched %ld out of %d..%d\n",
4639     REPORT_CODE_OFF+depth*2, "", (long)n, min, max)
4640    );
4641
4642    /* First just match a string of min A's. */
4643
4644    if (n < min) {
4645     ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4646     cur_curlyx->u.curlyx.lastloc = locinput;
4647     REGCP_SET(ST.lastcp);
4648
4649     PUSH_STATE_GOTO(WHILEM_A_pre, A);
4650     /* NOTREACHED */
4651    }
4652
4653    /* If degenerate A matches "", assume A done. */
4654
4655    if (locinput == cur_curlyx->u.curlyx.lastloc) {
4656     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4657     "%*s  whilem: empty match detected, trying continuation...\n",
4658     REPORT_CODE_OFF+depth*2, "")
4659     );
4660     goto do_whilem_B_max;
4661    }
4662
4663    /* super-linear cache processing */
4664
4665    if (scan->flags) {
4666
4667     if (!PL_reg_maxiter) {
4668      /* start the countdown: Postpone detection until we
4669      * know the match is not *that* much linear. */
4670      PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4671      /* possible overflow for long strings and many CURLYX's */
4672      if (PL_reg_maxiter < 0)
4673       PL_reg_maxiter = I32_MAX;
4674      PL_reg_leftiter = PL_reg_maxiter;
4675     }
4676
4677     if (PL_reg_leftiter-- == 0) {
4678      /* initialise cache */
4679      const I32 size = (PL_reg_maxiter + 7)/8;
4680      if (PL_reg_poscache) {
4681       if ((I32)PL_reg_poscache_size < size) {
4682        Renew(PL_reg_poscache, size, char);
4683        PL_reg_poscache_size = size;
4684       }
4685       Zero(PL_reg_poscache, size, char);
4686      }
4687      else {
4688       PL_reg_poscache_size = size;
4689       Newxz(PL_reg_poscache, size, char);
4690      }
4691      DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4692  "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4693        PL_colors[4], PL_colors[5])
4694      );
4695     }
4696
4697     if (PL_reg_leftiter < 0) {
4698      /* have we already failed at this position? */
4699      I32 offset, mask;
4700      offset  = (scan->flags & 0xf) - 1
4701         + (locinput - PL_bostr)  * (scan->flags>>4);
4702      mask    = 1 << (offset % 8);
4703      offset /= 8;
4704      if (PL_reg_poscache[offset] & mask) {
4705       DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4706        "%*s  whilem: (cache) already tried at this position...\n",
4707        REPORT_CODE_OFF+depth*2, "")
4708       );
4709       sayNO; /* cache records failure */
4710      }
4711      ST.cache_offset = offset;
4712      ST.cache_mask   = mask;
4713     }
4714    }
4715
4716    /* Prefer B over A for minimal matching. */
4717
4718    if (cur_curlyx->u.curlyx.minmod) {
4719     ST.save_curlyx = cur_curlyx;
4720     cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4721     ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4722     REGCP_SET(ST.lastcp);
4723     PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4724     /* NOTREACHED */
4725    }
4726
4727    /* Prefer A over B for maximal matching. */
4728
4729    if (n < max) { /* More greed allowed? */
4730     ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4731     cur_curlyx->u.curlyx.lastloc = locinput;
4732     REGCP_SET(ST.lastcp);
4733     PUSH_STATE_GOTO(WHILEM_A_max, A);
4734     /* NOTREACHED */
4735    }
4736    goto do_whilem_B_max;
4737   }
4738   /* NOTREACHED */
4739
4740   case WHILEM_B_min: /* just matched B in a minimal match */
4741   case WHILEM_B_max: /* just matched B in a maximal match */
4742    cur_curlyx = ST.save_curlyx;
4743    sayYES;
4744    /* NOTREACHED */
4745
4746   case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4747    cur_curlyx = ST.save_curlyx;
4748    cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4749    cur_curlyx->u.curlyx.count--;
4750    CACHEsayNO;
4751    /* NOTREACHED */
4752
4753   case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4754    /* FALL THROUGH */
4755   case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4756    REGCP_UNWIND(ST.lastcp);
4757    regcppop(rex);
4758    cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4759    cur_curlyx->u.curlyx.count--;
4760    CACHEsayNO;
4761    /* NOTREACHED */
4762
4763   case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4764    REGCP_UNWIND(ST.lastcp);
4765    regcppop(rex); /* Restore some previous $<digit>s? */
4766    PL_reginput = locinput;
4767    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4768     "%*s  whilem: failed, trying continuation...\n",
4769     REPORT_CODE_OFF+depth*2, "")
4770    );
4771   do_whilem_B_max:
4772    if (cur_curlyx->u.curlyx.count >= REG_INFTY
4773     && ckWARN(WARN_REGEXP)
4774     && !(PL_reg_flags & RF_warned))
4775    {
4776     PL_reg_flags |= RF_warned;
4777     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4778      "Complex regular subexpression recursion",
4779      REG_INFTY - 1);
4780    }
4781
4782    /* now try B */
4783    ST.save_curlyx = cur_curlyx;
4784    cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4785    PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4786    /* NOTREACHED */
4787
4788   case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4789    cur_curlyx = ST.save_curlyx;
4790    REGCP_UNWIND(ST.lastcp);
4791    regcppop(rex);
4792
4793    if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
4794     /* Maximum greed exceeded */
4795     if (cur_curlyx->u.curlyx.count >= REG_INFTY
4796      && ckWARN(WARN_REGEXP)
4797      && !(PL_reg_flags & RF_warned))
4798     {
4799      PL_reg_flags |= RF_warned;
4800      Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4801       "%s limit (%d) exceeded",
4802       "Complex regular subexpression recursion",
4803       REG_INFTY - 1);
4804     }
4805     cur_curlyx->u.curlyx.count--;
4806     CACHEsayNO;
4807    }
4808
4809    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4810     "%*s  trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4811    );
4812    /* Try grabbing another A and see if it helps. */
4813    PL_reginput = locinput;
4814    cur_curlyx->u.curlyx.lastloc = locinput;
4815    ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4816    REGCP_SET(ST.lastcp);
4817    PUSH_STATE_GOTO(WHILEM_A_min,
4818     /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS);
4819    /* NOTREACHED */
4820
4821 #undef  ST
4822 #define ST st->u.branch
4823
4824   case BRANCHJ:     /*  /(...|A|...)/ with long next pointer */
4825    next = scan + ARG(scan);
4826    if (next == scan)
4827     next = NULL;
4828    scan = NEXTOPER(scan);
4829    /* FALL THROUGH */
4830
4831   case BRANCH:     /*  /(...|A|...)/ */
4832    scan = NEXTOPER(scan); /* scan now points to inner node */
4833    ST.lastparen = *PL_reglastparen;
4834    ST.next_branch = next;
4835    REGCP_SET(ST.cp);
4836    PL_reginput = locinput;
4837
4838    /* Now go into the branch */
4839    if (has_cutgroup) {
4840     PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4841    } else {
4842     PUSH_STATE_GOTO(BRANCH_next, scan);
4843    }
4844    /* NOTREACHED */
4845   case CUTGROUP:
4846    PL_reginput = locinput;
4847    sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4848     MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4849    PUSH_STATE_GOTO(CUTGROUP_next,next);
4850    /* NOTREACHED */
4851   case CUTGROUP_next_fail:
4852    do_cutgroup = 1;
4853    no_final = 1;
4854    if (st->u.mark.mark_name)
4855     sv_commit = st->u.mark.mark_name;
4856    sayNO;
4857    /* NOTREACHED */
4858   case BRANCH_next:
4859    sayYES;
4860    /* NOTREACHED */
4861   case BRANCH_next_fail: /* that branch failed; try the next, if any */
4862    if (do_cutgroup) {
4863     do_cutgroup = 0;
4864     no_final = 0;
4865    }
4866    REGCP_UNWIND(ST.cp);
4867    for (n = *PL_reglastparen; n > ST.lastparen; n--)
4868     PL_regoffs[n].end = -1;
4869    *PL_reglastparen = n;
4870    /*dmq: *PL_reglastcloseparen = n; */
4871    scan = ST.next_branch;
4872    /* no more branches? */
4873    if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4874     DEBUG_EXECUTE_r({
4875      PerlIO_printf( Perl_debug_log,
4876       "%*s  %sBRANCH failed...%s\n",
4877       REPORT_CODE_OFF+depth*2, "",
4878       PL_colors[4],
4879       PL_colors[5] );
4880     });
4881     sayNO_SILENT;
4882    }
4883    continue; /* execute next BRANCH[J] op */
4884    /* NOTREACHED */
4885
4886   case MINMOD:
4887    minmod = 1;
4888    break;
4889
4890 #undef  ST
4891 #define ST st->u.curlym
4892
4893   case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4894
4895    /* This is an optimisation of CURLYX that enables us to push
4896    * only a single backtracking state, no matter how many matches
4897    * there are in {m,n}. It relies on the pattern being constant
4898    * length, with no parens to influence future backrefs
4899    */
4900
4901    ST.me = scan;
4902    scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4903
4904    /* if paren positive, emulate an OPEN/CLOSE around A */
4905    if (ST.me->flags) {
4906     U32 paren = ST.me->flags;
4907     if (paren > PL_regsize)
4908      PL_regsize = paren;
4909     if (paren > *PL_reglastparen)
4910      *PL_reglastparen = paren;
4911     scan += NEXT_OFF(scan); /* Skip former OPEN. */
4912    }
4913    ST.A = scan;
4914    ST.B = next;
4915    ST.alen = 0;
4916    ST.count = 0;
4917    ST.minmod = minmod;
4918    minmod = 0;
4919    ST.c1 = CHRTEST_UNINIT;
4920    REGCP_SET(ST.cp);
4921
4922    if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4923     goto curlym_do_B;
4924
4925   curlym_do_A: /* execute the A in /A{m,n}B/  */
4926    PL_reginput = locinput;
4927    PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4928    /* NOTREACHED */
4929
4930   case CURLYM_A: /* we've just matched an A */
4931    locinput = st->locinput;
4932    nextchr = UCHARAT(locinput);
4933
4934    ST.count++;
4935    /* after first match, determine A's length: u.curlym.alen */
4936    if (ST.count == 1) {
4937     if (PL_reg_match_utf8) {
4938      char *s = locinput;
4939      while (s < PL_reginput) {
4940       ST.alen++;
4941       s += UTF8SKIP(s);
4942      }
4943     }
4944     else {
4945      ST.alen = PL_reginput - locinput;
4946     }
4947     if (ST.alen == 0)
4948      ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4949    }
4950    DEBUG_EXECUTE_r(
4951     PerlIO_printf(Perl_debug_log,
4952       "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4953       (int)(REPORT_CODE_OFF+(depth*2)), "",
4954       (IV) ST.count, (IV)ST.alen)
4955    );
4956
4957    locinput = PL_reginput;
4958
4959    if (cur_eval && cur_eval->u.eval.close_paren &&
4960     cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4961     goto fake_end;
4962
4963    {
4964     I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
4965     if ( max == REG_INFTY || ST.count < max )
4966      goto curlym_do_A; /* try to match another A */
4967    }
4968    goto curlym_do_B; /* try to match B */
4969
4970   case CURLYM_A_fail: /* just failed to match an A */
4971    REGCP_UNWIND(ST.cp);
4972
4973    if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4974     || (cur_eval && cur_eval->u.eval.close_paren &&
4975      cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4976     sayNO;
4977
4978   curlym_do_B: /* execute the B in /A{m,n}B/  */
4979    PL_reginput = locinput;
4980    if (ST.c1 == CHRTEST_UNINIT) {
4981     /* calculate c1 and c2 for possible match of 1st char
4982     * following curly */
4983     ST.c1 = ST.c2 = CHRTEST_VOID;
4984     if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4985      regnode *text_node = ST.B;
4986      if (! HAS_TEXT(text_node))
4987       FIND_NEXT_IMPT(text_node);
4988      /* this used to be
4989
4990       (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4991
4992        But the former is redundant in light of the latter.
4993
4994        if this changes back then the macro for
4995        IS_TEXT and friends need to change.
4996      */
4997      if (PL_regkind[OP(text_node)] == EXACT)
4998      {
4999
5000       ST.c1 = (U8)*STRING(text_node);
5001       switch (OP(text_node)) {
5002        case EXACTF: ST.c2 = PL_fold[ST.c1]; break;
5003        case EXACTFA:
5004        case EXACTFU: ST.c2 = PL_fold_latin1[ST.c1]; break;
5005        case EXACTFL: ST.c2 = PL_fold_locale[ST.c1]; break;
5006        default: ST.c2 = ST.c1;
5007       }
5008      }
5009     }
5010    }
5011
5012    DEBUG_EXECUTE_r(
5013     PerlIO_printf(Perl_debug_log,
5014      "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
5015      (int)(REPORT_CODE_OFF+(depth*2)),
5016      "", (IV)ST.count)
5017     );
5018    if (ST.c1 != CHRTEST_VOID
5019      && UCHARAT(PL_reginput) != ST.c1
5020      && UCHARAT(PL_reginput) != ST.c2)
5021    {
5022     /* simulate B failing */
5023     DEBUG_OPTIMISE_r(
5024      PerlIO_printf(Perl_debug_log,
5025       "%*s  CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
5026       (int)(REPORT_CODE_OFF+(depth*2)),"",
5027       (IV)ST.c1,(IV)ST.c2
5028     ));
5029     state_num = CURLYM_B_fail;
5030     goto reenter_switch;
5031    }
5032
5033    if (ST.me->flags) {
5034     /* mark current A as captured */
5035     I32 paren = ST.me->flags;
5036     if (ST.count) {
5037      PL_regoffs[paren].start
5038       = HOPc(PL_reginput, -ST.alen) - PL_bostr;
5039      PL_regoffs[paren].end = PL_reginput - PL_bostr;
5040      /*dmq: *PL_reglastcloseparen = paren; */
5041     }
5042     else
5043      PL_regoffs[paren].end = -1;
5044     if (cur_eval && cur_eval->u.eval.close_paren &&
5045      cur_eval->u.eval.close_paren == (U32)ST.me->flags)
5046     {
5047      if (ST.count)
5048       goto fake_end;
5049      else
5050       sayNO;
5051     }
5052    }
5053
5054    PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
5055    /* NOTREACHED */
5056
5057   case CURLYM_B_fail: /* just failed to match a B */
5058    REGCP_UNWIND(ST.cp);
5059    if (ST.minmod) {
5060     I32 max = ARG2(ST.me);
5061     if (max != REG_INFTY && ST.count == max)
5062      sayNO;
5063     goto curlym_do_A; /* try to match a further A */
5064    }
5065    /* backtrack one A */
5066    if (ST.count == ARG1(ST.me) /* min */)
5067     sayNO;
5068    ST.count--;
5069    locinput = HOPc(locinput, -ST.alen);
5070    goto curlym_do_B; /* try to match B */
5071
5072 #undef ST
5073 #define ST st->u.curly
5074
5075 #define CURLY_SETPAREN(paren, success) \
5076  if (paren) { \
5077   if (success) { \
5078    PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
5079    PL_regoffs[paren].end = locinput - PL_bostr; \
5080    *PL_reglastcloseparen = paren; \
5081   } \
5082   else \
5083    PL_regoffs[paren].end = -1; \
5084  }
5085
5086   case STAR:  /*  /A*B/ where A is width 1 */
5087    ST.paren = 0;
5088    ST.min = 0;
5089    ST.max = REG_INFTY;
5090    scan = NEXTOPER(scan);
5091    goto repeat;
5092   case PLUS:  /*  /A+B/ where A is width 1 */
5093    ST.paren = 0;
5094    ST.min = 1;
5095    ST.max = REG_INFTY;
5096    scan = NEXTOPER(scan);
5097    goto repeat;
5098   case CURLYN:  /*  /(A){m,n}B/ where A is width 1 */
5099    ST.paren = scan->flags; /* Which paren to set */
5100    if (ST.paren > PL_regsize)
5101     PL_regsize = ST.paren;
5102    if (ST.paren > *PL_reglastparen)
5103     *PL_reglastparen = ST.paren;
5104    ST.min = ARG1(scan);  /* min to match */
5105    ST.max = ARG2(scan);  /* max to match */
5106    if (cur_eval && cur_eval->u.eval.close_paren &&
5107     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5108     ST.min=1;
5109     ST.max=1;
5110    }
5111    scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
5112    goto repeat;
5113   case CURLY:  /*  /A{m,n}B/ where A is width 1 */
5114    ST.paren = 0;
5115    ST.min = ARG1(scan);  /* min to match */
5116    ST.max = ARG2(scan);  /* max to match */
5117    scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
5118   repeat:
5119    /*
5120    * Lookahead to avoid useless match attempts
5121    * when we know what character comes next.
5122    *
5123    * Used to only do .*x and .*?x, but now it allows
5124    * for )'s, ('s and (?{ ... })'s to be in the way
5125    * of the quantifier and the EXACT-like node.  -- japhy
5126    */
5127
5128    if (ST.min > ST.max) /* XXX make this a compile-time check? */
5129     sayNO;
5130    if (HAS_TEXT(next) || JUMPABLE(next)) {
5131     U8 *s;
5132     regnode *text_node = next;
5133
5134     if (! HAS_TEXT(text_node))
5135      FIND_NEXT_IMPT(text_node);
5136
5137     if (! HAS_TEXT(text_node))
5138      ST.c1 = ST.c2 = CHRTEST_VOID;
5139     else {
5140      if ( PL_regkind[OP(text_node)] != EXACT ) {
5141       ST.c1 = ST.c2 = CHRTEST_VOID;
5142       goto assume_ok_easy;
5143      }
5144      else
5145       s = (U8*)STRING(text_node);
5146
5147      /*  Currently we only get here when
5148
5149       PL_rekind[OP(text_node)] == EXACT
5150
5151       if this changes back then the macro for IS_TEXT and
5152       friends need to change. */
5153      if (!UTF_PATTERN) {
5154       ST.c1 = *s;
5155       switch (OP(text_node)) {
5156        case EXACTF: ST.c2 = PL_fold[ST.c1]; break;
5157        case EXACTFA:
5158        case EXACTFU: ST.c2 = PL_fold_latin1[ST.c1]; break;
5159        case EXACTFL: ST.c2 = PL_fold_locale[ST.c1]; break;
5160        default: ST.c2 = ST.c1; break;
5161       }
5162      }
5163      else { /* UTF_PATTERN */
5164       if (IS_TEXTFU(text_node) || IS_TEXTF(text_node)) {
5165        STRLEN ulen1, ulen2;
5166        U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
5167        U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
5168
5169        to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
5170        to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
5171 #ifdef EBCDIC
5172        ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
5173              ckWARN(WARN_UTF8) ?
5174              0 : UTF8_ALLOW_ANY);
5175        ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
5176              ckWARN(WARN_UTF8) ?
5177              0 : UTF8_ALLOW_ANY);
5178 #else
5179        ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
5180              uniflags);
5181        ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
5182              uniflags);
5183 #endif
5184       }
5185       else {
5186        ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
5187              uniflags);
5188       }
5189      }
5190     }
5191    }
5192    else
5193     ST.c1 = ST.c2 = CHRTEST_VOID;
5194   assume_ok_easy:
5195
5196    ST.A = scan;
5197    ST.B = next;
5198    PL_reginput = locinput;
5199    if (minmod) {
5200     minmod = 0;
5201     if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
5202      sayNO;
5203     ST.count = ST.min;
5204     locinput = PL_reginput;
5205     REGCP_SET(ST.cp);
5206     if (ST.c1 == CHRTEST_VOID)
5207      goto curly_try_B_min;
5208
5209     ST.oldloc = locinput;
5210
5211     /* set ST.maxpos to the furthest point along the
5212     * string that could possibly match */
5213     if  (ST.max == REG_INFTY) {
5214      ST.maxpos = PL_regeol - 1;
5215      if (utf8_target)
5216       while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
5217        ST.maxpos--;
5218     }
5219     else if (utf8_target) {
5220      int m = ST.max - ST.min;
5221      for (ST.maxpos = locinput;
5222       m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
5223       ST.maxpos += UTF8SKIP(ST.maxpos);
5224     }
5225     else {
5226      ST.maxpos = locinput + ST.max - ST.min;
5227      if (ST.maxpos >= PL_regeol)
5228       ST.maxpos = PL_regeol - 1;
5229     }
5230     goto curly_try_B_min_known;
5231
5232    }
5233    else {
5234     ST.count = regrepeat(rex, ST.A, ST.max, depth);
5235     locinput = PL_reginput;
5236     if (ST.count < ST.min)
5237      sayNO;
5238     if ((ST.count > ST.min)
5239      && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
5240     {
5241      /* A{m,n} must come at the end of the string, there's
5242      * no point in backing off ... */
5243      ST.min = ST.count;
5244      /* ...except that $ and \Z can match before *and* after
5245      newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
5246      We may back off by one in this case. */
5247      if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
5248       ST.min--;
5249     }
5250     REGCP_SET(ST.cp);
5251     goto curly_try_B_max;
5252    }
5253    /* NOTREACHED */
5254
5255
5256   case CURLY_B_min_known_fail:
5257    /* failed to find B in a non-greedy match where c1,c2 valid */
5258    if (ST.paren && ST.count)
5259     PL_regoffs[ST.paren].end = -1;
5260
5261    PL_reginput = locinput; /* Could be reset... */
5262    REGCP_UNWIND(ST.cp);
5263    /* Couldn't or didn't -- move forward. */
5264    ST.oldloc = locinput;
5265    if (utf8_target)
5266     locinput += UTF8SKIP(locinput);
5267    else
5268     locinput++;
5269    ST.count++;
5270   curly_try_B_min_known:
5271    /* find the next place where 'B' could work, then call B */
5272    {
5273     int n;
5274     if (utf8_target) {
5275      n = (ST.oldloc == locinput) ? 0 : 1;
5276      if (ST.c1 == ST.c2) {
5277       STRLEN len;
5278       /* set n to utf8_distance(oldloc, locinput) */
5279       while (locinput <= ST.maxpos &&
5280        utf8n_to_uvchr((U8*)locinput,
5281            UTF8_MAXBYTES, &len,
5282            uniflags) != (UV)ST.c1) {
5283        locinput += len;
5284        n++;
5285       }
5286      }
5287      else {
5288       /* set n to utf8_distance(oldloc, locinput) */
5289       while (locinput <= ST.maxpos) {
5290        STRLEN len;
5291        const UV c = utf8n_to_uvchr((U8*)locinput,
5292             UTF8_MAXBYTES, &len,
5293             uniflags);
5294        if (c == (UV)ST.c1 || c == (UV)ST.c2)
5295         break;
5296        locinput += len;
5297        n++;
5298       }
5299      }
5300     }
5301     else {
5302      if (ST.c1 == ST.c2) {
5303       while (locinput <= ST.maxpos &&
5304        UCHARAT(locinput) != ST.c1)
5305        locinput++;
5306      }
5307      else {
5308       while (locinput <= ST.maxpos
5309        && UCHARAT(locinput) != ST.c1
5310        && UCHARAT(locinput) != ST.c2)
5311        locinput++;
5312      }
5313      n = locinput - ST.oldloc;
5314     }
5315     if (locinput > ST.maxpos)
5316      sayNO;
5317     /* PL_reginput == oldloc now */
5318     if (n) {
5319      ST.count += n;
5320      if (regrepeat(rex, ST.A, n, depth) < n)
5321       sayNO;
5322     }
5323     PL_reginput = locinput;
5324     CURLY_SETPAREN(ST.paren, ST.count);
5325     if (cur_eval && cur_eval->u.eval.close_paren &&
5326      cur_eval->u.eval.close_paren == (U32)ST.paren) {
5327      goto fake_end;
5328     }
5329     PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
5330    }
5331    /* NOTREACHED */
5332
5333
5334   case CURLY_B_min_fail:
5335    /* failed to find B in a non-greedy match where c1,c2 invalid */
5336    if (ST.paren && ST.count)
5337     PL_regoffs[ST.paren].end = -1;
5338
5339    REGCP_UNWIND(ST.cp);
5340    /* failed -- move forward one */
5341    PL_reginput = locinput;
5342    if (regrepeat(rex, ST.A, 1, depth)) {
5343     ST.count++;
5344     locinput = PL_reginput;
5345     if (ST.count <= ST.max || (ST.max == REG_INFTY &&
5346       ST.count > 0)) /* count overflow ? */
5347     {
5348     curly_try_B_min:
5349      CURLY_SETPAREN(ST.paren, ST.count);
5350      if (cur_eval && cur_eval->u.eval.close_paren &&
5351       cur_eval->u.eval.close_paren == (U32)ST.paren) {
5352       goto fake_end;
5353      }
5354      PUSH_STATE_GOTO(CURLY_B_min, ST.B);
5355     }
5356    }
5357    sayNO;
5358    /* NOTREACHED */
5359
5360
5361   curly_try_B_max:
5362    /* a successful greedy match: now try to match B */
5363    if (cur_eval && cur_eval->u.eval.close_paren &&
5364     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5365     goto fake_end;
5366    }
5367    {
5368     UV c = 0;
5369     if (ST.c1 != CHRTEST_VOID)
5370      c = utf8_target ? utf8n_to_uvchr((U8*)PL_reginput,
5371           UTF8_MAXBYTES, 0, uniflags)
5372         : (UV) UCHARAT(PL_reginput);
5373     /* If it could work, try it. */
5374     if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
5375      CURLY_SETPAREN(ST.paren, ST.count);
5376      PUSH_STATE_GOTO(CURLY_B_max, ST.B);
5377      /* NOTREACHED */
5378     }
5379    }
5380    /* FALL THROUGH */
5381   case CURLY_B_max_fail:
5382    /* failed to find B in a greedy match */
5383    if (ST.paren && ST.count)
5384     PL_regoffs[ST.paren].end = -1;
5385
5386    REGCP_UNWIND(ST.cp);
5387    /*  back up. */
5388    if (--ST.count < ST.min)
5389     sayNO;
5390    PL_reginput = locinput = HOPc(locinput, -1);
5391    goto curly_try_B_max;
5392
5393 #undef ST
5394
5395   case END:
5396    fake_end:
5397    if (cur_eval) {
5398     /* we've just finished A in /(??{A})B/; now continue with B */
5399     I32 tmpix;
5400     st->u.eval.toggle_reg_flags
5401        = cur_eval->u.eval.toggle_reg_flags;
5402     PL_reg_flags ^= st->u.eval.toggle_reg_flags;
5403
5404     st->u.eval.prev_rex = rex_sv;  /* inner */
5405     SETREX(rex_sv,cur_eval->u.eval.prev_rex);
5406     rex = (struct regexp *)SvANY(rex_sv);
5407     rexi = RXi_GET(rex);
5408     cur_curlyx = cur_eval->u.eval.prev_curlyx;
5409     (void)ReREFCNT_inc(rex_sv);
5410     st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
5411
5412     /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
5413     PL_reglastparen = &rex->lastparen;
5414     PL_reglastcloseparen = &rex->lastcloseparen;
5415
5416     REGCP_SET(st->u.eval.lastcp);
5417     PL_reginput = locinput;
5418
5419     /* Restore parens of the outer rex without popping the
5420     * savestack */
5421     tmpix = PL_savestack_ix;
5422     PL_savestack_ix = cur_eval->u.eval.lastcp;
5423     regcppop(rex);
5424     PL_savestack_ix = tmpix;
5425
5426     st->u.eval.prev_eval = cur_eval;
5427     cur_eval = cur_eval->u.eval.prev_eval;
5428     DEBUG_EXECUTE_r(
5429      PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ... %"UVxf"\n",
5430          REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
5431     if ( nochange_depth )
5432      nochange_depth--;
5433
5434     PUSH_YES_STATE_GOTO(EVAL_AB,
5435       st->u.eval.prev_eval->u.eval.B); /* match B */
5436    }
5437
5438    if (locinput < reginfo->till) {
5439     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5440          "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
5441          PL_colors[4],
5442          (long)(locinput - PL_reg_starttry),
5443          (long)(reginfo->till - PL_reg_starttry),
5444          PL_colors[5]));
5445
5446     sayNO_SILENT;  /* Cannot match: too short. */
5447    }
5448    PL_reginput = locinput; /* put where regtry can find it */
5449    sayYES;   /* Success! */
5450
5451   case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
5452    DEBUG_EXECUTE_r(
5453    PerlIO_printf(Perl_debug_log,
5454     "%*s  %ssubpattern success...%s\n",
5455     REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
5456    PL_reginput = locinput; /* put where regtry can find it */
5457    sayYES;   /* Success! */
5458
5459 #undef  ST
5460 #define ST st->u.ifmatch
5461
5462   case SUSPEND: /* (?>A) */
5463    ST.wanted = 1;
5464    PL_reginput = locinput;
5465    goto do_ifmatch;
5466
5467   case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
5468    ST.wanted = 0;
5469    goto ifmatch_trivial_fail_test;
5470
5471   case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
5472    ST.wanted = 1;
5473   ifmatch_trivial_fail_test:
5474    if (scan->flags) {
5475     char * const s = HOPBACKc(locinput, scan->flags);
5476     if (!s) {
5477      /* trivial fail */
5478      if (logical) {
5479       logical = 0;
5480       sw = 1 - cBOOL(ST.wanted);
5481      }
5482      else if (ST.wanted)
5483       sayNO;
5484      next = scan + ARG(scan);
5485      if (next == scan)
5486       next = NULL;
5487      break;
5488     }
5489     PL_reginput = s;
5490    }
5491    else
5492     PL_reginput = locinput;
5493
5494   do_ifmatch:
5495    ST.me = scan;
5496    ST.logical = logical;
5497    logical = 0; /* XXX: reset state of logical once it has been saved into ST */
5498
5499    /* execute body of (?...A) */
5500    PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
5501    /* NOTREACHED */
5502
5503   case IFMATCH_A_fail: /* body of (?...A) failed */
5504    ST.wanted = !ST.wanted;
5505    /* FALL THROUGH */
5506
5507   case IFMATCH_A: /* body of (?...A) succeeded */
5508    if (ST.logical) {
5509     sw = cBOOL(ST.wanted);
5510    }
5511    else if (!ST.wanted)
5512     sayNO;
5513
5514    if (OP(ST.me) == SUSPEND)
5515     locinput = PL_reginput;
5516    else {
5517     locinput = PL_reginput = st->locinput;
5518     nextchr = UCHARAT(locinput);
5519    }
5520    scan = ST.me + ARG(ST.me);
5521    if (scan == ST.me)
5522     scan = NULL;
5523    continue; /* execute B */
5524
5525 #undef ST
5526
5527   case LONGJMP:
5528    next = scan + ARG(scan);
5529    if (next == scan)
5530     next = NULL;
5531    break;
5532   case COMMIT:
5533    reginfo->cutpoint = PL_regeol;
5534    /* FALLTHROUGH */
5535   case PRUNE:
5536    PL_reginput = locinput;
5537    if (!scan->flags)
5538     sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5539    PUSH_STATE_GOTO(COMMIT_next,next);
5540    /* NOTREACHED */
5541   case COMMIT_next_fail:
5542    no_final = 1;
5543    /* FALLTHROUGH */
5544   case OPFAIL:
5545    sayNO;
5546    /* NOTREACHED */
5547
5548 #define ST st->u.mark
5549   case MARKPOINT:
5550    ST.prev_mark = mark_state;
5551    ST.mark_name = sv_commit = sv_yes_mark
5552     = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5553    mark_state = st;
5554    ST.mark_loc = PL_reginput = locinput;
5555    PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5556    /* NOTREACHED */
5557   case MARKPOINT_next:
5558    mark_state = ST.prev_mark;
5559    sayYES;
5560    /* NOTREACHED */
5561   case MARKPOINT_next_fail:
5562    if (popmark && sv_eq(ST.mark_name,popmark))
5563    {
5564     if (ST.mark_loc > startpoint)
5565      reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5566     popmark = NULL; /* we found our mark */
5567     sv_commit = ST.mark_name;
5568
5569     DEBUG_EXECUTE_r({
5570       PerlIO_printf(Perl_debug_log,
5571        "%*s  %ssetting cutpoint to mark:%"SVf"...%s\n",
5572        REPORT_CODE_OFF+depth*2, "",
5573        PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
5574     });
5575    }
5576    mark_state = ST.prev_mark;
5577    sv_yes_mark = mark_state ?
5578     mark_state->u.mark.mark_name : NULL;
5579    sayNO;
5580    /* NOTREACHED */
5581   case SKIP:
5582    PL_reginput = locinput;
5583    if (scan->flags) {
5584     /* (*SKIP) : if we fail we cut here*/
5585     ST.mark_name = NULL;
5586     ST.mark_loc = locinput;
5587     PUSH_STATE_GOTO(SKIP_next,next);
5588    } else {
5589     /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5590     otherwise do nothing.  Meaning we need to scan
5591     */
5592     regmatch_state *cur = mark_state;
5593     SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5594
5595     while (cur) {
5596      if ( sv_eq( cur->u.mark.mark_name,
5597         find ) )
5598      {
5599       ST.mark_name = find;
5600       PUSH_STATE_GOTO( SKIP_next, next );
5601      }
5602      cur = cur->u.mark.prev_mark;
5603     }
5604    }
5605    /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5606    break;
5607   case SKIP_next_fail:
5608    if (ST.mark_name) {
5609     /* (*CUT:NAME) - Set up to search for the name as we
5610     collapse the stack*/
5611     popmark = ST.mark_name;
5612    } else {
5613     /* (*CUT) - No name, we cut here.*/
5614     if (ST.mark_loc > startpoint)
5615      reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5616     /* but we set sv_commit to latest mark_name if there
5617     is one so they can test to see how things lead to this
5618     cut */
5619     if (mark_state)
5620      sv_commit=mark_state->u.mark.mark_name;
5621    }
5622    no_final = 1;
5623    sayNO;
5624    /* NOTREACHED */
5625 #undef ST
5626   case FOLDCHAR:
5627    n = ARG(scan);
5628    if ( n == (U32)what_len_TRICKYFOLD(locinput,utf8_target,ln) ) {
5629     locinput += ln;
5630    } else if ( LATIN_SMALL_LETTER_SHARP_S == n && !utf8_target && !UTF_PATTERN ) {
5631     sayNO;
5632    } else  {
5633     U8 folded[UTF8_MAXBYTES_CASE+1];
5634     STRLEN foldlen;
5635     const char * const l = locinput;
5636     char *e = PL_regeol;
5637     to_uni_fold(n, folded, &foldlen);
5638
5639     if (! foldEQ_utf8((const char*) folded, 0,  foldlen, 1,
5640        l, &e, 0,  utf8_target)) {
5641       sayNO;
5642     }
5643     locinput = e;
5644    }
5645    nextchr = UCHARAT(locinput);
5646    break;
5647   case LNBREAK:
5648    if ((n=is_LNBREAK(locinput,utf8_target))) {
5649     locinput += n;
5650     nextchr = UCHARAT(locinput);
5651    } else
5652     sayNO;
5653    break;
5654
5655 #define CASE_CLASS(nAmE)                              \
5656   case nAmE:                                    \
5657    if ((n=is_##nAmE(locinput,utf8_target))) {    \
5658     locinput += n;                        \
5659     nextchr = UCHARAT(locinput);          \
5660    } else                                    \
5661     sayNO;                                \
5662    break;                                    \
5663   case N##nAmE:                                 \
5664    if ((n=is_##nAmE(locinput,utf8_target))) {    \
5665     sayNO;                                \
5666    } else {                                  \
5667     locinput += UTF8SKIP(locinput);       \
5668     nextchr = UCHARAT(locinput);          \
5669    }                                         \
5670    break
5671
5672   CASE_CLASS(VERTWS);
5673   CASE_CLASS(HORIZWS);
5674 #undef CASE_CLASS
5675
5676   default:
5677    PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5678       PTR2UV(scan), OP(scan));
5679    Perl_croak(aTHX_ "regexp memory corruption");
5680
5681   } /* end switch */
5682
5683   /* switch break jumps here */
5684   scan = next; /* prepare to execute the next op and ... */
5685   continue;    /* ... jump back to the top, reusing st */
5686   /* NOTREACHED */
5687
5688  push_yes_state:
5689   /* push a state that backtracks on success */
5690   st->u.yes.prev_yes_state = yes_state;
5691   yes_state = st;
5692   /* FALL THROUGH */
5693  push_state:
5694   /* push a new regex state, then continue at scan  */
5695   {
5696    regmatch_state *newst;
5697
5698    DEBUG_STACK_r({
5699     regmatch_state *cur = st;
5700     regmatch_state *curyes = yes_state;
5701     int curd = depth;
5702     regmatch_slab *slab = PL_regmatch_slab;
5703     for (;curd > -1;cur--,curd--) {
5704      if (cur < SLAB_FIRST(slab)) {
5705       slab = slab->prev;
5706       cur = SLAB_LAST(slab);
5707      }
5708      PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5709       REPORT_CODE_OFF + 2 + depth * 2,"",
5710       curd, PL_reg_name[cur->resume_state],
5711       (curyes == cur) ? "yes" : ""
5712      );
5713      if (curyes == cur)
5714       curyes = cur->u.yes.prev_yes_state;
5715     }
5716    } else
5717     DEBUG_STATE_pp("push")
5718    );
5719    depth++;
5720    st->locinput = locinput;
5721    newst = st+1;
5722    if (newst >  SLAB_LAST(PL_regmatch_slab))
5723     newst = S_push_slab(aTHX);
5724    PL_regmatch_state = newst;
5725
5726    locinput = PL_reginput;
5727    nextchr = UCHARAT(locinput);
5728    st = newst;
5729    continue;
5730    /* NOTREACHED */
5731   }
5732  }
5733
5734  /*
5735  * We get here only if there's trouble -- normally "case END" is
5736  * the terminating point.
5737  */
5738  Perl_croak(aTHX_ "corrupted regexp pointers");
5739  /*NOTREACHED*/
5740  sayNO;
5741
5742 yes:
5743  if (yes_state) {
5744   /* we have successfully completed a subexpression, but we must now
5745   * pop to the state marked by yes_state and continue from there */
5746   assert(st != yes_state);
5747 #ifdef DEBUGGING
5748   while (st != yes_state) {
5749    st--;
5750    if (st < SLAB_FIRST(PL_regmatch_slab)) {
5751     PL_regmatch_slab = PL_regmatch_slab->prev;
5752     st = SLAB_LAST(PL_regmatch_slab);
5753    }
5754    DEBUG_STATE_r({
5755     if (no_final) {
5756      DEBUG_STATE_pp("pop (no final)");
5757     } else {
5758      DEBUG_STATE_pp("pop (yes)");
5759     }
5760    });
5761    depth--;
5762   }
5763 #else
5764   while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5765    || yes_state > SLAB_LAST(PL_regmatch_slab))
5766   {
5767    /* not in this slab, pop slab */
5768    depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5769    PL_regmatch_slab = PL_regmatch_slab->prev;
5770    st = SLAB_LAST(PL_regmatch_slab);
5771   }
5772   depth -= (st - yes_state);
5773 #endif
5774   st = yes_state;
5775   yes_state = st->u.yes.prev_yes_state;
5776   PL_regmatch_state = st;
5777
5778   if (no_final) {
5779    locinput= st->locinput;
5780    nextchr = UCHARAT(locinput);
5781   }
5782   state_num = st->resume_state + no_final;
5783   goto reenter_switch;
5784  }
5785
5786  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5787       PL_colors[4], PL_colors[5]));
5788
5789  if (PL_reg_eval_set) {
5790   /* each successfully executed (?{...}) block does the equivalent of
5791   *   local $^R = do {...}
5792   * When popping the save stack, all these locals would be undone;
5793   * bypass this by setting the outermost saved $^R to the latest
5794   * value */
5795   if (oreplsv != GvSV(PL_replgv))
5796    sv_setsv(oreplsv, GvSV(PL_replgv));
5797  }
5798  result = 1;
5799  goto final_exit;
5800
5801 no:
5802  DEBUG_EXECUTE_r(
5803   PerlIO_printf(Perl_debug_log,
5804    "%*s  %sfailed...%s\n",
5805    REPORT_CODE_OFF+depth*2, "",
5806    PL_colors[4], PL_colors[5])
5807   );
5808
5809 no_silent:
5810  if (no_final) {
5811   if (yes_state) {
5812    goto yes;
5813   } else {
5814    goto final_exit;
5815   }
5816  }
5817  if (depth) {
5818   /* there's a previous state to backtrack to */
5819   st--;
5820   if (st < SLAB_FIRST(PL_regmatch_slab)) {
5821    PL_regmatch_slab = PL_regmatch_slab->prev;
5822    st = SLAB_LAST(PL_regmatch_slab);
5823   }
5824   PL_regmatch_state = st;
5825   locinput= st->locinput;
5826   nextchr = UCHARAT(locinput);
5827
5828   DEBUG_STATE_pp("pop");
5829   depth--;
5830   if (yes_state == st)
5831    yes_state = st->u.yes.prev_yes_state;
5832
5833   state_num = st->resume_state + 1; /* failure = success + 1 */
5834   goto reenter_switch;
5835  }
5836  result = 0;
5837
5838   final_exit:
5839  if (rex->intflags & PREGf_VERBARG_SEEN) {
5840   SV *sv_err = get_sv("REGERROR", 1);
5841   SV *sv_mrk = get_sv("REGMARK", 1);
5842   if (result) {
5843    sv_commit = &PL_sv_no;
5844    if (!sv_yes_mark)
5845     sv_yes_mark = &PL_sv_yes;
5846   } else {
5847    if (!sv_commit)
5848     sv_commit = &PL_sv_yes;
5849    sv_yes_mark = &PL_sv_no;
5850   }
5851   sv_setsv(sv_err, sv_commit);
5852   sv_setsv(sv_mrk, sv_yes_mark);
5853  }
5854
5855  /* clean up; in particular, free all slabs above current one */
5856  LEAVE_SCOPE(oldsave);
5857
5858  return result;
5859 }
5860
5861 /*
5862  - regrepeat - repeatedly match something simple, report how many
5863  */
5864 /*
5865  * [This routine now assumes that it will only match on things of length 1.
5866  * That was true before, but now we assume scan - reginput is the count,
5867  * rather than incrementing count on every character.  [Er, except utf8.]]
5868  */
5869 STATIC I32
5870 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5871 {
5872  dVAR;
5873  register char *scan;
5874  register I32 c;
5875  register char *loceol = PL_regeol;
5876  register I32 hardcount = 0;
5877  register bool utf8_target = PL_reg_match_utf8;
5878  UV utf8_flags;
5879 #ifndef DEBUGGING
5880  PERL_UNUSED_ARG(depth);
5881 #endif
5882
5883  PERL_ARGS_ASSERT_REGREPEAT;
5884
5885  scan = PL_reginput;
5886  if (max == REG_INFTY)
5887   max = I32_MAX;
5888  else if (max < loceol - scan)
5889   loceol = scan + max;
5890  switch (OP(p)) {
5891  case REG_ANY:
5892   if (utf8_target) {
5893    loceol = PL_regeol;
5894    while (scan < loceol && hardcount < max && *scan != '\n') {
5895     scan += UTF8SKIP(scan);
5896     hardcount++;
5897    }
5898   } else {
5899    while (scan < loceol && *scan != '\n')
5900     scan++;
5901   }
5902   break;
5903  case SANY:
5904   if (utf8_target) {
5905    loceol = PL_regeol;
5906    while (scan < loceol && hardcount < max) {
5907     scan += UTF8SKIP(scan);
5908     hardcount++;
5909    }
5910   }
5911   else
5912    scan = loceol;
5913   break;
5914  case CANY:
5915   scan = loceol;
5916   break;
5917  case EXACT:
5918   /* To get here, EXACTish nodes must have *byte* length == 1.  That
5919   * means they match only characters in the string that can be expressed
5920   * as a single byte.  For non-utf8 strings, that means a simple match.
5921   * For utf8 strings, the character matched must be an invariant, or
5922   * downgradable to a single byte.  The pattern's utf8ness is
5923   * irrelevant, as since it's a single byte, it either isn't utf8, or if
5924   * it is, it's an invariant */
5925
5926   c = (U8)*STRING(p);
5927   assert(! UTF_PATTERN || UNI_IS_INVARIANT(c));
5928
5929   if (! utf8_target || UNI_IS_INVARIANT(c)) {
5930    while (scan < loceol && UCHARAT(scan) == c) {
5931     scan++;
5932    }
5933   }
5934   else {
5935
5936    /* Here, the string is utf8, and the pattern char is different
5937    * in utf8 than not, so can't compare them directly.  Outside the
5938    * loop, find find the two utf8 bytes that represent c, and then
5939    * look for those in sequence in the utf8 string */
5940    U8 high = UTF8_TWO_BYTE_HI(c);
5941    U8 low = UTF8_TWO_BYTE_LO(c);
5942    loceol = PL_regeol;
5943
5944    while (hardcount < max
5945      && scan + 1 < loceol
5946      && UCHARAT(scan) == high
5947      && UCHARAT(scan + 1) == low)
5948    {
5949     scan += 2;
5950     hardcount++;
5951    }
5952   }
5953   break;
5954  case EXACTFA:
5955   utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
5956   goto do_exactf;
5957
5958  case EXACTFL:
5959   PL_reg_flags |= RF_tainted;
5960   utf8_flags = FOLDEQ_UTF8_LOCALE;
5961   goto do_exactf;
5962
5963  case EXACTF:
5964  case EXACTFU:
5965   utf8_flags = 0;
5966
5967   /* The comments for the EXACT case above apply as well to these fold
5968   * ones */
5969
5970  do_exactf:
5971   c = (U8)*STRING(p);
5972   assert(! UTF_PATTERN || UNI_IS_INVARIANT(c));
5973
5974   if (utf8_target) { /* Use full Unicode fold matching */
5975    char *tmpeol = loceol;
5976    while (hardcount < max
5977      && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target,
5978         STRING(p), NULL, 1, cBOOL(UTF_PATTERN), utf8_flags))
5979    {
5980     scan = tmpeol;
5981     tmpeol = loceol;
5982     hardcount++;
5983    }
5984
5985    /* XXX Note that the above handles properly the German sharp s in
5986    * the pattern matching ss in the string.  But it doesn't handle
5987    * properly cases where the string contains say 'LIGATURE ff' and
5988    * the pattern is 'f+'.  This would require, say, a new function or
5989    * revised interface to foldEQ_utf8(), in which the maximum number
5990    * of characters to match could be passed and it would return how
5991    * many actually did.  This is just one of many cases where
5992    * multi-char folds don't work properly, and so the fix is being
5993    * deferred */
5994   }
5995   else {
5996    U8 folded;
5997
5998    /* Here, the string isn't utf8 and c is a single byte; and either
5999    * the pattern isn't utf8 or c is an invariant, so its utf8ness
6000    * doesn't affect c.  Can just do simple comparisons for exact or
6001    * fold matching. */
6002    switch (OP(p)) {
6003     case EXACTF: folded = PL_fold[c]; break;
6004     case EXACTFA:
6005     case EXACTFU: folded = PL_fold_latin1[c]; break;
6006     case EXACTFL: folded = PL_fold_locale[c]; break;
6007     default: Perl_croak(aTHX_ "panic: Unexpected op %u", OP(p));
6008    }
6009    while (scan < loceol &&
6010     (UCHARAT(scan) == c || UCHARAT(scan) == folded))
6011    {
6012     scan++;
6013    }
6014   }
6015   break;
6016  case ANYOFV:
6017  case ANYOF:
6018   if (utf8_target || OP(p) == ANYOFV) {
6019    STRLEN inclasslen;
6020    loceol = PL_regeol;
6021    inclasslen = loceol - scan;
6022    while (hardcount < max
6023     && ((inclasslen = loceol - scan) > 0)
6024     && reginclass(prog, p, (U8*)scan, &inclasslen, utf8_target))
6025    {
6026     scan += inclasslen;
6027     hardcount++;
6028    }
6029   } else {
6030    while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
6031     scan++;
6032   }
6033   break;
6034  case ALNUMU:
6035   if (utf8_target) {
6036  utf8_wordchar:
6037    loceol = PL_regeol;
6038    LOAD_UTF8_CHARCLASS_ALNUM();
6039    while (hardcount < max && scan < loceol &&
6040     swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target))
6041    {
6042     scan += UTF8SKIP(scan);
6043     hardcount++;
6044    }
6045   } else {
6046    while (scan < loceol && isWORDCHAR_L1((U8) *scan)) {
6047     scan++;
6048    }
6049   }
6050   break;
6051  case ALNUM:
6052   if (utf8_target)
6053    goto utf8_wordchar;
6054   while (scan < loceol && isALNUM((U8) *scan)) {
6055    scan++;
6056   }
6057   break;
6058  case ALNUMA:
6059   while (scan < loceol && isWORDCHAR_A((U8) *scan)) {
6060    scan++;
6061   }
6062   break;
6063  case ALNUML:
6064   PL_reg_flags |= RF_tainted;
6065   if (utf8_target) {
6066    loceol = PL_regeol;
6067    while (hardcount < max && scan < loceol &&
6068     isALNUM_LC_utf8((U8*)scan)) {
6069     scan += UTF8SKIP(scan);
6070     hardcount++;
6071    }
6072   } else {
6073    while (scan < loceol && isALNUM_LC(*scan))
6074     scan++;
6075   }
6076   break;
6077  case NALNUMU:
6078   if (utf8_target) {
6079
6080  utf8_Nwordchar:
6081
6082    loceol = PL_regeol;
6083    LOAD_UTF8_CHARCLASS_ALNUM();
6084    while (hardcount < max && scan < loceol &&
6085     ! swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target))
6086    {
6087     scan += UTF8SKIP(scan);
6088     hardcount++;
6089    }
6090   } else {
6091    while (scan < loceol && ! isWORDCHAR_L1((U8) *scan)) {
6092     scan++;
6093    }
6094   }
6095   break;
6096  case NALNUM:
6097   if (utf8_target)
6098    goto utf8_Nwordchar;
6099   while (scan < loceol && ! isALNUM((U8) *scan)) {
6100    scan++;
6101   }
6102   break;
6103  case NALNUMA:
6104   if (utf8_target) {
6105    while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) {
6106     scan += UTF8SKIP(scan);
6107    }
6108   }
6109   else {
6110    while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) {
6111     scan++;
6112    }
6113   }
6114   break;
6115  case NALNUML:
6116   PL_reg_flags |= RF_tainted;
6117   if (utf8_target) {
6118    loceol = PL_regeol;
6119    while (hardcount < max && scan < loceol &&
6120     !isALNUM_LC_utf8((U8*)scan)) {
6121     scan += UTF8SKIP(scan);
6122     hardcount++;
6123    }
6124   } else {
6125    while (scan < loceol && !isALNUM_LC(*scan))
6126     scan++;
6127   }
6128   break;
6129  case SPACEU:
6130   if (utf8_target) {
6131
6132  utf8_space:
6133
6134    loceol = PL_regeol;
6135    LOAD_UTF8_CHARCLASS_SPACE();
6136    while (hardcount < max && scan < loceol &&
6137     (*scan == ' ' ||
6138      swash_fetch(PL_utf8_space,(U8*)scan, utf8_target)))
6139    {
6140     scan += UTF8SKIP(scan);
6141     hardcount++;
6142    }
6143    break;
6144   }
6145   else {
6146    while (scan < loceol && isSPACE_L1((U8) *scan)) {
6147     scan++;
6148    }
6149    break;
6150   }
6151  case SPACE:
6152   if (utf8_target)
6153    goto utf8_space;
6154
6155   while (scan < loceol && isSPACE((U8) *scan)) {
6156    scan++;
6157   }
6158   break;
6159  case SPACEA:
6160   while (scan < loceol && isSPACE_A((U8) *scan)) {
6161    scan++;
6162   }
6163   break;
6164  case SPACEL:
6165   PL_reg_flags |= RF_tainted;
6166   if (utf8_target) {
6167    loceol = PL_regeol;
6168    while (hardcount < max && scan < loceol &&
6169     isSPACE_LC_utf8((U8*)scan)) {
6170     scan += UTF8SKIP(scan);
6171     hardcount++;
6172    }
6173   } else {
6174    while (scan < loceol && isSPACE_LC(*scan))
6175     scan++;
6176   }
6177   break;
6178  case NSPACEU:
6179   if (utf8_target) {
6180
6181  utf8_Nspace:
6182
6183    loceol = PL_regeol;
6184    LOAD_UTF8_CHARCLASS_SPACE();
6185    while (hardcount < max && scan < loceol &&
6186     ! (*scan == ' ' ||
6187      swash_fetch(PL_utf8_space,(U8*)scan, utf8_target)))
6188    {
6189     scan += UTF8SKIP(scan);
6190     hardcount++;
6191    }
6192    break;
6193   }
6194   else {
6195    while (scan < loceol && ! isSPACE_L1((U8) *scan)) {
6196     scan++;
6197    }
6198   }
6199   break;
6200  case NSPACE:
6201   if (utf8_target)
6202    goto utf8_Nspace;
6203
6204   while (scan < loceol && ! isSPACE((U8) *scan)) {
6205    scan++;
6206   }
6207   break;
6208  case NSPACEA:
6209   if (utf8_target) {
6210    while (scan < loceol && ! isSPACE_A((U8) *scan)) {
6211     scan += UTF8SKIP(scan);
6212    }
6213   }
6214   else {
6215    while (scan < loceol && ! isSPACE_A((U8) *scan)) {
6216     scan++;
6217    }
6218   }
6219   break;
6220  case NSPACEL:
6221   PL_reg_flags |= RF_tainted;
6222   if (utf8_target) {
6223    loceol = PL_regeol;
6224    while (hardcount < max && scan < loceol &&
6225     !isSPACE_LC_utf8((U8*)scan)) {
6226     scan += UTF8SKIP(scan);
6227     hardcount++;
6228    }
6229   } else {
6230    while (scan < loceol && !isSPACE_LC(*scan))
6231     scan++;
6232   }
6233   break;
6234  case DIGIT:
6235   if (utf8_target) {
6236    loceol = PL_regeol;
6237    LOAD_UTF8_CHARCLASS_DIGIT();
6238    while (hardcount < max && scan < loceol &&
6239     swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
6240     scan += UTF8SKIP(scan);
6241     hardcount++;
6242    }
6243   } else {
6244    while (scan < loceol && isDIGIT(*scan))
6245     scan++;
6246   }
6247   break;
6248  case DIGITA:
6249   while (scan < loceol && isDIGIT_A((U8) *scan)) {
6250    scan++;
6251   }
6252   break;
6253  case DIGITL:
6254   PL_reg_flags |= RF_tainted;
6255   if (utf8_target) {
6256    loceol = PL_regeol;
6257    while (hardcount < max && scan < loceol &&
6258     isDIGIT_LC_utf8((U8*)scan)) {
6259     scan += UTF8SKIP(scan);
6260     hardcount++;
6261    }
6262   } else {
6263    while (scan < loceol && isDIGIT_LC(*scan))
6264     scan++;
6265   }
6266   break;
6267  case NDIGIT:
6268   if (utf8_target) {
6269    loceol = PL_regeol;
6270    LOAD_UTF8_CHARCLASS_DIGIT();
6271    while (hardcount < max && scan < loceol &&
6272     !swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
6273     scan += UTF8SKIP(scan);
6274     hardcount++;
6275    }
6276   } else {
6277    while (scan < loceol && !isDIGIT(*scan))
6278     scan++;
6279   }
6280   break;
6281  case NDIGITA:
6282   if (utf8_target) {
6283    while (scan < loceol && ! isDIGIT_A((U8) *scan)) {
6284     scan += UTF8SKIP(scan);
6285    }
6286   }
6287   else {
6288    while (scan < loceol && ! isDIGIT_A((U8) *scan)) {
6289     scan++;
6290    }
6291   }
6292   break;
6293  case NDIGITL:
6294   PL_reg_flags |= RF_tainted;
6295   if (utf8_target) {
6296    loceol = PL_regeol;
6297    while (hardcount < max && scan < loceol &&
6298     !isDIGIT_LC_utf8((U8*)scan)) {
6299     scan += UTF8SKIP(scan);
6300     hardcount++;
6301    }
6302   } else {
6303    while (scan < loceol && !isDIGIT_LC(*scan))
6304     scan++;
6305   }
6306   break;
6307  case LNBREAK:
6308   if (utf8_target) {
6309    loceol = PL_regeol;
6310    while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
6311     scan += c;
6312     hardcount++;
6313    }
6314   } else {
6315    /*
6316    LNBREAK can match two latin chars, which is ok,
6317    because we have a null terminated string, but we
6318    have to use hardcount in this situation
6319    */
6320    while (scan < loceol && (c=is_LNBREAK_latin1(scan)))  {
6321     scan+=c;
6322     hardcount++;
6323    }
6324   }
6325   break;
6326  case HORIZWS:
6327   if (utf8_target) {
6328    loceol = PL_regeol;
6329    while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
6330     scan += c;
6331     hardcount++;
6332    }
6333   } else {
6334    while (scan < loceol && is_HORIZWS_latin1(scan))
6335     scan++;
6336   }
6337   break;
6338  case NHORIZWS:
6339   if (utf8_target) {
6340    loceol = PL_regeol;
6341    while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
6342     scan += UTF8SKIP(scan);
6343     hardcount++;
6344    }
6345   } else {
6346    while (scan < loceol && !is_HORIZWS_latin1(scan))
6347     scan++;
6348
6349   }
6350   break;
6351  case VERTWS:
6352   if (utf8_target) {
6353    loceol = PL_regeol;
6354    while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
6355     scan += c;
6356     hardcount++;
6357    }
6358   } else {
6359    while (scan < loceol && is_VERTWS_latin1(scan))
6360     scan++;
6361
6362   }
6363   break;
6364  case NVERTWS:
6365   if (utf8_target) {
6366    loceol = PL_regeol;
6367    while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
6368     scan += UTF8SKIP(scan);
6369     hardcount++;
6370    }
6371   } else {
6372    while (scan < loceol && !is_VERTWS_latin1(scan))
6373     scan++;
6374
6375   }
6376   break;
6377
6378  default:  /* Called on something of 0 width. */
6379   break;  /* So match right here or not at all. */
6380  }
6381
6382  if (hardcount)
6383   c = hardcount;
6384  else
6385   c = scan - PL_reginput;
6386  PL_reginput = scan;
6387
6388  DEBUG_r({
6389   GET_RE_DEBUG_FLAGS_DECL;
6390   DEBUG_EXECUTE_r({
6391    SV * const prop = sv_newmortal();
6392    regprop(prog, prop, p);
6393    PerlIO_printf(Perl_debug_log,
6394       "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
6395       REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
6396   });
6397  });
6398
6399  return(c);
6400 }
6401
6402
6403 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
6404 /*
6405 - regclass_swash - prepare the utf8 swash
6406 */
6407
6408 SV *
6409 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
6410 {
6411  dVAR;
6412  SV *sw  = NULL;
6413  SV *si  = NULL;
6414  SV *alt = NULL;
6415  RXi_GET_DECL(prog,progi);
6416  const struct reg_data * const data = prog ? progi->data : NULL;
6417
6418  PERL_ARGS_ASSERT_REGCLASS_SWASH;
6419
6420  assert(ANYOF_NONBITMAP(node));
6421
6422  if (data && data->count) {
6423   const U32 n = ARG(node);
6424
6425   if (data->what[n] == 's') {
6426    SV * const rv = MUTABLE_SV(data->data[n]);
6427    AV * const av = MUTABLE_AV(SvRV(rv));
6428    SV **const ary = AvARRAY(av);
6429    SV **a, **b;
6430
6431    /* See the end of regcomp.c:S_regclass() for
6432    * documentation of these array elements. */
6433
6434    si = *ary;
6435    a  = SvROK(ary[1]) ? &ary[1] : NULL;
6436    b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
6437
6438    if (a)
6439     sw = *a;
6440    else if (si && doinit) {
6441     sw = swash_init("utf8", "", si, 1, 0);
6442     (void)av_store(av, 1, sw);
6443    }
6444    if (b)
6445     alt = *b;
6446   }
6447  }
6448
6449  if (listsvp)
6450   *listsvp = si;
6451  if (altsvp)
6452   *altsvp  = alt;
6453
6454  return sw;
6455 }
6456 #endif
6457
6458 /*
6459  - reginclass - determine if a character falls into a character class
6460
6461   n is the ANYOF regnode
6462   p is the target string
6463   lenp is pointer to the maximum number of bytes of how far to go in p
6464  (This is assumed wthout checking to always be at least the current
6465  character's size)
6466   utf8_target tells whether p is in UTF-8.
6467
6468   Returns true if matched; false otherwise.  If lenp is not NULL, on return
6469   from a successful match, the value it points to will be updated to how many
6470   bytes in p were matched.  If there was no match, the value is undefined,
6471   possibly changed from the input.
6472
6473   Note that this can be a synthetic start class, a combination of various
6474   nodes, so things you think might be mutually exclusive, such as locale,
6475   aren't.  It can match both locale and non-locale
6476
6477  */
6478
6479 STATIC bool
6480 S_reginclass(pTHX_ const regexp * const prog, register const regnode * const n, register const U8* const p, STRLEN* lenp, register const bool utf8_target)
6481 {
6482  dVAR;
6483  const char flags = ANYOF_FLAGS(n);
6484  bool match = FALSE;
6485  UV c = *p;
6486  STRLEN c_len = 0;
6487  STRLEN maxlen;
6488
6489  PERL_ARGS_ASSERT_REGINCLASS;
6490
6491  /* If c is not already the code point, get it */
6492  if (utf8_target && !UTF8_IS_INVARIANT(c)) {
6493   c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &c_len,
6494     (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
6495     | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
6496     /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
6497     * UTF8_ALLOW_FFFF */
6498   if (c_len == (STRLEN)-1)
6499    Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
6500  }
6501  else {
6502   c_len = 1;
6503  }
6504
6505  /* Use passed in max length, or one character if none passed in or less
6506  * than one character.  And assume will match just one character.  This is
6507  * overwritten later if matched more. */
6508  if (lenp) {
6509   maxlen = (*lenp > c_len) ? *lenp : c_len;
6510   *lenp = c_len;
6511
6512  }
6513  else {
6514   maxlen = c_len;
6515  }
6516
6517  /* If this character is potentially in the bitmap, check it */
6518  if (c < 256) {
6519   if (ANYOF_BITMAP_TEST(n, c))
6520    match = TRUE;
6521   else if (flags & ANYOF_NON_UTF8_LATIN1_ALL
6522     && ! utf8_target
6523     && ! isASCII(c))
6524   {
6525    match = TRUE;
6526   }
6527
6528   else if (flags & ANYOF_LOCALE) {
6529    PL_reg_flags |= RF_tainted;
6530
6531    if ((flags & ANYOF_LOC_NONBITMAP_FOLD)
6532     && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
6533    {
6534     match = TRUE;
6535    }
6536    else if (ANYOF_CLASS_TEST_ANY_SET(n) &&
6537      ((ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
6538      (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
6539      (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
6540      (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
6541      (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
6542      (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
6543      (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
6544      (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
6545      (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
6546      (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
6547      (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
6548      (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
6549      (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
6550      (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
6551      (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
6552      (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
6553      (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
6554      (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
6555      (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
6556      (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
6557      (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
6558      (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
6559      (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
6560      (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
6561      (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
6562      (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
6563      (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
6564      (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
6565      (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
6566      (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
6567      ) /* How's that for a conditional? */
6568    ) {
6569     match = TRUE;
6570    }
6571   }
6572  }
6573
6574  /* If the bitmap didn't (or couldn't) match, and something outside the
6575  * bitmap could match, try that.  Locale nodes specifiy completely the
6576  * behavior of code points in the bit map (otherwise, a utf8 target would
6577  * cause them to be treated as Unicode and not locale), except in
6578  * the very unlikely event when this node is a synthetic start class, which
6579  * could be a combination of locale and non-locale nodes.  So allow locale
6580  * to match for the synthetic start class, which will give a false
6581  * positive that will be resolved when the match is done again as not part
6582  * of the synthetic start class */
6583  if (!match) {
6584   if (utf8_target && (flags & ANYOF_UNICODE_ALL) && c >= 256) {
6585    match = TRUE; /* Everything above 255 matches */
6586   }
6587   else if (ANYOF_NONBITMAP(n)
6588     && ((flags & ANYOF_NONBITMAP_NON_UTF8)
6589      || (utf8_target
6590       && (c >=256
6591        || (! (flags & ANYOF_LOCALE))
6592        || (flags & ANYOF_IS_SYNTHETIC)))))
6593   {
6594    AV *av;
6595    SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
6596
6597    if (sw) {
6598     U8 * utf8_p;
6599     if (utf8_target) {
6600      utf8_p = (U8 *) p;
6601     } else {
6602
6603      /* Not utf8.  Convert as much of the string as available up
6604      * to the limit of how far the (single) character in the
6605      * pattern can possibly match (no need to go further).  If
6606      * the node is a straight ANYOF or not folding, it can't
6607      * match more than one.  Otherwise, It can match up to how
6608      * far a single char can fold to.  Since not utf8, each
6609      * character is a single byte, so the max it can be in
6610      * bytes is the same as the max it can be in characters */
6611      STRLEN len = (OP(n) == ANYOF
6612         || ! (flags & ANYOF_LOC_NONBITMAP_FOLD))
6613         ? 1
6614         : (maxlen < UTF8_MAX_FOLD_CHAR_EXPAND)
6615          ? maxlen
6616          : UTF8_MAX_FOLD_CHAR_EXPAND;
6617      utf8_p = bytes_to_utf8(p, &len);
6618     }
6619
6620     if (swash_fetch(sw, utf8_p, TRUE))
6621      match = TRUE;
6622     else if (flags & ANYOF_LOC_NONBITMAP_FOLD) {
6623
6624      /* Here, we need to test if the fold of the target string
6625      * matches.  The non-multi char folds have all been moved to
6626      * the compilation phase, and the multi-char folds have
6627      * been stored by regcomp into 'av'; we linearly check to
6628      * see if any match the target string (folded).   We know
6629      * that the originals were each one character, but we don't
6630      * currently know how many characters/bytes each folded to,
6631      * except we do know that there are small limits imposed by
6632      * Unicode.  XXX A performance enhancement would be to have
6633      * regcomp.c store the max number of chars/bytes that are
6634      * in an av entry, as, say the 0th element.  Even better
6635      * would be to have a hash of the few characters that can
6636      * start a multi-char fold to the max number of chars of
6637      * those folds.
6638      *
6639      * If there is a match, we will need to advance (if lenp is
6640      * specified) the match pointer in the target string.  But
6641      * what we are comparing here isn't that string directly,
6642      * but its fold, whose length may differ from the original.
6643      * As we go along in constructing the fold, therefore, we
6644      * create a map so that we know how many bytes in the
6645      * source to advance given that we have matched a certain
6646      * number of bytes in the fold.  This map is stored in
6647      * 'map_fold_len_back'.  Let n mean the number of bytes in
6648      * the fold of the first character that we are folding.
6649      * Then map_fold_len_back[n] is set to the number of bytes
6650      * in that first character.  Similarly let m be the
6651      * corresponding number for the second character to be
6652      * folded.  Then map_fold_len_back[n+m] is set to the
6653      * number of bytes occupied by the first two source
6654      * characters. ... */
6655      U8 map_fold_len_back[UTF8_MAXBYTES_CASE+1] = { 0 };
6656      U8 folded[UTF8_MAXBYTES_CASE+1];
6657      STRLEN foldlen = 0; /* num bytes in fold of 1st char */
6658      STRLEN total_foldlen = 0; /* num bytes in fold of all
6659             chars */
6660
6661      if (OP(n) == ANYOF || maxlen == 1 || ! lenp || ! av) {
6662
6663       /* Here, only need to fold the first char of the target
6664       * string.  It the source wasn't utf8, is 1 byte long */
6665       to_utf8_fold(utf8_p, folded, &foldlen);
6666       total_foldlen = foldlen;
6667       map_fold_len_back[foldlen] = (utf8_target)
6668              ? UTF8SKIP(utf8_p)
6669              : 1;
6670      }
6671      else {
6672
6673       /* Here, need to fold more than the first char.  Do so
6674       * up to the limits */
6675       U8* source_ptr = utf8_p;    /* The source for the fold
6676              is the regex target
6677              string */
6678       U8* folded_ptr = folded;
6679       U8* e = utf8_p + maxlen;    /* Can't go beyond last
6680              available byte in the
6681              target string */
6682       U8 i;
6683       for (i = 0;
6684        i < UTF8_MAX_FOLD_CHAR_EXPAND && source_ptr < e;
6685        i++)
6686       {
6687
6688        /* Fold the next character */
6689        U8 this_char_folded[UTF8_MAXBYTES_CASE+1];
6690        STRLEN this_char_foldlen;
6691        to_utf8_fold(source_ptr,
6692           this_char_folded,
6693           &this_char_foldlen);
6694
6695        /* Bail if it would exceed the byte limit for
6696        * folding a single char. */
6697        if (this_char_foldlen + folded_ptr - folded >
6698                UTF8_MAXBYTES_CASE)
6699        {
6700         break;
6701        }
6702
6703        /* Add the fold of this character */
6704        Copy(this_char_folded,
6705         folded_ptr,
6706         this_char_foldlen,
6707         U8);
6708        source_ptr += UTF8SKIP(source_ptr);
6709        folded_ptr += this_char_foldlen;
6710        total_foldlen = folded_ptr - folded;
6711
6712        /* Create map from the number of bytes in the fold
6713        * back to the number of bytes in the source.  If
6714        * the source isn't utf8, the byte count is just
6715        * the number of characters so far */
6716        map_fold_len_back[total_foldlen]
6717              = (utf8_target)
6718               ? source_ptr - utf8_p
6719               : i + 1;
6720       }
6721       *folded_ptr = '\0';
6722      }
6723
6724
6725      /* Do the linear search to see if the fold is in the list
6726      * of multi-char folds. */
6727      if (av) {
6728       I32 i;
6729       for (i = 0; i <= av_len(av); i++) {
6730        SV* const sv = *av_fetch(av, i, FALSE);
6731        STRLEN len;
6732        const char * const s = SvPV_const(sv, len);
6733
6734        if (len <= total_foldlen && memEQ(s,
6735                (char*)folded,
6736                len))
6737        {
6738
6739         /* Advance the target string ptr to account for
6740         * this fold, but have to translate from the
6741         * folded length to the corresponding source
6742         * length. */
6743         if (lenp) {
6744          *lenp = map_fold_len_back[len];
6745          assert(*lenp != 0); /* Otherwise will loop */
6746         }
6747         match = TRUE;
6748         break;
6749        }
6750       }
6751      }
6752     }
6753
6754     /* If we allocated a string above, free it */
6755     if (! utf8_target) Safefree(utf8_p);
6756    }
6757   }
6758  }
6759
6760  return (flags & ANYOF_INVERT) ? !match : match;
6761 }
6762
6763 STATIC U8 *
6764 S_reghop3(U8 *s, I32 off, const U8* lim)
6765 {
6766  dVAR;
6767
6768  PERL_ARGS_ASSERT_REGHOP3;
6769
6770  if (off >= 0) {
6771   while (off-- && s < lim) {
6772    /* XXX could check well-formedness here */
6773    s += UTF8SKIP(s);
6774   }
6775  }
6776  else {
6777   while (off++ && s > lim) {
6778    s--;
6779    if (UTF8_IS_CONTINUED(*s)) {
6780     while (s > lim && UTF8_IS_CONTINUATION(*s))
6781      s--;
6782    }
6783    /* XXX could check well-formedness here */
6784   }
6785  }
6786  return s;
6787 }
6788
6789 #ifdef XXX_dmq
6790 /* there are a bunch of places where we use two reghop3's that should
6791    be replaced with this routine. but since thats not done yet
6792    we ifdef it out - dmq
6793 */
6794 STATIC U8 *
6795 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
6796 {
6797  dVAR;
6798
6799  PERL_ARGS_ASSERT_REGHOP4;
6800
6801  if (off >= 0) {
6802   while (off-- && s < rlim) {
6803    /* XXX could check well-formedness here */
6804    s += UTF8SKIP(s);
6805   }
6806  }
6807  else {
6808   while (off++ && s > llim) {
6809    s--;
6810    if (UTF8_IS_CONTINUED(*s)) {
6811     while (s > llim && UTF8_IS_CONTINUATION(*s))
6812      s--;
6813    }
6814    /* XXX could check well-formedness here */
6815   }
6816  }
6817  return s;
6818 }
6819 #endif
6820
6821 STATIC U8 *
6822 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
6823 {
6824  dVAR;
6825
6826  PERL_ARGS_ASSERT_REGHOPMAYBE3;
6827
6828  if (off >= 0) {
6829   while (off-- && s < lim) {
6830    /* XXX could check well-formedness here */
6831    s += UTF8SKIP(s);
6832   }
6833   if (off >= 0)
6834    return NULL;
6835  }
6836  else {
6837   while (off++ && s > lim) {
6838    s--;
6839    if (UTF8_IS_CONTINUED(*s)) {
6840     while (s > lim && UTF8_IS_CONTINUATION(*s))
6841      s--;
6842    }
6843    /* XXX could check well-formedness here */
6844   }
6845   if (off <= 0)
6846    return NULL;
6847  }
6848  return s;
6849 }
6850
6851 static void
6852 restore_pos(pTHX_ void *arg)
6853 {
6854  dVAR;
6855  regexp * const rex = (regexp *)arg;
6856  if (PL_reg_eval_set) {
6857   if (PL_reg_oldsaved) {
6858    rex->subbeg = PL_reg_oldsaved;
6859    rex->sublen = PL_reg_oldsavedlen;
6860 #ifdef PERL_OLD_COPY_ON_WRITE
6861    rex->saved_copy = PL_nrs;
6862 #endif
6863    RXp_MATCH_COPIED_on(rex);
6864   }
6865   PL_reg_magic->mg_len = PL_reg_oldpos;
6866   PL_reg_eval_set = 0;
6867   PL_curpm = PL_reg_oldcurpm;
6868  }
6869 }
6870
6871 STATIC void
6872 S_to_utf8_substr(pTHX_ register regexp *prog)
6873 {
6874  int i = 1;
6875
6876  PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
6877
6878  do {
6879   if (prog->substrs->data[i].substr
6880    && !prog->substrs->data[i].utf8_substr) {
6881    SV* const sv = newSVsv(prog->substrs->data[i].substr);
6882    prog->substrs->data[i].utf8_substr = sv;
6883    sv_utf8_upgrade(sv);
6884    if (SvVALID(prog->substrs->data[i].substr)) {
6885     const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
6886     if (flags & FBMcf_TAIL) {
6887      /* Trim the trailing \n that fbm_compile added last
6888      time.  */
6889      SvCUR_set(sv, SvCUR(sv) - 1);
6890      /* Whilst this makes the SV technically "invalid" (as its
6891      buffer is no longer followed by "\0") when fbm_compile()
6892      adds the "\n" back, a "\0" is restored.  */
6893     }
6894     fbm_compile(sv, flags);
6895    }
6896    if (prog->substrs->data[i].substr == prog->check_substr)
6897     prog->check_utf8 = sv;
6898   }
6899  } while (i--);
6900 }
6901
6902 STATIC void
6903 S_to_byte_substr(pTHX_ register regexp *prog)
6904 {
6905  dVAR;
6906  int i = 1;
6907
6908  PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
6909
6910  do {
6911   if (prog->substrs->data[i].utf8_substr
6912    && !prog->substrs->data[i].substr) {
6913    SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
6914    if (sv_utf8_downgrade(sv, TRUE)) {
6915     if (SvVALID(prog->substrs->data[i].utf8_substr)) {
6916      const U8 flags
6917       = BmFLAGS(prog->substrs->data[i].utf8_substr);
6918      if (flags & FBMcf_TAIL) {
6919       /* Trim the trailing \n that fbm_compile added last
6920       time.  */
6921       SvCUR_set(sv, SvCUR(sv) - 1);
6922      }
6923      fbm_compile(sv, flags);
6924     }
6925    } else {
6926     SvREFCNT_dec(sv);
6927     sv = &PL_sv_undef;
6928    }
6929    prog->substrs->data[i].substr = sv;
6930    if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
6931     prog->check_substr = sv;
6932   }
6933  } while (i--);
6934 }
6935
6936 /*
6937  * Local variables:
6938  * c-indentation-style: bsd
6939  * c-basic-offset: 4
6940  * indent-tabs-mode: t
6941  * End:
6942  *
6943  * ex: set ts=8 sts=4 sw=4 noet:
6944  */