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