regexec.c

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