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
3979                 n = ARG(scan);
3980                 PL_op = (OP_4tree*)rexi->data->data[n];
3981                 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3982                     "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3983                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3984                 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3985
3986                 if (sv_yes_mark) {
3987                     SV *sv_mrk = get_sv("REGMARK", 1);
3988                     sv_setsv(sv_mrk, sv_yes_mark);
3989                 }
3990
3991                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3992                 SPAGAIN;
3993                 if (SP == before)
3994                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3995                 else {
3996                     ret = POPs;
3997                     PUTBACK;
3998                 }
3999
4000                 PL_op = oop;
4001                 PAD_RESTORE_LOCAL(old_comppad);
4002                 PL_curcop = ocurcop;
4003                 PL_regeol = saved_regeol;
4004                 if (!logical) {
4005                     /* /(?{...})/ */
4006                     sv_setsv(save_scalar(PL_replgv), ret);
4007                     break;
4008                 }
4009             }
4010             if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
4011                 logical = 0;
4012                 {
4013                     /* extract RE object from returned value; compiling if
4014                      * necessary */
4015                     MAGIC *mg = NULL;
4016                     REGEXP *rx = NULL;
4017
4018                     if (SvROK(ret)) {
4019                         SV *const sv = SvRV(ret);
4020
4021                         if (SvTYPE(sv) == SVt_REGEXP) {
4022                             rx = (REGEXP*) sv;
4023                         } else if (SvSMAGICAL(sv)) {
4024                             mg = mg_find(sv, PERL_MAGIC_qr);
4025                             assert(mg);
4026                         }
4027                     } else if (SvTYPE(ret) == SVt_REGEXP) {
4028                         rx = (REGEXP*) ret;
4029                     } else if (SvSMAGICAL(ret)) {
4030                         if (SvGMAGICAL(ret)) {
4031                             /* I don't believe that there is ever qr magic
4032                                here.  */
4033                             assert(!mg_find(ret, PERL_MAGIC_qr));
4034                             sv_unmagic(ret, PERL_MAGIC_qr);
4035                         }
4036                         else {
4037                             mg = mg_find(ret, PERL_MAGIC_qr);
4038                             /* testing suggests mg only ends up non-NULL for
4039                                scalars who were upgraded and compiled in the
4040                                else block below. In turn, this is only
4041                                triggered in the "postponed utf8 string" tests
4042                                in t/op/pat.t  */
4043                         }
4044                     }
4045
4046                     if (mg) {
4047                         rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
4048                         assert(rx);
4049                     }
4050                     if (rx) {
4051                         rx = reg_temp_copy(NULL, rx);
4052                     }
4053                     else {
4054                         U32 pm_flags = 0;
4055                         const I32 osize = PL_regsize;
4056
4057                         if (DO_UTF8(ret)) {
4058                             assert (SvUTF8(ret));
4059                         } else if (SvUTF8(ret)) {
4060                             /* Not doing UTF-8, despite what the SV says. Is
4061                                this only if we're trapped in use 'bytes'?  */
4062                             /* Make a copy of the octet sequence, but without
4063                                the flag on, as the compiler now honours the
4064                                SvUTF8 flag on ret.  */
4065                             STRLEN len;
4066                             const char *const p = SvPV(ret, len);
4067                             ret = newSVpvn_flags(p, len, SVs_TEMP);
4068                         }
4069                         rx = CALLREGCOMP(ret, pm_flags);
4070                         if (!(SvFLAGS(ret)
4071                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
4072                                  | SVs_GMG))) {
4073                             /* This isn't a first class regexp. Instead, it's
4074                                caching a regexp onto an existing, Perl visible
4075                                scalar.  */
4076                             sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
4077                         }
4078                         PL_regsize = osize;
4079                     }
4080                     re_sv = rx;
4081                     re = (struct regexp *)SvANY(rx);
4082                 }
4083                 RXp_MATCH_COPIED_off(re);
4084                 re->subbeg = rex->subbeg;
4085                 re->sublen = rex->sublen;
4086                 rei = RXi_GET(re);
4087                 DEBUG_EXECUTE_r(
4088                     debug_start_match(re_sv, utf8_target, locinput, PL_regeol,
4089                         "Matching embedded");
4090                 );
4091                 startpoint = rei->program + 1;
4092                 ST.close_paren = 0; /* only used for GOSUB */
4093                 /* borrowed from regtry */
4094                 if (PL_reg_start_tmpl <= re->nparens) {
4095                     PL_reg_start_tmpl = re->nparens*3/2 + 3;
4096                     if(PL_reg_start_tmp)
4097                         Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4098                     else
4099                         Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4100                 }
4101
4102         eval_recurse_doit: /* Share code with GOSUB below this line */
4103                 /* run the pattern returned from (??{...}) */
4104                 ST.cp = regcppush(0);   /* Save *all* the positions. */
4105                 REGCP_SET(ST.lastcp);
4106
4107                 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
4108
4109                 /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
4110                 PL_reglastparen = &re->lastparen;
4111                 PL_reglastcloseparen = &re->lastcloseparen;
4112                 re->lastparen = 0;
4113                 re->lastcloseparen = 0;
4114
4115                 PL_reginput = locinput;
4116                 PL_regsize = 0;
4117
4118                 /* XXXX This is too dramatic a measure... */
4119                 PL_reg_maxiter = 0;
4120
4121                 ST.toggle_reg_flags = PL_reg_flags;
4122                 if (RX_UTF8(re_sv))
4123                     PL_reg_flags |= RF_utf8;
4124                 else
4125                     PL_reg_flags &= ~RF_utf8;
4126                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
4127
4128                 ST.prev_rex = rex_sv;
4129                 ST.prev_curlyx = cur_curlyx;
4130                 SETREX(rex_sv,re_sv);
4131                 rex = re;
4132                 rexi = rei;
4133                 cur_curlyx = NULL;
4134                 ST.B = next;
4135                 ST.prev_eval = cur_eval;
4136                 cur_eval = st;
4137                 /* now continue from first node in postoned RE */
4138                 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
4139                 /* NOTREACHED */
4140             }
4141             /* logical is 1,   /(?(?{...})X|Y)/ */
4142             sw = cBOOL(SvTRUE(ret));
4143             logical = 0;
4144             break;
4145         }
4146
4147         case EVAL_AB: /* cleanup after a successful (??{A})B */
4148             /* note: this is called twice; first after popping B, then A */
4149             PL_reg_flags ^= ST.toggle_reg_flags;
4150             ReREFCNT_dec(rex_sv);
4151             SETREX(rex_sv,ST.prev_rex);
4152             rex = (struct regexp *)SvANY(rex_sv);
4153             rexi = RXi_GET(rex);
4154             regcpblow(ST.cp);
4155             cur_eval = ST.prev_eval;
4156             cur_curlyx = ST.prev_curlyx;
4157
4158             /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4159             PL_reglastparen = &rex->lastparen;
4160             PL_reglastcloseparen = &rex->lastcloseparen;
4161             /* also update PL_regoffs */
4162             PL_regoffs = rex->offs;
4163
4164             /* XXXX This is too dramatic a measure... */
4165             PL_reg_maxiter = 0;
4166             if ( nochange_depth )
4167                 nochange_depth--;
4168             sayYES;
4169
4170
4171         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
4172             /* note: this is called twice; first after popping B, then A */
4173             PL_reg_flags ^= ST.toggle_reg_flags;
4174             ReREFCNT_dec(rex_sv);
4175             SETREX(rex_sv,ST.prev_rex);
4176             rex = (struct regexp *)SvANY(rex_sv);
4177             rexi = RXi_GET(rex);
4178             /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4179             PL_reglastparen = &rex->lastparen;
4180             PL_reglastcloseparen = &rex->lastcloseparen;
4181
4182             PL_reginput = locinput;
4183             REGCP_UNWIND(ST.lastcp);
4184             regcppop(rex);
4185             cur_eval = ST.prev_eval;
4186             cur_curlyx = ST.prev_curlyx;
4187             /* XXXX This is too dramatic a measure... */
4188             PL_reg_maxiter = 0;
4189             if ( nochange_depth )
4190                 nochange_depth--;
4191             sayNO_SILENT;
4192 #undef ST
4193
4194         case OPEN:
4195             n = ARG(scan);  /* which paren pair */
4196             PL_reg_start_tmp[n] = locinput;
4197             if (n > PL_regsize)
4198                 PL_regsize = n;
4199             lastopen = n;
4200             break;
4201         case CLOSE:
4202             n = ARG(scan);  /* which paren pair */
4203             PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
4204             PL_regoffs[n].end = locinput - PL_bostr;
4205             /*if (n > PL_regsize)
4206                 PL_regsize = n;*/
4207             if (n > *PL_reglastparen)
4208                 *PL_reglastparen = n;
4209             *PL_reglastcloseparen = n;
4210             if (cur_eval && cur_eval->u.eval.close_paren == n) {
4211                 goto fake_end;
4212             }
4213             break;
4214         case ACCEPT:
4215             if (ARG(scan)){
4216                 regnode *cursor;
4217                 for (cursor=scan;
4218                      cursor && OP(cursor)!=END;
4219                      cursor=regnext(cursor))
4220                 {
4221                     if ( OP(cursor)==CLOSE ){
4222                         n = ARG(cursor);
4223                         if ( n <= lastopen ) {
4224                             PL_regoffs[n].start
4225                                 = PL_reg_start_tmp[n] - PL_bostr;
4226                             PL_regoffs[n].end = locinput - PL_bostr;
4227                             /*if (n > PL_regsize)
4228                             PL_regsize = n;*/
4229                             if (n > *PL_reglastparen)
4230                                 *PL_reglastparen = n;
4231                             *PL_reglastcloseparen = n;
4232                             if ( n == ARG(scan) || (cur_eval &&
4233                                 cur_eval->u.eval.close_paren == n))
4234                                 break;
4235                         }
4236                     }
4237                 }
4238             }
4239             goto fake_end;
4240             /*NOTREACHED*/
4241         case GROUPP:
4242             n = ARG(scan);  /* which paren pair */
4243             sw = cBOOL(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
4244             break;
4245         case NGROUPP:
4246             /* reg_check_named_buff_matched returns 0 for no match */
4247             sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
4248             break;
4249         case INSUBP:
4250             n = ARG(scan);
4251             sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
4252             break;
4253         case DEFINEP:
4254             sw = 0;
4255             break;
4256         case IFTHEN:
4257             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
4258             if (sw)
4259                 next = NEXTOPER(NEXTOPER(scan));
4260             else {
4261                 next = scan + ARG(scan);
4262                 if (OP(next) == IFTHEN) /* Fake one. */
4263                     next = NEXTOPER(NEXTOPER(next));
4264             }
4265             break;
4266         case LOGICAL:
4267             logical = scan->flags;
4268             break;
4269
4270 /*******************************************************************
4271
4272 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
4273 pattern, where A and B are subpatterns. (For simple A, CURLYM or
4274 STAR/PLUS/CURLY/CURLYN are used instead.)
4275
4276 A*B is compiled as <CURLYX><A><WHILEM><B>
4277
4278 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
4279 state, which contains the current count, initialised to -1. It also sets
4280 cur_curlyx to point to this state, with any previous value saved in the
4281 state block.
4282
4283 CURLYX then jumps straight to the WHILEM op, rather than executing A,
4284 since the pattern may possibly match zero times (i.e. it's a while {} loop
4285 rather than a do {} while loop).
4286
4287 Each entry to WHILEM represents a successful match of A. The count in the
4288 CURLYX block is incremented, another WHILEM state is pushed, and execution
4289 passes to A or B depending on greediness and the current count.
4290
4291 For example, if matching against the string a1a2a3b (where the aN are
4292 substrings that match /A/), then the match progresses as follows: (the
4293 pushed states are interspersed with the bits of strings matched so far):
4294
4295     <CURLYX cnt=-1>
4296     <CURLYX cnt=0><WHILEM>
4297     <CURLYX cnt=1><WHILEM> a1 <WHILEM>
4298     <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
4299     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
4300     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
4301
4302 (Contrast this with something like CURLYM, which maintains only a single
4303 backtrack state:
4304
4305     <CURLYM cnt=0> a1
4306     a1 <CURLYM cnt=1> a2
4307     a1 a2 <CURLYM cnt=2> a3
4308     a1 a2 a3 <CURLYM cnt=3> b
4309 )
4310
4311 Each WHILEM state block marks a point to backtrack to upon partial failure
4312 of A or B, and also contains some minor state data related to that
4313 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
4314 overall state, such as the count, and pointers to the A and B ops.
4315
4316 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
4317 must always point to the *current* CURLYX block, the rules are:
4318
4319 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
4320 and set cur_curlyx to point the new block.
4321
4322 When popping the CURLYX block after a successful or unsuccessful match,
4323 restore the previous cur_curlyx.
4324
4325 When WHILEM is about to execute B, save the current cur_curlyx, and set it
4326 to the outer one saved in the CURLYX block.
4327
4328 When popping the WHILEM block after a successful or unsuccessful B match,
4329 restore the previous cur_curlyx.
4330
4331 Here's an example for the pattern (AI* BI)*BO
4332 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
4333
4334 cur_
4335 curlyx backtrack stack
4336 ------ ---------------
4337 NULL
4338 CO     <CO prev=NULL> <WO>
4339 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4340 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4341 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
4342
4343 At this point the pattern succeeds, and we work back down the stack to
4344 clean up, restoring as we go:
4345
4346 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4347 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4348 CO     <CO prev=NULL> <WO>
4349 NULL
4350
4351 *******************************************************************/
4352
4353 #define ST st->u.curlyx
4354
4355         case CURLYX:    /* start of /A*B/  (for complex A) */
4356         {
4357             /* No need to save/restore up to this paren */
4358             I32 parenfloor = scan->flags;
4359
4360             assert(next); /* keep Coverity happy */
4361             if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4362                 next += ARG(next);
4363
4364             /* XXXX Probably it is better to teach regpush to support
4365                parenfloor > PL_regsize... */
4366             if (parenfloor > (I32)*PL_reglastparen)
4367                 parenfloor = *PL_reglastparen; /* Pessimization... */
4368
4369             ST.prev_curlyx= cur_curlyx;
4370             cur_curlyx = st;
4371             ST.cp = PL_savestack_ix;
4372
4373             /* these fields contain the state of the current curly.
4374              * they are accessed by subsequent WHILEMs */
4375             ST.parenfloor = parenfloor;
4376             ST.me = scan;
4377             ST.B = next;
4378             ST.minmod = minmod;
4379             minmod = 0;
4380             ST.count = -1;      /* this will be updated by WHILEM */
4381             ST.lastloc = NULL;  /* this will be updated by WHILEM */
4382
4383             PL_reginput = locinput;
4384             PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4385             /* NOTREACHED */
4386         }
4387
4388         case CURLYX_end: /* just finished matching all of A*B */
4389             cur_curlyx = ST.prev_curlyx;
4390             sayYES;
4391             /* NOTREACHED */
4392
4393         case CURLYX_end_fail: /* just failed to match all of A*B */
4394             regcpblow(ST.cp);
4395             cur_curlyx = ST.prev_curlyx;
4396             sayNO;
4397             /* NOTREACHED */
4398
4399
4400 #undef ST
4401 #define ST st->u.whilem
4402
4403         case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
4404         {
4405             /* see the discussion above about CURLYX/WHILEM */
4406             I32 n;
4407             int min = ARG1(cur_curlyx->u.curlyx.me);
4408             int max = ARG2(cur_curlyx->u.curlyx.me);
4409             regnode *A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS;
4410
4411             assert(cur_curlyx); /* keep Coverity happy */
4412             n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4413             ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4414             ST.cache_offset = 0;
4415             ST.cache_mask = 0;
4416
4417             PL_reginput = locinput;
4418
4419             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4420                   "%*s  whilem: matched %ld out of %d..%d\n",
4421                   REPORT_CODE_OFF+depth*2, "", (long)n, min, max)
4422             );
4423
4424             /* First just match a string of min A's. */
4425
4426             if (n < min) {
4427                 cur_curlyx->u.curlyx.lastloc = locinput;
4428                 PUSH_STATE_GOTO(WHILEM_A_pre, A);
4429                 /* NOTREACHED */
4430             }
4431
4432             /* If degenerate A matches "", assume A done. */
4433
4434             if (locinput == cur_curlyx->u.curlyx.lastloc) {
4435                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4436                    "%*s  whilem: empty match detected, trying continuation...\n",
4437                    REPORT_CODE_OFF+depth*2, "")
4438                 );
4439                 goto do_whilem_B_max;
4440             }
4441
4442             /* super-linear cache processing */
4443
4444             if (scan->flags) {
4445
4446                 if (!PL_reg_maxiter) {
4447                     /* start the countdown: Postpone detection until we
4448                      * know the match is not *that* much linear. */
4449                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4450                     /* possible overflow for long strings and many CURLYX's */
4451                     if (PL_reg_maxiter < 0)
4452                         PL_reg_maxiter = I32_MAX;
4453                     PL_reg_leftiter = PL_reg_maxiter;
4454                 }
4455
4456                 if (PL_reg_leftiter-- == 0) {
4457                     /* initialise cache */
4458                     const I32 size = (PL_reg_maxiter + 7)/8;
4459                     if (PL_reg_poscache) {
4460                         if ((I32)PL_reg_poscache_size < size) {
4461                             Renew(PL_reg_poscache, size, char);
4462                             PL_reg_poscache_size = size;
4463                         }
4464                         Zero(PL_reg_poscache, size, char);
4465                     }
4466                     else {
4467                         PL_reg_poscache_size = size;
4468                         Newxz(PL_reg_poscache, size, char);
4469                     }
4470                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4471       "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4472                               PL_colors[4], PL_colors[5])
4473                     );
4474                 }
4475
4476                 if (PL_reg_leftiter < 0) {
4477                     /* have we already failed at this position? */
4478                     I32 offset, mask;
4479                     offset  = (scan->flags & 0xf) - 1
4480                                 + (locinput - PL_bostr)  * (scan->flags>>4);
4481                     mask    = 1 << (offset % 8);
4482                     offset /= 8;
4483                     if (PL_reg_poscache[offset] & mask) {
4484                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4485                             "%*s  whilem: (cache) already tried at this position...\n",
4486                             REPORT_CODE_OFF+depth*2, "")
4487                         );
4488                         sayNO; /* cache records failure */
4489                     }
4490                     ST.cache_offset = offset;
4491                     ST.cache_mask   = mask;
4492                 }
4493             }
4494
4495             /* Prefer B over A for minimal matching. */
4496
4497             if (cur_curlyx->u.curlyx.minmod) {
4498                 ST.save_curlyx = cur_curlyx;
4499                 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4500                 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4501                 REGCP_SET(ST.lastcp);
4502                 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4503                 /* NOTREACHED */
4504             }
4505
4506             /* Prefer A over B for maximal matching. */
4507
4508             if (n < max) { /* More greed allowed? */
4509                 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4510                 cur_curlyx->u.curlyx.lastloc = locinput;
4511                 REGCP_SET(ST.lastcp);
4512                 PUSH_STATE_GOTO(WHILEM_A_max, A);
4513                 /* NOTREACHED */
4514             }
4515             goto do_whilem_B_max;
4516         }
4517         /* NOTREACHED */
4518
4519         case WHILEM_B_min: /* just matched B in a minimal match */
4520         case WHILEM_B_max: /* just matched B in a maximal match */
4521             cur_curlyx = ST.save_curlyx;
4522             sayYES;
4523             /* NOTREACHED */
4524
4525         case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4526             cur_curlyx = ST.save_curlyx;
4527             cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4528             cur_curlyx->u.curlyx.count--;
4529             CACHEsayNO;
4530             /* NOTREACHED */
4531
4532         case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4533             REGCP_UNWIND(ST.lastcp);
4534             regcppop(rex);
4535             /* FALL THROUGH */
4536         case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4537             cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4538             cur_curlyx->u.curlyx.count--;
4539             CACHEsayNO;
4540             /* NOTREACHED */
4541
4542         case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4543             REGCP_UNWIND(ST.lastcp);
4544             regcppop(rex);      /* Restore some previous $<digit>s? */
4545             PL_reginput = locinput;
4546             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4547                 "%*s  whilem: failed, trying continuation...\n",
4548                 REPORT_CODE_OFF+depth*2, "")
4549             );
4550           do_whilem_B_max:
4551             if (cur_curlyx->u.curlyx.count >= REG_INFTY
4552                 && ckWARN(WARN_REGEXP)
4553                 && !(PL_reg_flags & RF_warned))
4554             {
4555                 PL_reg_flags |= RF_warned;
4556                 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4557                      "Complex regular subexpression recursion",
4558                      REG_INFTY - 1);
4559             }
4560
4561             /* now try B */
4562             ST.save_curlyx = cur_curlyx;
4563             cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4564             PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4565             /* NOTREACHED */
4566
4567         case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4568             cur_curlyx = ST.save_curlyx;
4569             REGCP_UNWIND(ST.lastcp);
4570             regcppop(rex);
4571
4572             if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
4573                 /* Maximum greed exceeded */
4574                 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4575                     && ckWARN(WARN_REGEXP)
4576                     && !(PL_reg_flags & RF_warned))
4577                 {
4578                     PL_reg_flags |= RF_warned;
4579                     Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4580                         "%s limit (%d) exceeded",
4581                         "Complex regular subexpression recursion",
4582                         REG_INFTY - 1);
4583                 }
4584                 cur_curlyx->u.curlyx.count--;
4585                 CACHEsayNO;
4586             }
4587
4588             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4589                 "%*s  trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4590             );
4591             /* Try grabbing another A and see if it helps. */
4592             PL_reginput = locinput;
4593             cur_curlyx->u.curlyx.lastloc = locinput;
4594             ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4595             REGCP_SET(ST.lastcp);
4596             PUSH_STATE_GOTO(WHILEM_A_min,
4597                 /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS);
4598             /* NOTREACHED */
4599
4600 #undef  ST
4601 #define ST st->u.branch
4602
4603         case BRANCHJ:       /*  /(...|A|...)/ with long next pointer */
4604             next = scan + ARG(scan);
4605             if (next == scan)
4606                 next = NULL;
4607             scan = NEXTOPER(scan);
4608             /* FALL THROUGH */
4609
4610         case BRANCH:        /*  /(...|A|...)/ */
4611             scan = NEXTOPER(scan); /* scan now points to inner node */
4612             ST.lastparen = *PL_reglastparen;
4613             ST.next_branch = next;
4614             REGCP_SET(ST.cp);
4615             PL_reginput = locinput;
4616
4617             /* Now go into the branch */
4618             if (has_cutgroup) {
4619                 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4620             } else {
4621                 PUSH_STATE_GOTO(BRANCH_next, scan);
4622             }
4623             /* NOTREACHED */
4624         case CUTGROUP:
4625             PL_reginput = locinput;
4626             sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4627                 MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4628             PUSH_STATE_GOTO(CUTGROUP_next,next);
4629             /* NOTREACHED */
4630         case CUTGROUP_next_fail:
4631             do_cutgroup = 1;
4632             no_final = 1;
4633             if (st->u.mark.mark_name)
4634                 sv_commit = st->u.mark.mark_name;
4635             sayNO;
4636             /* NOTREACHED */
4637         case BRANCH_next:
4638             sayYES;
4639             /* NOTREACHED */
4640         case BRANCH_next_fail: /* that branch failed; try the next, if any */
4641             if (do_cutgroup) {
4642                 do_cutgroup = 0;
4643                 no_final = 0;
4644             }
4645             REGCP_UNWIND(ST.cp);
4646             for (n = *PL_reglastparen; n > ST.lastparen; n--)
4647                 PL_regoffs[n].end = -1;
4648             *PL_reglastparen = n;
4649             /*dmq: *PL_reglastcloseparen = n; */
4650             scan = ST.next_branch;
4651             /* no more branches? */
4652             if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4653                 DEBUG_EXECUTE_r({
4654                     PerlIO_printf( Perl_debug_log,
4655                         "%*s  %sBRANCH failed...%s\n",
4656                         REPORT_CODE_OFF+depth*2, "",
4657                         PL_colors[4],
4658                         PL_colors[5] );
4659                 });
4660                 sayNO_SILENT;
4661             }
4662             continue; /* execute next BRANCH[J] op */
4663             /* NOTREACHED */
4664
4665         case MINMOD:
4666             minmod = 1;
4667             break;
4668
4669 #undef  ST
4670 #define ST st->u.curlym
4671
4672         case CURLYM:    /* /A{m,n}B/ where A is fixed-length */
4673
4674             /* This is an optimisation of CURLYX that enables us to push
4675              * only a single backtracking state, no matter how many matches
4676              * there are in {m,n}. It relies on the pattern being constant
4677              * length, with no parens to influence future backrefs
4678              */
4679
4680             ST.me = scan;
4681             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4682
4683             /* if paren positive, emulate an OPEN/CLOSE around A */
4684             if (ST.me->flags) {
4685                 U32 paren = ST.me->flags;
4686                 if (paren > PL_regsize)
4687                     PL_regsize = paren;
4688                 if (paren > *PL_reglastparen)
4689                     *PL_reglastparen = paren;
4690                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4691             }
4692             ST.A = scan;
4693             ST.B = next;
4694             ST.alen = 0;
4695             ST.count = 0;
4696             ST.minmod = minmod;
4697             minmod = 0;
4698             ST.c1 = CHRTEST_UNINIT;
4699             REGCP_SET(ST.cp);
4700
4701             if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4702                 goto curlym_do_B;
4703
4704           curlym_do_A: /* execute the A in /A{m,n}B/  */
4705             PL_reginput = locinput;
4706             PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4707             /* NOTREACHED */
4708
4709         case CURLYM_A: /* we've just matched an A */
4710             locinput = st->locinput;
4711             nextchr = UCHARAT(locinput);
4712
4713             ST.count++;
4714             /* after first match, determine A's length: u.curlym.alen */
4715             if (ST.count == 1) {
4716                 if (PL_reg_match_utf8) {
4717                     char *s = locinput;
4718                     while (s < PL_reginput) {
4719                         ST.alen++;
4720                         s += UTF8SKIP(s);
4721                     }
4722                 }
4723                 else {
4724                     ST.alen = PL_reginput - locinput;
4725                 }
4726                 if (ST.alen == 0)
4727                     ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4728             }
4729             DEBUG_EXECUTE_r(
4730                 PerlIO_printf(Perl_debug_log,
4731                           "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4732                           (int)(REPORT_CODE_OFF+(depth*2)), "",
4733                           (IV) ST.count, (IV)ST.alen)
4734             );
4735
4736             locinput = PL_reginput;
4737
4738             if (cur_eval && cur_eval->u.eval.close_paren &&
4739                 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4740                 goto fake_end;
4741
4742             {
4743                 I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
4744                 if ( max == REG_INFTY || ST.count < max )
4745                     goto curlym_do_A; /* try to match another A */
4746             }
4747             goto curlym_do_B; /* try to match B */
4748
4749         case CURLYM_A_fail: /* just failed to match an A */
4750             REGCP_UNWIND(ST.cp);
4751
4752             if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4753                 || (cur_eval && cur_eval->u.eval.close_paren &&
4754                     cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4755                 sayNO;
4756
4757           curlym_do_B: /* execute the B in /A{m,n}B/  */
4758             PL_reginput = locinput;
4759             if (ST.c1 == CHRTEST_UNINIT) {
4760                 /* calculate c1 and c2 for possible match of 1st char
4761                  * following curly */
4762                 ST.c1 = ST.c2 = CHRTEST_VOID;
4763                 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4764                     regnode *text_node = ST.B;
4765                     if (! HAS_TEXT(text_node))
4766                         FIND_NEXT_IMPT(text_node);
4767                     /* this used to be
4768
4769                         (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4770
4771                         But the former is redundant in light of the latter.
4772
4773                         if this changes back then the macro for
4774                         IS_TEXT and friends need to change.
4775                      */
4776                     if (PL_regkind[OP(text_node)] == EXACT)
4777                     {
4778
4779                         ST.c1 = (U8)*STRING(text_node);
4780                         ST.c2 =
4781                             (IS_TEXTF(text_node))
4782                             ? PL_fold[ST.c1]
4783                             : (IS_TEXTFL(text_node))
4784                                 ? PL_fold_locale[ST.c1]
4785                                 : ST.c1;
4786                     }
4787                 }
4788             }
4789
4790             DEBUG_EXECUTE_r(
4791                 PerlIO_printf(Perl_debug_log,
4792                     "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
4793                     (int)(REPORT_CODE_OFF+(depth*2)),
4794                     "", (IV)ST.count)
4795                 );
4796             if (ST.c1 != CHRTEST_VOID
4797                     && UCHARAT(PL_reginput) != ST.c1
4798                     && UCHARAT(PL_reginput) != ST.c2)
4799             {
4800                 /* simulate B failing */
4801                 DEBUG_OPTIMISE_r(
4802                     PerlIO_printf(Perl_debug_log,
4803                         "%*s  CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
4804                         (int)(REPORT_CODE_OFF+(depth*2)),"",
4805                         (IV)ST.c1,(IV)ST.c2
4806                 ));
4807                 state_num = CURLYM_B_fail;
4808                 goto reenter_switch;
4809             }
4810
4811             if (ST.me->flags) {
4812                 /* mark current A as captured */
4813                 I32 paren = ST.me->flags;
4814                 if (ST.count) {
4815                     PL_regoffs[paren].start
4816                         = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4817                     PL_regoffs[paren].end = PL_reginput - PL_bostr;
4818                     /*dmq: *PL_reglastcloseparen = paren; */
4819                 }
4820                 else
4821                     PL_regoffs[paren].end = -1;
4822                 if (cur_eval && cur_eval->u.eval.close_paren &&
4823                     cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4824                 {
4825                     if (ST.count)
4826                         goto fake_end;
4827                     else
4828                         sayNO;
4829                 }
4830             }
4831
4832             PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4833             /* NOTREACHED */
4834
4835         case CURLYM_B_fail: /* just failed to match a B */
4836             REGCP_UNWIND(ST.cp);
4837             if (ST.minmod) {
4838                 I32 max = ARG2(ST.me);
4839                 if (max != REG_INFTY && ST.count == max)
4840                     sayNO;
4841                 goto curlym_do_A; /* try to match a further A */
4842             }
4843             /* backtrack one A */
4844             if (ST.count == ARG1(ST.me) /* min */)
4845                 sayNO;
4846             ST.count--;
4847             locinput = HOPc(locinput, -ST.alen);
4848             goto curlym_do_B; /* try to match B */
4849
4850 #undef ST
4851 #define ST st->u.curly
4852
4853 #define CURLY_SETPAREN(paren, success) \
4854     if (paren) { \
4855         if (success) { \
4856             PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
4857             PL_regoffs[paren].end = locinput - PL_bostr; \
4858             *PL_reglastcloseparen = paren; \
4859         } \
4860         else \
4861             PL_regoffs[paren].end = -1; \
4862     }
4863
4864         case STAR:              /*  /A*B/ where A is width 1 */
4865             ST.paren = 0;
4866             ST.min = 0;
4867             ST.max = REG_INFTY;
4868             scan = NEXTOPER(scan);
4869             goto repeat;
4870         case PLUS:              /*  /A+B/ where A is width 1 */
4871             ST.paren = 0;
4872             ST.min = 1;
4873             ST.max = REG_INFTY;
4874             scan = NEXTOPER(scan);
4875             goto repeat;
4876         case CURLYN:            /*  /(A){m,n}B/ where A is width 1 */
4877             ST.paren = scan->flags;     /* Which paren to set */
4878             if (ST.paren > PL_regsize)
4879                 PL_regsize = ST.paren;
4880             if (ST.paren > *PL_reglastparen)
4881                 *PL_reglastparen = ST.paren;
4882             ST.min = ARG1(scan);  /* min to match */
4883             ST.max = ARG2(scan);  /* max to match */
4884             if (cur_eval && cur_eval->u.eval.close_paren &&
4885                 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4886                 ST.min=1;
4887                 ST.max=1;
4888             }
4889             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4890             goto repeat;
4891         case CURLY:             /*  /A{m,n}B/ where A is width 1 */
4892             ST.paren = 0;
4893             ST.min = ARG1(scan);  /* min to match */
4894             ST.max = ARG2(scan);  /* max to match */
4895             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4896           repeat:
4897             /*
4898             * Lookahead to avoid useless match attempts
4899             * when we know what character comes next.
4900             *
4901             * Used to only do .*x and .*?x, but now it allows
4902             * for )'s, ('s and (?{ ... })'s to be in the way
4903             * of the quantifier and the EXACT-like node.  -- japhy
4904             */
4905
4906             if (ST.min > ST.max) /* XXX make this a compile-time check? */
4907                 sayNO;
4908             if (HAS_TEXT(next) || JUMPABLE(next)) {
4909                 U8 *s;
4910                 regnode *text_node = next;
4911
4912                 if (! HAS_TEXT(text_node))
4913                     FIND_NEXT_IMPT(text_node);
4914
4915                 if (! HAS_TEXT(text_node))
4916                     ST.c1 = ST.c2 = CHRTEST_VOID;
4917                 else {
4918                     if ( PL_regkind[OP(text_node)] != EXACT ) {
4919                         ST.c1 = ST.c2 = CHRTEST_VOID;
4920                         goto assume_ok_easy;
4921                     }
4922                     else
4923                         s = (U8*)STRING(text_node);
4924
4925                     /*  Currently we only get here when
4926
4927                         PL_rekind[OP(text_node)] == EXACT
4928
4929                         if this changes back then the macro for IS_TEXT and
4930                         friends need to change. */
4931                     if (!UTF_PATTERN) {
4932                         ST.c2 = ST.c1 = *s;
4933                         if (IS_TEXTF(text_node))
4934                             ST.c2 = PL_fold[ST.c1];
4935                         else if (IS_TEXTFL(text_node))
4936                             ST.c2 = PL_fold_locale[ST.c1];
4937                     }
4938                     else { /* UTF_PATTERN */
4939                         if (IS_TEXTF(text_node)) {
4940                              STRLEN ulen1, ulen2;
4941                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4942                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4943
4944                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4945                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4946 #ifdef EBCDIC
4947                              ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4948                                                     ckWARN(WARN_UTF8) ?
4949                                                     0 : UTF8_ALLOW_ANY);
4950                              ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4951                                                     ckWARN(WARN_UTF8) ?
4952                                                     0 : UTF8_ALLOW_ANY);
4953 #else
4954                              ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4955                                                     uniflags);
4956                              ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4957                                                     uniflags);
4958 #endif
4959                         }
4960                         else {
4961                             ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4962                                                      uniflags);
4963                         }
4964                     }
4965                 }
4966             }
4967             else
4968                 ST.c1 = ST.c2 = CHRTEST_VOID;
4969         assume_ok_easy:
4970
4971             ST.A = scan;
4972             ST.B = next;
4973             PL_reginput = locinput;
4974             if (minmod) {
4975                 minmod = 0;
4976                 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4977                     sayNO;
4978                 ST.count = ST.min;
4979                 locinput = PL_reginput;
4980                 REGCP_SET(ST.cp);
4981                 if (ST.c1 == CHRTEST_VOID)
4982                     goto curly_try_B_min;
4983
4984                 ST.oldloc = locinput;
4985
4986                 /* set ST.maxpos to the furthest point along the
4987                  * string that could possibly match */
4988                 if  (ST.max == REG_INFTY) {
4989                     ST.maxpos = PL_regeol - 1;
4990                     if (utf8_target)
4991                         while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4992                             ST.maxpos--;
4993                 }
4994                 else if (utf8_target) {
4995                     int m = ST.max - ST.min;
4996                     for (ST.maxpos = locinput;
4997                          m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4998                         ST.maxpos += UTF8SKIP(ST.maxpos);
4999                 }
5000                 else {
5001                     ST.maxpos = locinput + ST.max - ST.min;
5002                     if (ST.maxpos >= PL_regeol)
5003                         ST.maxpos = PL_regeol - 1;
5004                 }
5005                 goto curly_try_B_min_known;
5006
5007             }
5008             else {
5009                 ST.count = regrepeat(rex, ST.A, ST.max, depth);
5010                 locinput = PL_reginput;
5011                 if (ST.count < ST.min)
5012                     sayNO;
5013                 if ((ST.count > ST.min)
5014                     && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
5015                 {
5016                     /* A{m,n} must come at the end of the string, there's
5017                      * no point in backing off ... */
5018                     ST.min = ST.count;
5019                     /* ...except that $ and \Z can match before *and* after
5020                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
5021                        We may back off by one in this case. */
5022                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
5023                         ST.min--;
5024                 }
5025                 REGCP_SET(ST.cp);
5026                 goto curly_try_B_max;
5027             }
5028             /* NOTREACHED */
5029
5030
5031         case CURLY_B_min_known_fail:
5032             /* failed to find B in a non-greedy match where c1,c2 valid */
5033             if (ST.paren && ST.count)
5034                 PL_regoffs[ST.paren].end = -1;
5035
5036             PL_reginput = locinput;     /* Could be reset... */
5037             REGCP_UNWIND(ST.cp);
5038             /* Couldn't or didn't -- move forward. */
5039             ST.oldloc = locinput;
5040             if (utf8_target)
5041                 locinput += UTF8SKIP(locinput);
5042             else
5043                 locinput++;
5044             ST.count++;
5045           curly_try_B_min_known:
5046              /* find the next place where 'B' could work, then call B */
5047             {
5048                 int n;
5049                 if (utf8_target) {
5050                     n = (ST.oldloc == locinput) ? 0 : 1;
5051                     if (ST.c1 == ST.c2) {
5052                         STRLEN len;
5053                         /* set n to utf8_distance(oldloc, locinput) */
5054                         while (locinput <= ST.maxpos &&
5055                                utf8n_to_uvchr((U8*)locinput,
5056                                               UTF8_MAXBYTES, &len,
5057                                               uniflags) != (UV)ST.c1) {
5058                             locinput += len;
5059                             n++;
5060                         }
5061                     }
5062                     else {
5063                         /* set n to utf8_distance(oldloc, locinput) */
5064                         while (locinput <= ST.maxpos) {
5065                             STRLEN len;
5066                             const UV c = utf8n_to_uvchr((U8*)locinput,
5067                                                   UTF8_MAXBYTES, &len,
5068                                                   uniflags);
5069                             if (c == (UV)ST.c1 || c == (UV)ST.c2)
5070                                 break;
5071                             locinput += len;
5072                             n++;
5073                         }
5074                     }
5075                 }
5076                 else {
5077                     if (ST.c1 == ST.c2) {
5078                         while (locinput <= ST.maxpos &&
5079                                UCHARAT(locinput) != ST.c1)
5080                             locinput++;
5081                     }
5082                     else {
5083                         while (locinput <= ST.maxpos
5084                                && UCHARAT(locinput) != ST.c1
5085                                && UCHARAT(locinput) != ST.c2)
5086                             locinput++;
5087                     }
5088                     n = locinput - ST.oldloc;
5089                 }
5090                 if (locinput > ST.maxpos)
5091                     sayNO;
5092                 /* PL_reginput == oldloc now */
5093                 if (n) {
5094                     ST.count += n;
5095                     if (regrepeat(rex, ST.A, n, depth) < n)
5096                         sayNO;
5097                 }
5098                 PL_reginput = locinput;
5099                 CURLY_SETPAREN(ST.paren, ST.count);
5100                 if (cur_eval && cur_eval->u.eval.close_paren &&
5101                     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5102                     goto fake_end;
5103                 }
5104                 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
5105             }
5106             /* NOTREACHED */
5107
5108
5109         case CURLY_B_min_fail:
5110             /* failed to find B in a non-greedy match where c1,c2 invalid */
5111             if (ST.paren && ST.count)
5112                 PL_regoffs[ST.paren].end = -1;
5113
5114             REGCP_UNWIND(ST.cp);
5115             /* failed -- move forward one */
5116             PL_reginput = locinput;
5117             if (regrepeat(rex, ST.A, 1, depth)) {
5118                 ST.count++;
5119                 locinput = PL_reginput;
5120                 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
5121                         ST.count > 0)) /* count overflow ? */
5122                 {
5123                   curly_try_B_min:
5124                     CURLY_SETPAREN(ST.paren, ST.count);
5125                     if (cur_eval && cur_eval->u.eval.close_paren &&
5126                         cur_eval->u.eval.close_paren == (U32)ST.paren) {
5127                         goto fake_end;
5128                     }
5129                     PUSH_STATE_GOTO(CURLY_B_min, ST.B);
5130                 }
5131             }
5132             sayNO;
5133             /* NOTREACHED */
5134
5135
5136         curly_try_B_max:
5137             /* a successful greedy match: now try to match B */
5138             if (cur_eval && cur_eval->u.eval.close_paren &&
5139                 cur_eval->u.eval.close_paren == (U32)ST.paren) {
5140                 goto fake_end;
5141             }
5142             {
5143                 UV c = 0;
5144                 if (ST.c1 != CHRTEST_VOID)
5145                     c = utf8_target ? utf8n_to_uvchr((U8*)PL_reginput,
5146                                            UTF8_MAXBYTES, 0, uniflags)
5147                                 : (UV) UCHARAT(PL_reginput);
5148                 /* If it could work, try it. */
5149                 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
5150                     CURLY_SETPAREN(ST.paren, ST.count);
5151                     PUSH_STATE_GOTO(CURLY_B_max, ST.B);
5152                     /* NOTREACHED */
5153                 }
5154             }
5155             /* FALL THROUGH */
5156         case CURLY_B_max_fail:
5157             /* failed to find B in a greedy match */
5158             if (ST.paren && ST.count)
5159                 PL_regoffs[ST.paren].end = -1;
5160
5161             REGCP_UNWIND(ST.cp);
5162             /*  back up. */
5163             if (--ST.count < ST.min)
5164                 sayNO;
5165             PL_reginput = locinput = HOPc(locinput, -1);
5166             goto curly_try_B_max;
5167
5168 #undef ST
5169
5170         case END:
5171             fake_end:
5172             if (cur_eval) {
5173                 /* we've just finished A in /(??{A})B/; now continue with B */
5174                 I32 tmpix;
5175                 st->u.eval.toggle_reg_flags
5176                             = cur_eval->u.eval.toggle_reg_flags;
5177                 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
5178
5179                 st->u.eval.prev_rex = rex_sv;           /* inner */
5180                 SETREX(rex_sv,cur_eval->u.eval.prev_rex);
5181                 rex = (struct regexp *)SvANY(rex_sv);
5182                 rexi = RXi_GET(rex);
5183                 cur_curlyx = cur_eval->u.eval.prev_curlyx;
5184                 ReREFCNT_inc(rex_sv);
5185                 st->u.eval.cp = regcppush(0);   /* Save *all* the positions. */
5186
5187                 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
5188                 PL_reglastparen = &rex->lastparen;
5189                 PL_reglastcloseparen = &rex->lastcloseparen;
5190
5191                 REGCP_SET(st->u.eval.lastcp);
5192                 PL_reginput = locinput;
5193
5194                 /* Restore parens of the outer rex without popping the
5195                  * savestack */
5196                 tmpix = PL_savestack_ix;
5197                 PL_savestack_ix = cur_eval->u.eval.lastcp;
5198                 regcppop(rex);
5199                 PL_savestack_ix = tmpix;
5200
5201                 st->u.eval.prev_eval = cur_eval;
5202                 cur_eval = cur_eval->u.eval.prev_eval;
5203                 DEBUG_EXECUTE_r(
5204                     PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ... %"UVxf"\n",
5205                                       REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
5206                 if ( nochange_depth )
5207                     nochange_depth--;
5208
5209                 PUSH_YES_STATE_GOTO(EVAL_AB,
5210                         st->u.eval.prev_eval->u.eval.B); /* match B */
5211             }
5212
5213             if (locinput < reginfo->till) {
5214                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5215                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
5216                                       PL_colors[4],
5217                                       (long)(locinput - PL_reg_starttry),
5218                                       (long)(reginfo->till - PL_reg_starttry),
5219                                       PL_colors[5]));
5220
5221                 sayNO_SILENT;           /* Cannot match: too short. */
5222             }
5223             PL_reginput = locinput;     /* put where regtry can find it */
5224             sayYES;                     /* Success! */
5225
5226         case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
5227             DEBUG_EXECUTE_r(
5228             PerlIO_printf(Perl_debug_log,
5229                 "%*s  %ssubpattern success...%s\n",
5230                 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
5231             PL_reginput = locinput;     /* put where regtry can find it */
5232             sayYES;                     /* Success! */
5233
5234 #undef  ST
5235 #define ST st->u.ifmatch
5236
5237         case SUSPEND:   /* (?>A) */
5238             ST.wanted = 1;
5239             PL_reginput = locinput;
5240             goto do_ifmatch;
5241
5242         case UNLESSM:   /* -ve lookaround: (?!A), or with flags, (?<!A) */
5243             ST.wanted = 0;
5244             goto ifmatch_trivial_fail_test;
5245
5246         case IFMATCH:   /* +ve lookaround: (?=A), or with flags, (?<=A) */
5247             ST.wanted = 1;
5248           ifmatch_trivial_fail_test:
5249             if (scan->flags) {
5250                 char * const s = HOPBACKc(locinput, scan->flags);
5251                 if (!s) {
5252                     /* trivial fail */
5253                     if (logical) {
5254                         logical = 0;
5255                         sw = 1 - cBOOL(ST.wanted);
5256                     }
5257                     else if (ST.wanted)
5258                         sayNO;
5259                     next = scan + ARG(scan);
5260                     if (next == scan)
5261                         next = NULL;
5262                     break;
5263                 }
5264                 PL_reginput = s;
5265             }
5266             else
5267                 PL_reginput = locinput;
5268
5269           do_ifmatch:
5270             ST.me = scan;
5271             ST.logical = logical;
5272             logical = 0; /* XXX: reset state of logical once it has been saved into ST */
5273
5274             /* execute body of (?...A) */
5275             PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
5276             /* NOTREACHED */
5277
5278         case IFMATCH_A_fail: /* body of (?...A) failed */
5279             ST.wanted = !ST.wanted;
5280             /* FALL THROUGH */
5281
5282         case IFMATCH_A: /* body of (?...A) succeeded */
5283             if (ST.logical) {
5284                 sw = cBOOL(ST.wanted);
5285             }
5286             else if (!ST.wanted)
5287                 sayNO;
5288
5289             if (OP(ST.me) == SUSPEND)
5290                 locinput = PL_reginput;
5291             else {
5292                 locinput = PL_reginput = st->locinput;
5293                 nextchr = UCHARAT(locinput);
5294             }
5295             scan = ST.me + ARG(ST.me);
5296             if (scan == ST.me)
5297                 scan = NULL;
5298             continue; /* execute B */
5299
5300 #undef ST
5301
5302         case LONGJMP:
5303             next = scan + ARG(scan);
5304             if (next == scan)
5305                 next = NULL;
5306             break;
5307         case COMMIT:
5308             reginfo->cutpoint = PL_regeol;
5309             /* FALLTHROUGH */
5310         case PRUNE:
5311             PL_reginput = locinput;
5312             if (!scan->flags)
5313                 sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5314             PUSH_STATE_GOTO(COMMIT_next,next);
5315             /* NOTREACHED */
5316         case COMMIT_next_fail:
5317             no_final = 1;
5318             /* FALLTHROUGH */
5319         case OPFAIL:
5320             sayNO;
5321             /* NOTREACHED */
5322
5323 #define ST st->u.mark
5324         case MARKPOINT:
5325             ST.prev_mark = mark_state;
5326             ST.mark_name = sv_commit = sv_yes_mark
5327                 = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5328             mark_state = st;
5329             ST.mark_loc = PL_reginput = locinput;
5330             PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5331             /* NOTREACHED */
5332         case MARKPOINT_next:
5333             mark_state = ST.prev_mark;
5334             sayYES;
5335             /* NOTREACHED */
5336         case MARKPOINT_next_fail:
5337             if (popmark && sv_eq(ST.mark_name,popmark))
5338             {
5339                 if (ST.mark_loc > startpoint)
5340                     reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5341                 popmark = NULL; /* we found our mark */
5342                 sv_commit = ST.mark_name;
5343
5344                 DEBUG_EXECUTE_r({
5345                         PerlIO_printf(Perl_debug_log,
5346                             "%*s  %ssetting cutpoint to mark:%"SVf"...%s\n",
5347                             REPORT_CODE_OFF+depth*2, "",
5348                             PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
5349                 });
5350             }
5351             mark_state = ST.prev_mark;
5352             sv_yes_mark = mark_state ?
5353                 mark_state->u.mark.mark_name : NULL;
5354             sayNO;
5355             /* NOTREACHED */
5356         case SKIP:
5357             PL_reginput = locinput;
5358             if (scan->flags) {
5359                 /* (*SKIP) : if we fail we cut here*/
5360                 ST.mark_name = NULL;
5361                 ST.mark_loc = locinput;
5362                 PUSH_STATE_GOTO(SKIP_next,next);
5363             } else {
5364                 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5365                    otherwise do nothing.  Meaning we need to scan
5366                  */
5367                 regmatch_state *cur = mark_state;
5368                 SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5369
5370                 while (cur) {
5371                     if ( sv_eq( cur->u.mark.mark_name,
5372                                 find ) )
5373                     {
5374                         ST.mark_name = find;
5375                         PUSH_STATE_GOTO( SKIP_next, next );
5376                     }
5377                     cur = cur->u.mark.prev_mark;
5378                 }
5379             }
5380             /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5381             break;
5382         case SKIP_next_fail:
5383             if (ST.mark_name) {
5384                 /* (*CUT:NAME) - Set up to search for the name as we
5385                    collapse the stack*/
5386                 popmark = ST.mark_name;
5387             } else {
5388                 /* (*CUT) - No name, we cut here.*/
5389                 if (ST.mark_loc > startpoint)
5390                     reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5391                 /* but we set sv_commit to latest mark_name if there
5392                    is one so they can test to see how things lead to this
5393                    cut */
5394                 if (mark_state)
5395                     sv_commit=mark_state->u.mark.mark_name;
5396             }
5397             no_final = 1;
5398             sayNO;
5399             /* NOTREACHED */
5400 #undef ST
5401         case FOLDCHAR:
5402             n = ARG(scan);
5403             if ( n == (U32)what_len_TRICKYFOLD(locinput,utf8_target,ln) ) {
5404                 locinput += ln;
5405             } else if ( 0xDF == n && !utf8_target && !UTF_PATTERN ) {
5406                 sayNO;
5407             } else  {
5408                 U8 folded[UTF8_MAXBYTES_CASE+1];
5409                 STRLEN foldlen;
5410                 const char * const l = locinput;
5411                 char *e = PL_regeol;
5412                 to_uni_fold(n, folded, &foldlen);
5413
5414                 if (! foldEQ_utf8((const char*) folded, 0,  foldlen, 1,
5415                                l, &e, 0,  utf8_target)) {
5416                         sayNO;
5417                 }
5418                 locinput = e;
5419             }
5420             nextchr = UCHARAT(locinput);
5421             break;
5422         case LNBREAK:
5423             if ((n=is_LNBREAK(locinput,utf8_target))) {
5424                 locinput += n;
5425                 nextchr = UCHARAT(locinput);
5426             } else
5427                 sayNO;
5428             break;
5429
5430 #define CASE_CLASS(nAmE)                              \
5431         case nAmE:                                    \
5432             if ((n=is_##nAmE(locinput,utf8_target))) {    \
5433                 locinput += n;                        \
5434                 nextchr = UCHARAT(locinput);          \
5435             } else                                    \
5436                 sayNO;                                \
5437             break;                                    \
5438         case N##nAmE:                                 \
5439             if ((n=is_##nAmE(locinput,utf8_target))) {    \
5440                 sayNO;                                \
5441             } else {                                  \
5442                 locinput += UTF8SKIP(locinput);       \
5443                 nextchr = UCHARAT(locinput);          \
5444             }                                         \
5445             break
5446
5447         CASE_CLASS(VERTWS);
5448         CASE_CLASS(HORIZWS);
5449 #undef CASE_CLASS
5450
5451         default:
5452             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5453                           PTR2UV(scan), OP(scan));
5454             Perl_croak(aTHX_ "regexp memory corruption");
5455
5456         } /* end switch */
5457
5458         /* switch break jumps here */
5459         scan = next; /* prepare to execute the next op and ... */
5460         continue;    /* ... jump back to the top, reusing st */
5461         /* NOTREACHED */
5462
5463       push_yes_state:
5464         /* push a state that backtracks on success */
5465         st->u.yes.prev_yes_state = yes_state;
5466         yes_state = st;
5467         /* FALL THROUGH */
5468       push_state:
5469         /* push a new regex state, then continue at scan  */
5470         {
5471             regmatch_state *newst;
5472
5473             DEBUG_STACK_r({
5474                 regmatch_state *cur = st;
5475                 regmatch_state *curyes = yes_state;
5476                 int curd = depth;
5477                 regmatch_slab *slab = PL_regmatch_slab;
5478                 for (;curd > -1;cur--,curd--) {
5479                     if (cur < SLAB_FIRST(slab)) {
5480                         slab = slab->prev;
5481                         cur = SLAB_LAST(slab);
5482                     }
5483                     PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5484                         REPORT_CODE_OFF + 2 + depth * 2,"",
5485                         curd, PL_reg_name[cur->resume_state],
5486                         (curyes == cur) ? "yes" : ""
5487                     );
5488                     if (curyes == cur)
5489                         curyes = cur->u.yes.prev_yes_state;
5490                 }
5491             } else
5492                 DEBUG_STATE_pp("push")
5493             );
5494             depth++;
5495             st->locinput = locinput;
5496             newst = st+1;
5497             if (newst >  SLAB_LAST(PL_regmatch_slab))
5498                 newst = S_push_slab(aTHX);
5499             PL_regmatch_state = newst;
5500
5501             locinput = PL_reginput;
5502             nextchr = UCHARAT(locinput);
5503             st = newst;
5504             continue;
5505             /* NOTREACHED */
5506         }
5507     }
5508
5509     /*
5510     * We get here only if there's trouble -- normally "case END" is
5511     * the terminating point.
5512     */
5513     Perl_croak(aTHX_ "corrupted regexp pointers");
5514     /*NOTREACHED*/
5515     sayNO;
5516
5517 yes:
5518     if (yes_state) {
5519         /* we have successfully completed a subexpression, but we must now
5520          * pop to the state marked by yes_state and continue from there */
5521         assert(st != yes_state);
5522 #ifdef DEBUGGING
5523         while (st != yes_state) {
5524             st--;
5525             if (st < SLAB_FIRST(PL_regmatch_slab)) {
5526                 PL_regmatch_slab = PL_regmatch_slab->prev;
5527                 st = SLAB_LAST(PL_regmatch_slab);
5528             }
5529             DEBUG_STATE_r({
5530                 if (no_final) {
5531                     DEBUG_STATE_pp("pop (no final)");
5532                 } else {
5533                     DEBUG_STATE_pp("pop (yes)");
5534                 }
5535             });
5536             depth--;
5537         }
5538 #else
5539         while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5540             || yes_state > SLAB_LAST(PL_regmatch_slab))
5541         {
5542             /* not in this slab, pop slab */
5543             depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5544             PL_regmatch_slab = PL_regmatch_slab->prev;
5545             st = SLAB_LAST(PL_regmatch_slab);
5546         }
5547         depth -= (st - yes_state);
5548 #endif
5549         st = yes_state;
5550         yes_state = st->u.yes.prev_yes_state;
5551         PL_regmatch_state = st;
5552
5553         if (no_final) {
5554             locinput= st->locinput;
5555             nextchr = UCHARAT(locinput);
5556         }
5557         state_num = st->resume_state + no_final;
5558         goto reenter_switch;
5559     }
5560
5561     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5562                           PL_colors[4], PL_colors[5]));
5563
5564     if (PL_reg_eval_set) {
5565         /* each successfully executed (?{...}) block does the equivalent of
5566          *   local $^R = do {...}
5567          * When popping the save stack, all these locals would be undone;
5568          * bypass this by setting the outermost saved $^R to the latest
5569          * value */
5570         if (oreplsv != GvSV(PL_replgv))
5571             sv_setsv(oreplsv, GvSV(PL_replgv));
5572     }
5573     result = 1;
5574     goto final_exit;
5575
5576 no:
5577     DEBUG_EXECUTE_r(
5578         PerlIO_printf(Perl_debug_log,
5579             "%*s  %sfailed...%s\n",
5580             REPORT_CODE_OFF+depth*2, "",
5581             PL_colors[4], PL_colors[5])
5582         );
5583
5584 no_silent:
5585     if (no_final) {
5586         if (yes_state) {
5587             goto yes;
5588         } else {
5589             goto final_exit;
5590         }
5591     }
5592     if (depth) {
5593         /* there's a previous state to backtrack to */
5594         st--;
5595         if (st < SLAB_FIRST(PL_regmatch_slab)) {
5596             PL_regmatch_slab = PL_regmatch_slab->prev;
5597             st = SLAB_LAST(PL_regmatch_slab);
5598         }
5599         PL_regmatch_state = st;
5600         locinput= st->locinput;
5601         nextchr = UCHARAT(locinput);
5602
5603         DEBUG_STATE_pp("pop");
5604         depth--;
5605         if (yes_state == st)
5606             yes_state = st->u.yes.prev_yes_state;
5607
5608         state_num = st->resume_state + 1; /* failure = success + 1 */
5609         goto reenter_switch;
5610     }
5611     result = 0;
5612
5613   final_exit:
5614     if (rex->intflags & PREGf_VERBARG_SEEN) {
5615         SV *sv_err = get_sv("REGERROR", 1);
5616         SV *sv_mrk = get_sv("REGMARK", 1);
5617         if (result) {
5618             sv_commit = &PL_sv_no;
5619             if (!sv_yes_mark)
5620                 sv_yes_mark = &PL_sv_yes;
5621         } else {
5622             if (!sv_commit)
5623                 sv_commit = &PL_sv_yes;
5624             sv_yes_mark = &PL_sv_no;
5625         }
5626         sv_setsv(sv_err, sv_commit);
5627         sv_setsv(sv_mrk, sv_yes_mark);
5628     }
5629
5630     /* clean up; in particular, free all slabs above current one */
5631     LEAVE_SCOPE(oldsave);
5632
5633     return result;
5634 }
5635
5636 /*
5637  - regrepeat - repeatedly match something simple, report how many
5638  */
5639 /*
5640  * [This routine now assumes that it will only match on things of length 1.
5641  * That was true before, but now we assume scan - reginput is the count,
5642  * rather than incrementing count on every character.  [Er, except utf8.]]
5643  */
5644 STATIC I32
5645 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5646 {
5647     dVAR;
5648     register char *scan;
5649     register I32 c;
5650     register char *loceol = PL_regeol;
5651     register I32 hardcount = 0;
5652     register bool utf8_target = PL_reg_match_utf8;
5653 #ifndef DEBUGGING
5654     PERL_UNUSED_ARG(depth);
5655 #endif
5656
5657     PERL_ARGS_ASSERT_REGREPEAT;
5658
5659     scan = PL_reginput;
5660     if (max == REG_INFTY)
5661         max = I32_MAX;
5662     else if (max < loceol - scan)
5663         loceol = scan + max;
5664     switch (OP(p)) {
5665     case REG_ANY:
5666         if (utf8_target) {
5667             loceol = PL_regeol;
5668             while (scan < loceol && hardcount < max && *scan != '\n') {
5669                 scan += UTF8SKIP(scan);
5670                 hardcount++;
5671             }
5672         } else {
5673             while (scan < loceol && *scan != '\n')
5674                 scan++;
5675         }
5676         break;
5677     case SANY:
5678         if (utf8_target) {
5679             loceol = PL_regeol;
5680             while (scan < loceol && hardcount < max) {
5681                 scan += UTF8SKIP(scan);
5682                 hardcount++;
5683             }
5684         }
5685         else
5686             scan = loceol;
5687         break;
5688     case CANY:
5689         scan = loceol;
5690         break;
5691     case EXACT:         /* length of string is 1 */
5692         c = (U8)*STRING(p);
5693         while (scan < loceol && UCHARAT(scan) == c)
5694             scan++;
5695         break;
5696     case EXACTF:        /* length of string is 1 */
5697         c = (U8)*STRING(p);
5698         while (scan < loceol &&
5699                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5700             scan++;
5701         break;
5702     case EXACTFL:       /* length of string is 1 */
5703         PL_reg_flags |= RF_tainted;
5704         c = (U8)*STRING(p);
5705         while (scan < loceol &&
5706                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5707             scan++;
5708         break;
5709     case ANYOF:
5710         if (utf8_target) {
5711             loceol = PL_regeol;
5712             while (hardcount < max && scan < loceol &&
5713                    reginclass(prog, p, (U8*)scan, 0, utf8_target)) {
5714                 scan += UTF8SKIP(scan);
5715                 hardcount++;
5716             }
5717         } else {
5718             while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5719                 scan++;
5720         }
5721         break;
5722     case ALNUM:
5723         if (utf8_target) {
5724             loceol = PL_regeol;
5725             LOAD_UTF8_CHARCLASS_ALNUM();
5726             while (hardcount < max && scan < loceol &&
5727                    swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target)) {
5728                 scan += UTF8SKIP(scan);
5729                 hardcount++;
5730             }
5731         } else {
5732             while (scan < loceol && isALNUM(*scan))
5733                 scan++;
5734         }
5735         break;
5736     case ALNUML:
5737         PL_reg_flags |= RF_tainted;
5738         if (utf8_target) {
5739             loceol = PL_regeol;
5740             while (hardcount < max && scan < loceol &&
5741                    isALNUM_LC_utf8((U8*)scan)) {
5742                 scan += UTF8SKIP(scan);
5743                 hardcount++;
5744             }
5745         } else {
5746             while (scan < loceol && isALNUM_LC(*scan))
5747                 scan++;
5748         }
5749         break;
5750     case NALNUM:
5751         if (utf8_target) {
5752             loceol = PL_regeol;
5753             LOAD_UTF8_CHARCLASS_ALNUM();
5754             while (hardcount < max && scan < loceol &&
5755                    !swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target)) {
5756                 scan += UTF8SKIP(scan);
5757                 hardcount++;
5758             }
5759         } else {
5760             while (scan < loceol && !isALNUM(*scan))
5761                 scan++;
5762         }
5763         break;
5764     case NALNUML:
5765         PL_reg_flags |= RF_tainted;
5766         if (utf8_target) {
5767             loceol = PL_regeol;
5768             while (hardcount < max && scan < loceol &&
5769                    !isALNUM_LC_utf8((U8*)scan)) {
5770                 scan += UTF8SKIP(scan);
5771                 hardcount++;
5772             }
5773         } else {
5774             while (scan < loceol && !isALNUM_LC(*scan))
5775                 scan++;
5776         }
5777         break;
5778     case SPACE:
5779         if (utf8_target) {
5780             loceol = PL_regeol;
5781             LOAD_UTF8_CHARCLASS_SPACE();
5782             while (hardcount < max && scan < loceol &&
5783                    (*scan == ' ' ||
5784                     swash_fetch(PL_utf8_space,(U8*)scan, utf8_target))) {
5785                 scan += UTF8SKIP(scan);
5786                 hardcount++;
5787             }
5788         } else {
5789             while (scan < loceol && isSPACE(*scan))
5790                 scan++;
5791         }
5792         break;
5793     case SPACEL:
5794         PL_reg_flags |= RF_tainted;
5795         if (utf8_target) {
5796             loceol = PL_regeol;
5797             while (hardcount < max && scan < loceol &&
5798                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5799                 scan += UTF8SKIP(scan);
5800                 hardcount++;
5801             }
5802         } else {
5803             while (scan < loceol && isSPACE_LC(*scan))
5804                 scan++;
5805         }
5806         break;
5807     case NSPACE:
5808         if (utf8_target) {
5809             loceol = PL_regeol;
5810             LOAD_UTF8_CHARCLASS_SPACE();
5811             while (hardcount < max && scan < loceol &&
5812                    !(*scan == ' ' ||
5813                      swash_fetch(PL_utf8_space,(U8*)scan, utf8_target))) {
5814                 scan += UTF8SKIP(scan);
5815                 hardcount++;
5816             }
5817         } else {
5818             while (scan < loceol && !isSPACE(*scan))
5819                 scan++;
5820         }
5821         break;
5822     case NSPACEL:
5823         PL_reg_flags |= RF_tainted;
5824         if (utf8_target) {
5825             loceol = PL_regeol;
5826             while (hardcount < max && scan < loceol &&
5827                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5828                 scan += UTF8SKIP(scan);
5829                 hardcount++;
5830             }
5831         } else {
5832             while (scan < loceol && !isSPACE_LC(*scan))
5833                 scan++;
5834         }
5835         break;
5836     case DIGIT:
5837         if (utf8_target) {
5838             loceol = PL_regeol;
5839             LOAD_UTF8_CHARCLASS_DIGIT();
5840             while (hardcount < max && scan < loceol &&
5841                    swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
5842                 scan += UTF8SKIP(scan);
5843                 hardcount++;
5844             }
5845         } else {
5846             while (scan < loceol && isDIGIT(*scan))
5847                 scan++;
5848         }
5849         break;
5850     case NDIGIT:
5851         if (utf8_target) {
5852             loceol = PL_regeol;
5853             LOAD_UTF8_CHARCLASS_DIGIT();
5854             while (hardcount < max && scan < loceol &&
5855                    !swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
5856                 scan += UTF8SKIP(scan);
5857                 hardcount++;
5858             }
5859         } else {
5860             while (scan < loceol && !isDIGIT(*scan))
5861                 scan++;
5862         }
5863     case LNBREAK:
5864         if (utf8_target) {
5865             loceol = PL_regeol;
5866             while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
5867                 scan += c;
5868                 hardcount++;
5869             }
5870         } else {
5871             /*
5872               LNBREAK can match two latin chars, which is ok,
5873               because we have a null terminated string, but we
5874               have to use hardcount in this situation
5875             */
5876             while (scan < loceol && (c=is_LNBREAK_latin1(scan)))  {
5877                 scan+=c;
5878                 hardcount++;
5879             }
5880         }
5881         break;
5882     case HORIZWS:
5883         if (utf8_target) {
5884             loceol = PL_regeol;
5885             while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
5886                 scan += c;
5887                 hardcount++;
5888             }
5889         } else {
5890             while (scan < loceol && is_HORIZWS_latin1(scan))
5891                 scan++;
5892         }
5893         break;
5894     case NHORIZWS:
5895         if (utf8_target) {
5896             loceol = PL_regeol;
5897             while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
5898                 scan += UTF8SKIP(scan);
5899                 hardcount++;
5900             }
5901         } else {
5902             while (scan < loceol && !is_HORIZWS_latin1(scan))
5903                 scan++;
5904
5905         }
5906         break;
5907     case VERTWS:
5908         if (utf8_target) {
5909             loceol = PL_regeol;
5910             while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
5911                 scan += c;
5912                 hardcount++;
5913             }
5914         } else {
5915             while (scan < loceol && is_VERTWS_latin1(scan))
5916                 scan++;
5917
5918         }
5919         break;
5920     case NVERTWS:
5921         if (utf8_target) {
5922             loceol = PL_regeol;
5923             while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
5924                 scan += UTF8SKIP(scan);
5925                 hardcount++;
5926             }
5927         } else {
5928             while (scan < loceol && !is_VERTWS_latin1(scan))
5929                 scan++;
5930
5931         }
5932         break;
5933
5934     default:            /* Called on something of 0 width. */
5935         break;          /* So match right here or not at all. */
5936     }
5937
5938     if (hardcount)
5939         c = hardcount;
5940     else
5941         c = scan - PL_reginput;
5942     PL_reginput = scan;
5943
5944     DEBUG_r({
5945         GET_RE_DEBUG_FLAGS_DECL;
5946         DEBUG_EXECUTE_r({
5947             SV * const prop = sv_newmortal();
5948             regprop(prog, prop, p);
5949             PerlIO_printf(Perl_debug_log,
5950                         "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
5951                         REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5952         });
5953     });
5954
5955     return(c);
5956 }
5957
5958
5959 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5960 /*
5961 - regclass_swash - prepare the utf8 swash
5962 */
5963
5964 SV *
5965 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5966 {
5967     dVAR;
5968     SV *sw  = NULL;
5969     SV *si  = NULL;
5970     SV *alt = NULL;
5971     RXi_GET_DECL(prog,progi);
5972     const struct reg_data * const data = prog ? progi->data : NULL;
5973
5974     PERL_ARGS_ASSERT_REGCLASS_SWASH;
5975
5976     if (data && data->count) {
5977         const U32 n = ARG(node);
5978
5979         if (data->what[n] == 's') {
5980             SV * const rv = MUTABLE_SV(data->data[n]);
5981             AV * const av = MUTABLE_AV(SvRV(rv));
5982             SV **const ary = AvARRAY(av);
5983             SV **a, **b;
5984
5985             /* See the end of regcomp.c:S_regclass() for
5986              * documentation of these array elements. */
5987
5988             si = *ary;
5989             a  = SvROK(ary[1]) ? &ary[1] : NULL;
5990             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
5991
5992             if (a)
5993                 sw = *a;
5994             else if (si && doinit) {
5995                 sw = swash_init("utf8", "", si, 1, 0);
5996                 (void)av_store(av, 1, sw);
5997             }
5998             if (b)
5999                 alt = *b;
6000         }
6001     }
6002
6003     if (listsvp)
6004         *listsvp = si;
6005     if (altsvp)
6006         *altsvp  = alt;
6007
6008     return sw;
6009 }
6010 #endif
6011
6012 /*
6013  - reginclass - determine if a character falls into a character class
6014
6015   The n is the ANYOF regnode, the p is the target string, lenp
6016   is pointer to the maximum length of how far to go in the p
6017   (if the lenp is zero, UTF8SKIP(p) is used),
6018   utf8_target tells whether the target string is in UTF-8.
6019
6020  */
6021
6022 STATIC bool
6023 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool utf8_target)
6024 {
6025     dVAR;
6026     const char flags = ANYOF_FLAGS(n);
6027     bool match = FALSE;
6028     UV c = *p;
6029     STRLEN len = 0;
6030     STRLEN plen;
6031
6032     PERL_ARGS_ASSERT_REGINCLASS;
6033
6034     if (utf8_target && !UTF8_IS_INVARIANT(c)) {
6035         c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
6036                 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
6037                 | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
6038                 /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
6039                  * UTF8_ALLOW_FFFF */
6040         if (len == (STRLEN)-1)
6041             Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
6042     }
6043
6044     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
6045     if (utf8_target || (flags & ANYOF_UNICODE)) {
6046         if (lenp)
6047             *lenp = 0;
6048         if (utf8_target && !ANYOF_RUNTIME(n)) {
6049             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
6050                 match = TRUE;
6051         }
6052         if (!match && utf8_target && (flags & ANYOF_UNICODE_ALL) && c >= 256)
6053             match = TRUE;
6054         if (!match) {
6055             AV *av;
6056             SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
6057
6058             if (sw) {
6059                 U8 * utf8_p;
6060                 if (utf8_target) {
6061                     utf8_p = (U8 *) p;
6062                 } else {
6063                     STRLEN len = 1;
6064                     utf8_p = bytes_to_utf8(p, &len);
6065                 }
6066                 if (swash_fetch(sw, utf8_p, 1))
6067                     match = TRUE;
6068                 else if (flags & ANYOF_FOLD) {
6069                     if (!match && lenp && av) {
6070                         I32 i;
6071                         for (i = 0; i <= av_len(av); i++) {
6072                             SV* const sv = *av_fetch(av, i, FALSE);
6073                             STRLEN len;
6074                             const char * const s = SvPV_const(sv, len);
6075                             if (len <= plen && memEQ(s, (char*)utf8_p, len)) {
6076                                 *lenp = len;
6077                                 match = TRUE;
6078                                 break;
6079                             }
6080                         }
6081                     }
6082                     if (!match) {
6083                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
6084
6085                         STRLEN tmplen;
6086                         to_utf8_fold(utf8_p, tmpbuf, &tmplen);
6087                         if (swash_fetch(sw, tmpbuf, 1))
6088                             match = TRUE;
6089                     }
6090                 }
6091
6092                 /* If we allocated a string above, free it */
6093                 if (! utf8_target) Safefree(utf8_p);
6094             }
6095         }
6096         if (match && lenp && *lenp == 0)
6097             *lenp = UNISKIP(NATIVE_TO_UNI(c));
6098     }
6099     if (!match && c < 256) {
6100         if (ANYOF_BITMAP_TEST(n, c))
6101             match = TRUE;
6102         else if (flags & ANYOF_FOLD) {
6103             U8 f;
6104
6105             if (flags & ANYOF_LOCALE) {
6106                 PL_reg_flags |= RF_tainted;
6107                 f = PL_fold_locale[c];
6108             }
6109             else
6110                 f = PL_fold[c];
6111             if (f != c && ANYOF_BITMAP_TEST(n, f))
6112                 match = TRUE;
6113         }
6114
6115         if (!match && (flags & ANYOF_CLASS)) {
6116             PL_reg_flags |= RF_tainted;
6117             if (
6118                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
6119                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
6120                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
6121                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
6122                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
6123                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
6124                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
6125                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
6126                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
6127                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
6128                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
6129                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
6130                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
6131                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
6132                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
6133                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
6134                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
6135                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
6136                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
6137                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
6138                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
6139                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
6140                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
6141                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
6142                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
6143                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
6144                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
6145                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
6146                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
6147                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
6148                 ) /* How's that for a conditional? */
6149             {
6150                 match = TRUE;
6151             }
6152         }
6153     }
6154
6155     return (flags & ANYOF_INVERT) ? !match : match;
6156 }
6157
6158 STATIC U8 *
6159 S_reghop3(U8 *s, I32 off, const U8* lim)
6160 {
6161     dVAR;
6162
6163     PERL_ARGS_ASSERT_REGHOP3;
6164
6165     if (off >= 0) {
6166         while (off-- && s < lim) {
6167             /* XXX could check well-formedness here */
6168             s += UTF8SKIP(s);
6169         }
6170     }
6171     else {
6172         while (off++ && s > lim) {
6173             s--;
6174             if (UTF8_IS_CONTINUED(*s)) {
6175                 while (s > lim && UTF8_IS_CONTINUATION(*s))
6176                     s--;
6177             }
6178             /* XXX could check well-formedness here */
6179         }
6180     }
6181     return s;
6182 }
6183
6184 #ifdef XXX_dmq
6185 /* there are a bunch of places where we use two reghop3's that should
6186    be replaced with this routine. but since thats not done yet
6187    we ifdef it out - dmq
6188 */
6189 STATIC U8 *
6190 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
6191 {
6192     dVAR;
6193
6194     PERL_ARGS_ASSERT_REGHOP4;
6195
6196     if (off >= 0) {
6197         while (off-- && s < rlim) {
6198             /* XXX could check well-formedness here */
6199             s += UTF8SKIP(s);
6200         }
6201     }
6202     else {
6203         while (off++ && s > llim) {
6204             s--;
6205             if (UTF8_IS_CONTINUED(*s)) {
6206                 while (s > llim && UTF8_IS_CONTINUATION(*s))
6207                     s--;
6208             }
6209             /* XXX could check well-formedness here */
6210         }
6211     }
6212     return s;
6213 }
6214 #endif
6215
6216 STATIC U8 *
6217 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
6218 {
6219     dVAR;
6220
6221     PERL_ARGS_ASSERT_REGHOPMAYBE3;
6222
6223     if (off >= 0) {
6224         while (off-- && s < lim) {
6225             /* XXX could check well-formedness here */
6226             s += UTF8SKIP(s);
6227         }
6228         if (off >= 0)
6229             return NULL;
6230     }
6231     else {
6232         while (off++ && s > lim) {
6233             s--;
6234             if (UTF8_IS_CONTINUED(*s)) {
6235                 while (s > lim && UTF8_IS_CONTINUATION(*s))
6236                     s--;
6237             }
6238             /* XXX could check well-formedness here */
6239         }
6240         if (off <= 0)
6241             return NULL;
6242     }
6243     return s;
6244 }
6245
6246 static void
6247 restore_pos(pTHX_ void *arg)
6248 {
6249     dVAR;
6250     regexp * const rex = (regexp *)arg;
6251     if (PL_reg_eval_set) {
6252         if (PL_reg_oldsaved) {
6253             rex->subbeg = PL_reg_oldsaved;
6254             rex->sublen = PL_reg_oldsavedlen;
6255 #ifdef PERL_OLD_COPY_ON_WRITE
6256             rex->saved_copy = PL_nrs;
6257 #endif
6258             RXp_MATCH_COPIED_on(rex);
6259         }
6260         PL_reg_magic->mg_len = PL_reg_oldpos;
6261         PL_reg_eval_set = 0;
6262         PL_curpm = PL_reg_oldcurpm;
6263     }
6264 }
6265
6266 STATIC void
6267 S_to_utf8_substr(pTHX_ register regexp *prog)
6268 {
6269     int i = 1;
6270
6271     PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
6272
6273     do {
6274         if (prog->substrs->data[i].substr
6275             && !prog->substrs->data[i].utf8_substr) {
6276             SV* const sv = newSVsv(prog->substrs->data[i].substr);
6277             prog->substrs->data[i].utf8_substr = sv;
6278             sv_utf8_upgrade(sv);
6279             if (SvVALID(prog->substrs->data[i].substr)) {
6280                 const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
6281                 if (flags & FBMcf_TAIL) {
6282                     /* Trim the trailing \n that fbm_compile added last
6283                        time.  */
6284                     SvCUR_set(sv, SvCUR(sv) - 1);
6285                     /* Whilst this makes the SV technically "invalid" (as its
6286                        buffer is no longer followed by "\0") when fbm_compile()
6287                        adds the "\n" back, a "\0" is restored.  */
6288                 }
6289                 fbm_compile(sv, flags);
6290             }
6291             if (prog->substrs->data[i].substr == prog->check_substr)
6292                 prog->check_utf8 = sv;
6293         }
6294     } while (i--);
6295 }
6296
6297 STATIC void
6298 S_to_byte_substr(pTHX_ register regexp *prog)
6299 {
6300     dVAR;
6301     int i = 1;
6302
6303     PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
6304
6305     do {
6306         if (prog->substrs->data[i].utf8_substr
6307             && !prog->substrs->data[i].substr) {
6308             SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
6309             if (sv_utf8_downgrade(sv, TRUE)) {
6310                 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
6311                     const U8 flags
6312                         = BmFLAGS(prog->substrs->data[i].utf8_substr);
6313                     if (flags & FBMcf_TAIL) {
6314                         /* Trim the trailing \n that fbm_compile added last
6315                            time.  */
6316                         SvCUR_set(sv, SvCUR(sv) - 1);
6317                     }
6318                     fbm_compile(sv, flags);
6319                 }
6320             } else {
6321                 SvREFCNT_dec(sv);
6322                 sv = &PL_sv_undef;
6323             }
6324             prog->substrs->data[i].substr = sv;
6325             if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
6326                 prog->check_substr = sv;
6327         }
6328     } while (i--);
6329 }
6330
6331 /*
6332  * Local variables:
6333  * c-indentation-style: bsd
6334  * c-basic-offset: 4
6335  * indent-tabs-mode: t
6336  * End:
6337  *
6338  * ex: set ts=8 sts=4 sw=4 noet:
6339  */