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