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