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