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