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