src/5014004/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    /* Set the end position to the final character available */
1515    e = HOP3c(strend, -1, s);
1516
1517    if (!reginfo && e < s) {
1518     e = s;   /* Due to minlen logic of intuit() */
1519    }
1520
1521    while (s <= e) {
1522     char *my_strend= (char *)strend;
1523     if (foldEQ_utf8_flags(s, &my_strend, 0,  utf8_target,
1524      pat_string, NULL, ln, cBOOL(UTF_PATTERN), utf8_fold_flags)
1525      && (!reginfo || regtry(reginfo, &s)) )
1526     {
1527      goto got_it;
1528     }
1529     s += (utf8_target) ? UTF8SKIP(s) : 1;
1530    }
1531    break;
1532   case BOUNDL:
1533    PL_reg_flags |= RF_tainted;
1534    FBC_BOUND(isALNUM_LC,
1535      isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
1536      isALNUM_LC_utf8((U8*)s));
1537    break;
1538   case NBOUNDL:
1539    PL_reg_flags |= RF_tainted;
1540    FBC_NBOUND(isALNUM_LC,
1541      isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
1542      isALNUM_LC_utf8((U8*)s));
1543    break;
1544   case BOUND:
1545    FBC_BOUND(isWORDCHAR,
1546      isALNUM_uni(tmp),
1547      cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1548    break;
1549   case BOUNDA:
1550    FBC_BOUND_NOLOAD(isWORDCHAR_A,
1551        isWORDCHAR_A(tmp),
1552        isWORDCHAR_A((U8*)s));
1553    break;
1554   case NBOUND:
1555    FBC_NBOUND(isWORDCHAR,
1556      isALNUM_uni(tmp),
1557      cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1558    break;
1559   case NBOUNDA:
1560    FBC_NBOUND_NOLOAD(isWORDCHAR_A,
1561        isWORDCHAR_A(tmp),
1562        isWORDCHAR_A((U8*)s));
1563    break;
1564   case BOUNDU:
1565    FBC_BOUND(isWORDCHAR_L1,
1566      isALNUM_uni(tmp),
1567      cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1568    break;
1569   case NBOUNDU:
1570    FBC_NBOUND(isWORDCHAR_L1,
1571      isALNUM_uni(tmp),
1572      cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1573    break;
1574   case ALNUML:
1575    REXEC_FBC_CSCAN_TAINT(
1576     isALNUM_LC_utf8((U8*)s),
1577     isALNUM_LC(*s)
1578    );
1579    break;
1580   case ALNUMU:
1581    REXEC_FBC_CSCAN_PRELOAD(
1582     LOAD_UTF8_CHARCLASS_ALNUM(),
1583     swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
1584     isWORDCHAR_L1((U8) *s)
1585    );
1586    break;
1587   case ALNUM:
1588    REXEC_FBC_CSCAN_PRELOAD(
1589     LOAD_UTF8_CHARCLASS_ALNUM(),
1590     swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
1591     isWORDCHAR((U8) *s)
1592    );
1593    break;
1594   case ALNUMA:
1595    /* Don't need to worry about utf8, as it can match only a single
1596    * byte invariant character */
1597    REXEC_FBC_CLASS_SCAN( isWORDCHAR_A(*s));
1598    break;
1599   case NALNUMU:
1600    REXEC_FBC_CSCAN_PRELOAD(
1601     LOAD_UTF8_CHARCLASS_ALNUM(),
1602     !swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
1603     ! isWORDCHAR_L1((U8) *s)
1604    );
1605    break;
1606   case NALNUM:
1607    REXEC_FBC_CSCAN_PRELOAD(
1608     LOAD_UTF8_CHARCLASS_ALNUM(),
1609     !swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target),
1610     ! isALNUM(*s)
1611    );
1612    break;
1613   case NALNUMA:
1614    REXEC_FBC_CSCAN(
1615     !isWORDCHAR_A(*s),
1616     !isWORDCHAR_A(*s)
1617    );
1618    break;
1619   case NALNUML:
1620    REXEC_FBC_CSCAN_TAINT(
1621     !isALNUM_LC_utf8((U8*)s),
1622     !isALNUM_LC(*s)
1623    );
1624    break;
1625   case SPACEU:
1626    REXEC_FBC_CSCAN_PRELOAD(
1627     LOAD_UTF8_CHARCLASS_SPACE(),
1628     *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, utf8_target),
1629     isSPACE_L1((U8) *s)
1630    );
1631    break;
1632   case SPACE:
1633    REXEC_FBC_CSCAN_PRELOAD(
1634     LOAD_UTF8_CHARCLASS_SPACE(),
1635     *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, utf8_target),
1636     isSPACE((U8) *s)
1637    );
1638    break;
1639   case SPACEA:
1640    /* Don't need to worry about utf8, as it can match only a single
1641    * byte invariant character */
1642    REXEC_FBC_CLASS_SCAN( isSPACE_A(*s));
1643    break;
1644   case SPACEL:
1645    REXEC_FBC_CSCAN_TAINT(
1646     isSPACE_LC_utf8((U8*)s),
1647     isSPACE_LC(*s)
1648    );
1649    break;
1650   case NSPACEU:
1651    REXEC_FBC_CSCAN_PRELOAD(
1652     LOAD_UTF8_CHARCLASS_SPACE(),
1653     !( *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, utf8_target)),
1654     ! isSPACE_L1((U8) *s)
1655    );
1656    break;
1657   case NSPACE:
1658    REXEC_FBC_CSCAN_PRELOAD(
1659     LOAD_UTF8_CHARCLASS_SPACE(),
1660     !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, utf8_target)),
1661     ! isSPACE((U8) *s)
1662    );
1663    break;
1664   case NSPACEA:
1665    REXEC_FBC_CSCAN(
1666     !isSPACE_A(*s),
1667     !isSPACE_A(*s)
1668    );
1669    break;
1670   case NSPACEL:
1671    REXEC_FBC_CSCAN_TAINT(
1672     !isSPACE_LC_utf8((U8*)s),
1673     !isSPACE_LC(*s)
1674    );
1675    break;
1676   case DIGIT:
1677    REXEC_FBC_CSCAN_PRELOAD(
1678     LOAD_UTF8_CHARCLASS_DIGIT(),
1679     swash_fetch(PL_utf8_digit,(U8*)s, utf8_target),
1680     isDIGIT(*s)
1681    );
1682    break;
1683   case DIGITA:
1684    /* Don't need to worry about utf8, as it can match only a single
1685    * byte invariant character */
1686    REXEC_FBC_CLASS_SCAN( isDIGIT_A(*s));
1687    break;
1688   case DIGITL:
1689    REXEC_FBC_CSCAN_TAINT(
1690     isDIGIT_LC_utf8((U8*)s),
1691     isDIGIT_LC(*s)
1692    );
1693    break;
1694   case NDIGIT:
1695    REXEC_FBC_CSCAN_PRELOAD(
1696     LOAD_UTF8_CHARCLASS_DIGIT(),
1697     !swash_fetch(PL_utf8_digit,(U8*)s, utf8_target),
1698     !isDIGIT(*s)
1699    );
1700    break;
1701   case NDIGITA:
1702    REXEC_FBC_CSCAN(
1703     !isDIGIT_A(*s),
1704     !isDIGIT_A(*s)
1705    );
1706    break;
1707   case NDIGITL:
1708    REXEC_FBC_CSCAN_TAINT(
1709     !isDIGIT_LC_utf8((U8*)s),
1710     !isDIGIT_LC(*s)
1711    );
1712    break;
1713   case LNBREAK:
1714    REXEC_FBC_CSCAN(
1715     is_LNBREAK_utf8(s),
1716     is_LNBREAK_latin1(s)
1717    );
1718    break;
1719   case VERTWS:
1720    REXEC_FBC_CSCAN(
1721     is_VERTWS_utf8(s),
1722     is_VERTWS_latin1(s)
1723    );
1724    break;
1725   case NVERTWS:
1726    REXEC_FBC_CSCAN(
1727     !is_VERTWS_utf8(s),
1728     !is_VERTWS_latin1(s)
1729    );
1730    break;
1731   case HORIZWS:
1732    REXEC_FBC_CSCAN(
1733     is_HORIZWS_utf8(s),
1734     is_HORIZWS_latin1(s)
1735    );
1736    break;
1737   case NHORIZWS:
1738    REXEC_FBC_CSCAN(
1739     !is_HORIZWS_utf8(s),
1740     !is_HORIZWS_latin1(s)
1741    );
1742    break;
1743   case AHOCORASICKC:
1744   case AHOCORASICK:
1745    {
1746     DECL_TRIE_TYPE(c);
1747     /* what trie are we using right now */
1748     reg_ac_data *aho
1749      = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1750     reg_trie_data *trie
1751      = (reg_trie_data*)progi->data->data[ aho->trie ];
1752     HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1753
1754     const char *last_start = strend - trie->minlen;
1755 #ifdef DEBUGGING
1756     const char *real_start = s;
1757 #endif
1758     STRLEN maxlen = trie->maxlen;
1759     SV *sv_points;
1760     U8 **points; /* map of where we were in the input string
1761         when reading a given char. For ASCII this
1762         is unnecessary overhead as the relationship
1763         is always 1:1, but for Unicode, especially
1764         case folded Unicode this is not true. */
1765     U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1766     U8 *bitmap=NULL;
1767
1768
1769     GET_RE_DEBUG_FLAGS_DECL;
1770
1771     /* We can't just allocate points here. We need to wrap it in
1772     * an SV so it gets freed properly if there is a croak while
1773     * running the match */
1774     ENTER;
1775     SAVETMPS;
1776     sv_points=newSV(maxlen * sizeof(U8 *));
1777     SvCUR_set(sv_points,
1778      maxlen * sizeof(U8 *));
1779     SvPOK_on(sv_points);
1780     sv_2mortal(sv_points);
1781     points=(U8**)SvPV_nolen(sv_points );
1782     if ( trie_type != trie_utf8_fold
1783      && (trie->bitmap || OP(c)==AHOCORASICKC) )
1784     {
1785      if (trie->bitmap)
1786       bitmap=(U8*)trie->bitmap;
1787      else
1788       bitmap=(U8*)ANYOF_BITMAP(c);
1789     }
1790     /* this is the Aho-Corasick algorithm modified a touch
1791     to include special handling for long "unknown char"
1792     sequences. The basic idea being that we use AC as long
1793     as we are dealing with a possible matching char, when
1794     we encounter an unknown char (and we have not encountered
1795     an accepting state) we scan forward until we find a legal
1796     starting char.
1797     AC matching is basically that of trie matching, except
1798     that when we encounter a failing transition, we fall back
1799     to the current states "fail state", and try the current char
1800     again, a process we repeat until we reach the root state,
1801     state 1, or a legal transition. If we fail on the root state
1802     then we can either terminate if we have reached an accepting
1803     state previously, or restart the entire process from the beginning
1804     if we have not.
1805
1806     */
1807     while (s <= last_start) {
1808      const U32 uniflags = UTF8_ALLOW_DEFAULT;
1809      U8 *uc = (U8*)s;
1810      U16 charid = 0;
1811      U32 base = 1;
1812      U32 state = 1;
1813      UV uvc = 0;
1814      STRLEN len = 0;
1815      STRLEN foldlen = 0;
1816      U8 *uscan = (U8*)NULL;
1817      U8 *leftmost = NULL;
1818 #ifdef DEBUGGING
1819      U32 accepted_word= 0;
1820 #endif
1821      U32 pointpos = 0;
1822
1823      while ( state && uc <= (U8*)strend ) {
1824       int failed=0;
1825       U32 word = aho->states[ state ].wordnum;
1826
1827       if( state==1 ) {
1828        if ( bitmap ) {
1829         DEBUG_TRIE_EXECUTE_r(
1830          if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1831           dump_exec_pos( (char *)uc, c, strend, real_start,
1832            (char *)uc, utf8_target );
1833           PerlIO_printf( Perl_debug_log,
1834            " Scanning for legal start char...\n");
1835          }
1836         );
1837         if (utf8_target) {
1838          while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1839           uc += UTF8SKIP(uc);
1840          }
1841         } else {
1842          while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1843           uc++;
1844          }
1845         }
1846         s= (char *)uc;
1847        }
1848        if (uc >(U8*)last_start) break;
1849       }
1850
1851       if ( word ) {
1852        U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
1853        if (!leftmost || lpos < leftmost) {
1854         DEBUG_r(accepted_word=word);
1855         leftmost= lpos;
1856        }
1857        if (base==0) break;
1858
1859       }
1860       points[pointpos++ % maxlen]= uc;
1861       REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1862            uscan, len, uvc, charid, foldlen,
1863            foldbuf, uniflags);
1864       DEBUG_TRIE_EXECUTE_r({
1865        dump_exec_pos( (char *)uc, c, strend, real_start,
1866         s,   utf8_target );
1867        PerlIO_printf(Perl_debug_log,
1868         " Charid:%3u CP:%4"UVxf" ",
1869         charid, uvc);
1870       });
1871
1872       do {
1873 #ifdef DEBUGGING
1874        word = aho->states[ state ].wordnum;
1875 #endif
1876        base = aho->states[ state ].trans.base;
1877
1878        DEBUG_TRIE_EXECUTE_r({
1879         if (failed)
1880          dump_exec_pos( (char *)uc, c, strend, real_start,
1881           s,   utf8_target );
1882         PerlIO_printf( Perl_debug_log,
1883          "%sState: %4"UVxf", word=%"UVxf,
1884          failed ? " Fail transition to " : "",
1885          (UV)state, (UV)word);
1886        });
1887        if ( base ) {
1888         U32 tmp;
1889         I32 offset;
1890         if (charid &&
1891          ( ((offset = base + charid
1892           - 1 - trie->uniquecharcount)) >= 0)
1893          && ((U32)offset < trie->lasttrans)
1894          && trie->trans[offset].check == state
1895          && (tmp=trie->trans[offset].next))
1896         {
1897          DEBUG_TRIE_EXECUTE_r(
1898           PerlIO_printf( Perl_debug_log," - legal\n"));
1899          state = tmp;
1900          break;
1901         }
1902         else {
1903          DEBUG_TRIE_EXECUTE_r(
1904           PerlIO_printf( Perl_debug_log," - fail\n"));
1905          failed = 1;
1906          state = aho->fail[state];
1907         }
1908        }
1909        else {
1910         /* we must be accepting here */
1911         DEBUG_TRIE_EXECUTE_r(
1912           PerlIO_printf( Perl_debug_log," - accepting\n"));
1913         failed = 1;
1914         break;
1915        }
1916       } while(state);
1917       uc += len;
1918       if (failed) {
1919        if (leftmost)
1920         break;
1921        if (!state) state = 1;
1922       }
1923      }
1924      if ( aho->states[ state ].wordnum ) {
1925       U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
1926       if (!leftmost || lpos < leftmost) {
1927        DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1928        leftmost = lpos;
1929       }
1930      }
1931      if (leftmost) {
1932       s = (char*)leftmost;
1933       DEBUG_TRIE_EXECUTE_r({
1934        PerlIO_printf(
1935         Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1936         (UV)accepted_word, (IV)(s - real_start)
1937        );
1938       });
1939       if (!reginfo || regtry(reginfo, &s)) {
1940        FREETMPS;
1941        LEAVE;
1942        goto got_it;
1943       }
1944       s = HOPc(s,1);
1945       DEBUG_TRIE_EXECUTE_r({
1946        PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1947       });
1948      } else {
1949       DEBUG_TRIE_EXECUTE_r(
1950        PerlIO_printf( Perl_debug_log,"No match.\n"));
1951       break;
1952      }
1953     }
1954     FREETMPS;
1955     LEAVE;
1956    }
1957    break;
1958   default:
1959    Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1960    break;
1961   }
1962   return 0;
1963  got_it:
1964   return s;
1965 }
1966
1967
1968 /*
1969  - regexec_flags - match a regexp against a string
1970  */
1971 I32
1972 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
1973    char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1974 /* strend: pointer to null at end of string */
1975 /* strbeg: real beginning of string */
1976 /* minend: end of match must be >=minend after stringarg. */
1977 /* data: May be used for some additional optimizations.
1978   Currently its only used, with a U32 cast, for transmitting
1979   the ganch offset when doing a /g match. This will change */
1980 /* nosave: For optimizations. */
1981 {
1982  dVAR;
1983  struct regexp *const prog = (struct regexp *)SvANY(rx);
1984  /*register*/ char *s;
1985  register regnode *c;
1986  /*register*/ char *startpos = stringarg;
1987  I32 minlen;  /* must match at least this many chars */
1988  I32 dontbother = 0; /* how many characters not to try at end */
1989  I32 end_shift = 0;   /* Same for the end. */  /* CC */
1990  I32 scream_pos = -1;  /* Internal iterator of scream. */
1991  char *scream_olds = NULL;
1992  const bool utf8_target = cBOOL(DO_UTF8(sv));
1993  I32 multiline;
1994  RXi_GET_DECL(prog,progi);
1995  regmatch_info reginfo;  /* create some info to pass to regtry etc */
1996  regexp_paren_pair *swap = NULL;
1997  GET_RE_DEBUG_FLAGS_DECL;
1998
1999  PERL_ARGS_ASSERT_REGEXEC_FLAGS;
2000  PERL_UNUSED_ARG(data);
2001
2002  /* Be paranoid... */
2003  if (prog == NULL || startpos == NULL) {
2004   Perl_croak(aTHX_ "NULL regexp parameter");
2005   return 0;
2006  }
2007
2008  multiline = prog->extflags & RXf_PMf_MULTILINE;
2009  reginfo.prog = rx;  /* Yes, sorry that this is confusing.  */
2010
2011  RX_MATCH_UTF8_set(rx, utf8_target);
2012  DEBUG_EXECUTE_r(
2013   debug_start_match(rx, utf8_target, startpos, strend,
2014   "Matching");
2015  );
2016
2017  minlen = prog->minlen;
2018
2019  if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
2020   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2021        "String too short [regexec_flags]...\n"));
2022   goto phooey;
2023  }
2024
2025
2026  /* Check validity of program. */
2027  if (UCHARAT(progi->program) != REG_MAGIC) {
2028   Perl_croak(aTHX_ "corrupted regexp program");
2029  }
2030
2031  PL_reg_flags = 0;
2032  PL_reg_eval_set = 0;
2033  PL_reg_maxiter = 0;
2034
2035  if (RX_UTF8(rx))
2036   PL_reg_flags |= RF_utf8;
2037
2038  /* Mark beginning of line for ^ and lookbehind. */
2039  reginfo.bol = startpos; /* XXX not used ??? */
2040  PL_bostr  = strbeg;
2041  reginfo.sv = sv;
2042
2043  /* Mark end of line for $ (and such) */
2044  PL_regeol = strend;
2045
2046  /* see how far we have to get to not match where we matched before */
2047  reginfo.till = startpos+minend;
2048
2049  /* If there is a "must appear" string, look for it. */
2050  s = startpos;
2051
2052  if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
2053   MAGIC *mg;
2054   if (flags & REXEC_IGNOREPOS){ /* Means: check only at start */
2055    reginfo.ganch = startpos + prog->gofs;
2056    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2057    "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
2058   } else if (sv && SvTYPE(sv) >= SVt_PVMG
2059     && SvMAGIC(sv)
2060     && (mg = mg_find(sv, PERL_MAGIC_regex_global))
2061     && mg->mg_len >= 0) {
2062    reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
2063    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2064     "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
2065
2066    if (prog->extflags & RXf_ANCH_GPOS) {
2067     if (s > reginfo.ganch)
2068      goto phooey;
2069     s = reginfo.ganch - prog->gofs;
2070     DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2071      "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
2072     if (s < strbeg)
2073      goto phooey;
2074    }
2075   }
2076   else if (data) {
2077    reginfo.ganch = strbeg + PTR2UV(data);
2078    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2079     "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
2080
2081   } else {    /* pos() not defined */
2082    reginfo.ganch = strbeg;
2083    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2084     "GPOS: reginfo.ganch = strbeg\n"));
2085   }
2086  }
2087  if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
2088   /* We have to be careful. If the previous successful match
2089   was from this regex we don't want a subsequent partially
2090   successful match to clobber the old results.
2091   So when we detect this possibility we add a swap buffer
2092   to the re, and switch the buffer each match. If we fail
2093   we switch it back, otherwise we leave it swapped.
2094   */
2095   swap = prog->offs;
2096   /* do we need a save destructor here for eval dies? */
2097   Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
2098  }
2099  if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
2100   re_scream_pos_data d;
2101
2102   d.scream_olds = &scream_olds;
2103   d.scream_pos = &scream_pos;
2104   s = re_intuit_start(rx, sv, s, strend, flags, &d);
2105   if (!s) {
2106    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
2107    goto phooey; /* not present */
2108   }
2109  }
2110
2111
2112
2113  /* Simplest case:  anchored match need be tried only once. */
2114  /*  [unless only anchor is BOL and multiline is set] */
2115  if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
2116   if (s == startpos && regtry(&reginfo, &startpos))
2117    goto got_it;
2118   else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2119     || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
2120   {
2121    char *end;
2122
2123    if (minlen)
2124     dontbother = minlen - 1;
2125    end = HOP3c(strend, -dontbother, strbeg) - 1;
2126    /* for multiline we only have to try after newlines */
2127    if (prog->check_substr || prog->check_utf8) {
2128     /* because of the goto we can not easily reuse the macros for bifurcating the
2129     unicode/non-unicode match modes here like we do elsewhere - demerphq */
2130     if (utf8_target) {
2131      if (s == startpos)
2132       goto after_try_utf8;
2133      while (1) {
2134       if (regtry(&reginfo, &s)) {
2135        goto got_it;
2136       }
2137      after_try_utf8:
2138       if (s > end) {
2139        goto phooey;
2140       }
2141       if (prog->extflags & RXf_USE_INTUIT) {
2142        s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL);
2143        if (!s) {
2144         goto phooey;
2145        }
2146       }
2147       else {
2148        s += UTF8SKIP(s);
2149       }
2150      }
2151     } /* end search for check string in unicode */
2152     else {
2153      if (s == startpos) {
2154       goto after_try_latin;
2155      }
2156      while (1) {
2157       if (regtry(&reginfo, &s)) {
2158        goto got_it;
2159       }
2160      after_try_latin:
2161       if (s > end) {
2162        goto phooey;
2163       }
2164       if (prog->extflags & RXf_USE_INTUIT) {
2165        s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2166        if (!s) {
2167         goto phooey;
2168        }
2169       }
2170       else {
2171        s++;
2172       }
2173      }
2174     } /* end search for check string in latin*/
2175    } /* end search for check string */
2176    else { /* search for newline */
2177     if (s > startpos) {
2178      /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
2179      s--;
2180     }
2181     /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
2182     while (s < end) {
2183      if (*s++ == '\n') { /* don't need PL_utf8skip here */
2184       if (regtry(&reginfo, &s))
2185        goto got_it;
2186      }
2187     }
2188    } /* end search for newline */
2189   } /* end anchored/multiline check string search */
2190   goto phooey;
2191  } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
2192  {
2193   /* the warning about reginfo.ganch being used without initialization
2194   is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
2195   and we only enter this block when the same bit is set. */
2196   char *tmp_s = reginfo.ganch - prog->gofs;
2197
2198   if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
2199    goto got_it;
2200   goto phooey;
2201  }
2202
2203  /* Messy cases:  unanchored match. */
2204  if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2205   /* we have /x+whatever/ */
2206   /* it must be a one character string (XXXX Except UTF_PATTERN?) */
2207   char ch;
2208 #ifdef DEBUGGING
2209   int did_match = 0;
2210 #endif
2211   if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
2212    utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2213   ch = SvPVX_const(utf8_target ? prog->anchored_utf8 : prog->anchored_substr)[0];
2214
2215   if (utf8_target) {
2216    REXEC_FBC_SCAN(
2217     if (*s == ch) {
2218      DEBUG_EXECUTE_r( did_match = 1 );
2219      if (regtry(&reginfo, &s)) goto got_it;
2220      s += UTF8SKIP(s);
2221      while (s < strend && *s == ch)
2222       s += UTF8SKIP(s);
2223     }
2224    );
2225   }
2226   else {
2227    REXEC_FBC_SCAN(
2228     if (*s == ch) {
2229      DEBUG_EXECUTE_r( did_match = 1 );
2230      if (regtry(&reginfo, &s)) goto got_it;
2231      s++;
2232      while (s < strend && *s == ch)
2233       s++;
2234     }
2235    );
2236   }
2237   DEBUG_EXECUTE_r(if (!did_match)
2238     PerlIO_printf(Perl_debug_log,
2239         "Did not find anchored character...\n")
2240    );
2241  }
2242  else if (prog->anchored_substr != NULL
2243    || prog->anchored_utf8 != NULL
2244    || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2245     && prog->float_max_offset < strend - s)) {
2246   SV *must;
2247   I32 back_max;
2248   I32 back_min;
2249   char *last;
2250   char *last1;  /* Last position checked before */
2251 #ifdef DEBUGGING
2252   int did_match = 0;
2253 #endif
2254   if (prog->anchored_substr || prog->anchored_utf8) {
2255    if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
2256     utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2257    must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
2258    back_max = back_min = prog->anchored_offset;
2259   } else {
2260    if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
2261     utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2262    must = utf8_target ? prog->float_utf8 : prog->float_substr;
2263    back_max = prog->float_max_offset;
2264    back_min = prog->float_min_offset;
2265   }
2266
2267
2268   if (must == &PL_sv_undef)
2269    /* could not downgrade utf8 check substring, so must fail */
2270    goto phooey;
2271
2272   if (back_min<0) {
2273    last = strend;
2274   } else {
2275    last = HOP3c(strend, /* Cannot start after this */
2276     -(I32)(CHR_SVLEN(must)
2277       - (SvTAIL(must) != 0) + back_min), strbeg);
2278   }
2279   if (s > PL_bostr)
2280    last1 = HOPc(s, -1);
2281   else
2282    last1 = s - 1; /* bogus */
2283
2284   /* XXXX check_substr already used to find "s", can optimize if
2285   check_substr==must. */
2286   scream_pos = -1;
2287   dontbother = end_shift;
2288   strend = HOPc(strend, -dontbother);
2289   while ( (s <= last) &&
2290     ((flags & REXEC_SCREAM)
2291     ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2292          end_shift, &scream_pos, 0))
2293     : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2294         (unsigned char*)strend, must,
2295         multiline ? FBMrf_MULTILINE : 0))) ) {
2296    /* we may be pointing at the wrong string */
2297    if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2298     s = strbeg + (s - SvPVX_const(sv));
2299    DEBUG_EXECUTE_r( did_match = 1 );
2300    if (HOPc(s, -back_max) > last1) {
2301     last1 = HOPc(s, -back_min);
2302     s = HOPc(s, -back_max);
2303    }
2304    else {
2305     char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2306
2307     last1 = HOPc(s, -back_min);
2308     s = t;
2309    }
2310    if (utf8_target) {
2311     while (s <= last1) {
2312      if (regtry(&reginfo, &s))
2313       goto got_it;
2314      s += UTF8SKIP(s);
2315     }
2316    }
2317    else {
2318     while (s <= last1) {
2319      if (regtry(&reginfo, &s))
2320       goto got_it;
2321      s++;
2322     }
2323    }
2324   }
2325   DEBUG_EXECUTE_r(if (!did_match) {
2326    RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
2327     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2328    PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2329        ((must == prog->anchored_substr || must == prog->anchored_utf8)
2330        ? "anchored" : "floating"),
2331     quoted, RE_SV_TAIL(must));
2332   });
2333   goto phooey;
2334  }
2335  else if ( (c = progi->regstclass) ) {
2336   if (minlen) {
2337    const OPCODE op = OP(progi->regstclass);
2338    /* don't bother with what can't match */
2339    if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2340     strend = HOPc(strend, -(minlen - 1));
2341   }
2342   DEBUG_EXECUTE_r({
2343    SV * const prop = sv_newmortal();
2344    regprop(prog, prop, c);
2345    {
2346     RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
2347      s,strend-s,60);
2348     PerlIO_printf(Perl_debug_log,
2349      "Matching stclass %.*s against %s (%d bytes)\n",
2350      (int)SvCUR(prop), SvPVX_const(prop),
2351      quoted, (int)(strend - s));
2352    }
2353   });
2354   if (find_byclass(prog, c, s, strend, &reginfo))
2355    goto got_it;
2356   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2357  }
2358  else {
2359   dontbother = 0;
2360   if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2361    /* Trim the end. */
2362    char *last;
2363    SV* float_real;
2364
2365    if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
2366     utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2367    float_real = utf8_target ? prog->float_utf8 : prog->float_substr;
2368
2369    if (flags & REXEC_SCREAM) {
2370     last = screaminstr(sv, float_real, s - strbeg,
2371         end_shift, &scream_pos, 1); /* last one */
2372     if (!last)
2373      last = scream_olds; /* Only one occurrence. */
2374     /* we may be pointing at the wrong string */
2375     else if (RXp_MATCH_COPIED(prog))
2376      s = strbeg + (s - SvPVX_const(sv));
2377    }
2378    else {
2379     STRLEN len;
2380     const char * const little = SvPV_const(float_real, len);
2381
2382     if (SvTAIL(float_real)) {
2383      if (memEQ(strend - len + 1, little, len - 1))
2384       last = strend - len + 1;
2385      else if (!multiline)
2386       last = memEQ(strend - len, little, len)
2387        ? strend - len : NULL;
2388      else
2389       goto find_last;
2390     } else {
2391     find_last:
2392      if (len)
2393       last = rninstr(s, strend, little, little + len);
2394      else
2395       last = strend; /* matching "$" */
2396     }
2397    }
2398    if (last == NULL) {
2399     DEBUG_EXECUTE_r(
2400      PerlIO_printf(Perl_debug_log,
2401       "%sCan't trim the tail, match fails (should not happen)%s\n",
2402       PL_colors[4], PL_colors[5]));
2403     goto phooey; /* Should not happen! */
2404    }
2405    dontbother = strend - last + prog->float_min_offset;
2406   }
2407   if (minlen && (dontbother < minlen))
2408    dontbother = minlen - 1;
2409   strend -= dontbother;      /* this one's always in bytes! */
2410   /* We don't know much -- general case. */
2411   if (utf8_target) {
2412    for (;;) {
2413     if (regtry(&reginfo, &s))
2414      goto got_it;
2415     if (s >= strend)
2416      break;
2417     s += UTF8SKIP(s);
2418    };
2419   }
2420   else {
2421    do {
2422     if (regtry(&reginfo, &s))
2423      goto got_it;
2424    } while (s++ < strend);
2425   }
2426  }
2427
2428  /* Failure. */
2429  goto phooey;
2430
2431 got_it:
2432  Safefree(swap);
2433  RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2434
2435  if (PL_reg_eval_set)
2436   restore_pos(aTHX_ prog);
2437  if (RXp_PAREN_NAMES(prog))
2438   (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2439
2440  /* make sure $`, $&, $', and $digit will work later */
2441  if ( !(flags & REXEC_NOT_FIRST) ) {
2442   RX_MATCH_COPY_FREE(rx);
2443   if (flags & REXEC_COPY_STR) {
2444    const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2445 #ifdef PERL_OLD_COPY_ON_WRITE
2446    if ((SvIsCOW(sv)
2447     || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2448     if (DEBUG_C_TEST) {
2449      PerlIO_printf(Perl_debug_log,
2450         "Copy on write: regexp capture, type %d\n",
2451         (int) SvTYPE(sv));
2452     }
2453     prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2454     prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2455     assert (SvPOKp(prog->saved_copy));
2456    } else
2457 #endif
2458    {
2459     RX_MATCH_COPIED_on(rx);
2460     s = savepvn(strbeg, i);
2461     prog->subbeg = s;
2462    }
2463    prog->sublen = i;
2464   }
2465   else {
2466    prog->subbeg = strbeg;
2467    prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2468   }
2469  }
2470
2471  return 1;
2472
2473 phooey:
2474  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2475       PL_colors[4], PL_colors[5]));
2476  if (PL_reg_eval_set)
2477   restore_pos(aTHX_ prog);
2478  if (swap) {
2479   /* we failed :-( roll it back */
2480   Safefree(prog->offs);
2481   prog->offs = swap;
2482  }
2483
2484  return 0;
2485 }
2486
2487
2488 /*
2489  - regtry - try match at specific point
2490  */
2491 STATIC I32   /* 0 failure, 1 success */
2492 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2493 {
2494  dVAR;
2495  CHECKPOINT lastcp;
2496  REGEXP *const rx = reginfo->prog;
2497  regexp *const prog = (struct regexp *)SvANY(rx);
2498  RXi_GET_DECL(prog,progi);
2499  GET_RE_DEBUG_FLAGS_DECL;
2500
2501  PERL_ARGS_ASSERT_REGTRY;
2502
2503  reginfo->cutpoint=NULL;
2504
2505  if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2506   MAGIC *mg;
2507
2508   PL_reg_eval_set = RS_init;
2509   DEBUG_EXECUTE_r(DEBUG_s(
2510    PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2511       (IV)(PL_stack_sp - PL_stack_base));
2512    ));
2513   SAVESTACK_CXPOS();
2514   cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2515   /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2516   SAVETMPS;
2517   /* Apparently this is not needed, judging by wantarray. */
2518   /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2519   cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2520
2521   if (reginfo->sv) {
2522    /* Make $_ available to executed code. */
2523    if (reginfo->sv != DEFSV) {
2524     SAVE_DEFSV;
2525     DEFSV_set(reginfo->sv);
2526    }
2527
2528    if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2529     && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2530     /* prepare for quick setting of pos */
2531 #ifdef PERL_OLD_COPY_ON_WRITE
2532     if (SvIsCOW(reginfo->sv))
2533      sv_force_normal_flags(reginfo->sv, 0);
2534 #endif
2535     mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2536         &PL_vtbl_mglob, NULL, 0);
2537     mg->mg_len = -1;
2538    }
2539    PL_reg_magic    = mg;
2540    PL_reg_oldpos   = mg->mg_len;
2541    SAVEDESTRUCTOR_X(restore_pos, prog);
2542   }
2543   if (!PL_reg_curpm) {
2544    Newxz(PL_reg_curpm, 1, PMOP);
2545 #ifdef USE_ITHREADS
2546    {
2547     SV* const repointer = &PL_sv_undef;
2548     /* this regexp is also owned by the new PL_reg_curpm, which
2549     will try to free it.  */
2550     av_push(PL_regex_padav, repointer);
2551     PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2552     PL_regex_pad = AvARRAY(PL_regex_padav);
2553    }
2554 #endif
2555   }
2556 #ifdef USE_ITHREADS
2557   /* It seems that non-ithreads works both with and without this code.
2558   So for efficiency reasons it seems best not to have the code
2559   compiled when it is not needed.  */
2560   /* This is safe against NULLs: */
2561   ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2562   /* PM_reg_curpm owns a reference to this regexp.  */
2563   (void)ReREFCNT_inc(rx);
2564 #endif
2565   PM_SETRE(PL_reg_curpm, rx);
2566   PL_reg_oldcurpm = PL_curpm;
2567   PL_curpm = PL_reg_curpm;
2568   if (RXp_MATCH_COPIED(prog)) {
2569    /*  Here is a serious problem: we cannot rewrite subbeg,
2570     since it may be needed if this match fails.  Thus
2571     $` inside (?{}) could fail... */
2572    PL_reg_oldsaved = prog->subbeg;
2573    PL_reg_oldsavedlen = prog->sublen;
2574 #ifdef PERL_OLD_COPY_ON_WRITE
2575    PL_nrs = prog->saved_copy;
2576 #endif
2577    RXp_MATCH_COPIED_off(prog);
2578   }
2579   else
2580    PL_reg_oldsaved = NULL;
2581   prog->subbeg = PL_bostr;
2582   prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2583  }
2584  DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2585  prog->offs[0].start = *startpos - PL_bostr;
2586  PL_reginput = *startpos;
2587  PL_reglastparen = &prog->lastparen;
2588  PL_reglastcloseparen = &prog->lastcloseparen;
2589  prog->lastparen = 0;
2590  prog->lastcloseparen = 0;
2591  PL_regsize = 0;
2592  PL_regoffs = prog->offs;
2593  if (PL_reg_start_tmpl <= prog->nparens) {
2594   PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2595   if(PL_reg_start_tmp)
2596    Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2597   else
2598    Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2599  }
2600
2601  /* XXXX What this code is doing here?!!!  There should be no need
2602  to do this again and again, PL_reglastparen should take care of
2603  this!  --ilya*/
2604
2605  /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2606  * Actually, the code in regcppop() (which Ilya may be meaning by
2607  * PL_reglastparen), is not needed at all by the test suite
2608  * (op/regexp, op/pat, op/split), but that code is needed otherwise
2609  * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2610  * Meanwhile, this code *is* needed for the
2611  * above-mentioned test suite tests to succeed.  The common theme
2612  * on those tests seems to be returning null fields from matches.
2613  * --jhi updated by dapm */
2614 #if 1
2615  if (prog->nparens) {
2616   regexp_paren_pair *pp = PL_regoffs;
2617   register I32 i;
2618   for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2619    ++pp;
2620    pp->start = -1;
2621    pp->end = -1;
2622   }
2623  }
2624 #endif
2625  REGCP_SET(lastcp);
2626  if (regmatch(reginfo, progi->program + 1)) {
2627   PL_regoffs[0].end = PL_reginput - PL_bostr;
2628   return 1;
2629  }
2630  if (reginfo->cutpoint)
2631   *startpos= reginfo->cutpoint;
2632  REGCP_UNWIND(lastcp);
2633  return 0;
2634 }
2635
2636
2637 #define sayYES goto yes
2638 #define sayNO goto no
2639 #define sayNO_SILENT goto no_silent
2640
2641 /* we dont use STMT_START/END here because it leads to
2642    "unreachable code" warnings, which are bogus, but distracting. */
2643 #define CACHEsayNO \
2644  if (ST.cache_mask) \
2645  PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2646  sayNO
2647
2648 /* this is used to determine how far from the left messages like
2649    'failed...' are printed. It should be set such that messages
2650    are inline with the regop output that created them.
2651 */
2652 #define REPORT_CODE_OFF 32
2653
2654
2655 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2656 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2657
2658 #define SLAB_FIRST(s) (&(s)->states[0])
2659 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2660
2661 /* grab a new slab and return the first slot in it */
2662
2663 STATIC regmatch_state *
2664 S_push_slab(pTHX)
2665 {
2666 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2667  dMY_CXT;
2668 #endif
2669  regmatch_slab *s = PL_regmatch_slab->next;
2670  if (!s) {
2671   Newx(s, 1, regmatch_slab);
2672   s->prev = PL_regmatch_slab;
2673   s->next = NULL;
2674   PL_regmatch_slab->next = s;
2675  }
2676  PL_regmatch_slab = s;
2677  return SLAB_FIRST(s);
2678 }
2679
2680
2681 /* push a new state then goto it */
2682
2683 #define PUSH_STATE_GOTO(state, node) \
2684  scan = node; \
2685  st->resume_state = state; \
2686  goto push_state;
2687
2688 /* push a new state with success backtracking, then goto it */
2689
2690 #define PUSH_YES_STATE_GOTO(state, node) \
2691  scan = node; \
2692  st->resume_state = state; \
2693  goto push_yes_state;
2694
2695
2696
2697 /*
2698
2699 regmatch() - main matching routine
2700
2701 This is basically one big switch statement in a loop. We execute an op,
2702 set 'next' to point the next op, and continue. If we come to a point which
2703 we may need to backtrack to on failure such as (A|B|C), we push a
2704 backtrack state onto the backtrack stack. On failure, we pop the top
2705 state, and re-enter the loop at the state indicated. If there are no more
2706 states to pop, we return failure.
2707
2708 Sometimes we also need to backtrack on success; for example /A+/, where
2709 after successfully matching one A, we need to go back and try to
2710 match another one; similarly for lookahead assertions: if the assertion
2711 completes successfully, we backtrack to the state just before the assertion
2712 and then carry on.  In these cases, the pushed state is marked as
2713 'backtrack on success too'. This marking is in fact done by a chain of
2714 pointers, each pointing to the previous 'yes' state. On success, we pop to
2715 the nearest yes state, discarding any intermediate failure-only states.
2716 Sometimes a yes state is pushed just to force some cleanup code to be
2717 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2718 it to free the inner regex.
2719
2720 Note that failure backtracking rewinds the cursor position, while
2721 success backtracking leaves it alone.
2722
2723 A pattern is complete when the END op is executed, while a subpattern
2724 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2725 ops trigger the "pop to last yes state if any, otherwise return true"
2726 behaviour.
2727
2728 A common convention in this function is to use A and B to refer to the two
2729 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2730 the subpattern to be matched possibly multiple times, while B is the entire
2731 rest of the pattern. Variable and state names reflect this convention.
2732
2733 The states in the main switch are the union of ops and failure/success of
2734 substates associated with with that op.  For example, IFMATCH is the op
2735 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2736 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2737 successfully matched A and IFMATCH_A_fail is a state saying that we have
2738 just failed to match A. Resume states always come in pairs. The backtrack
2739 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2740 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2741 on success or failure.
2742
2743 The struct that holds a backtracking state is actually a big union, with
2744 one variant for each major type of op. The variable st points to the
2745 top-most backtrack struct. To make the code clearer, within each
2746 block of code we #define ST to alias the relevant union.
2747
2748 Here's a concrete example of a (vastly oversimplified) IFMATCH
2749 implementation:
2750
2751  switch (state) {
2752  ....
2753
2754 #define ST st->u.ifmatch
2755
2756  case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2757   ST.foo = ...; // some state we wish to save
2758   ...
2759   // push a yes backtrack state with a resume value of
2760   // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2761   // first node of A:
2762   PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2763   // NOTREACHED
2764
2765  case IFMATCH_A: // we have successfully executed A; now continue with B
2766   next = B;
2767   bar = ST.foo; // do something with the preserved value
2768   break;
2769
2770  case IFMATCH_A_fail: // A failed, so the assertion failed
2771   ...;   // do some housekeeping, then ...
2772   sayNO; // propagate the failure
2773
2774 #undef ST
2775
2776  ...
2777  }
2778
2779 For any old-timers reading this who are familiar with the old recursive
2780 approach, the code above is equivalent to:
2781
2782  case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2783  {
2784   int foo = ...
2785   ...
2786   if (regmatch(A)) {
2787    next = B;
2788    bar = foo;
2789    break;
2790   }
2791   ...;   // do some housekeeping, then ...
2792   sayNO; // propagate the failure
2793  }
2794
2795 The topmost backtrack state, pointed to by st, is usually free. If you
2796 want to claim it, populate any ST.foo fields in it with values you wish to
2797 save, then do one of
2798
2799   PUSH_STATE_GOTO(resume_state, node);
2800   PUSH_YES_STATE_GOTO(resume_state, node);
2801
2802 which sets that backtrack state's resume value to 'resume_state', pushes a
2803 new free entry to the top of the backtrack stack, then goes to 'node'.
2804 On backtracking, the free slot is popped, and the saved state becomes the
2805 new free state. An ST.foo field in this new top state can be temporarily
2806 accessed to retrieve values, but once the main loop is re-entered, it
2807 becomes available for reuse.
2808
2809 Note that the depth of the backtrack stack constantly increases during the
2810 left-to-right execution of the pattern, rather than going up and down with
2811 the pattern nesting. For example the stack is at its maximum at Z at the
2812 end of the pattern, rather than at X in the following:
2813
2814  /(((X)+)+)+....(Y)+....Z/
2815
2816 The only exceptions to this are lookahead/behind assertions and the cut,
2817 (?>A), which pop all the backtrack states associated with A before
2818 continuing.
2819
2820 Backtrack state structs are allocated in slabs of about 4K in size.
2821 PL_regmatch_state and st always point to the currently active state,
2822 and PL_regmatch_slab points to the slab currently containing
2823 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2824 allocated, and is never freed until interpreter destruction. When the slab
2825 is full, a new one is allocated and chained to the end. At exit from
2826 regmatch(), slabs allocated since entry are freed.
2827
2828 */
2829
2830
2831 #define DEBUG_STATE_pp(pp)        \
2832  DEBUG_STATE_r({         \
2833   DUMP_EXEC_POS(locinput, scan, utf8_target);      \
2834   PerlIO_printf(Perl_debug_log,       \
2835    "    %*s"pp" %s%s%s%s%s\n",       \
2836    depth*2, "",        \
2837    PL_reg_name[st->resume_state],                     \
2838    ((st==yes_state||st==mark_state) ? "[" : ""),   \
2839    ((st==yes_state) ? "Y" : ""),                   \
2840    ((st==mark_state) ? "M" : ""),                  \
2841    ((st==yes_state||st==mark_state) ? "]" : "")    \
2842   );                                                  \
2843  });
2844
2845
2846 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2847
2848 #ifdef DEBUGGING
2849
2850 STATIC void
2851 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
2852  const char *start, const char *end, const char *blurb)
2853 {
2854  const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2855
2856  PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2857
2858  if (!PL_colorset)
2859    reginitcolors();
2860  {
2861   RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2862    RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
2863
2864   RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
2865    start, end - start, 60);
2866
2867   PerlIO_printf(Perl_debug_log,
2868    "%s%s REx%s %s against %s\n",
2869      PL_colors[4], blurb, PL_colors[5], s0, s1);
2870
2871   if (utf8_target||utf8_pat)
2872    PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2873     utf8_pat ? "pattern" : "",
2874     utf8_pat && utf8_target ? " and " : "",
2875     utf8_target ? "string" : ""
2876    );
2877  }
2878 }
2879
2880 STATIC void
2881 S_dump_exec_pos(pTHX_ const char *locinput,
2882      const regnode *scan,
2883      const char *loc_regeol,
2884      const char *loc_bostr,
2885      const char *loc_reg_starttry,
2886      const bool utf8_target)
2887 {
2888  const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2889  const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2890  int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2891  /* The part of the string before starttry has one color
2892  (pref0_len chars), between starttry and current
2893  position another one (pref_len - pref0_len chars),
2894  after the current position the third one.
2895  We assume that pref0_len <= pref_len, otherwise we
2896  decrease pref0_len.  */
2897  int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2898   ? (5 + taill) - l : locinput - loc_bostr;
2899  int pref0_len;
2900
2901  PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2902
2903  while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2904   pref_len++;
2905  pref0_len = pref_len  - (locinput - loc_reg_starttry);
2906  if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2907   l = ( loc_regeol - locinput > (5 + taill) - pref_len
2908    ? (5 + taill) - pref_len : loc_regeol - locinput);
2909  while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2910   l--;
2911  if (pref0_len < 0)
2912   pref0_len = 0;
2913  if (pref0_len > pref_len)
2914   pref0_len = pref_len;
2915  {
2916   const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
2917
2918   RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2919    (locinput - pref_len),pref0_len, 60, 4, 5);
2920
2921   RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2922      (locinput - pref_len + pref0_len),
2923      pref_len - pref0_len, 60, 2, 3);
2924
2925   RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2926      locinput, loc_regeol - locinput, 10, 0, 1);
2927
2928   const STRLEN tlen=len0+len1+len2;
2929   PerlIO_printf(Perl_debug_log,
2930      "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2931      (IV)(locinput - loc_bostr),
2932      len0, s0,
2933      len1, s1,
2934      (docolor ? "" : "> <"),
2935      len2, s2,
2936      (int)(tlen > 19 ? 0 :  19 - tlen),
2937      "");
2938  }
2939 }
2940
2941 #endif
2942
2943 /* reg_check_named_buff_matched()
2944  * Checks to see if a named buffer has matched. The data array of
2945  * buffer numbers corresponding to the buffer is expected to reside
2946  * in the regexp->data->data array in the slot stored in the ARG() of
2947  * node involved. Note that this routine doesn't actually care about the
2948  * name, that information is not preserved from compilation to execution.
2949  * Returns the index of the leftmost defined buffer with the given name
2950  * or 0 if non of the buffers matched.
2951  */
2952 STATIC I32
2953 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2954 {
2955  I32 n;
2956  RXi_GET_DECL(rex,rexi);
2957  SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
2958  I32 *nums=(I32*)SvPVX(sv_dat);
2959
2960  PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
2961
2962  for ( n=0; n<SvIVX(sv_dat); n++ ) {
2963   if ((I32)*PL_reglastparen >= nums[n] &&
2964    PL_regoffs[nums[n]].end != -1)
2965   {
2966    return nums[n];
2967   }
2968  }
2969  return 0;
2970 }
2971
2972
2973 /* free all slabs above current one  - called during LEAVE_SCOPE */
2974
2975 STATIC void
2976 S_clear_backtrack_stack(pTHX_ void *p)
2977 {
2978  regmatch_slab *s = PL_regmatch_slab->next;
2979  PERL_UNUSED_ARG(p);
2980
2981  if (!s)
2982   return;
2983  PL_regmatch_slab->next = NULL;
2984  while (s) {
2985   regmatch_slab * const osl = s;
2986   s = s->next;
2987   Safefree(osl);
2988  }
2989 }
2990
2991
2992 #define SETREX(Re1,Re2) \
2993  if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2994  Re1 = (Re2)
2995
2996 STATIC I32   /* 0 failure, 1 success */
2997 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2998 {
2999 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3000  dMY_CXT;
3001 #endif
3002  dVAR;
3003  register const bool utf8_target = PL_reg_match_utf8;
3004  const U32 uniflags = UTF8_ALLOW_DEFAULT;
3005  REGEXP *rex_sv = reginfo->prog;
3006  regexp *rex = (struct regexp *)SvANY(rex_sv);
3007  RXi_GET_DECL(rex,rexi);
3008  I32 oldsave;
3009  /* the current state. This is a cached copy of PL_regmatch_state */
3010  register regmatch_state *st;
3011  /* cache heavy used fields of st in registers */
3012  register regnode *scan;
3013  register regnode *next;
3014  register U32 n = 0; /* general value; init to avoid compiler warning */
3015  register I32 ln = 0; /* len or last;  init to avoid compiler warning */
3016  register char *locinput = PL_reginput;
3017  register I32 nextchr;   /* is always set to UCHARAT(locinput) */
3018
3019  bool result = 0;     /* return value of S_regmatch */
3020  int depth = 0;     /* depth of backtrack stack */
3021  U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
3022  const U32 max_nochange_depth =
3023   (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
3024   3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
3025  regmatch_state *yes_state = NULL; /* state to pop to on success of
3026                subpattern */
3027  /* mark_state piggy backs on the yes_state logic so that when we unwind
3028  the stack on success we can update the mark_state as we go */
3029  regmatch_state *mark_state = NULL; /* last mark state we have seen */
3030  regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
3031  struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
3032  U32 state_num;
3033  bool no_final = 0;      /* prevent failure from backtracking? */
3034  bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
3035  char *startpoint = PL_reginput;
3036  SV *popmark = NULL;     /* are we looking for a mark? */
3037  SV *sv_commit = NULL;   /* last mark name seen in failure */
3038  SV *sv_yes_mark = NULL; /* last mark name we have seen
3039        during a successful match */
3040  U32 lastopen = 0;       /* last open we saw */
3041  bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
3042  SV* const oreplsv = GvSV(PL_replgv);
3043  /* these three flags are set by various ops to signal information to
3044  * the very next op. They have a useful lifetime of exactly one loop
3045  * iteration, and are not preserved or restored by state pushes/pops
3046  */
3047  bool sw = 0;     /* the condition value in (?(cond)a|b) */
3048  bool minmod = 0;     /* the next "{n,m}" is a "{n,m}?" */
3049  int logical = 0;     /* the following EVAL is:
3050         0: (?{...})
3051         1: (?(?{...})X|Y)
3052         2: (??{...})
3053        or the following IFMATCH/UNLESSM is:
3054         false: plain (?=foo)
3055         true:  used as a condition: (?(?=foo))
3056        */
3057 #ifdef DEBUGGING
3058  GET_RE_DEBUG_FLAGS_DECL;
3059 #endif
3060
3061  PERL_ARGS_ASSERT_REGMATCH;
3062
3063  DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
3064    PerlIO_printf(Perl_debug_log,"regmatch start\n");
3065  }));
3066  /* on first ever call to regmatch, allocate first slab */
3067  if (!PL_regmatch_slab) {
3068   Newx(PL_regmatch_slab, 1, regmatch_slab);
3069   PL_regmatch_slab->prev = NULL;
3070   PL_regmatch_slab->next = NULL;
3071   PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
3072  }
3073
3074  oldsave = PL_savestack_ix;
3075  SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
3076  SAVEVPTR(PL_regmatch_slab);
3077  SAVEVPTR(PL_regmatch_state);
3078
3079  /* grab next free state slot */
3080  st = ++PL_regmatch_state;
3081  if (st >  SLAB_LAST(PL_regmatch_slab))
3082   st = PL_regmatch_state = S_push_slab(aTHX);
3083
3084  /* Note that nextchr is a byte even in UTF */
3085  nextchr = UCHARAT(locinput);
3086  scan = prog;
3087  while (scan != NULL) {
3088
3089   DEBUG_EXECUTE_r( {
3090    SV * const prop = sv_newmortal();
3091    regnode *rnext=regnext(scan);
3092    DUMP_EXEC_POS( locinput, scan, utf8_target );
3093    regprop(rex, prop, scan);
3094
3095    PerlIO_printf(Perl_debug_log,
3096      "%3"IVdf":%*s%s(%"IVdf")\n",
3097      (IV)(scan - rexi->program), depth*2, "",
3098      SvPVX_const(prop),
3099      (PL_regkind[OP(scan)] == END || !rnext) ?
3100       0 : (IV)(rnext - rexi->program));
3101   });
3102
3103   next = scan + NEXT_OFF(scan);
3104   if (next == scan)
3105    next = NULL;
3106   state_num = OP(scan);
3107
3108   REH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);
3109  reenter_switch:
3110
3111   assert(PL_reglastparen == &rex->lastparen);
3112   assert(PL_reglastcloseparen == &rex->lastcloseparen);
3113   assert(PL_regoffs == rex->offs);
3114
3115   switch (state_num) {
3116   case BOL:
3117    if (locinput == PL_bostr)
3118    {
3119     /* reginfo->till = reginfo->bol; */
3120     break;
3121    }
3122    sayNO;
3123   case MBOL:
3124    if (locinput == PL_bostr ||
3125     ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
3126    {
3127     break;
3128    }
3129    sayNO;
3130   case SBOL:
3131    if (locinput == PL_bostr)
3132     break;
3133    sayNO;
3134   case GPOS:
3135    if (locinput == reginfo->ganch)
3136     break;
3137    sayNO;
3138
3139   case KEEPS:
3140    /* update the startpoint */
3141    st->u.keeper.val = PL_regoffs[0].start;
3142    PL_reginput = locinput;
3143    PL_regoffs[0].start = locinput - PL_bostr;
3144    PUSH_STATE_GOTO(KEEPS_next, next);
3145    /*NOT-REACHED*/
3146   case KEEPS_next_fail:
3147    /* rollback the start point change */
3148    PL_regoffs[0].start = st->u.keeper.val;
3149    sayNO_SILENT;
3150    /*NOT-REACHED*/
3151   case EOL:
3152     goto seol;
3153   case MEOL:
3154    if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3155     sayNO;
3156    break;
3157   case SEOL:
3158   seol:
3159    if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3160     sayNO;
3161    if (PL_regeol - locinput > 1)
3162     sayNO;
3163    break;
3164   case EOS:
3165    if (PL_regeol != locinput)
3166     sayNO;
3167    break;
3168   case SANY:
3169    if (!nextchr && locinput >= PL_regeol)
3170     sayNO;
3171    if (utf8_target) {
3172     locinput += PL_utf8skip[nextchr];
3173     if (locinput > PL_regeol)
3174      sayNO;
3175     nextchr = UCHARAT(locinput);
3176    }
3177    else
3178     nextchr = UCHARAT(++locinput);
3179    break;
3180   case CANY:
3181    if (!nextchr && locinput >= PL_regeol)
3182     sayNO;
3183    nextchr = UCHARAT(++locinput);
3184    break;
3185   case REG_ANY:
3186    if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
3187     sayNO;
3188    if (utf8_target) {
3189     locinput += PL_utf8skip[nextchr];
3190     if (locinput > PL_regeol)
3191      sayNO;
3192     nextchr = UCHARAT(locinput);
3193    }
3194    else
3195     nextchr = UCHARAT(++locinput);
3196    break;
3197
3198 #undef  ST
3199 #define ST st->u.trie
3200   case TRIEC:
3201    /* In this case the charclass data is available inline so
3202    we can fail fast without a lot of extra overhead.
3203    */
3204    if (scan->flags == EXACT || !utf8_target) {
3205     if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3206      DEBUG_EXECUTE_r(
3207       PerlIO_printf(Perl_debug_log,
3208          "%*s  %sfailed to match trie start class...%s\n",
3209          REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3210      );
3211      sayNO_SILENT;
3212      /* NOTREACHED */
3213     }
3214    }
3215    /* FALL THROUGH */
3216   case TRIE:
3217    /* the basic plan of execution of the trie is:
3218    * At the beginning, run though all the states, and
3219    * find the longest-matching word. Also remember the position
3220    * of the shortest matching word. For example, this pattern:
3221    *    1  2 3 4    5
3222    *    ab|a|x|abcd|abc
3223    * when matched against the string "abcde", will generate
3224    * accept states for all words except 3, with the longest
3225    * matching word being 4, and the shortest being 1 (with
3226    * the position being after char 1 of the string).
3227    *
3228    * Then for each matching word, in word order (i.e. 1,2,4,5),
3229    * we run the remainder of the pattern; on each try setting
3230    * the current position to the character following the word,
3231    * returning to try the next word on failure.
3232    *
3233    * We avoid having to build a list of words at runtime by
3234    * using a compile-time structure, wordinfo[].prev, which
3235    * gives, for each word, the previous accepting word (if any).
3236    * In the case above it would contain the mappings 1->2, 2->0,
3237    * 3->0, 4->5, 5->1.  We can use this table to generate, from
3238    * the longest word (4 above), a list of all words, by
3239    * following the list of prev pointers; this gives us the
3240    * unordered list 4,5,1,2. Then given the current word we have
3241    * just tried, we can go through the list and find the
3242    * next-biggest word to try (so if we just failed on word 2,
3243    * the next in the list is 4).
3244    *
3245    * Since at runtime we don't record the matching position in
3246    * the string for each word, we have to work that out for
3247    * each word we're about to process. The wordinfo table holds
3248    * the character length of each word; given that we recorded
3249    * at the start: the position of the shortest word and its
3250    * length in chars, we just need to move the pointer the
3251    * difference between the two char lengths. Depending on
3252    * Unicode status and folding, that's cheap or expensive.
3253    *
3254    * This algorithm is optimised for the case where are only a
3255    * small number of accept states, i.e. 0,1, or maybe 2.
3256    * With lots of accepts states, and having to try all of them,
3257    * it becomes quadratic on number of accept states to find all
3258    * the next words.
3259    */
3260
3261    {
3262     /* what type of TRIE am I? (utf8 makes this contextual) */
3263     DECL_TRIE_TYPE(scan);
3264
3265     /* what trie are we using right now */
3266     reg_trie_data * const trie
3267      = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3268     HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3269     U32 state = trie->startstate;
3270
3271     if (trie->bitmap && trie_type != trie_utf8_fold &&
3272      !TRIE_BITMAP_TEST(trie,*locinput)
3273     ) {
3274      if (trie->states[ state ].wordnum) {
3275       DEBUG_EXECUTE_r(
3276        PerlIO_printf(Perl_debug_log,
3277           "%*s  %smatched empty string...%s\n",
3278           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3279       );
3280       if (!trie->jump)
3281        break;
3282      } else {
3283       DEBUG_EXECUTE_r(
3284        PerlIO_printf(Perl_debug_log,
3285           "%*s  %sfailed to match trie start class...%s\n",
3286           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3287       );
3288       sayNO_SILENT;
3289     }
3290     }
3291
3292    {
3293     U8 *uc = ( U8* )locinput;
3294
3295     STRLEN len = 0;
3296     STRLEN foldlen = 0;
3297     U8 *uscan = (U8*)NULL;
3298     U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3299     U32 charcount = 0; /* how many input chars we have matched */
3300     U32 accepted = 0; /* have we seen any accepting states? */
3301
3302     ST.B = next;
3303     ST.jump = trie->jump;
3304     ST.me = scan;
3305     ST.firstpos = NULL;
3306     ST.longfold = FALSE; /* char longer if folded => it's harder */
3307     ST.nextword = 0;
3308
3309     /* fully traverse the TRIE; note the position of the
3310     shortest accept state and the wordnum of the longest
3311     accept state */
3312
3313     while ( state && uc <= (U8*)PL_regeol ) {
3314      U32 base = trie->states[ state ].trans.base;
3315      UV uvc = 0;
3316      U16 charid = 0;
3317      U16 wordnum;
3318      wordnum = trie->states[ state ].wordnum;
3319
3320      if (wordnum) { /* it's an accept state */
3321       if (!accepted) {
3322        accepted = 1;
3323        /* record first match position */
3324        if (ST.longfold) {
3325         ST.firstpos = (U8*)locinput;
3326         ST.firstchars = 0;
3327        }
3328        else {
3329         ST.firstpos = uc;
3330         ST.firstchars = charcount;
3331        }
3332       }
3333       if (!ST.nextword || wordnum < ST.nextword)
3334        ST.nextword = wordnum;
3335       ST.topword = wordnum;
3336      }
3337
3338      DEBUG_TRIE_EXECUTE_r({
3339         DUMP_EXEC_POS( (char *)uc, scan, utf8_target );
3340         PerlIO_printf( Perl_debug_log,
3341          "%*s  %sState: %4"UVxf" Accepted: %c ",
3342          2+depth * 2, "", PL_colors[4],
3343          (UV)state, (accepted ? 'Y' : 'N'));
3344      });
3345
3346      /* read a char and goto next state */
3347      if ( base ) {
3348       I32 offset;
3349       REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3350            uscan, len, uvc, charid, foldlen,
3351            foldbuf, uniflags);
3352       charcount++;
3353       if (foldlen>0)
3354        ST.longfold = TRUE;
3355       if (charid &&
3356        ( ((offset =
3357        base + charid - 1 - trie->uniquecharcount)) >= 0)
3358
3359        && ((U32)offset < trie->lasttrans)
3360        && trie->trans[offset].check == state)
3361       {
3362        state = trie->trans[offset].next;
3363       }
3364       else {
3365        state = 0;
3366       }
3367       uc += len;
3368
3369      }
3370      else {
3371       state = 0;
3372      }
3373      DEBUG_TRIE_EXECUTE_r(
3374       PerlIO_printf( Perl_debug_log,
3375        "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3376        charid, uvc, (UV)state, PL_colors[5] );
3377      );
3378     }
3379     if (!accepted)
3380     sayNO;
3381
3382     /* calculate total number of accept states */
3383     {
3384      U16 w = ST.topword;
3385      accepted = 0;
3386      while (w) {
3387       w = trie->wordinfo[w].prev;
3388       accepted++;
3389      }
3390      ST.accepted = accepted;
3391     }
3392
3393     DEBUG_EXECUTE_r(
3394      PerlIO_printf( Perl_debug_log,
3395       "%*s  %sgot %"IVdf" possible matches%s\n",
3396       REPORT_CODE_OFF + depth * 2, "",
3397       PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3398     );
3399     goto trie_first_try; /* jump into the fail handler */
3400    }}
3401    /* NOTREACHED */
3402
3403   case TRIE_next_fail: /* we failed - try next alternative */
3404    if ( ST.jump) {
3405     REGCP_UNWIND(ST.cp);
3406     for (n = *PL_reglastparen; n > ST.lastparen; n--)
3407      PL_regoffs[n].end = -1;
3408     *PL_reglastparen = n;
3409    }
3410    if (!--ST.accepted) {
3411     DEBUG_EXECUTE_r({
3412      PerlIO_printf( Perl_debug_log,
3413       "%*s  %sTRIE failed...%s\n",
3414       REPORT_CODE_OFF+depth*2, "",
3415       PL_colors[4],
3416       PL_colors[5] );
3417     });
3418     sayNO_SILENT;
3419    }
3420    {
3421     /* Find next-highest word to process.  Note that this code
3422     * is O(N^2) per trie run (O(N) per branch), so keep tight */
3423     register U16 min = 0;
3424     register U16 word;
3425     register U16 const nextword = ST.nextword;
3426     register reg_trie_wordinfo * const wordinfo
3427      = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo;
3428     for (word=ST.topword; word; word=wordinfo[word].prev) {
3429      if (word > nextword && (!min || word < min))
3430       min = word;
3431     }
3432     ST.nextword = min;
3433    }
3434
3435   trie_first_try:
3436    if (do_cutgroup) {
3437     do_cutgroup = 0;
3438     no_final = 0;
3439    }
3440
3441    if ( ST.jump) {
3442     ST.lastparen = *PL_reglastparen;
3443     REGCP_SET(ST.cp);
3444    }
3445
3446    /* find start char of end of current word */
3447    {
3448     U32 chars; /* how many chars to skip */
3449     U8 *uc = ST.firstpos;
3450     reg_trie_data * const trie
3451      = (reg_trie_data*)rexi->data->data[ARG(ST.me)];
3452
3453     assert((trie->wordinfo[ST.nextword].len - trie->prefixlen)
3454        >=  ST.firstchars);
3455     chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen)
3456        - ST.firstchars;
3457
3458     if (ST.longfold) {
3459      /* the hard option - fold each char in turn and find
3460      * its folded length (which may be different */
3461      U8 foldbuf[UTF8_MAXBYTES_CASE + 1];
3462      STRLEN foldlen;
3463      STRLEN len;
3464      UV uvc;
3465      U8 *uscan;
3466
3467      while (chars) {
3468       if (utf8_target) {
3469        uvc = utf8n_to_uvuni((U8*)uc, UTF8_MAXLEN, &len,
3470              uniflags);
3471        uc += len;
3472       }
3473       else {
3474        uvc = *uc;
3475        uc++;
3476       }
3477       uvc = to_uni_fold(uvc, foldbuf, &foldlen);
3478       uscan = foldbuf;
3479       while (foldlen) {
3480        if (!--chars)
3481         break;
3482        uvc = utf8n_to_uvuni(uscan, UTF8_MAXLEN, &len,
3483            uniflags);
3484        uscan += len;
3485        foldlen -= len;
3486       }
3487      }
3488     }
3489     else {
3490      if (utf8_target)
3491       while (chars--)
3492        uc += UTF8SKIP(uc);
3493      else
3494       uc += chars;
3495     }
3496     PL_reginput = (char *)uc;
3497    }
3498
3499    scan = (ST.jump && ST.jump[ST.nextword])
3500       ? ST.me + ST.jump[ST.nextword]
3501       : ST.B;
3502
3503    DEBUG_EXECUTE_r({
3504     PerlIO_printf( Perl_debug_log,
3505      "%*s  %sTRIE matched word #%d, continuing%s\n",
3506      REPORT_CODE_OFF+depth*2, "",
3507      PL_colors[4],
3508      ST.nextword,
3509      PL_colors[5]
3510      );
3511    });
3512
3513    if (ST.accepted > 1 || has_cutgroup) {
3514     PUSH_STATE_GOTO(TRIE_next, scan);
3515     /* NOTREACHED */
3516    }
3517    /* only one choice left - just continue */
3518    DEBUG_EXECUTE_r({
3519     AV *const trie_words
3520      = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3521     SV ** const tmp = av_fetch( trie_words,
3522      ST.nextword-1, 0 );
3523     SV *sv= tmp ? sv_newmortal() : NULL;
3524
3525     PerlIO_printf( Perl_debug_log,
3526      "%*s  %sonly one match left, short-circuiting: #%d <%s>%s\n",
3527      REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3528      ST.nextword,
3529      tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3530        PL_colors[0], PL_colors[1],
3531        (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII
3532       )
3533      : "not compiled under -Dr",
3534      PL_colors[5] );
3535    });
3536
3537    locinput = PL_reginput;
3538    nextchr = UCHARAT(locinput);
3539    continue; /* execute rest of RE */
3540    /* NOTREACHED */
3541 #undef  ST
3542
3543   case EXACT: {
3544    char *s = STRING(scan);
3545    ln = STR_LEN(scan);
3546    if (utf8_target != UTF_PATTERN) {
3547     /* The target and the pattern have differing utf8ness. */
3548     char *l = locinput;
3549     const char * const e = s + ln;
3550
3551     if (utf8_target) {
3552      /* The target is utf8, the pattern is not utf8. */
3553      while (s < e) {
3554       STRLEN ulen;
3555       if (l >= PL_regeol)
3556        sayNO;
3557       if (NATIVE_TO_UNI(*(U8*)s) !=
3558        utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3559            uniflags))
3560        sayNO;
3561       l += ulen;
3562       s ++;
3563      }
3564     }
3565     else {
3566      /* The target is not utf8, the pattern is utf8. */
3567      while (s < e) {
3568       STRLEN ulen;
3569       if (l >= PL_regeol)
3570        sayNO;
3571       if (NATIVE_TO_UNI(*((U8*)l)) !=
3572        utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3573           uniflags))
3574        sayNO;
3575       s += ulen;
3576       l ++;
3577      }
3578     }
3579     locinput = l;
3580     nextchr = UCHARAT(locinput);
3581     break;
3582    }
3583    /* The target and the pattern have the same utf8ness. */
3584    /* Inline the first character, for speed. */
3585    if (UCHARAT(s) != nextchr)
3586     sayNO;
3587    if (PL_regeol - locinput < ln)
3588     sayNO;
3589    if (ln > 1 && memNE(s, locinput, ln))
3590     sayNO;
3591    locinput += ln;
3592    nextchr = UCHARAT(locinput);
3593    break;
3594    }
3595   case EXACTFL: {
3596    re_fold_t folder;
3597    const U8 * fold_array;
3598    const char * s;
3599    U32 fold_utf8_flags;
3600
3601    PL_reg_flags |= RF_tainted;
3602    folder = foldEQ_locale;
3603    fold_array = PL_fold_locale;
3604    fold_utf8_flags = FOLDEQ_UTF8_LOCALE;
3605    goto do_exactf;
3606
3607   case EXACTFU:
3608    folder = foldEQ_latin1;
3609    fold_array = PL_fold_latin1;
3610    fold_utf8_flags = 0;
3611    goto do_exactf;
3612
3613   case EXACTFA:
3614    folder = foldEQ_latin1;
3615    fold_array = PL_fold_latin1;
3616    fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
3617    goto do_exactf;
3618
3619   case EXACTF:
3620    folder = foldEQ;
3621    fold_array = PL_fold;
3622    fold_utf8_flags = 0;
3623
3624   do_exactf:
3625    s = STRING(scan);
3626    ln = STR_LEN(scan);
3627
3628    if (utf8_target || UTF_PATTERN) {
3629    /* Either target or the pattern are utf8. */
3630     const char * const l = locinput;
3631     char *e = PL_regeol;
3632
3633     if (! foldEQ_utf8_flags(s, 0,  ln, cBOOL(UTF_PATTERN),
3634        l, &e, 0,  utf8_target, fold_utf8_flags))
3635     {
3636      sayNO;
3637     }
3638     locinput = e;
3639     nextchr = UCHARAT(locinput);
3640     break;
3641    }
3642
3643    /* Neither the target nor the pattern are utf8 */
3644    if (UCHARAT(s) != nextchr &&
3645     UCHARAT(s) != fold_array[nextchr])
3646    {
3647     sayNO;
3648    }
3649    if (PL_regeol - locinput < ln)
3650     sayNO;
3651    if (ln > 1 && ! folder(s, locinput, ln))
3652     sayNO;
3653    locinput += ln;
3654    nextchr = UCHARAT(locinput);
3655    break;
3656   }
3657
3658   /* XXX Could improve efficiency by separating these all out using a
3659   * macro or in-line function.  At that point regcomp.c would no longer
3660   * have to set the FLAGS fields of these */
3661   case BOUNDL:
3662   case NBOUNDL:
3663    PL_reg_flags |= RF_tainted;
3664    /* FALL THROUGH */
3665   case BOUND:
3666   case BOUNDU:
3667   case BOUNDA:
3668   case NBOUND:
3669   case NBOUNDU:
3670   case NBOUNDA:
3671    /* was last char in word? */
3672    if (utf8_target
3673     && FLAGS(scan) != REGEX_ASCII_RESTRICTED_CHARSET
3674     && FLAGS(scan) != REGEX_ASCII_MORE_RESTRICTED_CHARSET)
3675    {
3676     if (locinput == PL_bostr)
3677      ln = '\n';
3678     else {
3679      const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3680
3681      ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3682     }
3683     if (FLAGS(scan) != REGEX_LOCALE_CHARSET) {
3684      ln = isALNUM_uni(ln);
3685      LOAD_UTF8_CHARCLASS_ALNUM();
3686      n = swash_fetch(PL_utf8_alnum, (U8*)locinput, utf8_target);
3687     }
3688     else {
3689      ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3690      n = isALNUM_LC_utf8((U8*)locinput);
3691     }
3692    }
3693    else {
3694
3695     /* Here the string isn't utf8, or is utf8 and only ascii
3696     * characters are to match \w.  In the latter case looking at
3697     * the byte just prior to the current one may be just the final
3698     * byte of a multi-byte character.  This is ok.  There are two
3699     * cases:
3700     * 1) it is a single byte character, and then the test is doing
3701     * just what it's supposed to.
3702     * 2) it is a multi-byte character, in which case the final
3703     * byte is never mistakable for ASCII, and so the test
3704     * will say it is not a word character, which is the
3705     * correct answer. */
3706     ln = (locinput != PL_bostr) ?
3707      UCHARAT(locinput - 1) : '\n';
3708     switch (FLAGS(scan)) {
3709      case REGEX_UNICODE_CHARSET:
3710       ln = isWORDCHAR_L1(ln);
3711       n = isWORDCHAR_L1(nextchr);
3712       break;
3713      case REGEX_LOCALE_CHARSET:
3714       ln = isALNUM_LC(ln);
3715       n = isALNUM_LC(nextchr);
3716       break;
3717      case REGEX_DEPENDS_CHARSET:
3718       ln = isALNUM(ln);
3719       n = isALNUM(nextchr);
3720       break;
3721      case REGEX_ASCII_RESTRICTED_CHARSET:
3722      case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
3723       ln = isWORDCHAR_A(ln);
3724       n = isWORDCHAR_A(nextchr);
3725       break;
3726      default:
3727       Perl_croak(aTHX_ "panic: Unexpected FLAGS %u in op %u", FLAGS(scan), OP(scan));
3728       break;
3729     }
3730    }
3731    /* Note requires that all BOUNDs be lower than all NBOUNDs in
3732    * regcomp.sym */
3733    if (((!ln) == (!n)) == (OP(scan) < NBOUND))
3734      sayNO;
3735    break;
3736   case ANYOFV:
3737   case ANYOF:
3738    if (utf8_target || state_num == ANYOFV) {
3739     STRLEN inclasslen = PL_regeol - locinput;
3740     if (locinput >= PL_regeol)
3741      sayNO;
3742
3743     if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, utf8_target))
3744      sayNO;
3745     locinput += inclasslen;
3746     nextchr = UCHARAT(locinput);
3747     break;
3748    }
3749    else {
3750     if (nextchr < 0)
3751      nextchr = UCHARAT(locinput);
3752     if (!nextchr && locinput >= PL_regeol)
3753      sayNO;
3754     if (!REGINCLASS(rex, scan, (U8*)locinput))
3755      sayNO;
3756     nextchr = UCHARAT(++locinput);
3757     break;
3758    }
3759    break;
3760   /* Special char classes - The defines start on line 129 or so */
3761   CCC_TRY_U(ALNUM,  NALNUM,  isWORDCHAR,
3762     ALNUML, NALNUML, isALNUM_LC, isALNUM_LC_utf8,
3763     ALNUMU, NALNUMU, isWORDCHAR_L1,
3764     ALNUMA, NALNUMA, isWORDCHAR_A,
3765     alnum, "a");
3766
3767   CCC_TRY_U(SPACE,  NSPACE,  isSPACE,
3768     SPACEL, NSPACEL, isSPACE_LC, isSPACE_LC_utf8,
3769     SPACEU, NSPACEU, isSPACE_L1,
3770     SPACEA, NSPACEA, isSPACE_A,
3771     space, " ");
3772
3773   CCC_TRY(DIGIT,  NDIGIT,  isDIGIT,
3774     DIGITL, NDIGITL, isDIGIT_LC, isDIGIT_LC_utf8,
3775     DIGITA, NDIGITA, isDIGIT_A,
3776     digit, "0");
3777
3778   case CLUMP: /* Match \X: logical Unicode character.  This is defined as
3779      a Unicode extended Grapheme Cluster */
3780    /* From http://www.unicode.org/reports/tr29 (5.2 version).  An
3781    extended Grapheme Cluster is:
3782
3783    CR LF
3784    | Prepend* Begin Extend*
3785    | .
3786
3787    Begin is (Hangul-syllable | ! Control)
3788    Extend is (Grapheme_Extend | Spacing_Mark)
3789    Control is [ GCB_Control CR LF ]
3790
3791    The discussion below shows how the code for CLUMP is derived
3792    from this regex.  Note that most of these concepts are from
3793    property values of the Grapheme Cluster Boundary (GCB) property.
3794    No code point can have multiple property values for a given
3795    property.  Thus a code point in Prepend can't be in Control, but
3796    it must be in !Control.  This is why Control above includes
3797    GCB_Control plus CR plus LF.  The latter two are used in the GCB
3798    property separately, and so can't be in GCB_Control, even though
3799    they logically are controls.  Control is not the same as gc=cc,
3800    but includes format and other characters as well.
3801
3802    The Unicode definition of Hangul-syllable is:
3803     L+
3804     | (L* ( ( V | LV ) V* | LVT ) T*)
3805     | T+
3806     )
3807    Each of these is a value for the GCB property, and hence must be
3808    disjoint, so the order they are tested is immaterial, so the
3809    above can safely be changed to
3810     T+
3811     | L+
3812     | (L* ( LVT | ( V | LV ) V*) T*)
3813
3814    The last two terms can be combined like this:
3815     L* ( L
3816       | (( LVT | ( V | LV ) V*) T*))
3817
3818    And refactored into this:
3819     L* (L | LVT T* | V  V* T* | LV  V* T*)
3820
3821    That means that if we have seen any L's at all we can quit
3822    there, but if the next character is a LVT, a V or and LV we
3823    should keep going.
3824
3825    There is a subtlety with Prepend* which showed up in testing.
3826    Note that the Begin, and only the Begin is required in:
3827     | Prepend* Begin Extend*
3828    Also, Begin contains '! Control'.  A Prepend must be a '!
3829    Control', which means it must be a Begin.  What it comes down to
3830    is that if we match Prepend* and then find no suitable Begin
3831    afterwards, that if we backtrack the last Prepend, that one will
3832    be a suitable Begin.
3833    */
3834
3835    if (locinput >= PL_regeol)
3836     sayNO;
3837    if  (! utf8_target) {
3838
3839     /* Match either CR LF  or '.', as all the other possibilities
3840     * require utf8 */
3841     locinput++;     /* Match the . or CR */
3842     if (nextchr == '\r'
3843      && locinput < PL_regeol
3844      && UCHARAT(locinput) == '\n') locinput++;
3845    }
3846    else {
3847
3848     /* Utf8: See if is ( CR LF ); already know that locinput <
3849     * PL_regeol, so locinput+1 is in bounds */
3850     if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
3851      locinput += 2;
3852     }
3853     else {
3854      /* In case have to backtrack to beginning, then match '.' */
3855      char *starting = locinput;
3856
3857      /* In case have to backtrack the last prepend */
3858      char *previous_prepend = 0;
3859
3860      LOAD_UTF8_CHARCLASS_GCB();
3861
3862      /* Match (prepend)* */
3863      while (locinput < PL_regeol
3864       && swash_fetch(PL_utf8_X_prepend,
3865           (U8*)locinput, utf8_target))
3866      {
3867       previous_prepend = locinput;
3868       locinput += UTF8SKIP(locinput);
3869      }
3870
3871      /* As noted above, if we matched a prepend character, but
3872      * the next thing won't match, back off the last prepend we
3873      * matched, as it is guaranteed to match the begin */
3874      if (previous_prepend
3875       && (locinput >=  PL_regeol
3876        || ! swash_fetch(PL_utf8_X_begin,
3877            (U8*)locinput, utf8_target)))
3878      {
3879       locinput = previous_prepend;
3880      }
3881
3882      /* Note that here we know PL_regeol > locinput, as we
3883      * tested that upon input to this switch case, and if we
3884      * moved locinput forward, we tested the result just above
3885      * and it either passed, or we backed off so that it will
3886      * now pass */
3887      if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, utf8_target)) {
3888
3889       /* Here did not match the required 'Begin' in the
3890       * second term.  So just match the very first
3891       * character, the '.' of the final term of the regex */
3892       locinput = starting + UTF8SKIP(starting);
3893      } else {
3894
3895       /* Here is the beginning of a character that can have
3896       * an extender.  It is either a hangul syllable, or a
3897       * non-control */
3898       if (swash_fetch(PL_utf8_X_non_hangul,
3899           (U8*)locinput, utf8_target))
3900       {
3901
3902        /* Here not a Hangul syllable, must be a
3903        * ('!  * Control') */
3904        locinput += UTF8SKIP(locinput);
3905       } else {
3906
3907        /* Here is a Hangul syllable.  It can be composed
3908        * of several individual characters.  One
3909        * possibility is T+ */
3910        if (swash_fetch(PL_utf8_X_T,
3911            (U8*)locinput, utf8_target))
3912        {
3913         while (locinput < PL_regeol
3914           && swash_fetch(PL_utf8_X_T,
3915               (U8*)locinput, utf8_target))
3916         {
3917          locinput += UTF8SKIP(locinput);
3918         }
3919        } else {
3920
3921         /* Here, not T+, but is a Hangul.  That means
3922         * it is one of the others: L, LV, LVT or V,
3923         * and matches:
3924         * L* (L | LVT T* | V  V* T* | LV  V* T*) */
3925
3926         /* Match L*           */
3927         while (locinput < PL_regeol
3928           && swash_fetch(PL_utf8_X_L,
3929               (U8*)locinput, utf8_target))
3930         {
3931          locinput += UTF8SKIP(locinput);
3932         }
3933
3934         /* Here, have exhausted L*.  If the next
3935         * character is not an LV, LVT nor V, it means
3936         * we had to have at least one L, so matches L+
3937         * in the original equation, we have a complete
3938         * hangul syllable.  Are done. */
3939
3940         if (locinput < PL_regeol
3941          && swash_fetch(PL_utf8_X_LV_LVT_V,
3942              (U8*)locinput, utf8_target))
3943         {
3944
3945          /* Otherwise keep going.  Must be LV, LVT
3946          * or V.  See if LVT */
3947          if (swash_fetch(PL_utf8_X_LVT,
3948              (U8*)locinput, utf8_target))
3949          {
3950           locinput += UTF8SKIP(locinput);
3951          } else {
3952
3953           /* Must be  V or LV.  Take it, then
3954           * match V*     */
3955           locinput += UTF8SKIP(locinput);
3956           while (locinput < PL_regeol
3957             && swash_fetch(PL_utf8_X_V,
3958               (U8*)locinput, utf8_target))
3959           {
3960            locinput += UTF8SKIP(locinput);
3961           }
3962          }
3963
3964          /* And any of LV, LVT, or V can be followed
3965          * by T*            */
3966          while (locinput < PL_regeol
3967           && swash_fetch(PL_utf8_X_T,
3968               (U8*)locinput,
3969               utf8_target))
3970          {
3971           locinput += UTF8SKIP(locinput);
3972          }
3973         }
3974        }
3975       }
3976
3977       /* Match any extender */
3978       while (locinput < PL_regeol
3979         && swash_fetch(PL_utf8_X_extend,
3980             (U8*)locinput, utf8_target))
3981       {
3982        locinput += UTF8SKIP(locinput);
3983       }
3984      }
3985     }
3986     if (locinput > PL_regeol) sayNO;
3987    }
3988    nextchr = UCHARAT(locinput);
3989    break;
3990
3991   case NREFFL:
3992   {   /* The capture buffer cases.  The ones beginning with N for the
3993    named buffers just convert to the equivalent numbered and
3994    pretend they were called as the corresponding numbered buffer
3995    op.  */
3996    /* don't initialize these in the declaration, it makes C++
3997    unhappy */
3998    char *s;
3999    char type;
4000    re_fold_t folder;
4001    const U8 *fold_array;
4002    UV utf8_fold_flags;
4003
4004    PL_reg_flags |= RF_tainted;
4005    folder = foldEQ_locale;
4006    fold_array = PL_fold_locale;
4007    type = REFFL;
4008    utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
4009    goto do_nref;
4010
4011   case NREFFA:
4012    folder = foldEQ_latin1;
4013    fold_array = PL_fold_latin1;
4014    type = REFFA;
4015    utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4016    goto do_nref;
4017
4018   case NREFFU:
4019    folder = foldEQ_latin1;
4020    fold_array = PL_fold_latin1;
4021    type = REFFU;
4022    utf8_fold_flags = 0;
4023    goto do_nref;
4024
4025   case NREFF:
4026    folder = foldEQ;
4027    fold_array = PL_fold;
4028    type = REFF;
4029    utf8_fold_flags = 0;
4030    goto do_nref;
4031
4032   case NREF:
4033    type = REF;
4034    folder = NULL;
4035    fold_array = NULL;
4036    utf8_fold_flags = 0;
4037   do_nref:
4038
4039    /* For the named back references, find the corresponding buffer
4040    * number */
4041    n = reg_check_named_buff_matched(rex,scan);
4042
4043    if ( ! n ) {
4044     sayNO;
4045    }
4046    goto do_nref_ref_common;
4047
4048   case REFFL:
4049    PL_reg_flags |= RF_tainted;
4050    folder = foldEQ_locale;
4051    fold_array = PL_fold_locale;
4052    utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
4053    goto do_ref;
4054
4055   case REFFA:
4056    folder = foldEQ_latin1;
4057    fold_array = PL_fold_latin1;
4058    utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4059    goto do_ref;
4060
4061   case REFFU:
4062    folder = foldEQ_latin1;
4063    fold_array = PL_fold_latin1;
4064    utf8_fold_flags = 0;
4065    goto do_ref;
4066
4067   case REFF:
4068    folder = foldEQ;
4069    fold_array = PL_fold;
4070    utf8_fold_flags = 0;
4071    goto do_ref;
4072
4073   case REF:
4074    folder = NULL;
4075    fold_array = NULL;
4076    utf8_fold_flags = 0;
4077
4078   do_ref:
4079    type = OP(scan);
4080    n = ARG(scan);  /* which paren pair */
4081
4082   do_nref_ref_common:
4083    ln = PL_regoffs[n].start;
4084    PL_reg_leftiter = PL_reg_maxiter;  /* Void cache */
4085    if (*PL_reglastparen < n || ln == -1)
4086     sayNO;   /* Do not match unless seen CLOSEn. */
4087    if (ln == PL_regoffs[n].end)
4088     break;
4089
4090    s = PL_bostr + ln;
4091    if (type != REF /* REF can do byte comparison */
4092     && (utf8_target || type == REFFU))
4093    { /* XXX handle REFFL better */
4094     char * limit = PL_regeol;
4095
4096     /* This call case insensitively compares the entire buffer
4097      * at s, with the current input starting at locinput, but
4098      * not going off the end given by PL_regeol, and returns in
4099      * limit upon success, how much of the current input was
4100      * matched */
4101     if (! foldEQ_utf8_flags(s, NULL, PL_regoffs[n].end - ln, utf8_target,
4102          locinput, &limit, 0, utf8_target, utf8_fold_flags))
4103     {
4104      sayNO;
4105     }
4106     locinput = limit;
4107     nextchr = UCHARAT(locinput);
4108     break;
4109    }
4110
4111    /* Not utf8:  Inline the first character, for speed. */
4112    if (UCHARAT(s) != nextchr &&
4113     (type == REF ||
4114     UCHARAT(s) != fold_array[nextchr]))
4115     sayNO;
4116    ln = PL_regoffs[n].end - ln;
4117    if (locinput + ln > PL_regeol)
4118     sayNO;
4119    if (ln > 1 && (type == REF
4120       ? memNE(s, locinput, ln)
4121       : ! folder(s, locinput, ln)))
4122     sayNO;
4123    locinput += ln;
4124    nextchr = UCHARAT(locinput);
4125    break;
4126   }
4127   case NOTHING:
4128   case TAIL:
4129    break;
4130   case BACK:
4131    break;
4132
4133 #undef  ST
4134 #define ST st->u.eval
4135   {
4136    SV *ret;
4137    REGEXP *re_sv;
4138    regexp *re;
4139    regexp_internal *rei;
4140    regnode *startpoint;
4141
4142   case GOSTART:
4143   case GOSUB: /*    /(...(?1))/   /(...(?&foo))/   */
4144    if (cur_eval && cur_eval->locinput==locinput) {
4145     if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
4146      Perl_croak(aTHX_ "Infinite recursion in regex");
4147     if ( ++nochange_depth > max_nochange_depth )
4148      Perl_croak(aTHX_
4149       "Pattern subroutine nesting without pos change"
4150       " exceeded limit in regex");
4151    } else {
4152     nochange_depth = 0;
4153    }
4154    re_sv = rex_sv;
4155    re = rex;
4156    rei = rexi;
4157    (void)ReREFCNT_inc(rex_sv);
4158    if (OP(scan)==GOSUB) {
4159     startpoint = scan + ARG2L(scan);
4160     ST.close_paren = ARG(scan);
4161    } else {
4162     startpoint = rei->program+1;
4163     ST.close_paren = 0;
4164    }
4165    goto eval_recurse_doit;
4166    /* NOTREACHED */
4167   case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
4168    if (cur_eval && cur_eval->locinput==locinput) {
4169     if ( ++nochange_depth > max_nochange_depth )
4170      Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
4171    } else {
4172     nochange_depth = 0;
4173    }
4174    {
4175     /* execute the code in the {...} */
4176     dSP;
4177     SV ** const before = SP;
4178     OP_4tree * const oop = PL_op;
4179     COP * const ocurcop = PL_curcop;
4180     PAD *old_comppad;
4181     char *saved_regeol = PL_regeol;
4182     struct re_save_state saved_state;
4183
4184     /* To not corrupt the existing regex state while executing the
4185     * eval we would normally put it on the save stack, like with
4186     * save_re_context. However, re-evals have a weird scoping so we
4187     * can't just add ENTER/LEAVE here. With that, things like
4188     *
4189     *    (?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a})
4190     *
4191     * would break, as they expect the localisation to be unwound
4192     * only when the re-engine backtracks through the bit that
4193     * localised it.
4194     *
4195     * What we do instead is just saving the state in a local c
4196     * variable.
4197     */
4198     Copy(&PL_reg_state, &saved_state, 1, struct re_save_state);
4199
4200     n = ARG(scan);
4201     PL_op = (OP_4tree*)rexi->data->data[n];
4202     DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
4203      "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
4204     PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
4205     PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
4206
4207     if (sv_yes_mark) {
4208      SV *sv_mrk = get_sv("REGMARK", 1);
4209      sv_setsv(sv_mrk, sv_yes_mark);
4210     }
4211
4212     CALLRUNOPS(aTHX);   /* Scalar context. */
4213     SPAGAIN;
4214     if (SP == before)
4215      ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
4216     else {
4217      ret = POPs;
4218      PUTBACK;
4219     }
4220
4221     Copy(&saved_state, &PL_reg_state, 1, struct re_save_state);
4222
4223     PL_op = oop;
4224     PAD_RESTORE_LOCAL(old_comppad);
4225     PL_curcop = ocurcop;
4226     PL_regeol = saved_regeol;
4227     if (!logical) {
4228      /* /(?{...})/ */
4229      sv_setsv(save_scalar(PL_replgv), ret);
4230      break;
4231     }
4232    }
4233    if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
4234     logical = 0;
4235     {
4236      /* extract RE object from returned value; compiling if
4237      * necessary */
4238      MAGIC *mg = NULL;
4239      REGEXP *rx = NULL;
4240
4241      if (SvROK(ret)) {
4242       SV *const sv = SvRV(ret);
4243
4244       if (SvTYPE(sv) == SVt_REGEXP) {
4245        rx = (REGEXP*) sv;
4246       } else if (SvSMAGICAL(sv)) {
4247        mg = mg_find(sv, PERL_MAGIC_qr);
4248        assert(mg);
4249       }
4250      } else if (SvTYPE(ret) == SVt_REGEXP) {
4251       rx = (REGEXP*) ret;
4252      } else if (SvSMAGICAL(ret)) {
4253       if (SvGMAGICAL(ret)) {
4254        /* I don't believe that there is ever qr magic
4255        here.  */
4256        assert(!mg_find(ret, PERL_MAGIC_qr));
4257        sv_unmagic(ret, PERL_MAGIC_qr);
4258       }
4259       else {
4260        mg = mg_find(ret, PERL_MAGIC_qr);
4261        /* testing suggests mg only ends up non-NULL for
4262        scalars who were upgraded and compiled in the
4263        else block below. In turn, this is only
4264        triggered in the "postponed utf8 string" tests
4265        in t/op/pat.t  */
4266       }
4267      }
4268
4269      if (mg) {
4270       rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
4271       assert(rx);
4272      }
4273      if (rx) {
4274       rx = reg_temp_copy(NULL, rx);
4275      }
4276      else {
4277       U32 pm_flags = 0;
4278       const I32 osize = PL_regsize;
4279
4280       if (DO_UTF8(ret)) {
4281        assert (SvUTF8(ret));
4282       } else if (SvUTF8(ret)) {
4283        /* Not doing UTF-8, despite what the SV says. Is
4284        this only if we're trapped in use 'bytes'?  */
4285        /* Make a copy of the octet sequence, but without
4286        the flag on, as the compiler now honours the
4287        SvUTF8 flag on ret.  */
4288        STRLEN len;
4289        const char *const p = SvPV(ret, len);
4290        ret = newSVpvn_flags(p, len, SVs_TEMP);
4291       }
4292       rx = CALLREGCOMP(ret, pm_flags);
4293       if (!(SvFLAGS(ret)
4294        & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
4295         | SVs_GMG))) {
4296        /* This isn't a first class regexp. Instead, it's
4297        caching a regexp onto an existing, Perl visible
4298        scalar.  */
4299        sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
4300       }
4301       PL_regsize = osize;
4302      }
4303      re_sv = rx;
4304      re = (struct regexp *)SvANY(rx);
4305     }
4306     RXp_MATCH_COPIED_off(re);
4307     re->subbeg = rex->subbeg;
4308     re->sublen = rex->sublen;
4309     rei = RXi_GET(re);
4310     DEBUG_EXECUTE_r(
4311      debug_start_match(re_sv, utf8_target, locinput, PL_regeol,
4312       "Matching embedded");
4313     );
4314     startpoint = rei->program + 1;
4315      ST.close_paren = 0; /* only used for GOSUB */
4316      /* borrowed from regtry */
4317     if (PL_reg_start_tmpl <= re->nparens) {
4318      PL_reg_start_tmpl = re->nparens*3/2 + 3;
4319      if(PL_reg_start_tmp)
4320       Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4321      else
4322       Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4323     }
4324
4325   eval_recurse_doit: /* Share code with GOSUB below this line */
4326     /* run the pattern returned from (??{...}) */
4327     ST.cp = regcppush(0); /* Save *all* the positions. */
4328     REGCP_SET(ST.lastcp);
4329
4330     PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
4331
4332     /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
4333     PL_reglastparen = &re->lastparen;
4334     PL_reglastcloseparen = &re->lastcloseparen;
4335     re->lastparen = 0;
4336     re->lastcloseparen = 0;
4337
4338     PL_reginput = locinput;
4339     PL_regsize = 0;
4340
4341     /* XXXX This is too dramatic a measure... */
4342     PL_reg_maxiter = 0;
4343
4344     ST.toggle_reg_flags = PL_reg_flags;
4345     if (RX_UTF8(re_sv))
4346      PL_reg_flags |= RF_utf8;
4347     else
4348      PL_reg_flags &= ~RF_utf8;
4349     ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
4350
4351     ST.prev_rex = rex_sv;
4352     ST.prev_curlyx = cur_curlyx;
4353     SETREX(rex_sv,re_sv);
4354     rex = re;
4355     rexi = rei;
4356     cur_curlyx = NULL;
4357     ST.B = next;
4358     ST.prev_eval = cur_eval;
4359     cur_eval = st;
4360     /* now continue from first node in postoned RE */
4361     PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
4362     /* NOTREACHED */
4363    }
4364    /* logical is 1,   /(?(?{...})X|Y)/ */
4365    sw = cBOOL(SvTRUE(ret));
4366    logical = 0;
4367    break;
4368   }
4369
4370   case EVAL_AB: /* cleanup after a successful (??{A})B */
4371    /* note: this is called twice; first after popping B, then A */
4372    PL_reg_flags ^= ST.toggle_reg_flags;
4373    ReREFCNT_dec(rex_sv);
4374    SETREX(rex_sv,ST.prev_rex);
4375    rex = (struct regexp *)SvANY(rex_sv);
4376    rexi = RXi_GET(rex);
4377    regcpblow(ST.cp);
4378    cur_eval = ST.prev_eval;
4379    cur_curlyx = ST.prev_curlyx;
4380
4381    /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4382    PL_reglastparen = &rex->lastparen;
4383    PL_reglastcloseparen = &rex->lastcloseparen;
4384    /* also update PL_regoffs */
4385    PL_regoffs = rex->offs;
4386
4387    /* XXXX This is too dramatic a measure... */
4388    PL_reg_maxiter = 0;
4389    if ( nochange_depth )
4390     nochange_depth--;
4391    sayYES;
4392
4393
4394   case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
4395    /* note: this is called twice; first after popping B, then A */
4396    PL_reg_flags ^= ST.toggle_reg_flags;
4397    ReREFCNT_dec(rex_sv);
4398    SETREX(rex_sv,ST.prev_rex);
4399    rex = (struct regexp *)SvANY(rex_sv);
4400    rexi = RXi_GET(rex);
4401    /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4402    PL_reglastparen = &rex->lastparen;
4403    PL_reglastcloseparen = &rex->lastcloseparen;
4404
4405    PL_reginput = locinput;
4406    REGCP_UNWIND(ST.lastcp);
4407    regcppop(rex);
4408    cur_eval = ST.prev_eval;
4409    cur_curlyx = ST.prev_curlyx;
4410    /* XXXX This is too dramatic a measure... */
4411    PL_reg_maxiter = 0;
4412    if ( nochange_depth )
4413     nochange_depth--;
4414    sayNO_SILENT;
4415 #undef ST
4416
4417   case OPEN:
4418    n = ARG(scan);  /* which paren pair */
4419    PL_reg_start_tmp[n] = locinput;
4420    if (n > PL_regsize)
4421     PL_regsize = n;
4422    lastopen = n;
4423    break;
4424   case CLOSE:
4425    n = ARG(scan);  /* which paren pair */
4426    PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
4427    PL_regoffs[n].end = locinput - PL_bostr;
4428    /*if (n > PL_regsize)
4429     PL_regsize = n;*/
4430    if (n > *PL_reglastparen)
4431     *PL_reglastparen = n;
4432    *PL_reglastcloseparen = n;
4433    if (cur_eval && cur_eval->u.eval.close_paren == n) {
4434     goto fake_end;
4435    }
4436    break;
4437   case ACCEPT:
4438    if (ARG(scan)){
4439     regnode *cursor;
4440     for (cursor=scan;
4441      cursor && OP(cursor)!=END;
4442      cursor=regnext(cursor))
4443     {
4444      if ( OP(cursor)==CLOSE ){
4445       n = ARG(cursor);
4446       if ( n <= lastopen ) {
4447        PL_regoffs[n].start
4448         = PL_reg_start_tmp[n] - PL_bostr;
4449        PL_regoffs[n].end = locinput - PL_bostr;
4450        /*if (n > PL_regsize)
4451        PL_regsize = n;*/
4452        if (n > *PL_reglastparen)
4453         *PL_reglastparen = n;
4454        *PL_reglastcloseparen = n;
4455        if ( n == ARG(scan) || (cur_eval &&
4456         cur_eval->u.eval.close_paren == n))
4457         break;
4458       }
4459      }
4460     }
4461    }
4462    goto fake_end;
4463    /*NOTREACHED*/
4464   case GROUPP:
4465    n = ARG(scan);  /* which paren pair */
4466    sw = cBOOL(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
4467    break;
4468   case NGROUPP:
4469    /* reg_check_named_buff_matched returns 0 for no match */
4470    sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
4471    break;
4472   case INSUBP:
4473    n = ARG(scan);
4474    sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
4475    break;
4476   case DEFINEP:
4477    sw = 0;
4478    break;
4479   case IFTHEN:
4480    PL_reg_leftiter = PL_reg_maxiter;  /* Void cache */
4481    if (sw)
4482     next = NEXTOPER(NEXTOPER(scan));
4483    else {
4484     next = scan + ARG(scan);
4485     if (OP(next) == IFTHEN) /* Fake one. */
4486      next = NEXTOPER(NEXTOPER(next));
4487    }
4488    break;
4489   case LOGICAL:
4490    logical = scan->flags;
4491    break;
4492
4493 /*******************************************************************
4494
4495 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
4496 pattern, where A and B are subpatterns. (For simple A, CURLYM or
4497 STAR/PLUS/CURLY/CURLYN are used instead.)
4498
4499 A*B is compiled as <CURLYX><A><WHILEM><B>
4500
4501 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
4502 state, which contains the current count, initialised to -1. It also sets
4503 cur_curlyx to point to this state, with any previous value saved in the
4504 state block.
4505
4506 CURLYX then jumps straight to the WHILEM op, rather than executing A,
4507 since the pattern may possibly match zero times (i.e. it's a while {} loop
4508 rather than a do {} while loop).
4509
4510 Each entry to WHILEM represents a successful match of A. The count in the
4511 CURLYX block is incremented, another WHILEM state is pushed, and execution
4512 passes to A or B depending on greediness and the current count.
4513
4514 For example, if matching against the string a1a2a3b (where the aN are
4515 substrings that match /A/), then the match progresses as follows: (the
4516 pushed states are interspersed with the bits of strings matched so far):
4517
4518  <CURLYX cnt=-1>
4519  <CURLYX cnt=0><WHILEM>
4520  <CURLYX cnt=1><WHILEM> a1 <WHILEM>
4521  <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
4522  <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
4523  <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
4524
4525 (Contrast this with something like CURLYM, which maintains only a single
4526 backtrack state:
4527
4528  <CURLYM cnt=0> a1
4529  a1 <CURLYM cnt=1> a2
4530  a1 a2 <CURLYM cnt=2> a3
4531  a1 a2 a3 <CURLYM cnt=3> b
4532 )
4533
4534 Each WHILEM state block marks a point to backtrack to upon partial failure
4535 of A or B, and also contains some minor state data related to that
4536 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
4537 overall state, such as the count, and pointers to the A and B ops.
4538
4539 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
4540 must always point to the *current* CURLYX block, the rules are:
4541
4542 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
4543 and set cur_curlyx to point the new block.
4544
4545 When popping the CURLYX block after a successful or unsuccessful match,
4546 restore the previous cur_curlyx.
4547
4548 When WHILEM is about to execute B, save the current cur_curlyx, and set it
4549 to the outer one saved in the CURLYX block.
4550
4551 When popping the WHILEM block after a successful or unsuccessful B match,
4552 restore the previous cur_curlyx.
4553
4554 Here's an example for the pattern (AI* BI)*BO
4555 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
4556
4557 cur_
4558 curlyx backtrack stack
4559 ------ ---------------
4560 NULL
4561 CO     <CO prev=NULL> <WO>
4562 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4563 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4564 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
4565
4566 At this point the pattern succeeds, and we work back down the stack to
4567 clean up, restoring as we go:
4568
4569 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4570 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4571 CO     <CO prev=NULL> <WO>
4572 NULL
4573
4574 *******************************************************************/
4575
4576 #define ST st->u.curlyx
4577
4578   case CURLYX:    /* start of /A*B/  (for complex A) */
4579   {
4580    /* No need to save/restore up to this paren */
4581    I32 parenfloor = scan->flags;
4582
4583    assert(next); /* keep Coverity happy */
4584    if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4585     next += ARG(next);
4586
4587    /* XXXX Probably it is better to teach regpush to support
4588    parenfloor > PL_regsize... */
4589    if (parenfloor > (I32)*PL_reglastparen)
4590     parenfloor = *PL_reglastparen; /* Pessimization... */
4591
4592    ST.prev_curlyx= cur_curlyx;
4593    cur_curlyx = st;
4594    ST.cp = PL_savestack_ix;
4595
4596    /* these fields contain the state of the current curly.
4597    * they are accessed by subsequent WHILEMs */
4598    ST.parenfloor = parenfloor;
4599    ST.me = scan;
4600    ST.B = next;
4601    ST.minmod = minmod;
4602    minmod = 0;
4603    ST.count = -1; /* this will be updated by WHILEM */
4604    ST.lastloc = NULL;  /* this will be updated by WHILEM */
4605
4606    PL_reginput = locinput;
4607    PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4608    /* NOTREACHED */
4609   }
4610
4611   case CURLYX_end: /* just finished matching all of A*B */
4612    cur_curlyx = ST.prev_curlyx;
4613    sayYES;
4614    /* NOTREACHED */
4615
4616   case CURLYX_end_fail: /* just failed to match all of A*B */
4617    regcpblow(ST.cp);
4618    cur_curlyx = ST.prev_curlyx;
4619    sayNO;
4620    /* NOTREACHED */
4621
4622
4623 #undef ST
4624 #define ST st->u.whilem
4625
4626   case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
4627   {
4628    /* see the discussion above about CURLYX/WHILEM */
4629    I32 n;
4630    int min = ARG1(cur_curlyx->u.curlyx.me);
4631    int max = ARG2(cur_curlyx->u.curlyx.me);
4632    regnode *A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS;
4633
4634    assert(cur_curlyx); /* keep Coverity happy */
4635    n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4636    ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4637    ST.cache_offset = 0;
4638    ST.cache_mask = 0;
4639
4640    PL_reginput = locinput;
4641
4642    DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4643     "%*s  whilem: matched %ld out of %d..%d\n",
4644     REPORT_CODE_OFF+depth*2, "", (long)n, min, max)
4645    );
4646
4647    /* First just match a string of min A's. */
4648
4649    if (n < min) {
4650     ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4651     cur_curlyx->u.curlyx.lastloc = locinput;
4652     REGCP_SET(ST.lastcp);
4653
4654     PUSH_STATE_GOTO(WHILEM_A_pre, A);
4655     /* NOTREACHED */
4656    }
4657
4658    /* If degenerate A matches "", assume A done. */
4659
4660    if (locinput == cur_curlyx->u.curlyx.lastloc) {
4661     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4662     "%*s  whilem: empty match detected, trying continuation...\n",
4663     REPORT_CODE_OFF+depth*2, "")
4664     );
4665     goto do_whilem_B_max;
4666    }
4667
4668    /* super-linear cache processing */
4669
4670    if (scan->flags) {
4671
4672     if (!PL_reg_maxiter) {
4673      /* start the countdown: Postpone detection until we
4674      * know the match is not *that* much linear. */
4675      PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4676      /* possible overflow for long strings and many CURLYX's */
4677      if (PL_reg_maxiter < 0)
4678       PL_reg_maxiter = I32_MAX;
4679      PL_reg_leftiter = PL_reg_maxiter;
4680     }
4681
4682     if (PL_reg_leftiter-- == 0) {
4683      /* initialise cache */
4684      const I32 size = (PL_reg_maxiter + 7)/8;
4685      if (PL_reg_poscache) {
4686       if ((I32)PL_reg_poscache_size < size) {
4687        Renew(PL_reg_poscache, size, char);
4688        PL_reg_poscache_size = size;
4689       }
4690       Zero(PL_reg_poscache, size, char);
4691      }
4692      else {
4693       PL_reg_poscache_size = size;
4694       Newxz(PL_reg_poscache, size, char);
4695      }
4696      DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4697  "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4698        PL_colors[4], PL_colors[5])
4699      );
4700     }
4701
4702     if (PL_reg_leftiter < 0) {
4703      /* have we already failed at this position? */
4704      I32 offset, mask;
4705      offset  = (scan->flags & 0xf) - 1
4706         + (locinput - PL_bostr)  * (scan->flags>>4);
4707      mask    = 1 << (offset % 8);
4708      offset /= 8;
4709      if (PL_reg_poscache[offset] & mask) {
4710       DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4711        "%*s  whilem: (cache) already tried at this position...\n",
4712        REPORT_CODE_OFF+depth*2, "")
4713       );
4714       sayNO; /* cache records failure */
4715      }
4716      ST.cache_offset = offset;
4717      ST.cache_mask   = mask;
4718     }
4719    }
4720
4721    /* Prefer B over A for minimal matching. */
4722
4723    if (cur_curlyx->u.curlyx.minmod) {
4724     ST.save_curlyx = cur_curlyx;
4725     cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4726     ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4727     REGCP_SET(ST.lastcp);
4728     PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4729     /* NOTREACHED */
4730    }
4731
4732    /* Prefer A over B for maximal matching. */
4733
4734    if (n < max) { /* More greed allowed? */
4735     ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4736     cur_curlyx->u.curlyx.lastloc = locinput;
4737     REGCP_SET(ST.lastcp);
4738     PUSH_STATE_GOTO(WHILEM_A_max, A);
4739     /* NOTREACHED */
4740    }
4741    goto do_whilem_B_max;
4742   }
4743   /* NOTREACHED */
4744
4745   case WHILEM_B_min: /* just matched B in a minimal match */
4746   case WHILEM_B_max: /* just matched B in a maximal match */
4747    cur_curlyx = ST.save_curlyx;
4748    sayYES;
4749    /* NOTREACHED */
4750
4751   case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4752    cur_curlyx = ST.save_curlyx;
4753    cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4754    cur_curlyx->u.curlyx.count--;
4755    CACHEsayNO;
4756    /* NOTREACHED */
4757
4758   case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4759    /* FALL THROUGH */
4760   case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4761    REGCP_UNWIND(ST.lastcp);
4762    regcppop(rex);
4763    cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4764    cur_curlyx->u.curlyx.count--;
4765    CACHEsayNO;
4766    /* NOTREACHED */
4767
4768   case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4769    REGCP_UNWIND(ST.lastcp);
4770    regcppop(rex); /* Restore some previous $<digit>s? */
4771    PL_reginput = locinput;
4772    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4773     "%*s  whilem: failed, trying continuation...\n",
4774     REPORT_CODE_OFF+depth*2, "")
4775    );
4776   do_whilem_B_max:
4777    if (cur_curlyx->u.curlyx.count >= REG_INFTY
4778     && ckWARN(WARN_REGEXP)
4779     && !(PL_reg_flags & RF_warned))
4780    {
4781     PL_reg_flags |= RF_warned;
4782     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4783      "Complex regular subexpression recursion",
4784      REG_INFTY - 1);
4785    }
4786
4787    /* now try B */
4788    ST.save_curlyx = cur_curlyx;
4789    cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4790    PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4791    /* NOTREACHED */
4792
4793   case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4794    cur_curlyx = ST.save_curlyx;
4795    REGCP_UNWIND(ST.lastcp);
4796    regcppop(rex);
4797
4798    if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
4799     /* Maximum greed exceeded */
4800     if (cur_curlyx->u.curlyx.count >= REG_INFTY
4801      && ckWARN(WARN_REGEXP)
4802      && !(PL_reg_flags & RF_warned))
4803     {
4804      PL_reg_flags |= RF_warned;
4805      Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4806       "%s limit (%d) exceeded",
4807       "Complex regular subexpression recursion",
4808       REG_INFTY - 1);
4809     }
4810     cur_curlyx->u.curlyx.count--;
4811     CACHEsayNO;
4812    }
4813
4814    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4815     "%*s  trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4816    );
4817    /* Try grabbing another A and see if it helps. */
4818    PL_reginput = locinput;
4819    cur_curlyx->u.curlyx.lastloc = locinput;
4820    ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4821    REGCP_SET(ST.lastcp);
4822    PUSH_STATE_GOTO(WHILEM_A_min,
4823     /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS);
4824    /* NOTREACHED */
4825
4826 #undef  ST
4827 #define ST st->u.branch
4828
4829   case BRANCHJ:     /*  /(...|A|...)/ with long next pointer */
4830    next = scan + ARG(scan);
4831    if (next == scan)
4832     next = NULL;
4833    scan = NEXTOPER(scan);
4834    /* FALL THROUGH */
4835
4836   case BRANCH:     /*  /(...|A|...)/ */
4837    scan = NEXTOPER(scan); /* scan now points to inner node */
4838    ST.lastparen = *PL_reglastparen;
4839    ST.next_branch = next;
4840    REGCP_SET(ST.cp);
4841    PL_reginput = locinput;
4842
4843    /* Now go into the branch */
4844    if (has_cutgroup) {
4845     PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4846    } else {
4847     PUSH_STATE_GOTO(BRANCH_next, scan);
4848    }
4849    /* NOTREACHED */
4850   case CUTGROUP:
4851    PL_reginput = locinput;
4852    sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4853     MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4854    PUSH_STATE_GOTO(CUTGROUP_next,next);
4855    /* NOTREACHED */
4856   case CUTGROUP_next_fail:
4857    do_cutgroup = 1;
4858    no_final = 1;
4859    if (st->u.mark.mark_name)
4860     sv_commit = st->u.mark.mark_name;
4861    sayNO;
4862    /* NOTREACHED */
4863   case BRANCH_next:
4864    sayYES;
4865    /* NOTREACHED */
4866   case BRANCH_next_fail: /* that branch failed; try the next, if any */
4867    if (do_cutgroup) {
4868     do_cutgroup = 0;
4869     no_final = 0;
4870    }
4871    REGCP_UNWIND(ST.cp);
4872    for (n = *PL_reglastparen; n > ST.lastparen; n--)
4873     PL_regoffs[n].end = -1;
4874    *PL_reglastparen = n;
4875    /*dmq: *PL_reglastcloseparen = n; */
4876    scan = ST.next_branch;
4877    /* no more branches? */
4878    if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4879     DEBUG_EXECUTE_r({
4880      PerlIO_printf( Perl_debug_log,
4881       "%*s  %sBRANCH failed...%s\n",
4882       REPORT_CODE_OFF+depth*2, "",
4883       PL_colors[4],
4884       PL_colors[5] );
4885     });
4886     sayNO_SILENT;
4887    }
4888    continue; /* execute next BRANCH[J] op */
4889    /* NOTREACHED */
4890
4891   case MINMOD:
4892    minmod = 1;
4893    break;
4894
4895 #undef  ST
4896 #define ST st->u.curlym
4897
4898   case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4899
4900    /* This is an optimisation of CURLYX that enables us to push
4901    * only a single backtracking state, no matter how many matches
4902    * there are in {m,n}. It relies on the pattern being constant
4903    * length, with no parens to influence future backrefs
4904    */
4905
4906    ST.me = scan;
4907    scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4908
4909    /* if paren positive, emulate an OPEN/CLOSE around A */
4910    if (ST.me->flags) {
4911     U32 paren = ST.me->flags;
4912     if (paren > PL_regsize)
4913      PL_regsize = paren;
4914     if (paren > *PL_reglastparen)
4915      *PL_reglastparen = paren;
4916     scan += NEXT_OFF(scan); /* Skip former OPEN. */
4917    }
4918    ST.A = scan;
4919    ST.B = next;
4920    ST.alen = 0;
4921    ST.count = 0;
4922    ST.minmod = minmod;
4923    minmod = 0;
4924    ST.c1 = CHRTEST_UNINIT;
4925    REGCP_SET(ST.cp);
4926
4927    if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4928     goto curlym_do_B;
4929
4930   curlym_do_A: /* execute the A in /A{m,n}B/  */
4931    PL_reginput = locinput;
4932    PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4933    /* NOTREACHED */
4934
4935   case CURLYM_A: /* we've just matched an A */
4936    locinput = st->locinput;
4937    nextchr = UCHARAT(locinput);
4938
4939    ST.count++;
4940    /* after first match, determine A's length: u.curlym.alen */
4941    if (ST.count == 1) {
4942     if (PL_reg_match_utf8) {
4943      char *s = locinput;
4944      while (s < PL_reginput) {
4945       ST.alen++;
4946       s += UTF8SKIP(s);
4947      }
4948     }
4949     else {
4950      ST.alen = PL_reginput - locinput;
4951     }
4952     if (ST.alen == 0)
4953      ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4954    }
4955    DEBUG_EXECUTE_r(
4956     PerlIO_printf(Perl_debug_log,
4957       "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4958       (int)(REPORT_CODE_OFF+(depth*2)), "",
4959       (IV) ST.count, (IV)ST.alen)
4960    );
4961
4962    locinput = PL_reginput;
4963
4964    if (cur_eval && cur_eval->u.eval.close_paren &&
4965     cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4966     goto fake_end;
4967
4968    {
4969     I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
4970     if ( max == REG_INFTY || ST.count < max )
4971      goto curlym_do_A; /* try to match another A */
4972    }
4973    goto curlym_do_B; /* try to match B */
4974
4975   case CURLYM_A_fail: /* just failed to match an A */
4976    REGCP_UNWIND(ST.cp);
4977
4978    if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4979     || (cur_eval && cur_eval->u.eval.close_paren &&
4980      cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4981     sayNO;
4982
4983   curlym_do_B: /* execute the B in /A{m,n}B/  */
4984    PL_reginput = locinput;
4985    if (ST.c1 == CHRTEST_UNINIT) {
4986     /* calculate c1 and c2 for possible match of 1st char
4987     * following curly */
4988     ST.c1 = ST.c2 = CHRTEST_VOID;
4989     if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4990      regnode *text_node = ST.B;
4991      if (! HAS_TEXT(text_node))
4992       FIND_NEXT_IMPT(text_node);
4993      /* this used to be
4994
4995       (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4996
4997        But the former is redundant in light of the latter.
4998
4999        if this changes back then the macro for
5000        IS_TEXT and friends need to change.
5001      */
5002      if (PL_regkind[OP(text_node)] == EXACT)
5003      {
5004
5005       ST.c1 = (U8)*STRING(text_node);
5006       switch (OP(text_node)) {
5007        case EXACTF: ST.c2 = PL_fold[ST.c1]; break;
5008        case EXACTFA:
5009        case EXACTFU: ST.c2 = PL_fold_latin1[ST.c1]; break;
5010        case EXACTFL: ST.c2 = PL_fold_locale[ST.c1]; break;
5011        default: ST.c2 = ST.c1;
5012       }
5013      }
5014     }
5015    }
5016
5017    DEBUG_EXECUTE_r(
5018     PerlIO_printf(Perl_debug_log,
5019      "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
5020      (int)(REPORT_CODE_OFF+(depth*2)),
5021      "", (IV)ST.count)
5022     );
5023    if (ST.c1 != CHRTEST_VOID
5024      && UCHARAT(PL_reginput) != ST.c1
5025      && UCHARAT(PL_reginput) != ST.c2)
5026    {
5027     /* simulate B failing */
5028     DEBUG_OPTIMISE_r(
5029      PerlIO_printf(Perl_debug_log,
5030       "%*s  CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
5031       (int)(REPORT_CODE_OFF+(depth*2)),"",
5032       (IV)ST.c1,(IV)ST.c2
5033     ));
5034     state_num = CURLYM_B_fail;
5035     goto reenter_switch;
5036    }
5037
5038    if (ST.me->flags) {
5039     /* mark current A as captured */
5040     I32 paren = ST.me->flags;
5041     if (ST.count) {
5042      PL_regoffs[paren].start
5043       = HOPc(PL_reginput, -ST.alen) - PL_bostr;
5044      PL_regoffs[paren].end = PL_reginput - PL_bostr;
5045      /*dmq: *PL_reglastcloseparen = paren; */
5046     }
5047     else
5048      PL_regoffs[paren].end = -1;
5049     if (cur_eval && cur_eval->u.eval.close_paren &&
5050      cur_eval->u.eval.close_paren == (U32)ST.me->flags)
5051     {
5052      if (ST.count)
5053       goto fake_end;
5054      else
5055       sayNO;
5056     }
5057    }
5058
5059    PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
5060    /* NOTREACHED */
5061
5062   case CURLYM_B_fail: /* just failed to match a B */
5063    REGCP_UNWIND(ST.cp);
5064    if (ST.minmod) {
5065     I32 max = ARG2(ST.me);
5066     if (max != REG_INFTY && ST.count == max)
5067      sayNO;
5068     goto curlym_do_A; /* try to match a further A */
5069    }
5070    /* backtrack one A */
5071    if (ST.count == ARG1(ST.me) /* min */)
5072     sayNO;
5073    ST.count--;
5074    locinput = HOPc(locinput, -ST.alen);
5075    goto curlym_do_B; /* try to match B */
5076
5077 #undef ST
5078 #define ST st->u.curly
5079
5080 #define CURLY_SETPAREN(paren, success) \
5081  if (paren) { \
5082   if (success) { \
5083    PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
5084    PL_regoffs[paren].end = locinput - PL_bostr; \
5085    *PL_reglastcloseparen = paren; \
5086   } \
5087   else \
5088    PL_regoffs[paren].end = -1; \
5089  }
5090
5091   case STAR:  /*  /A*B/ where A is width 1 */
5092    ST.paren = 0;
5093    ST.min = 0;
5094    ST.max = REG_INFTY;
5095    scan = NEXTOPER(scan);
5096    goto repeat;
5097   case PLUS:  /*  /A+B/ where A is width 1 */
5098    ST.paren = 0;
5099    ST.min = 1;
5100    ST.max = REG_INFTY;
5101    scan = NEXTOPER(scan);
5102    goto repeat;
5103   case CURLYN:  /*  /(A){m,n}B/ where A is width 1 */
5104    ST.paren = scan->flags; /* Which paren to set */
5105    if (ST.paren > PL_regsize)
5106     PL_regsize = ST.paren;
5107    if (ST.paren > *PL_reglastparen)
5108     *PL_reglastparen = ST.paren;
5109    ST.min = ARG1(scan);  /* min to match */
5110    ST.max = ARG2(scan);  /* max to match */
5111    if (cur_eval && cur_eval->u.eval.close_paren &&
5112     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5113     ST.min=1;
5114     ST.max=1;
5115    }
5116    scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
5117    goto repeat;
5118   case CURLY:  /*  /A{m,n}B/ where A is width 1 */
5119    ST.paren = 0;
5120    ST.min = ARG1(scan);  /* min to match */
5121    ST.max = ARG2(scan);  /* max to match */
5122    scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
5123   repeat:
5124    /*
5125    * Lookahead to avoid useless match attempts
5126    * when we know what character comes next.
5127    *
5128    * Used to only do .*x and .*?x, but now it allows
5129    * for )'s, ('s and (?{ ... })'s to be in the way
5130    * of the quantifier and the EXACT-like node.  -- japhy
5131    */
5132
5133    if (ST.min > ST.max) /* XXX make this a compile-time check? */
5134     sayNO;
5135    if (HAS_TEXT(next) || JUMPABLE(next)) {
5136     U8 *s;
5137     regnode *text_node = next;
5138
5139     if (! HAS_TEXT(text_node))
5140      FIND_NEXT_IMPT(text_node);
5141
5142     if (! HAS_TEXT(text_node))
5143      ST.c1 = ST.c2 = CHRTEST_VOID;
5144     else {
5145      if ( PL_regkind[OP(text_node)] != EXACT ) {
5146       ST.c1 = ST.c2 = CHRTEST_VOID;
5147       goto assume_ok_easy;
5148      }
5149      else
5150       s = (U8*)STRING(text_node);
5151
5152      /*  Currently we only get here when
5153
5154       PL_rekind[OP(text_node)] == EXACT
5155
5156       if this changes back then the macro for IS_TEXT and
5157       friends need to change. */
5158      if (!UTF_PATTERN) {
5159       ST.c1 = *s;
5160       switch (OP(text_node)) {
5161        case EXACTF: ST.c2 = PL_fold[ST.c1]; break;
5162        case EXACTFA:
5163        case EXACTFU: ST.c2 = PL_fold_latin1[ST.c1]; break;
5164        case EXACTFL: ST.c2 = PL_fold_locale[ST.c1]; break;
5165        default: ST.c2 = ST.c1; break;
5166       }
5167      }
5168      else { /* UTF_PATTERN */
5169       if (IS_TEXTFU(text_node) || IS_TEXTF(text_node)) {
5170        STRLEN ulen1, ulen2;
5171        U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
5172        U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
5173
5174        to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
5175        to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
5176 #ifdef EBCDIC
5177        ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
5178              ckWARN(WARN_UTF8) ?
5179              0 : UTF8_ALLOW_ANY);
5180        ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
5181              ckWARN(WARN_UTF8) ?
5182              0 : UTF8_ALLOW_ANY);
5183 #else
5184        ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
5185              uniflags);
5186        ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
5187              uniflags);
5188 #endif
5189       }
5190       else {
5191        ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
5192              uniflags);
5193       }
5194      }
5195     }
5196    }
5197    else
5198     ST.c1 = ST.c2 = CHRTEST_VOID;
5199   assume_ok_easy:
5200
5201    ST.A = scan;
5202    ST.B = next;
5203    PL_reginput = locinput;
5204    if (minmod) {
5205     minmod = 0;
5206     if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
5207      sayNO;
5208     ST.count = ST.min;
5209     locinput = PL_reginput;
5210     REGCP_SET(ST.cp);
5211     if (ST.c1 == CHRTEST_VOID)
5212      goto curly_try_B_min;
5213
5214     ST.oldloc = locinput;
5215
5216     /* set ST.maxpos to the furthest point along the
5217     * string that could possibly match */
5218     if  (ST.max == REG_INFTY) {
5219      ST.maxpos = PL_regeol - 1;
5220      if (utf8_target)
5221       while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
5222        ST.maxpos--;
5223     }
5224     else if (utf8_target) {
5225      int m = ST.max - ST.min;
5226      for (ST.maxpos = locinput;
5227       m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
5228       ST.maxpos += UTF8SKIP(ST.maxpos);
5229     }
5230     else {
5231      ST.maxpos = locinput + ST.max - ST.min;
5232      if (ST.maxpos >= PL_regeol)
5233       ST.maxpos = PL_regeol - 1;
5234     }
5235     goto curly_try_B_min_known;
5236
5237    }
5238    else {
5239     ST.count = regrepeat(rex, ST.A, ST.max, depth);
5240     locinput = PL_reginput;
5241     if (ST.count < ST.min)
5242      sayNO;
5243     if ((ST.count > ST.min)
5244      && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
5245     {
5246      /* A{m,n} must come at the end of the string, there's
5247      * no point in backing off ... */
5248      ST.min = ST.count;
5249      /* ...except that $ and \Z can match before *and* after
5250      newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
5251      We may back off by one in this case. */
5252      if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
5253       ST.min--;
5254     }
5255     REGCP_SET(ST.cp);
5256     goto curly_try_B_max;
5257    }
5258    /* NOTREACHED */
5259
5260
5261   case CURLY_B_min_known_fail:
5262    /* failed to find B in a non-greedy match where c1,c2 valid */
5263    if (ST.paren && ST.count)
5264     PL_regoffs[ST.paren].end = -1;
5265
5266    PL_reginput = locinput; /* Could be reset... */
5267    REGCP_UNWIND(ST.cp);
5268    /* Couldn't or didn't -- move forward. */
5269    ST.oldloc = locinput;
5270    if (utf8_target)
5271     locinput += UTF8SKIP(locinput);
5272    else
5273     locinput++;
5274    ST.count++;
5275   curly_try_B_min_known:
5276    /* find the next place where 'B' could work, then call B */
5277    {
5278     int n;
5279     if (utf8_target) {
5280      n = (ST.oldloc == locinput) ? 0 : 1;
5281      if (ST.c1 == ST.c2) {
5282       STRLEN len;
5283       /* set n to utf8_distance(oldloc, locinput) */
5284       while (locinput <= ST.maxpos &&
5285        utf8n_to_uvchr((U8*)locinput,
5286            UTF8_MAXBYTES, &len,
5287            uniflags) != (UV)ST.c1) {
5288        locinput += len;
5289        n++;
5290       }
5291      }
5292      else {
5293       /* set n to utf8_distance(oldloc, locinput) */
5294       while (locinput <= ST.maxpos) {
5295        STRLEN len;
5296        const UV c = utf8n_to_uvchr((U8*)locinput,
5297             UTF8_MAXBYTES, &len,
5298             uniflags);
5299        if (c == (UV)ST.c1 || c == (UV)ST.c2)
5300         break;
5301        locinput += len;
5302        n++;
5303       }
5304      }
5305     }
5306     else {
5307      if (ST.c1 == ST.c2) {
5308       while (locinput <= ST.maxpos &&
5309        UCHARAT(locinput) != ST.c1)
5310        locinput++;
5311      }
5312      else {
5313       while (locinput <= ST.maxpos
5314        && UCHARAT(locinput) != ST.c1
5315        && UCHARAT(locinput) != ST.c2)
5316        locinput++;
5317      }
5318      n = locinput - ST.oldloc;
5319     }
5320     if (locinput > ST.maxpos)
5321      sayNO;
5322     /* PL_reginput == oldloc now */
5323     if (n) {
5324      ST.count += n;
5325      if (regrepeat(rex, ST.A, n, depth) < n)
5326       sayNO;
5327     }
5328     PL_reginput = locinput;
5329     CURLY_SETPAREN(ST.paren, ST.count);
5330     if (cur_eval && cur_eval->u.eval.close_paren &&
5331      cur_eval->u.eval.close_paren == (U32)ST.paren) {
5332      goto fake_end;
5333     }
5334     PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
5335    }
5336    /* NOTREACHED */
5337
5338
5339   case CURLY_B_min_fail:
5340    /* failed to find B in a non-greedy match where c1,c2 invalid */
5341    if (ST.paren && ST.count)
5342     PL_regoffs[ST.paren].end = -1;
5343
5344    REGCP_UNWIND(ST.cp);
5345    /* failed -- move forward one */
5346    PL_reginput = locinput;
5347    if (regrepeat(rex, ST.A, 1, depth)) {
5348     ST.count++;
5349     locinput = PL_reginput;
5350     if (ST.count <= ST.max || (ST.max == REG_INFTY &&
5351       ST.count > 0)) /* count overflow ? */
5352     {
5353     curly_try_B_min:
5354      CURLY_SETPAREN(ST.paren, ST.count);
5355      if (cur_eval && cur_eval->u.eval.close_paren &&
5356       cur_eval->u.eval.close_paren == (U32)ST.paren) {
5357       goto fake_end;
5358      }
5359      PUSH_STATE_GOTO(CURLY_B_min, ST.B);
5360     }
5361    }
5362    sayNO;
5363    /* NOTREACHED */
5364
5365
5366   curly_try_B_max:
5367    /* a successful greedy match: now try to match B */
5368    if (cur_eval && cur_eval->u.eval.close_paren &&
5369     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5370     goto fake_end;
5371    }
5372    {
5373     UV c = 0;
5374     if (ST.c1 != CHRTEST_VOID)
5375      c = utf8_target ? utf8n_to_uvchr((U8*)PL_reginput,
5376           UTF8_MAXBYTES, 0, uniflags)
5377         : (UV) UCHARAT(PL_reginput);
5378     /* If it could work, try it. */
5379     if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
5380      CURLY_SETPAREN(ST.paren, ST.count);
5381      PUSH_STATE_GOTO(CURLY_B_max, ST.B);
5382      /* NOTREACHED */
5383     }
5384    }
5385    /* FALL THROUGH */
5386   case CURLY_B_max_fail:
5387    /* failed to find B in a greedy match */
5388    if (ST.paren && ST.count)
5389     PL_regoffs[ST.paren].end = -1;
5390
5391    REGCP_UNWIND(ST.cp);
5392    /*  back up. */
5393    if (--ST.count < ST.min)
5394     sayNO;
5395    PL_reginput = locinput = HOPc(locinput, -1);
5396    goto curly_try_B_max;
5397
5398 #undef ST
5399
5400   case END:
5401    fake_end:
5402    if (cur_eval) {
5403     /* we've just finished A in /(??{A})B/; now continue with B */
5404     I32 tmpix;
5405     st->u.eval.toggle_reg_flags
5406        = cur_eval->u.eval.toggle_reg_flags;
5407     PL_reg_flags ^= st->u.eval.toggle_reg_flags;
5408
5409     st->u.eval.prev_rex = rex_sv;  /* inner */
5410     SETREX(rex_sv,cur_eval->u.eval.prev_rex);
5411     rex = (struct regexp *)SvANY(rex_sv);
5412     rexi = RXi_GET(rex);
5413     cur_curlyx = cur_eval->u.eval.prev_curlyx;
5414     (void)ReREFCNT_inc(rex_sv);
5415     st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
5416
5417     /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
5418     PL_reglastparen = &rex->lastparen;
5419     PL_reglastcloseparen = &rex->lastcloseparen;
5420
5421     REGCP_SET(st->u.eval.lastcp);
5422     PL_reginput = locinput;
5423
5424     /* Restore parens of the outer rex without popping the
5425     * savestack */
5426     tmpix = PL_savestack_ix;
5427     PL_savestack_ix = cur_eval->u.eval.lastcp;
5428     regcppop(rex);
5429     PL_savestack_ix = tmpix;
5430
5431     st->u.eval.prev_eval = cur_eval;
5432     cur_eval = cur_eval->u.eval.prev_eval;
5433     DEBUG_EXECUTE_r(
5434      PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ... %"UVxf"\n",
5435          REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
5436     if ( nochange_depth )
5437      nochange_depth--;
5438
5439     PUSH_YES_STATE_GOTO(EVAL_AB,
5440       st->u.eval.prev_eval->u.eval.B); /* match B */
5441    }
5442
5443    if (locinput < reginfo->till) {
5444     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5445          "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
5446          PL_colors[4],
5447          (long)(locinput - PL_reg_starttry),
5448          (long)(reginfo->till - PL_reg_starttry),
5449          PL_colors[5]));
5450
5451     sayNO_SILENT;  /* Cannot match: too short. */
5452    }
5453    PL_reginput = locinput; /* put where regtry can find it */
5454    sayYES;   /* Success! */
5455
5456   case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
5457    DEBUG_EXECUTE_r(
5458    PerlIO_printf(Perl_debug_log,
5459     "%*s  %ssubpattern success...%s\n",
5460     REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
5461    PL_reginput = locinput; /* put where regtry can find it */
5462    sayYES;   /* Success! */
5463
5464 #undef  ST
5465 #define ST st->u.ifmatch
5466
5467   case SUSPEND: /* (?>A) */
5468    ST.wanted = 1;
5469    PL_reginput = locinput;
5470    goto do_ifmatch;
5471
5472   case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
5473    ST.wanted = 0;
5474    goto ifmatch_trivial_fail_test;
5475
5476   case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
5477    ST.wanted = 1;
5478   ifmatch_trivial_fail_test:
5479    if (scan->flags) {
5480     char * const s = HOPBACKc(locinput, scan->flags);
5481     if (!s) {
5482      /* trivial fail */
5483      if (logical) {
5484       logical = 0;
5485       sw = 1 - cBOOL(ST.wanted);
5486      }
5487      else if (ST.wanted)
5488       sayNO;
5489      next = scan + ARG(scan);
5490      if (next == scan)
5491       next = NULL;
5492      break;
5493     }
5494     PL_reginput = s;
5495    }
5496    else
5497     PL_reginput = locinput;
5498
5499   do_ifmatch:
5500    ST.me = scan;
5501    ST.logical = logical;
5502    logical = 0; /* XXX: reset state of logical once it has been saved into ST */
5503
5504    /* execute body of (?...A) */
5505    PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
5506    /* NOTREACHED */
5507
5508   case IFMATCH_A_fail: /* body of (?...A) failed */
5509    ST.wanted = !ST.wanted;
5510    /* FALL THROUGH */
5511
5512   case IFMATCH_A: /* body of (?...A) succeeded */
5513    if (ST.logical) {
5514     sw = cBOOL(ST.wanted);
5515    }
5516    else if (!ST.wanted)
5517     sayNO;
5518
5519    if (OP(ST.me) == SUSPEND)
5520     locinput = PL_reginput;
5521    else {
5522     locinput = PL_reginput = st->locinput;
5523     nextchr = UCHARAT(locinput);
5524    }
5525    scan = ST.me + ARG(ST.me);
5526    if (scan == ST.me)
5527     scan = NULL;
5528    continue; /* execute B */
5529
5530 #undef ST
5531
5532   case LONGJMP:
5533    next = scan + ARG(scan);
5534    if (next == scan)
5535     next = NULL;
5536    break;
5537   case COMMIT:
5538    reginfo->cutpoint = PL_regeol;
5539    /* FALLTHROUGH */
5540   case PRUNE:
5541    PL_reginput = locinput;
5542    if (!scan->flags)
5543     sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5544    PUSH_STATE_GOTO(COMMIT_next,next);
5545    /* NOTREACHED */
5546   case COMMIT_next_fail:
5547    no_final = 1;
5548    /* FALLTHROUGH */
5549   case OPFAIL:
5550    sayNO;
5551    /* NOTREACHED */
5552
5553 #define ST st->u.mark
5554   case MARKPOINT:
5555    ST.prev_mark = mark_state;
5556    ST.mark_name = sv_commit = sv_yes_mark
5557     = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5558    mark_state = st;
5559    ST.mark_loc = PL_reginput = locinput;
5560    PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5561    /* NOTREACHED */
5562   case MARKPOINT_next:
5563    mark_state = ST.prev_mark;
5564    sayYES;
5565    /* NOTREACHED */
5566   case MARKPOINT_next_fail:
5567    if (popmark && sv_eq(ST.mark_name,popmark))
5568    {
5569     if (ST.mark_loc > startpoint)
5570      reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5571     popmark = NULL; /* we found our mark */
5572     sv_commit = ST.mark_name;
5573
5574     DEBUG_EXECUTE_r({
5575       PerlIO_printf(Perl_debug_log,
5576        "%*s  %ssetting cutpoint to mark:%"SVf"...%s\n",
5577        REPORT_CODE_OFF+depth*2, "",
5578        PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
5579     });
5580    }
5581    mark_state = ST.prev_mark;
5582    sv_yes_mark = mark_state ?
5583     mark_state->u.mark.mark_name : NULL;
5584    sayNO;
5585    /* NOTREACHED */
5586   case SKIP:
5587    PL_reginput = locinput;
5588    if (scan->flags) {
5589     /* (*SKIP) : if we fail we cut here*/
5590     ST.mark_name = NULL;
5591     ST.mark_loc = locinput;
5592     PUSH_STATE_GOTO(SKIP_next,next);
5593    } else {
5594     /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5595     otherwise do nothing.  Meaning we need to scan
5596     */
5597     regmatch_state *cur = mark_state;
5598     SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5599
5600     while (cur) {
5601      if ( sv_eq( cur->u.mark.mark_name,
5602         find ) )
5603      {
5604       ST.mark_name = find;
5605       PUSH_STATE_GOTO( SKIP_next, next );
5606      }
5607      cur = cur->u.mark.prev_mark;
5608     }
5609    }
5610    /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5611    break;
5612   case SKIP_next_fail:
5613    if (ST.mark_name) {
5614     /* (*CUT:NAME) - Set up to search for the name as we
5615     collapse the stack*/
5616     popmark = ST.mark_name;
5617    } else {
5618     /* (*CUT) - No name, we cut here.*/
5619     if (ST.mark_loc > startpoint)
5620      reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5621     /* but we set sv_commit to latest mark_name if there
5622     is one so they can test to see how things lead to this
5623     cut */
5624     if (mark_state)
5625      sv_commit=mark_state->u.mark.mark_name;
5626    }
5627    no_final = 1;
5628    sayNO;
5629    /* NOTREACHED */
5630 #undef ST
5631   case FOLDCHAR:
5632    n = ARG(scan);
5633    if ( n == (U32)what_len_TRICKYFOLD(locinput,utf8_target,ln) ) {
5634     locinput += ln;
5635    } else if ( LATIN_SMALL_LETTER_SHARP_S == n && !utf8_target && !UTF_PATTERN ) {
5636     sayNO;
5637    } else  {
5638     U8 folded[UTF8_MAXBYTES_CASE+1];
5639     STRLEN foldlen;
5640     const char * const l = locinput;
5641     char *e = PL_regeol;
5642     to_uni_fold(n, folded, &foldlen);
5643
5644     if (! foldEQ_utf8((const char*) folded, 0,  foldlen, 1,
5645        l, &e, 0,  utf8_target)) {
5646       sayNO;
5647     }
5648     locinput = e;
5649    }
5650    nextchr = UCHARAT(locinput);
5651    break;
5652   case LNBREAK:
5653    if ((n=is_LNBREAK(locinput,utf8_target))) {
5654     locinput += n;
5655     nextchr = UCHARAT(locinput);
5656    } else
5657     sayNO;
5658    break;
5659
5660 #define CASE_CLASS(nAmE)                              \
5661   case nAmE:                                    \
5662    if ((n=is_##nAmE(locinput,utf8_target))) {    \
5663     locinput += n;                        \
5664     nextchr = UCHARAT(locinput);          \
5665    } else                                    \
5666     sayNO;                                \
5667    break;                                    \
5668   case N##nAmE:                                 \
5669    if ((n=is_##nAmE(locinput,utf8_target))) {    \
5670     sayNO;                                \
5671    } else {                                  \
5672     locinput += UTF8SKIP(locinput);       \
5673     nextchr = UCHARAT(locinput);          \
5674    }                                         \
5675    break
5676
5677   CASE_CLASS(VERTWS);
5678   CASE_CLASS(HORIZWS);
5679 #undef CASE_CLASS
5680
5681   default:
5682    PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5683       PTR2UV(scan), OP(scan));
5684    Perl_croak(aTHX_ "regexp memory corruption");
5685
5686   } /* end switch */
5687
5688   /* switch break jumps here */
5689   scan = next; /* prepare to execute the next op and ... */
5690   continue;    /* ... jump back to the top, reusing st */
5691   /* NOTREACHED */
5692
5693  push_yes_state:
5694   /* push a state that backtracks on success */
5695   st->u.yes.prev_yes_state = yes_state;
5696   yes_state = st;
5697   /* FALL THROUGH */
5698  push_state:
5699   /* push a new regex state, then continue at scan  */
5700   {
5701    regmatch_state *newst;
5702
5703    DEBUG_STACK_r({
5704     regmatch_state *cur = st;
5705     regmatch_state *curyes = yes_state;
5706     int curd = depth;
5707     regmatch_slab *slab = PL_regmatch_slab;
5708     for (;curd > -1;cur--,curd--) {
5709      if (cur < SLAB_FIRST(slab)) {
5710       slab = slab->prev;
5711       cur = SLAB_LAST(slab);
5712      }
5713      PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5714       REPORT_CODE_OFF + 2 + depth * 2,"",
5715       curd, PL_reg_name[cur->resume_state],
5716       (curyes == cur) ? "yes" : ""
5717      );
5718      if (curyes == cur)
5719       curyes = cur->u.yes.prev_yes_state;
5720     }
5721    } else
5722     DEBUG_STATE_pp("push")
5723    );
5724    depth++;
5725    st->locinput = locinput;
5726    newst = st+1;
5727    if (newst >  SLAB_LAST(PL_regmatch_slab))
5728     newst = S_push_slab(aTHX);
5729    PL_regmatch_state = newst;
5730
5731    locinput = PL_reginput;
5732    nextchr = UCHARAT(locinput);
5733    st = newst;
5734    continue;
5735    /* NOTREACHED */
5736   }
5737  }
5738
5739  /*
5740  * We get here only if there's trouble -- normally "case END" is
5741  * the terminating point.
5742  */
5743  Perl_croak(aTHX_ "corrupted regexp pointers");
5744  /*NOTREACHED*/
5745  sayNO;
5746
5747 yes:
5748  if (yes_state) {
5749   /* we have successfully completed a subexpression, but we must now
5750   * pop to the state marked by yes_state and continue from there */
5751   assert(st != yes_state);
5752 #ifdef DEBUGGING
5753   while (st != yes_state) {
5754    st--;
5755    if (st < SLAB_FIRST(PL_regmatch_slab)) {
5756     PL_regmatch_slab = PL_regmatch_slab->prev;
5757     st = SLAB_LAST(PL_regmatch_slab);
5758    }
5759    DEBUG_STATE_r({
5760     if (no_final) {
5761      DEBUG_STATE_pp("pop (no final)");
5762     } else {
5763      DEBUG_STATE_pp("pop (yes)");
5764     }
5765    });
5766    depth--;
5767   }
5768 #else
5769   while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5770    || yes_state > SLAB_LAST(PL_regmatch_slab))
5771   {
5772    /* not in this slab, pop slab */
5773    depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5774    PL_regmatch_slab = PL_regmatch_slab->prev;
5775    st = SLAB_LAST(PL_regmatch_slab);
5776   }
5777   depth -= (st - yes_state);
5778 #endif
5779   st = yes_state;
5780   yes_state = st->u.yes.prev_yes_state;
5781   PL_regmatch_state = st;
5782
5783   if (no_final) {
5784    locinput= st->locinput;
5785    nextchr = UCHARAT(locinput);
5786   }
5787   state_num = st->resume_state + no_final;
5788   goto reenter_switch;
5789  }
5790
5791  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5792       PL_colors[4], PL_colors[5]));
5793
5794  if (PL_reg_eval_set) {
5795   /* each successfully executed (?{...}) block does the equivalent of
5796   *   local $^R = do {...}
5797   * When popping the save stack, all these locals would be undone;
5798   * bypass this by setting the outermost saved $^R to the latest
5799   * value */
5800   if (oreplsv != GvSV(PL_replgv))
5801    sv_setsv(oreplsv, GvSV(PL_replgv));
5802  }
5803  result = 1;
5804  goto final_exit;
5805
5806 no:
5807  DEBUG_EXECUTE_r(
5808   PerlIO_printf(Perl_debug_log,
5809    "%*s  %sfailed...%s\n",
5810    REPORT_CODE_OFF+depth*2, "",
5811    PL_colors[4], PL_colors[5])
5812   );
5813
5814 no_silent:
5815  if (no_final) {
5816   if (yes_state) {
5817    goto yes;
5818   } else {
5819    goto final_exit;
5820   }
5821  }
5822  if (depth) {
5823   /* there's a previous state to backtrack to */
5824   st--;
5825   if (st < SLAB_FIRST(PL_regmatch_slab)) {
5826    PL_regmatch_slab = PL_regmatch_slab->prev;
5827    st = SLAB_LAST(PL_regmatch_slab);
5828   }
5829   PL_regmatch_state = st;
5830   locinput= st->locinput;
5831   nextchr = UCHARAT(locinput);
5832
5833   DEBUG_STATE_pp("pop");
5834   depth--;
5835   if (yes_state == st)
5836    yes_state = st->u.yes.prev_yes_state;
5837
5838   state_num = st->resume_state + 1; /* failure = success + 1 */
5839   goto reenter_switch;
5840  }
5841  result = 0;
5842
5843   final_exit:
5844  if (rex->intflags & PREGf_VERBARG_SEEN) {
5845   SV *sv_err = get_sv("REGERROR", 1);
5846   SV *sv_mrk = get_sv("REGMARK", 1);
5847   if (result) {
5848    sv_commit = &PL_sv_no;
5849    if (!sv_yes_mark)
5850     sv_yes_mark = &PL_sv_yes;
5851   } else {
5852    if (!sv_commit)
5853     sv_commit = &PL_sv_yes;
5854    sv_yes_mark = &PL_sv_no;
5855   }
5856   sv_setsv(sv_err, sv_commit);
5857   sv_setsv(sv_mrk, sv_yes_mark);
5858  }
5859
5860  /* clean up; in particular, free all slabs above current one */
5861  LEAVE_SCOPE(oldsave);
5862
5863  return result;
5864 }
5865
5866 /*
5867  - regrepeat - repeatedly match something simple, report how many
5868  */
5869 /*
5870  * [This routine now assumes that it will only match on things of length 1.
5871  * That was true before, but now we assume scan - reginput is the count,
5872  * rather than incrementing count on every character.  [Er, except utf8.]]
5873  */
5874 STATIC I32
5875 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5876 {
5877  dVAR;
5878  register char *scan;
5879  register I32 c;
5880  register char *loceol = PL_regeol;
5881  register I32 hardcount = 0;
5882  register bool utf8_target = PL_reg_match_utf8;
5883  UV utf8_flags;
5884 #ifndef DEBUGGING
5885  PERL_UNUSED_ARG(depth);
5886 #endif
5887
5888  PERL_ARGS_ASSERT_REGREPEAT;
5889
5890  scan = PL_reginput;
5891  if (max == REG_INFTY)
5892   max = I32_MAX;
5893  else if (max < loceol - scan)
5894   loceol = scan + max;
5895  switch (OP(p)) {
5896  case REG_ANY:
5897   if (utf8_target) {
5898    loceol = PL_regeol;
5899    while (scan < loceol && hardcount < max && *scan != '\n') {
5900     scan += UTF8SKIP(scan);
5901     hardcount++;
5902    }
5903   } else {
5904    while (scan < loceol && *scan != '\n')
5905     scan++;
5906   }
5907   break;
5908  case SANY:
5909   if (utf8_target) {
5910    loceol = PL_regeol;
5911    while (scan < loceol && hardcount < max) {
5912     scan += UTF8SKIP(scan);
5913     hardcount++;
5914    }
5915   }
5916   else
5917    scan = loceol;
5918   break;
5919  case CANY:
5920   scan = loceol;
5921   break;
5922  case EXACT:
5923   /* To get here, EXACTish nodes must have *byte* length == 1.  That
5924   * means they match only characters in the string that can be expressed
5925   * as a single byte.  For non-utf8 strings, that means a simple match.
5926   * For utf8 strings, the character matched must be an invariant, or
5927   * downgradable to a single byte.  The pattern's utf8ness is
5928   * irrelevant, as since it's a single byte, it either isn't utf8, or if
5929   * it is, it's an invariant */
5930
5931   c = (U8)*STRING(p);
5932   assert(! UTF_PATTERN || UNI_IS_INVARIANT(c));
5933
5934   if (! utf8_target || UNI_IS_INVARIANT(c)) {
5935    while (scan < loceol && UCHARAT(scan) == c) {
5936     scan++;
5937    }
5938   }
5939   else {
5940
5941    /* Here, the string is utf8, and the pattern char is different
5942    * in utf8 than not, so can't compare them directly.  Outside the
5943    * loop, find find the two utf8 bytes that represent c, and then
5944    * look for those in sequence in the utf8 string */
5945    U8 high = UTF8_TWO_BYTE_HI(c);
5946    U8 low = UTF8_TWO_BYTE_LO(c);
5947    loceol = PL_regeol;
5948
5949    while (hardcount < max
5950      && scan + 1 < loceol
5951      && UCHARAT(scan) == high
5952      && UCHARAT(scan + 1) == low)
5953    {
5954     scan += 2;
5955     hardcount++;
5956    }
5957   }
5958   break;
5959  case EXACTFA:
5960   utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
5961   goto do_exactf;
5962
5963  case EXACTFL:
5964   PL_reg_flags |= RF_tainted;
5965   utf8_flags = FOLDEQ_UTF8_LOCALE;
5966   goto do_exactf;
5967
5968  case EXACTF:
5969  case EXACTFU:
5970   utf8_flags = 0;
5971
5972   /* The comments for the EXACT case above apply as well to these fold
5973   * ones */
5974
5975  do_exactf:
5976   c = (U8)*STRING(p);
5977   assert(! UTF_PATTERN || UNI_IS_INVARIANT(c));
5978
5979   if (utf8_target) { /* Use full Unicode fold matching */
5980    char *tmpeol = loceol;
5981    while (hardcount < max
5982      && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target,
5983         STRING(p), NULL, 1, cBOOL(UTF_PATTERN), utf8_flags))
5984    {
5985     scan = tmpeol;
5986     tmpeol = loceol;
5987     hardcount++;
5988    }
5989
5990    /* XXX Note that the above handles properly the German sharp s in
5991    * the pattern matching ss in the string.  But it doesn't handle
5992    * properly cases where the string contains say 'LIGATURE ff' and
5993    * the pattern is 'f+'.  This would require, say, a new function or
5994    * revised interface to foldEQ_utf8(), in which the maximum number
5995    * of characters to match could be passed and it would return how
5996    * many actually did.  This is just one of many cases where
5997    * multi-char folds don't work properly, and so the fix is being
5998    * deferred */
5999   }
6000   else {
6001    U8 folded;
6002
6003    /* Here, the string isn't utf8 and c is a single byte; and either
6004    * the pattern isn't utf8 or c is an invariant, so its utf8ness
6005    * doesn't affect c.  Can just do simple comparisons for exact or
6006    * fold matching. */
6007    switch (OP(p)) {
6008     case EXACTF: folded = PL_fold[c]; break;
6009     case EXACTFA:
6010     case EXACTFU: folded = PL_fold_latin1[c]; break;
6011     case EXACTFL: folded = PL_fold_locale[c]; break;
6012     default: Perl_croak(aTHX_ "panic: Unexpected op %u", OP(p));
6013    }
6014    while (scan < loceol &&
6015     (UCHARAT(scan) == c || UCHARAT(scan) == folded))
6016    {
6017     scan++;
6018    }
6019   }
6020   break;
6021  case ANYOFV:
6022  case ANYOF:
6023   if (utf8_target || OP(p) == ANYOFV) {
6024    STRLEN inclasslen;
6025    loceol = PL_regeol;
6026    inclasslen = loceol - scan;
6027    while (hardcount < max
6028     && ((inclasslen = loceol - scan) > 0)
6029     && reginclass(prog, p, (U8*)scan, &inclasslen, utf8_target))
6030    {
6031     scan += inclasslen;
6032     hardcount++;
6033    }
6034   } else {
6035    while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
6036     scan++;
6037   }
6038   break;
6039  case ALNUMU:
6040   if (utf8_target) {
6041  utf8_wordchar:
6042    loceol = PL_regeol;
6043    LOAD_UTF8_CHARCLASS_ALNUM();
6044    while (hardcount < max && scan < loceol &&
6045     swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target))
6046    {
6047     scan += UTF8SKIP(scan);
6048     hardcount++;
6049    }
6050   } else {
6051    while (scan < loceol && isWORDCHAR_L1((U8) *scan)) {
6052     scan++;
6053    }
6054   }
6055   break;
6056  case ALNUM:
6057   if (utf8_target)
6058    goto utf8_wordchar;
6059   while (scan < loceol && isALNUM((U8) *scan)) {
6060    scan++;
6061   }
6062   break;
6063  case ALNUMA:
6064   while (scan < loceol && isWORDCHAR_A((U8) *scan)) {
6065    scan++;
6066   }
6067   break;
6068  case ALNUML:
6069   PL_reg_flags |= RF_tainted;
6070   if (utf8_target) {
6071    loceol = PL_regeol;
6072    while (hardcount < max && scan < loceol &&
6073     isALNUM_LC_utf8((U8*)scan)) {
6074     scan += UTF8SKIP(scan);
6075     hardcount++;
6076    }
6077   } else {
6078    while (scan < loceol && isALNUM_LC(*scan))
6079     scan++;
6080   }
6081   break;
6082  case NALNUMU:
6083   if (utf8_target) {
6084
6085  utf8_Nwordchar:
6086
6087    loceol = PL_regeol;
6088    LOAD_UTF8_CHARCLASS_ALNUM();
6089    while (hardcount < max && scan < loceol &&
6090     ! swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target))
6091    {
6092     scan += UTF8SKIP(scan);
6093     hardcount++;
6094    }
6095   } else {
6096    while (scan < loceol && ! isWORDCHAR_L1((U8) *scan)) {
6097     scan++;
6098    }
6099   }
6100   break;
6101  case NALNUM:
6102   if (utf8_target)
6103    goto utf8_Nwordchar;
6104   while (scan < loceol && ! isALNUM((U8) *scan)) {
6105    scan++;
6106   }
6107   break;
6108  case NALNUMA:
6109   if (utf8_target) {
6110    while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) {
6111     scan += UTF8SKIP(scan);
6112    }
6113   }
6114   else {
6115    while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) {
6116     scan++;
6117    }
6118   }
6119   break;
6120  case NALNUML:
6121   PL_reg_flags |= RF_tainted;
6122   if (utf8_target) {
6123    loceol = PL_regeol;
6124    while (hardcount < max && scan < loceol &&
6125     !isALNUM_LC_utf8((U8*)scan)) {
6126     scan += UTF8SKIP(scan);
6127     hardcount++;
6128    }
6129   } else {
6130    while (scan < loceol && !isALNUM_LC(*scan))
6131     scan++;
6132   }
6133   break;
6134  case SPACEU:
6135   if (utf8_target) {
6136
6137  utf8_space:
6138
6139    loceol = PL_regeol;
6140    LOAD_UTF8_CHARCLASS_SPACE();
6141    while (hardcount < max && scan < loceol &&
6142     (*scan == ' ' ||
6143      swash_fetch(PL_utf8_space,(U8*)scan, utf8_target)))
6144    {
6145     scan += UTF8SKIP(scan);
6146     hardcount++;
6147    }
6148    break;
6149   }
6150   else {
6151    while (scan < loceol && isSPACE_L1((U8) *scan)) {
6152     scan++;
6153    }
6154    break;
6155   }
6156  case SPACE:
6157   if (utf8_target)
6158    goto utf8_space;
6159
6160   while (scan < loceol && isSPACE((U8) *scan)) {
6161    scan++;
6162   }
6163   break;
6164  case SPACEA:
6165   while (scan < loceol && isSPACE_A((U8) *scan)) {
6166    scan++;
6167   }
6168   break;
6169  case SPACEL:
6170   PL_reg_flags |= RF_tainted;
6171   if (utf8_target) {
6172    loceol = PL_regeol;
6173    while (hardcount < max && scan < loceol &&
6174     isSPACE_LC_utf8((U8*)scan)) {
6175     scan += UTF8SKIP(scan);
6176     hardcount++;
6177    }
6178   } else {
6179    while (scan < loceol && isSPACE_LC(*scan))
6180     scan++;
6181   }
6182   break;
6183  case NSPACEU:
6184   if (utf8_target) {
6185
6186  utf8_Nspace:
6187
6188    loceol = PL_regeol;
6189    LOAD_UTF8_CHARCLASS_SPACE();
6190    while (hardcount < max && scan < loceol &&
6191     ! (*scan == ' ' ||
6192      swash_fetch(PL_utf8_space,(U8*)scan, utf8_target)))
6193    {
6194     scan += UTF8SKIP(scan);
6195     hardcount++;
6196    }
6197    break;
6198   }
6199   else {
6200    while (scan < loceol && ! isSPACE_L1((U8) *scan)) {
6201     scan++;
6202    }
6203   }
6204   break;
6205  case NSPACE:
6206   if (utf8_target)
6207    goto utf8_Nspace;
6208
6209   while (scan < loceol && ! isSPACE((U8) *scan)) {
6210    scan++;
6211   }
6212   break;
6213  case NSPACEA:
6214   if (utf8_target) {
6215    while (scan < loceol && ! isSPACE_A((U8) *scan)) {
6216     scan += UTF8SKIP(scan);
6217    }
6218   }
6219   else {
6220    while (scan < loceol && ! isSPACE_A((U8) *scan)) {
6221     scan++;
6222    }
6223   }
6224   break;
6225  case NSPACEL:
6226   PL_reg_flags |= RF_tainted;
6227   if (utf8_target) {
6228    loceol = PL_regeol;
6229    while (hardcount < max && scan < loceol &&
6230     !isSPACE_LC_utf8((U8*)scan)) {
6231     scan += UTF8SKIP(scan);
6232     hardcount++;
6233    }
6234   } else {
6235    while (scan < loceol && !isSPACE_LC(*scan))
6236     scan++;
6237   }
6238   break;
6239  case DIGIT:
6240   if (utf8_target) {
6241    loceol = PL_regeol;
6242    LOAD_UTF8_CHARCLASS_DIGIT();
6243    while (hardcount < max && scan < loceol &&
6244     swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
6245     scan += UTF8SKIP(scan);
6246     hardcount++;
6247    }
6248   } else {
6249    while (scan < loceol && isDIGIT(*scan))
6250     scan++;
6251   }
6252   break;
6253  case DIGITA:
6254   while (scan < loceol && isDIGIT_A((U8) *scan)) {
6255    scan++;
6256   }
6257   break;
6258  case DIGITL:
6259   PL_reg_flags |= RF_tainted;
6260   if (utf8_target) {
6261    loceol = PL_regeol;
6262    while (hardcount < max && scan < loceol &&
6263     isDIGIT_LC_utf8((U8*)scan)) {
6264     scan += UTF8SKIP(scan);
6265     hardcount++;
6266    }
6267   } else {
6268    while (scan < loceol && isDIGIT_LC(*scan))
6269     scan++;
6270   }
6271   break;
6272  case NDIGIT:
6273   if (utf8_target) {
6274    loceol = PL_regeol;
6275    LOAD_UTF8_CHARCLASS_DIGIT();
6276    while (hardcount < max && scan < loceol &&
6277     !swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
6278     scan += UTF8SKIP(scan);
6279     hardcount++;
6280    }
6281   } else {
6282    while (scan < loceol && !isDIGIT(*scan))
6283     scan++;
6284   }
6285   break;
6286  case NDIGITA:
6287   if (utf8_target) {
6288    while (scan < loceol && ! isDIGIT_A((U8) *scan)) {
6289     scan += UTF8SKIP(scan);
6290    }
6291   }
6292   else {
6293    while (scan < loceol && ! isDIGIT_A((U8) *scan)) {
6294     scan++;
6295    }
6296   }
6297   break;
6298  case NDIGITL:
6299   PL_reg_flags |= RF_tainted;
6300   if (utf8_target) {
6301    loceol = PL_regeol;
6302    while (hardcount < max && scan < loceol &&
6303     !isDIGIT_LC_utf8((U8*)scan)) {
6304     scan += UTF8SKIP(scan);
6305     hardcount++;
6306    }
6307   } else {
6308    while (scan < loceol && !isDIGIT_LC(*scan))
6309     scan++;
6310   }
6311   break;
6312  case LNBREAK:
6313   if (utf8_target) {
6314    loceol = PL_regeol;
6315    while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
6316     scan += c;
6317     hardcount++;
6318    }
6319   } else {
6320    /*
6321    LNBREAK can match two latin chars, which is ok,
6322    because we have a null terminated string, but we
6323    have to use hardcount in this situation
6324    */
6325    while (scan < loceol && (c=is_LNBREAK_latin1(scan)))  {
6326     scan+=c;
6327     hardcount++;
6328    }
6329   }
6330   break;
6331  case HORIZWS:
6332   if (utf8_target) {
6333    loceol = PL_regeol;
6334    while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
6335     scan += c;
6336     hardcount++;
6337    }
6338   } else {
6339    while (scan < loceol && is_HORIZWS_latin1(scan))
6340     scan++;
6341   }
6342   break;
6343  case NHORIZWS:
6344   if (utf8_target) {
6345    loceol = PL_regeol;
6346    while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
6347     scan += UTF8SKIP(scan);
6348     hardcount++;
6349    }
6350   } else {
6351    while (scan < loceol && !is_HORIZWS_latin1(scan))
6352     scan++;
6353
6354   }
6355   break;
6356  case VERTWS:
6357   if (utf8_target) {
6358    loceol = PL_regeol;
6359    while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
6360     scan += c;
6361     hardcount++;
6362    }
6363   } else {
6364    while (scan < loceol && is_VERTWS_latin1(scan))
6365     scan++;
6366
6367   }
6368   break;
6369  case NVERTWS:
6370   if (utf8_target) {
6371    loceol = PL_regeol;
6372    while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
6373     scan += UTF8SKIP(scan);
6374     hardcount++;
6375    }
6376   } else {
6377    while (scan < loceol && !is_VERTWS_latin1(scan))
6378     scan++;
6379
6380   }
6381   break;
6382
6383  default:  /* Called on something of 0 width. */
6384   break;  /* So match right here or not at all. */
6385  }
6386
6387  if (hardcount)
6388   c = hardcount;
6389  else
6390   c = scan - PL_reginput;
6391  PL_reginput = scan;
6392
6393  DEBUG_r({
6394   GET_RE_DEBUG_FLAGS_DECL;
6395   DEBUG_EXECUTE_r({
6396    SV * const prop = sv_newmortal();
6397    regprop(prog, prop, p);
6398    PerlIO_printf(Perl_debug_log,
6399       "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
6400       REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
6401   });
6402  });
6403
6404  return(c);
6405 }
6406
6407
6408 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
6409 /*
6410 - regclass_swash - prepare the utf8 swash
6411 */
6412
6413 SV *
6414 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
6415 {
6416  dVAR;
6417  SV *sw  = NULL;
6418  SV *si  = NULL;
6419  SV *alt = NULL;
6420  RXi_GET_DECL(prog,progi);
6421  const struct reg_data * const data = prog ? progi->data : NULL;
6422
6423  PERL_ARGS_ASSERT_REGCLASS_SWASH;
6424
6425  assert(ANYOF_NONBITMAP(node));
6426
6427  if (data && data->count) {
6428   const U32 n = ARG(node);
6429
6430   if (data->what[n] == 's') {
6431    SV * const rv = MUTABLE_SV(data->data[n]);
6432    AV * const av = MUTABLE_AV(SvRV(rv));
6433    SV **const ary = AvARRAY(av);
6434    SV **a, **b;
6435
6436    /* See the end of regcomp.c:S_regclass() for
6437    * documentation of these array elements. */
6438
6439    si = *ary;
6440    a  = SvROK(ary[1]) ? &ary[1] : NULL;
6441    b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
6442
6443    if (a)
6444     sw = *a;
6445    else if (si && doinit) {
6446     sw = swash_init("utf8", "", si, 1, 0);
6447     (void)av_store(av, 1, sw);
6448    }
6449    if (b)
6450     alt = *b;
6451   }
6452  }
6453
6454  if (listsvp)
6455   *listsvp = si;
6456  if (altsvp)
6457   *altsvp  = alt;
6458
6459  return sw;
6460 }
6461 #endif
6462
6463 /*
6464  - reginclass - determine if a character falls into a character class
6465
6466   n is the ANYOF regnode
6467   p is the target string
6468   lenp is pointer to the maximum number of bytes of how far to go in p
6469  (This is assumed wthout checking to always be at least the current
6470  character's size)
6471   utf8_target tells whether p is in UTF-8.
6472
6473   Returns true if matched; false otherwise.  If lenp is not NULL, on return
6474   from a successful match, the value it points to will be updated to how many
6475   bytes in p were matched.  If there was no match, the value is undefined,
6476   possibly changed from the input.
6477
6478   Note that this can be a synthetic start class, a combination of various
6479   nodes, so things you think might be mutually exclusive, such as locale,
6480   aren't.  It can match both locale and non-locale
6481
6482  */
6483
6484 STATIC bool
6485 S_reginclass(pTHX_ const regexp * const prog, register const regnode * const n, register const U8* const p, STRLEN* lenp, register const bool utf8_target)
6486 {
6487  dVAR;
6488  const char flags = ANYOF_FLAGS(n);
6489  bool match = FALSE;
6490  UV c = *p;
6491  STRLEN c_len = 0;
6492  STRLEN maxlen;
6493
6494  PERL_ARGS_ASSERT_REGINCLASS;
6495
6496  /* If c is not already the code point, get it */
6497  if (utf8_target && !UTF8_IS_INVARIANT(c)) {
6498   c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &c_len,
6499     (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
6500     | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
6501     /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
6502     * UTF8_ALLOW_FFFF */
6503   if (c_len == (STRLEN)-1)
6504    Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
6505  }
6506  else {
6507   c_len = 1;
6508  }
6509
6510  /* Use passed in max length, or one character if none passed in or less
6511  * than one character.  And assume will match just one character.  This is
6512  * overwritten later if matched more. */
6513  if (lenp) {
6514   maxlen = (*lenp > c_len) ? *lenp : c_len;
6515   *lenp = c_len;
6516
6517  }
6518  else {
6519   maxlen = c_len;
6520  }
6521
6522  /* If this character is potentially in the bitmap, check it */
6523  if (c < 256) {
6524   if (ANYOF_BITMAP_TEST(n, c))
6525    match = TRUE;
6526   else if (flags & ANYOF_NON_UTF8_LATIN1_ALL
6527     && ! utf8_target
6528     && ! isASCII(c))
6529   {
6530    match = TRUE;
6531   }
6532
6533   else if (flags & ANYOF_LOCALE) {
6534    PL_reg_flags |= RF_tainted;
6535
6536    if ((flags & ANYOF_LOC_NONBITMAP_FOLD)
6537     && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
6538    {
6539     match = TRUE;
6540    }
6541    else if (ANYOF_CLASS_TEST_ANY_SET(n) &&
6542      ((ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
6543      (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
6544      (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
6545      (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
6546      (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
6547      (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
6548      (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
6549      (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
6550      (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
6551      (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
6552      (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
6553      (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
6554      (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
6555      (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
6556      (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
6557      (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
6558      (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
6559      (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
6560      (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
6561      (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
6562      (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
6563      (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
6564      (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
6565      (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
6566      (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
6567      (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
6568      (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
6569      (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
6570      (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
6571      (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
6572      ) /* How's that for a conditional? */
6573    ) {
6574     match = TRUE;
6575    }
6576   }
6577  }
6578
6579  /* If the bitmap didn't (or couldn't) match, and something outside the
6580  * bitmap could match, try that.  Locale nodes specifiy completely the
6581  * behavior of code points in the bit map (otherwise, a utf8 target would
6582  * cause them to be treated as Unicode and not locale), except in
6583  * the very unlikely event when this node is a synthetic start class, which
6584  * could be a combination of locale and non-locale nodes.  So allow locale
6585  * to match for the synthetic start class, which will give a false
6586  * positive that will be resolved when the match is done again as not part
6587  * of the synthetic start class */
6588  if (!match) {
6589   if (utf8_target && (flags & ANYOF_UNICODE_ALL) && c >= 256) {
6590    match = TRUE; /* Everything above 255 matches */
6591   }
6592   else if (ANYOF_NONBITMAP(n)
6593     && ((flags & ANYOF_NONBITMAP_NON_UTF8)
6594      || (utf8_target
6595       && (c >=256
6596        || (! (flags & ANYOF_LOCALE))
6597        || (flags & ANYOF_IS_SYNTHETIC)))))
6598   {
6599    AV *av;
6600    SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
6601
6602    if (sw) {
6603     U8 * utf8_p;
6604     if (utf8_target) {
6605      utf8_p = (U8 *) p;
6606     } else {
6607
6608      /* Not utf8.  Convert as much of the string as available up
6609      * to the limit of how far the (single) character in the
6610      * pattern can possibly match (no need to go further).  If
6611      * the node is a straight ANYOF or not folding, it can't
6612      * match more than one.  Otherwise, It can match up to how
6613      * far a single char can fold to.  Since not utf8, each
6614      * character is a single byte, so the max it can be in
6615      * bytes is the same as the max it can be in characters */
6616      STRLEN len = (OP(n) == ANYOF
6617         || ! (flags & ANYOF_LOC_NONBITMAP_FOLD))
6618         ? 1
6619         : (maxlen < UTF8_MAX_FOLD_CHAR_EXPAND)
6620          ? maxlen
6621          : UTF8_MAX_FOLD_CHAR_EXPAND;
6622      utf8_p = bytes_to_utf8(p, &len);
6623     }
6624
6625     if (swash_fetch(sw, utf8_p, TRUE))
6626      match = TRUE;
6627     else if (flags & ANYOF_LOC_NONBITMAP_FOLD) {
6628
6629      /* Here, we need to test if the fold of the target string
6630      * matches.  The non-multi char folds have all been moved to
6631      * the compilation phase, and the multi-char folds have
6632      * been stored by regcomp into 'av'; we linearly check to
6633      * see if any match the target string (folded).   We know
6634      * that the originals were each one character, but we don't
6635      * currently know how many characters/bytes each folded to,
6636      * except we do know that there are small limits imposed by
6637      * Unicode.  XXX A performance enhancement would be to have
6638      * regcomp.c store the max number of chars/bytes that are
6639      * in an av entry, as, say the 0th element.  Even better
6640      * would be to have a hash of the few characters that can
6641      * start a multi-char fold to the max number of chars of
6642      * those folds.
6643      *
6644      * If there is a match, we will need to advance (if lenp is
6645      * specified) the match pointer in the target string.  But
6646      * what we are comparing here isn't that string directly,
6647      * but its fold, whose length may differ from the original.
6648      * As we go along in constructing the fold, therefore, we
6649      * create a map so that we know how many bytes in the
6650      * source to advance given that we have matched a certain
6651      * number of bytes in the fold.  This map is stored in
6652      * 'map_fold_len_back'.  Let n mean the number of bytes in
6653      * the fold of the first character that we are folding.
6654      * Then map_fold_len_back[n] is set to the number of bytes
6655      * in that first character.  Similarly let m be the
6656      * corresponding number for the second character to be
6657      * folded.  Then map_fold_len_back[n+m] is set to the
6658      * number of bytes occupied by the first two source
6659      * characters. ... */
6660      U8 map_fold_len_back[UTF8_MAXBYTES_CASE+1] = { 0 };
6661      U8 folded[UTF8_MAXBYTES_CASE+1];
6662      STRLEN foldlen = 0; /* num bytes in fold of 1st char */
6663      STRLEN total_foldlen = 0; /* num bytes in fold of all
6664             chars */
6665
6666      if (OP(n) == ANYOF || maxlen == 1 || ! lenp || ! av) {
6667
6668       /* Here, only need to fold the first char of the target
6669       * string.  It the source wasn't utf8, is 1 byte long */
6670       to_utf8_fold(utf8_p, folded, &foldlen);
6671       total_foldlen = foldlen;
6672       map_fold_len_back[foldlen] = (utf8_target)
6673              ? UTF8SKIP(utf8_p)
6674              : 1;
6675      }
6676      else {
6677
6678       /* Here, need to fold more than the first char.  Do so
6679       * up to the limits */
6680       U8* source_ptr = utf8_p;    /* The source for the fold
6681              is the regex target
6682              string */
6683       U8* folded_ptr = folded;
6684       U8* e = utf8_p + maxlen;    /* Can't go beyond last
6685              available byte in the
6686              target string */
6687       U8 i;
6688       for (i = 0;
6689        i < UTF8_MAX_FOLD_CHAR_EXPAND && source_ptr < e;
6690        i++)
6691       {
6692
6693        /* Fold the next character */
6694        U8 this_char_folded[UTF8_MAXBYTES_CASE+1];
6695        STRLEN this_char_foldlen;
6696        to_utf8_fold(source_ptr,
6697           this_char_folded,
6698           &this_char_foldlen);
6699
6700        /* Bail if it would exceed the byte limit for
6701        * folding a single char. */
6702        if (this_char_foldlen + folded_ptr - folded >
6703                UTF8_MAXBYTES_CASE)
6704        {
6705         break;
6706        }
6707
6708        /* Add the fold of this character */
6709        Copy(this_char_folded,
6710         folded_ptr,
6711         this_char_foldlen,
6712         U8);
6713        source_ptr += UTF8SKIP(source_ptr);
6714        folded_ptr += this_char_foldlen;
6715        total_foldlen = folded_ptr - folded;
6716
6717        /* Create map from the number of bytes in the fold
6718        * back to the number of bytes in the source.  If
6719        * the source isn't utf8, the byte count is just
6720        * the number of characters so far */
6721        map_fold_len_back[total_foldlen]
6722              = (utf8_target)
6723               ? source_ptr - utf8_p
6724               : i + 1;
6725       }
6726       *folded_ptr = '\0';
6727      }
6728
6729
6730      /* Do the linear search to see if the fold is in the list
6731      * of multi-char folds. */
6732      if (av) {
6733       I32 i;
6734       for (i = 0; i <= av_len(av); i++) {
6735        SV* const sv = *av_fetch(av, i, FALSE);
6736        STRLEN len;
6737        const char * const s = SvPV_const(sv, len);
6738
6739        if (len <= total_foldlen
6740         && memEQ(s, (char*)folded, len)
6741
6742         /* If 0, means matched a partial char. See
6743          * [perl #90536] */
6744         && map_fold_len_back[len])
6745        {
6746
6747         /* Advance the target string ptr to account for
6748         * this fold, but have to translate from the
6749         * folded length to the corresponding source
6750         * length. */
6751         if (lenp) {
6752          *lenp = map_fold_len_back[len];
6753         }
6754         match = TRUE;
6755         break;
6756        }
6757       }
6758      }
6759     }
6760
6761     /* If we allocated a string above, free it */
6762     if (! utf8_target) Safefree(utf8_p);
6763    }
6764   }
6765  }
6766
6767  return (flags & ANYOF_INVERT) ? !match : match;
6768 }
6769
6770 STATIC U8 *
6771 S_reghop3(U8 *s, I32 off, const U8* lim)
6772 {
6773  dVAR;
6774
6775  PERL_ARGS_ASSERT_REGHOP3;
6776
6777  if (off >= 0) {
6778   while (off-- && s < lim) {
6779    /* XXX could check well-formedness here */
6780    s += UTF8SKIP(s);
6781   }
6782  }
6783  else {
6784   while (off++ && s > lim) {
6785    s--;
6786    if (UTF8_IS_CONTINUED(*s)) {
6787     while (s > lim && UTF8_IS_CONTINUATION(*s))
6788      s--;
6789    }
6790    /* XXX could check well-formedness here */
6791   }
6792  }
6793  return s;
6794 }
6795
6796 #ifdef XXX_dmq
6797 /* there are a bunch of places where we use two reghop3's that should
6798    be replaced with this routine. but since thats not done yet
6799    we ifdef it out - dmq
6800 */
6801 STATIC U8 *
6802 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
6803 {
6804  dVAR;
6805
6806  PERL_ARGS_ASSERT_REGHOP4;
6807
6808  if (off >= 0) {
6809   while (off-- && s < rlim) {
6810    /* XXX could check well-formedness here */
6811    s += UTF8SKIP(s);
6812   }
6813  }
6814  else {
6815   while (off++ && s > llim) {
6816    s--;
6817    if (UTF8_IS_CONTINUED(*s)) {
6818     while (s > llim && UTF8_IS_CONTINUATION(*s))
6819      s--;
6820    }
6821    /* XXX could check well-formedness here */
6822   }
6823  }
6824  return s;
6825 }
6826 #endif
6827
6828 STATIC U8 *
6829 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
6830 {
6831  dVAR;
6832
6833  PERL_ARGS_ASSERT_REGHOPMAYBE3;
6834
6835  if (off >= 0) {
6836   while (off-- && s < lim) {
6837    /* XXX could check well-formedness here */
6838    s += UTF8SKIP(s);
6839   }
6840   if (off >= 0)
6841    return NULL;
6842  }
6843  else {
6844   while (off++ && s > lim) {
6845    s--;
6846    if (UTF8_IS_CONTINUED(*s)) {
6847     while (s > lim && UTF8_IS_CONTINUATION(*s))
6848      s--;
6849    }
6850    /* XXX could check well-formedness here */
6851   }
6852   if (off <= 0)
6853    return NULL;
6854  }
6855  return s;
6856 }
6857
6858 static void
6859 restore_pos(pTHX_ void *arg)
6860 {
6861  dVAR;
6862  regexp * const rex = (regexp *)arg;
6863  if (PL_reg_eval_set) {
6864   if (PL_reg_oldsaved) {
6865    rex->subbeg = PL_reg_oldsaved;
6866    rex->sublen = PL_reg_oldsavedlen;
6867 #ifdef PERL_OLD_COPY_ON_WRITE
6868    rex->saved_copy = PL_nrs;
6869 #endif
6870    RXp_MATCH_COPIED_on(rex);
6871   }
6872   PL_reg_magic->mg_len = PL_reg_oldpos;
6873   PL_reg_eval_set = 0;
6874   PL_curpm = PL_reg_oldcurpm;
6875  }
6876 }
6877
6878 STATIC void
6879 S_to_utf8_substr(pTHX_ register regexp *prog)
6880 {
6881  int i = 1;
6882
6883  PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
6884
6885  do {
6886   if (prog->substrs->data[i].substr
6887    && !prog->substrs->data[i].utf8_substr) {
6888    SV* const sv = newSVsv(prog->substrs->data[i].substr);
6889    prog->substrs->data[i].utf8_substr = sv;
6890    sv_utf8_upgrade(sv);
6891    if (SvVALID(prog->substrs->data[i].substr)) {
6892     const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
6893     if (flags & FBMcf_TAIL) {
6894      /* Trim the trailing \n that fbm_compile added last
6895      time.  */
6896      SvCUR_set(sv, SvCUR(sv) - 1);
6897      /* Whilst this makes the SV technically "invalid" (as its
6898      buffer is no longer followed by "\0") when fbm_compile()
6899      adds the "\n" back, a "\0" is restored.  */
6900     }
6901     fbm_compile(sv, flags);
6902    }
6903    if (prog->substrs->data[i].substr == prog->check_substr)
6904     prog->check_utf8 = sv;
6905   }
6906  } while (i--);
6907 }
6908
6909 STATIC void
6910 S_to_byte_substr(pTHX_ register regexp *prog)
6911 {
6912  dVAR;
6913  int i = 1;
6914
6915  PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
6916
6917  do {
6918   if (prog->substrs->data[i].utf8_substr
6919    && !prog->substrs->data[i].substr) {
6920    SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
6921    if (sv_utf8_downgrade(sv, TRUE)) {
6922     if (SvVALID(prog->substrs->data[i].utf8_substr)) {
6923      const U8 flags
6924       = BmFLAGS(prog->substrs->data[i].utf8_substr);
6925      if (flags & FBMcf_TAIL) {
6926       /* Trim the trailing \n that fbm_compile added last
6927       time.  */
6928       SvCUR_set(sv, SvCUR(sv) - 1);
6929      }
6930      fbm_compile(sv, flags);
6931     }
6932    } else {
6933     SvREFCNT_dec(sv);
6934     sv = &PL_sv_undef;
6935    }
6936    prog->substrs->data[i].substr = sv;
6937    if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
6938     prog->check_substr = sv;
6939   }
6940  } while (i--);
6941 }
6942
6943 /*
6944  * Local variables:
6945  * c-indentation-style: bsd
6946  * c-basic-offset: 4
6947  * indent-tabs-mode: t
6948  * End:
6949  *
6950  * ex: set ts=8 sts=4 sw=4 noet:
6951  */