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 /* At least one required character in the target string is expressible only in
  41  * UTF-8. */
  42 static const char* const non_utf8_target_but_utf8_required
  43                 = "Can't match, because target string needs to be in UTF-8\n";
  44
  45 #define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START { \
  46     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s", non_utf8_target_but_utf8_required));\
  47     goto target; \
  48 } STMT_END
  49
  50 /*
  51  * pregcomp and pregexec -- regsub and regerror are not used in perl
  52  *
  53  *      Copyright (c) 1986 by University of Toronto.
  54  *      Written by Henry Spencer.  Not derived from licensed software.
  55  *
  56  *      Permission is granted to anyone to use this software for any
  57  *      purpose on any computer system, and to redistribute it freely,
  58  *      subject to the following restrictions:
  59  *
  60  *      1. The author is not responsible for the consequences of use of
  61  *              this software, no matter how awful, even if they arise
  62  *              from defects in it.
  63  *
  64  *      2. The origin of this software must not be misrepresented, either
  65  *              by explicit claim or by omission.
  66  *
  67  *      3. Altered versions must be plainly marked as such, and must not
  68  *              be misrepresented as being the original software.
  69  *
  70  ****    Alterations to Henry's code are...
  71  ****
  72  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
  73  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
  74  ****    by Larry Wall and others
  75  ****
  76  ****    You may distribute under the terms of either the GNU General Public
  77  ****    License or the Artistic License, as specified in the README file.
  78  *
  79  * Beware that some of this code is subtly aware of the way operator
  80  * precedence is structured in regular expressions.  Serious changes in
  81  * regular-expression syntax might require a total rethink.
  82  */
  83 #include "EXTERN.h"
  84 #define PERL_IN_REGEXEC_C
  85 #include "perl.h"
  86
  87 #ifdef PERL_IN_XSUB_RE
  88 #  include "re_comp.h"
  89 #else
  90 #  include "regcomp.h"
  91 #endif
  92
  93 #include "inline_invlist.c"
  94 #include "unicode_constants.h"
  95
  96 #define RF_tainted      1       /* tainted information used? e.g. locale */
  97 #define RF_warned       2               /* warned about big count? */
  98
  99 #define RF_utf8         8               /* Pattern contains multibyte chars? */
 100
 101 #define UTF_PATTERN ((PL_reg_flags & RF_utf8) != 0)
 102
 103 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
 104
 105 #ifndef STATIC
 106 #define STATIC  static
 107 #endif
 108
 109 /* Valid for non-utf8 strings: avoids the reginclass
 110  * call if there are no complications: i.e., if everything matchable is
 111  * straight forward in the bitmap */
 112 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0)   \
 113                                               : ANYOF_BITMAP_TEST(p,*(c)))
 114
 115 /*
 116  * Forwards.
 117  */
 118
 119 #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv))
 120 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
 121
 122 #define HOPc(pos,off) \
 123         (char *)(PL_reg_match_utf8 \
 124             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
 125             : (U8*)(pos + off))
 126 #define HOPBACKc(pos, off) \
 127         (char*)(PL_reg_match_utf8\
 128             ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
 129             : (pos - off >= PL_bostr)           \
 130                 ? (U8*)pos - off                \
 131                 : NULL)
 132
 133 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
 134 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
 135
 136
 137 #define NEXTCHR_EOS -10 /* nextchr has fallen off the end */
 138 #define NEXTCHR_IS_EOS (nextchr < 0)
 139
 140 #define SET_nextchr \
 141     nextchr = ((locinput < PL_regeol) ? UCHARAT(locinput) : NEXTCHR_EOS)
 142
 143 #define SET_locinput(p) \
 144     locinput = (p);  \
 145     SET_nextchr
 146
 147
 148 /* these are unrolled below in the CCC_TRY_XXX defined */
 149 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
 150     if (!CAT2(PL_utf8_,class)) { \
 151         bool ok; \
 152         ENTER; save_re_context(); \
 153         ok=CAT2(is_utf8_,class)((const U8*)str); \
 154         PERL_UNUSED_VAR(ok); \
 155         assert(ok); assert(CAT2(PL_utf8_,class)); LEAVE; } } STMT_END
 156 /* Doesn't do an assert to verify that is correct */
 157 #define LOAD_UTF8_CHARCLASS_NO_CHECK(class) STMT_START { \
 158     if (!CAT2(PL_utf8_,class)) { \
 159         bool throw_away PERL_UNUSED_DECL; \
 160         ENTER; save_re_context(); \
 161         throw_away = CAT2(is_utf8_,class)((const U8*)" "); \
 162         PERL_UNUSED_VAR(throw_away); \
 163         LEAVE; } } STMT_END
 164
 165 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
 166 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
 167
 168 #define LOAD_UTF8_CHARCLASS_GCB()  /* Grapheme cluster boundaries */        \
 169         /* No asserts are done for some of these, in case called on a   */  \
 170         /* Unicode version in which they map to nothing */                  \
 171         LOAD_UTF8_CHARCLASS(X_regular_begin, HYPHEN_UTF8);                  \
 172         LOAD_UTF8_CHARCLASS(X_extend, COMBINING_GRAVE_ACCENT_UTF8);         \
 173
 174 #define PLACEHOLDER     /* Something for the preprocessor to grab onto */
 175
 176 /* The actual code for CCC_TRY, which uses several variables from the routine
 177  * it's callable from.  It is designed to be the bulk of a case statement.
 178  * FUNC is the macro or function to call on non-utf8 targets that indicate if
 179  *      nextchr matches the class.
 180  * UTF8_TEST is the whole test string to use for utf8 targets
 181  * LOAD is what to use to test, and if not present to load in the swash for the
 182  *      class
 183  * POS_OR_NEG is either empty or ! to complement the results of FUNC or
 184  *      UTF8_TEST test.
 185  * The logic is: Fail if we're at the end-of-string; otherwise if the target is
 186  * utf8 and a variant, load the swash if necessary and test using the utf8
 187  * test.  Advance to the next character if test is ok, otherwise fail; If not
 188  * utf8 or an invariant under utf8, use the non-utf8 test, and fail if it
 189  * fails, or advance to the next character */
 190
 191 #define _CCC_TRY_CODE(POS_OR_NEG, FUNC, UTF8_TEST, CLASS, STR)                \
 192     if (NEXTCHR_IS_EOS) {                                                     \
 193         sayNO;                                                                \
 194     }                                                                         \
 195     if (utf8_target && UTF8_IS_CONTINUED(nextchr)) {                          \
 196         LOAD_UTF8_CHARCLASS(CLASS, STR);                                      \
 197         if (POS_OR_NEG (UTF8_TEST)) {                                         \
 198             sayNO;                                                            \
 199         }                                                                     \
 200     }                                                                         \
 201     else if (POS_OR_NEG (FUNC(nextchr))) {                                    \
 202             sayNO;                                                            \
 203     }                                                                         \
 204     goto increment_locinput;
 205
 206 /* Handle the non-locale cases for a character class and its complement.  It
 207  * calls _CCC_TRY_CODE with a ! to complement the test for the character class.
 208  * This is because that code fails when the test succeeds, so we want to have
 209  * the test fail so that the code succeeds.  The swash is stored in a
 210  * predictable PL_ place */
 211 #define _CCC_TRY_NONLOCALE(NAME,  NNAME,  FUNC,                               \
 212                            CLASS, STR)                                        \
 213     case NAME:                                                                \
 214         _CCC_TRY_CODE( !, FUNC,                                               \
 215                           cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS),             \
 216                                             (U8*)locinput, TRUE)),            \
 217                           CLASS, STR)                                         \
 218     case NNAME:                                                               \
 219         _CCC_TRY_CODE(  PLACEHOLDER , FUNC,                                   \
 220                           cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS),             \
 221                                             (U8*)locinput, TRUE)),            \
 222                           CLASS, STR)
 223 /* Generate the case statements for both locale and non-locale character
 224  * classes in regmatch for classes that don't have special unicode semantics.
 225  * Locales don't use an immediate swash, but an intermediary special locale
 226  * function that is called on the pointer to the current place in the input
 227  * string.  That function will resolve to needing the same swash.  One might
 228  * think that because we don't know what the locale will match, we shouldn't
 229  * check with the swash loading function that it loaded properly; ie, that we
 230  * should use LOAD_UTF8_CHARCLASS_NO_CHECK for those, but what is passed to the
 231  * regular LOAD_UTF8_CHARCLASS is in non-locale terms, and so locale is
 232  * irrelevant here */
 233 #define CCC_TRY(NAME,  NNAME,  FUNC,                                          \
 234                 NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8,                           \
 235                 NAMEA, NNAMEA, FUNCA,                                         \
 236                 CLASS, STR)                                                   \
 237     case NAMEL:                                                               \
 238         PL_reg_flags |= RF_tainted;                                           \
 239         _CCC_TRY_CODE( !, LCFUNC, LCFUNC_utf8((U8*)locinput), CLASS, STR)     \
 240     case NNAMEL:                                                              \
 241         PL_reg_flags |= RF_tainted;                                           \
 242         _CCC_TRY_CODE( PLACEHOLDER, LCFUNC, LCFUNC_utf8((U8*)locinput),       \
 243                        CLASS, STR)                                            \
 244     case NAMEA:                                                               \
 245         if (NEXTCHR_IS_EOS || ! FUNCA(nextchr)) {                      \
 246             sayNO;                                                            \
 247         }                                                                     \
 248         /* Matched a utf8-invariant, so don't have to worry about utf8 */     \
 249         locinput++;                                        \
 250         break;                                                                \
 251     case NNAMEA:                                                              \
 252         if (NEXTCHR_IS_EOS || FUNCA(nextchr)) {                        \
 253             sayNO;                                                            \
 254         }                                                                     \
 255         goto increment_locinput;                                              \
 256     /* Generate the non-locale cases */                                       \
 257     _CCC_TRY_NONLOCALE(NAME, NNAME, FUNC, CLASS, STR)
 258
 259 /* This is like CCC_TRY, but has an extra set of parameters for generating case
 260  * statements to handle separate Unicode semantics nodes */
 261 #define CCC_TRY_U(NAME,  NNAME,  FUNC,                                         \
 262                   NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8,                          \
 263                   NAMEU, NNAMEU, FUNCU,                                        \
 264                   NAMEA, NNAMEA, FUNCA,                                        \
 265                   CLASS, STR)                                                  \
 266     CCC_TRY(NAME, NNAME, FUNC,                                                 \
 267             NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8,                                \
 268             NAMEA, NNAMEA, FUNCA,                                              \
 269             CLASS, STR)                                                        \
 270     _CCC_TRY_NONLOCALE(NAMEU, NNAMEU, FUNCU, CLASS, STR)
 271
 272 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
 273
 274 /* for use after a quantifier and before an EXACT-like node -- japhy */
 275 /* it would be nice to rework regcomp.sym to generate this stuff. sigh
 276  *
 277  * NOTE that *nothing* that affects backtracking should be in here, specifically
 278  * VERBS must NOT be included. JUMPABLE is used to determine  if we can ignore a
 279  * node that is in between two EXACT like nodes when ascertaining what the required
 280  * "follow" character is. This should probably be moved to regex compile time
 281  * although it may be done at run time beause of the REF possibility - more
 282  * investigation required. -- demerphq
 283 */
 284 #define JUMPABLE(rn) (      \
 285     OP(rn) == OPEN ||       \
 286     (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
 287     OP(rn) == EVAL ||   \
 288     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 289     OP(rn) == PLUS || OP(rn) == MINMOD || \
 290     OP(rn) == KEEPS || \
 291     (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
 292 )
 293 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
 294
 295 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
 296
 297 #if 0
 298 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
 299    we don't need this definition. */
 300 #define IS_TEXT(rn)   ( OP(rn)==EXACT   || OP(rn)==REF   || OP(rn)==NREF   )
 301 #define IS_TEXTF(rn)  ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFU_TRICKYFOLD || OP(rn)==EXACTFA || OP(rn)==EXACTF || OP(rn)==REFF  || OP(rn)==NREFF )
 302 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
 303
 304 #else
 305 /* ... so we use this as its faster. */
 306 #define IS_TEXT(rn)   ( OP(rn)==EXACT   )
 307 #define IS_TEXTFU(rn)  ( OP(rn)==EXACTFU || OP(rn)==EXACTFU_SS || OP(rn)==EXACTFU_TRICKYFOLD || OP(rn) == EXACTFA)
 308 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  )
 309 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
 310
 311 #endif
 312
 313 /*
 314   Search for mandatory following text node; for lookahead, the text must
 315   follow but for lookbehind (rn->flags != 0) we skip to the next step.
 316 */
 317 #define FIND_NEXT_IMPT(rn) STMT_START { \
 318     while (JUMPABLE(rn)) { \
 319         const OPCODE type = OP(rn); \
 320         if (type == SUSPEND || PL_regkind[type] == CURLY) \
 321             rn = NEXTOPER(NEXTOPER(rn)); \
 322         else if (type == PLUS) \
 323             rn = NEXTOPER(rn); \
 324         else if (type == IFMATCH) \
 325             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
 326         else rn += NEXT_OFF(rn); \
 327     } \
 328 } STMT_END
 329
 330 /* These constants are for finding GCB=LV and GCB=LVT in the CLUMP regnode.
 331  * These are for the pre-composed Hangul syllables, which are all in a
 332  * contiguous block and arranged there in such a way so as to facilitate
 333  * alorithmic determination of their characteristics.  As such, they don't need
 334  * a swash, but can be determined by simple arithmetic.  Almost all are
 335  * GCB=LVT, but every 28th one is a GCB=LV */
 336 #define SBASE 0xAC00    /* Start of block */
 337 #define SCount 11172    /* Length of block */
 338 #define TCount 28
 339
 340 static void restore_pos(pTHX_ void *arg);
 341
 342 #define REGCP_PAREN_ELEMS 3
 343 #define REGCP_OTHER_ELEMS 3
 344 #define REGCP_FRAME_ELEMS 1
 345 /* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
 346  * are needed for the regexp context stack bookkeeping. */
 347
 348 STATIC CHECKPOINT
 349 S_regcppush(pTHX_ const regexp *rex, I32 parenfloor)
 350 {
 351     dVAR;
 352     const int retval = PL_savestack_ix;
 353     const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
 354     const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
 355     const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
 356     I32 p;
 357     GET_RE_DEBUG_FLAGS_DECL;
 358
 359     PERL_ARGS_ASSERT_REGCPPUSH;
 360
 361     if (paren_elems_to_push < 0)
 362         Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0",
 363                    paren_elems_to_push);
 364
 365     if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
 366         Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf
 367                    " out of range (%lu-%ld)",
 368                    total_elems, (unsigned long)PL_regsize, (long)parenfloor);
 369
 370     SSGROW(total_elems + REGCP_FRAME_ELEMS);
 371
 372     DEBUG_BUFFERS_r(
 373         if ((int)PL_regsize > (int)parenfloor)
 374             PerlIO_printf(Perl_debug_log,
 375                 "rex=0x%"UVxf" offs=0x%"UVxf": saving capture indices:\n",
 376                 PTR2UV(rex),
 377                 PTR2UV(rex->offs)
 378             );
 379     );
 380     for (p = parenfloor+1; p <= (I32)PL_regsize;  p++) {
 381 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 382         SSPUSHINT(rex->offs[p].end);
 383         SSPUSHINT(rex->offs[p].start);
 384         SSPUSHINT(rex->offs[p].start_tmp);
 385         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
 386             "    \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"\n",
 387             (UV)p,
 388             (IV)rex->offs[p].start,
 389             (IV)rex->offs[p].start_tmp,
 390             (IV)rex->offs[p].end
 391         ));
 392     }
 393 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 394     SSPUSHINT(PL_regsize);
 395     SSPUSHINT(rex->lastparen);
 396     SSPUSHINT(rex->lastcloseparen);
 397     SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
 398
 399     return retval;
 400 }
 401
 402 /* These are needed since we do not localize EVAL nodes: */
 403 #define REGCP_SET(cp)                                           \
 404     DEBUG_STATE_r(                                              \
 405             PerlIO_printf(Perl_debug_log,                       \
 406                 "  Setting an EVAL scope, savestack=%"IVdf"\n", \
 407                 (IV)PL_savestack_ix));                          \
 408     cp = PL_savestack_ix
 409
 410 #define REGCP_UNWIND(cp)                                        \
 411     DEBUG_STATE_r(                                              \
 412         if (cp != PL_savestack_ix)                              \
 413             PerlIO_printf(Perl_debug_log,                       \
 414                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 415                 (IV)(cp), (IV)PL_savestack_ix));                \
 416     regcpblow(cp)
 417
 418 #define UNWIND_PAREN(lp, lcp)               \
 419     for (n = rex->lastparen; n > lp; n--)   \
 420         rex->offs[n].end = -1;              \
 421     rex->lastparen = n;                     \
 422     rex->lastcloseparen = lcp;
 423
 424
 425 STATIC void
 426 S_regcppop(pTHX_ regexp *rex)
 427 {
 428     dVAR;
 429     UV i;
 430     U32 paren;
 431     GET_RE_DEBUG_FLAGS_DECL;
 432
 433     PERL_ARGS_ASSERT_REGCPPOP;
 434
 435     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 436     i = SSPOPUV;
 437     assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 438     i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
 439     rex->lastcloseparen = SSPOPINT;
 440     rex->lastparen = SSPOPINT;
 441     PL_regsize = SSPOPINT;
 442
 443     i -= REGCP_OTHER_ELEMS;
 444     /* Now restore the parentheses context. */
 445     DEBUG_BUFFERS_r(
 446         if (i || rex->lastparen + 1 <= rex->nparens)
 447             PerlIO_printf(Perl_debug_log,
 448                 "rex=0x%"UVxf" offs=0x%"UVxf": restoring capture indices to:\n",
 449                 PTR2UV(rex),
 450                 PTR2UV(rex->offs)
 451             );
 452     );
 453     paren = PL_regsize;
 454     for ( ; i > 0; i -= REGCP_PAREN_ELEMS) {
 455         I32 tmps;
 456         rex->offs[paren].start_tmp = SSPOPINT;
 457         rex->offs[paren].start = SSPOPINT;
 458         tmps = SSPOPINT;
 459         if (paren <= rex->lastparen)
 460             rex->offs[paren].end = tmps;
 461         DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
 462             "    \\%"UVuf": %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 463             (UV)paren,
 464             (IV)rex->offs[paren].start,
 465             (IV)rex->offs[paren].start_tmp,
 466             (IV)rex->offs[paren].end,
 467             (paren > rex->lastparen ? "(skipped)" : ""));
 468         );
 469         paren--;
 470     }
 471 #if 1
 472     /* It would seem that the similar code in regtry()
 473      * already takes care of this, and in fact it is in
 474      * a better location to since this code can #if 0-ed out
 475      * but the code in regtry() is needed or otherwise tests
 476      * requiring null fields (pat.t#187 and split.t#{13,14}
 477      * (as of patchlevel 7877)  will fail.  Then again,
 478      * this code seems to be necessary or otherwise
 479      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
 480      * --jhi updated by dapm */
 481     for (i = rex->lastparen + 1; i <= rex->nparens; i++) {
 482         if (i > PL_regsize)
 483             rex->offs[i].start = -1;
 484         rex->offs[i].end = -1;
 485         DEBUG_BUFFERS_r( PerlIO_printf(Perl_debug_log,
 486             "    \\%"UVuf": %s   ..-1 undeffing\n",
 487             (UV)i,
 488             (i > PL_regsize) ? "-1" : "  "
 489         ));
 490     }
 491 #endif
 492 }
 493
 494 /* restore the parens and associated vars at savestack position ix,
 495  * but without popping the stack */
 496
 497 STATIC void
 498 S_regcp_restore(pTHX_ regexp *rex, I32 ix)
 499 {
 500     I32 tmpix = PL_savestack_ix;
 501     PL_savestack_ix = ix;
 502     regcppop(rex);
 503     PL_savestack_ix = tmpix;
 504 }
 505
 506 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
 507
 508 STATIC bool
 509 S_isFOO_lc(pTHX_ const U8 classnum, const U8 character)
 510 {
 511     /* Returns a boolean as to whether or not 'character' is a member of the
 512      * Posix character class given by 'classnum' that should be equivalent to a
 513      * value in the typedef '_char_class_number'.
 514      *
 515      * Ideally this could be replaced by a just an array of function pointers
 516      * to the C library functions that implement the macros this calls.
 517      * However, to compile, the precise function signatures are required, and
 518      * these may vary from platform to to platform.  To avoid having to figure
 519      * out what those all are on each platform, I (khw) am using this method,
 520      * which adds an extra layer of function call overhead.  But we don't
 521      * particularly care about performance with locales anyway. */
 522
 523     switch ((_char_class_number) classnum) {
 524         case _CC_ENUM_ALNUMC:    return isALNUMC_LC(character);
 525         case _CC_ENUM_ALPHA:     return isALPHA_LC(character);
 526         case _CC_ENUM_DIGIT:     return isDIGIT_LC(character);
 527         case _CC_ENUM_GRAPH:     return isGRAPH_LC(character);
 528         case _CC_ENUM_LOWER:     return isLOWER_LC(character);
 529         case _CC_ENUM_PRINT:     return isPRINT_LC(character);
 530         case _CC_ENUM_PUNCT:     return isPUNCT_LC(character);
 531         case _CC_ENUM_UPPER:     return isUPPER_LC(character);
 532         case _CC_ENUM_WORDCHAR:  return isWORDCHAR_LC(character);
 533         case _CC_ENUM_SPACE:     return isSPACE_LC(character);
 534         case _CC_ENUM_BLANK:     return isBLANK_LC(character);
 535         case _CC_ENUM_XDIGIT:    return isXDIGIT_LC(character);
 536         case _CC_ENUM_CNTRL:     return isCNTRL_LC(character);
 537         case _CC_ENUM_PSXSPC:    return isPSXSPC_LC(character);
 538         case _CC_ENUM_ASCII:     return isASCII_LC(character);
 539         default:    /* VERTSPACE should never occur in locales */
 540             Perl_croak(aTHX_ "panic: isFOO_lc() has an unexpected character class '%d'", classnum);
 541     }
 542
 543     assert(0); /* NOTREACHED */
 544     return FALSE;
 545 }
 546
 547 /*
 548  * pregexec and friends
 549  */
 550
 551 #ifndef PERL_IN_XSUB_RE
 552 /*
 553  - pregexec - match a regexp against a string
 554  */
 555 I32
 556 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend,
 557          char *strbeg, I32 minend, SV *screamer, U32 nosave)
 558 /* stringarg: the point in the string at which to begin matching */
 559 /* strend:    pointer to null at end of string */
 560 /* strbeg:    real beginning of string */
 561 /* minend:    end of match must be >= minend bytes after stringarg. */
 562 /* screamer:  SV being matched: only used for utf8 flag, pos() etc; string
 563  *            itself is accessed via the pointers above */
 564 /* nosave:    For optimizations. */
 565 {
 566     PERL_ARGS_ASSERT_PREGEXEC;
 567
 568     return
 569         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 570                       nosave ? 0 : REXEC_COPY_STR);
 571 }
 572 #endif
 573
 574 /*
 575  * Need to implement the following flags for reg_anch:
 576  *
 577  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
 578  * USE_INTUIT_ML
 579  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
 580  * INTUIT_AUTORITATIVE_ML
 581  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
 582  * INTUIT_ONCE_ML
 583  *
 584  * Another flag for this function: SECOND_TIME (so that float substrs
 585  * with giant delta may be not rechecked).
 586  */
 587
 588 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 589
 590 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
 591    Otherwise, only SvCUR(sv) is used to get strbeg. */
 592
 593 /* XXXX We assume that strpos is strbeg unless sv. */
 594
 595 /* XXXX Some places assume that there is a fixed substring.
 596         An update may be needed if optimizer marks as "INTUITable"
 597         RExen without fixed substrings.  Similarly, it is assumed that
 598         lengths of all the strings are no more than minlen, thus they
 599         cannot come from lookahead.
 600         (Or minlen should take into account lookahead.)
 601   NOTE: Some of this comment is not correct. minlen does now take account
 602   of lookahead/behind. Further research is required. -- demerphq
 603
 604 */
 605
 606 /* A failure to find a constant substring means that there is no need to make
 607    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 608    finding a substring too deep into the string means that less calls to
 609    regtry() should be needed.
 610
 611    REx compiler's optimizer found 4 possible hints:
 612         a) Anchored substring;
 613         b) Fixed substring;
 614         c) Whether we are anchored (beginning-of-line or \G);
 615         d) First node (of those at offset 0) which may distinguish positions;
 616    We use a)b)d) and multiline-part of c), and try to find a position in the
 617    string which does not contradict any of them.
 618  */
 619
 620 /* Most of decisions we do here should have been done at compile time.
 621    The nodes of the REx which we used for the search should have been
 622    deleted from the finite automaton. */
 623
 624 char *
 625 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
 626                      char *strend, const U32 flags, re_scream_pos_data *data)
 627 {
 628     dVAR;
 629     struct regexp *const prog = ReANY(rx);
 630     I32 start_shift = 0;
 631     /* Should be nonnegative! */
 632     I32 end_shift   = 0;
 633     char *s;
 634     SV *check;
 635     char *strbeg;
 636     char *t;
 637     const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
 638     I32 ml_anch;
 639     char *other_last = NULL;    /* other substr checked before this */
 640     char *check_at = NULL;              /* check substr found at this pos */
 641     char *checked_upto = NULL;          /* how far into the string we have already checked using find_byclass*/
 642     const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
 643     RXi_GET_DECL(prog,progi);
 644 #ifdef DEBUGGING
 645     const char * const i_strpos = strpos;
 646 #endif
 647     GET_RE_DEBUG_FLAGS_DECL;
 648
 649     PERL_ARGS_ASSERT_RE_INTUIT_START;
 650     PERL_UNUSED_ARG(flags);
 651     PERL_UNUSED_ARG(data);
 652
 653     RX_MATCH_UTF8_set(rx,utf8_target);
 654
 655     if (RX_UTF8(rx)) {
 656         PL_reg_flags |= RF_utf8;
 657     }
 658     DEBUG_EXECUTE_r(
 659         debug_start_match(rx, utf8_target, strpos, strend,
 660             sv ? "Guessing start of match in sv for"
 661                : "Guessing start of match in string for");
 662               );
 663
 664     /* CHR_DIST() would be more correct here but it makes things slow. */
 665     if (prog->minlen > strend - strpos) {
 666         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 667                               "String too short... [re_intuit_start]\n"));
 668         goto fail;
 669     }
 670
 671     /* XXX we need to pass strbeg as a separate arg: the following is
 672      * guesswork and can be wrong... */
 673     if (sv && SvPOK(sv)) {
 674         char * p   = SvPVX(sv);
 675         STRLEN cur = SvCUR(sv);
 676         if (p <= strpos && strpos < p + cur) {
 677             strbeg = p;
 678             assert(p <= strend && strend <= p + cur);
 679         }
 680         else
 681             strbeg = strend - cur;
 682     }
 683     else
 684         strbeg = strpos;
 685
 686     PL_regeol = strend;
 687     if (utf8_target) {
 688         if (!prog->check_utf8 && prog->check_substr)
 689             to_utf8_substr(prog);
 690         check = prog->check_utf8;
 691     } else {
 692         if (!prog->check_substr && prog->check_utf8) {
 693             if (! to_byte_substr(prog)) {
 694                 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(fail);
 695             }
 696         }
 697         check = prog->check_substr;
 698     }
 699     if (prog->extflags & RXf_ANCH) {    /* Match at beg-of-str or after \n */
 700         ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
 701                      || ( (prog->extflags & RXf_ANCH_BOL)
 702                           && !multiline ) );    /* Check after \n? */
 703
 704         if (!ml_anch) {
 705           if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
 706                 && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
 707                /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
 708                && sv && !SvROK(sv)
 709                && (strpos != strbeg)) {
 710               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 711               goto fail;
 712           }
 713           if (prog->check_offset_min == prog->check_offset_max
 714               && !(prog->extflags & RXf_CANY_SEEN)
 715               && ! multiline)   /* /m can cause \n's to match that aren't
 716                                    accounted for in the string max length.
 717                                    See [perl #115242] */
 718           {
 719             /* Substring at constant offset from beg-of-str... */
 720             I32 slen;
 721
 722             s = HOP3c(strpos, prog->check_offset_min, strend);
 723
 724             if (SvTAIL(check)) {
 725                 slen = SvCUR(check);    /* >= 1 */
 726
 727                 if ( strend - s > slen || strend - s < slen - 1
 728                      || (strend - s == slen && strend[-1] != '\n')) {
 729                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 730                     goto fail_finish;
 731                 }
 732                 /* Now should match s[0..slen-2] */
 733                 slen--;
 734                 if (slen && (*SvPVX_const(check) != *s
 735                              || (slen > 1
 736                                  && memNE(SvPVX_const(check), s, slen)))) {
 737                   report_neq:
 738                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 739                     goto fail_finish;
 740                 }
 741             }
 742             else if (*SvPVX_const(check) != *s
 743                      || ((slen = SvCUR(check)) > 1
 744                          && memNE(SvPVX_const(check), s, slen)))
 745                 goto report_neq;
 746             check_at = s;
 747             goto success_at_start;
 748           }
 749         }
 750         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 751         s = strpos;
 752         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 753         end_shift = prog->check_end_shift;
 754
 755         if (!ml_anch) {
 756             const I32 end = prog->check_offset_max + CHR_SVLEN(check)
 757                                          - (SvTAIL(check) != 0);
 758             const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 759
 760             if (end_shift < eshift)
 761                 end_shift = eshift;
 762         }
 763     }
 764     else {                              /* Can match at random position */
 765         ml_anch = 0;
 766         s = strpos;
 767         start_shift = prog->check_offset_min;  /* okay to underestimate on CC */
 768         end_shift = prog->check_end_shift;
 769
 770         /* end shift should be non negative here */
 771     }
 772
 773 #ifdef QDEBUGGING       /* 7/99: reports of failure (with the older version) */
 774     if (end_shift < 0)
 775         Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
 776                    (IV)end_shift, RX_PRECOMP(prog));
 777 #endif
 778
 779   restart:
 780     /* Find a possible match in the region s..strend by looking for
 781        the "check" substring in the region corrected by start/end_shift. */
 782
 783     {
 784         I32 srch_start_shift = start_shift;
 785         I32 srch_end_shift = end_shift;
 786         U8* start_point;
 787         U8* end_point;
 788         if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
 789             srch_end_shift -= ((strbeg - s) - srch_start_shift);
 790             srch_start_shift = strbeg - s;
 791         }
 792     DEBUG_OPTIMISE_MORE_r({
 793         PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
 794             (IV)prog->check_offset_min,
 795             (IV)srch_start_shift,
 796             (IV)srch_end_shift,
 797             (IV)prog->check_end_shift);
 798     });
 799
 800         if (prog->extflags & RXf_CANY_SEEN) {
 801             start_point= (U8*)(s + srch_start_shift);
 802             end_point= (U8*)(strend - srch_end_shift);
 803         } else {
 804             start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
 805             end_point= HOP3(strend, -srch_end_shift, strbeg);
 806         }
 807         DEBUG_OPTIMISE_MORE_r({
 808             PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
 809                 (int)(end_point - start_point),
 810                 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
 811                 start_point);
 812         });
 813
 814         s = fbm_instr( start_point, end_point,
 815                       check, multiline ? FBMrf_MULTILINE : 0);
 816     }
 817     /* Update the count-of-usability, remove useless subpatterns,
 818         unshift s.  */
 819
 820     DEBUG_EXECUTE_r({
 821         RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
 822             SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
 823         PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
 824                           (s ? "Found" : "Did not find"),
 825             (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr)
 826                 ? "anchored" : "floating"),
 827             quoted,
 828             RE_SV_TAIL(check),
 829             (s ? " at offset " : "...\n") );
 830     });
 831
 832     if (!s)
 833         goto fail_finish;
 834     /* Finish the diagnostic message */
 835     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 836
 837     /* XXX dmq: first branch is for positive lookbehind...
 838        Our check string is offset from the beginning of the pattern.
 839        So we need to do any stclass tests offset forward from that
 840        point. I think. :-(
 841      */
 842
 843
 844
 845     check_at=s;
 846
 847
 848     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 849        Start with the other substr.
 850        XXXX no SCREAM optimization yet - and a very coarse implementation
 851        XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
 852                 *always* match.  Probably should be marked during compile...
 853        Probably it is right to do no SCREAM here...
 854      */
 855
 856     if (utf8_target ? (prog->float_utf8 && prog->anchored_utf8)
 857                 : (prog->float_substr && prog->anchored_substr))
 858     {
 859         /* Take into account the "other" substring. */
 860         /* XXXX May be hopelessly wrong for UTF... */
 861         if (!other_last)
 862             other_last = strpos;
 863         if (check == (utf8_target ? prog->float_utf8 : prog->float_substr)) {
 864           do_other_anchored:
 865             {
 866                 char * const last = HOP3c(s, -start_shift, strbeg);
 867                 char *last1, *last2;
 868                 char * const saved_s = s;
 869                 SV* must;
 870
 871                 t = s - prog->check_offset_max;
 872                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 873                     && (!utf8_target
 874                         || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
 875                             && t > strpos)))
 876                     NOOP;
 877                 else
 878                     t = strpos;
 879                 t = HOP3c(t, prog->anchored_offset, strend);
 880                 if (t < other_last)     /* These positions already checked */
 881                     t = other_last;
 882                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 883                 if (last < last1)
 884                     last1 = last;
 885                 /* XXXX It is not documented what units *_offsets are in.
 886                    We assume bytes, but this is clearly wrong.
 887                    Meaning this code needs to be carefully reviewed for errors.
 888                    dmq.
 889                   */
 890
 891                 /* On end-of-str: see comment below. */
 892                 must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
 893                 if (must == &PL_sv_undef) {
 894                     s = (char*)NULL;
 895                     DEBUG_r(must = prog->anchored_utf8);        /* for debug */
 896                 }
 897                 else
 898                     s = fbm_instr(
 899                         (unsigned char*)t,
 900                         HOP3(HOP3(last1, prog->anchored_offset, strend)
 901                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
 902                         must,
 903                         multiline ? FBMrf_MULTILINE : 0
 904                     );
 905                 DEBUG_EXECUTE_r({
 906                     RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
 907                         SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 908                     PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
 909                         (s ? "Found" : "Contradicts"),
 910                         quoted, RE_SV_TAIL(must));
 911                 });
 912
 913
 914                 if (!s) {
 915                     if (last1 >= last2) {
 916                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 917                                                 ", giving up...\n"));
 918                         goto fail_finish;
 919                     }
 920                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 921                         ", trying floating at offset %ld...\n",
 922                         (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
 923                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 924                     s = HOP3c(last, 1, strend);
 925                     goto restart;
 926                 }
 927                 else {
 928                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 929                           (long)(s - i_strpos)));
 930                     t = HOP3c(s, -prog->anchored_offset, strbeg);
 931                     other_last = HOP3c(s, 1, strend);
 932                     s = saved_s;
 933                     if (t == strpos)
 934                         goto try_at_start;
 935                     goto try_at_offset;
 936                 }
 937             }
 938         }
 939         else {          /* Take into account the floating substring. */
 940             char *last, *last1;
 941             char * const saved_s = s;
 942             SV* must;
 943
 944             t = HOP3c(s, -start_shift, strbeg);
 945             last1 = last =
 946                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 947             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 948                 last = HOP3c(t, prog->float_max_offset, strend);
 949             s = HOP3c(t, prog->float_min_offset, strend);
 950             if (s < other_last)
 951                 s = other_last;
 952  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 953             must = utf8_target ? prog->float_utf8 : prog->float_substr;
 954             /* fbm_instr() takes into account exact value of end-of-str
 955                if the check is SvTAIL(ed).  Since false positives are OK,
 956                and end-of-str is not later than strend we are OK. */
 957             if (must == &PL_sv_undef) {
 958                 s = (char*)NULL;
 959                 DEBUG_r(must = prog->float_utf8);       /* for debug message */
 960             }
 961             else
 962                 s = fbm_instr((unsigned char*)s,
 963                               (unsigned char*)last + SvCUR(must)
 964                                   - (SvTAIL(must)!=0),
 965                               must, multiline ? FBMrf_MULTILINE : 0);
 966             DEBUG_EXECUTE_r({
 967                 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
 968                     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 969                 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
 970                     (s ? "Found" : "Contradicts"),
 971                     quoted, RE_SV_TAIL(must));
 972             });
 973             if (!s) {
 974                 if (last1 == last) {
 975                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 976                                             ", giving up...\n"));
 977                     goto fail_finish;
 978                 }
 979                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 980                     ", trying anchored starting at offset %ld...\n",
 981                     (long)(saved_s + 1 - i_strpos)));
 982                 other_last = last;
 983                 s = HOP3c(t, 1, strend);
 984                 goto restart;
 985             }
 986             else {
 987                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 988                       (long)(s - i_strpos)));
 989                 other_last = s; /* Fix this later. --Hugo */
 990                 s = saved_s;
 991                 if (t == strpos)
 992                     goto try_at_start;
 993                 goto try_at_offset;
 994             }
 995         }
 996     }
 997
 998
 999     t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
1000
1001     DEBUG_OPTIMISE_MORE_r(
1002         PerlIO_printf(Perl_debug_log,
1003             "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
1004             (IV)prog->check_offset_min,
1005             (IV)prog->check_offset_max,
1006             (IV)(s-strpos),
1007             (IV)(t-strpos),
1008             (IV)(t-s),
1009             (IV)(strend-strpos)
1010         )
1011     );
1012
1013     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
1014         && (!utf8_target
1015             || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
1016                  && t > strpos)))
1017     {
1018         /* Fixed substring is found far enough so that the match
1019            cannot start at strpos. */
1020       try_at_offset:
1021         if (ml_anch && t[-1] != '\n') {
1022             /* Eventually fbm_*() should handle this, but often
1023                anchored_offset is not 0, so this check will not be wasted. */
1024             /* XXXX In the code below we prefer to look for "^" even in
1025                presence of anchored substrings.  And we search even
1026                beyond the found float position.  These pessimizations
1027                are historical artefacts only.  */
1028           find_anchor:
1029             while (t < strend - prog->minlen) {
1030                 if (*t == '\n') {
1031                     if (t < check_at - prog->check_offset_min) {
1032                         if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
1033                             /* Since we moved from the found position,
1034                                we definitely contradict the found anchored
1035                                substr.  Due to the above check we do not
1036                                contradict "check" substr.
1037                                Thus we can arrive here only if check substr
1038                                is float.  Redo checking for "other"=="fixed".
1039                              */
1040                             strpos = t + 1;
1041                             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
1042                                 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
1043                             goto do_other_anchored;
1044                         }
1045                         /* We don't contradict the found floating substring. */
1046                         /* XXXX Why not check for STCLASS? */
1047                         s = t + 1;
1048                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
1049                             PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
1050                         goto set_useful;
1051                     }
1052                     /* Position contradicts check-string */
1053                     /* XXXX probably better to look for check-string
1054                        than for "\n", so one should lower the limit for t? */
1055                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
1056                         PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
1057                     other_last = strpos = s = t + 1;
1058                     goto restart;
1059                 }
1060                 t++;
1061             }
1062             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
1063                         PL_colors[0], PL_colors[1]));
1064             goto fail_finish;
1065         }
1066         else {
1067             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
1068                         PL_colors[0], PL_colors[1]));
1069         }
1070         s = t;
1071       set_useful:
1072         ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr);        /* hooray/5 */
1073     }
1074     else {
1075         /* The found string does not prohibit matching at strpos,
1076            - no optimization of calling REx engine can be performed,
1077            unless it was an MBOL and we are not after MBOL,
1078            or a future STCLASS check will fail this. */
1079       try_at_start:
1080         /* Even in this situation we may use MBOL flag if strpos is offset
1081            wrt the start of the string. */
1082         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
1083             && (strpos != strbeg) && strpos[-1] != '\n'
1084             /* May be due to an implicit anchor of m{.*foo}  */
1085             && !(prog->intflags & PREGf_IMPLICIT))
1086         {
1087             t = strpos;
1088             goto find_anchor;
1089         }
1090         DEBUG_EXECUTE_r( if (ml_anch)
1091             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
1092                           (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
1093         );
1094       success_at_start:
1095         if (!(prog->intflags & PREGf_NAUGHTY)   /* XXXX If strpos moved? */
1096             && (utf8_target ? (
1097                 prog->check_utf8                /* Could be deleted already */
1098                 && --BmUSEFUL(prog->check_utf8) < 0
1099                 && (prog->check_utf8 == prog->float_utf8)
1100             ) : (
1101                 prog->check_substr              /* Could be deleted already */
1102                 && --BmUSEFUL(prog->check_substr) < 0
1103                 && (prog->check_substr == prog->float_substr)
1104             )))
1105         {
1106             /* If flags & SOMETHING - do not do it many times on the same match */
1107             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
1108             /* XXX Does the destruction order has to change with utf8_target? */
1109             SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
1110             SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
1111             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
1112             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
1113             check = NULL;                       /* abort */
1114             s = strpos;
1115             /* XXXX If the check string was an implicit check MBOL, then we need to unset the relevant flag
1116                     see http://bugs.activestate.com/show_bug.cgi?id=87173 */
1117             if (prog->intflags & PREGf_IMPLICIT)
1118                 prog->extflags &= ~RXf_ANCH_MBOL;
1119             /* XXXX This is a remnant of the old implementation.  It
1120                     looks wasteful, since now INTUIT can use many
1121                     other heuristics. */
1122             prog->extflags &= ~RXf_USE_INTUIT;
1123             /* XXXX What other flags might need to be cleared in this branch? */
1124         }
1125         else
1126             s = strpos;
1127     }
1128
1129     /* Last resort... */
1130     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
1131     /* trie stclasses are too expensive to use here, we are better off to
1132        leave it to regmatch itself */
1133     if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1134         /* minlen == 0 is possible if regstclass is \b or \B,
1135            and the fixed substr is ''$.
1136            Since minlen is already taken into account, s+1 is before strend;
1137            accidentally, minlen >= 1 guaranties no false positives at s + 1
1138            even for \b or \B.  But (minlen? 1 : 0) below assumes that
1139            regstclass does not come from lookahead...  */
1140         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
1141            This leaves EXACTF-ish only, which are dealt with in find_byclass().  */
1142         const U8* const str = (U8*)STRING(progi->regstclass);
1143         const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1144                     ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
1145                     : 1);
1146         char * endpos;
1147         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1148             endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
1149         else if (prog->float_substr || prog->float_utf8)
1150             endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
1151         else
1152             endpos= strend;
1153
1154         if (checked_upto < s)
1155            checked_upto = s;
1156         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
1157                                       (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
1158
1159         t = s;
1160         s = find_byclass(prog, progi->regstclass, checked_upto, endpos, NULL);
1161         if (s) {
1162             checked_upto = s;
1163         } else {
1164 #ifdef DEBUGGING
1165             const char *what = NULL;
1166 #endif
1167             if (endpos == strend) {
1168                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1169                                 "Could not match STCLASS...\n") );
1170                 goto fail;
1171             }
1172             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1173                                    "This position contradicts STCLASS...\n") );
1174             if ((prog->extflags & RXf_ANCH) && !ml_anch)
1175                 goto fail;
1176             checked_upto = HOPBACKc(endpos, start_shift);
1177             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
1178                                       (IV)start_shift, (IV)(check_at - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
1179             /* Contradict one of substrings */
1180             if (prog->anchored_substr || prog->anchored_utf8) {
1181                 if ((utf8_target ? prog->anchored_utf8 : prog->anchored_substr) == check) {
1182                     DEBUG_EXECUTE_r( what = "anchored" );
1183                   hop_and_restart:
1184                     s = HOP3c(t, 1, strend);
1185                     if (s + start_shift + end_shift > strend) {
1186                         /* XXXX Should be taken into account earlier? */
1187                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1188                                                "Could not match STCLASS...\n") );
1189                         goto fail;
1190                     }
1191                     if (!check)
1192                         goto giveup;
1193                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1194                                 "Looking for %s substr starting at offset %ld...\n",
1195                                  what, (long)(s + start_shift - i_strpos)) );
1196                     goto restart;
1197                 }
1198                 /* Have both, check_string is floating */
1199                 if (t + start_shift >= check_at) /* Contradicts floating=check */
1200                     goto retry_floating_check;
1201                 /* Recheck anchored substring, but not floating... */
1202                 s = check_at;
1203                 if (!check)
1204                     goto giveup;
1205                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1206                           "Looking for anchored substr starting at offset %ld...\n",
1207                           (long)(other_last - i_strpos)) );
1208                 goto do_other_anchored;
1209             }
1210             /* Another way we could have checked stclass at the
1211                current position only: */
1212             if (ml_anch) {
1213                 s = t = t + 1;
1214                 if (!check)
1215                     goto giveup;
1216                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1217                           "Looking for /%s^%s/m starting at offset %ld...\n",
1218                           PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
1219                 goto try_at_offset;
1220             }
1221             if (!(utf8_target ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
1222                 goto fail;
1223             /* Check is floating substring. */
1224           retry_floating_check:
1225             t = check_at - start_shift;
1226             DEBUG_EXECUTE_r( what = "floating" );
1227             goto hop_and_restart;
1228         }
1229         if (t != s) {
1230             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1231                         "By STCLASS: moving %ld --> %ld\n",
1232                                   (long)(t - i_strpos), (long)(s - i_strpos))
1233                    );
1234         }
1235         else {
1236             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1237                                   "Does not contradict STCLASS...\n");
1238                    );
1239         }
1240     }
1241   giveup:
1242     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
1243                           PL_colors[4], (check ? "Guessed" : "Giving up"),
1244                           PL_colors[5], (long)(s - i_strpos)) );
1245     return s;
1246
1247   fail_finish:                          /* Substring not found */
1248     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
1249         BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1250   fail:
1251     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1252                           PL_colors[4], PL_colors[5]));
1253     return NULL;
1254 }
1255
1256 #define DECL_TRIE_TYPE(scan) \
1257     const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
1258                     trie_type = ((scan->flags == EXACT) \
1259                               ? (utf8_target ? trie_utf8 : trie_plain) \
1260                               : (utf8_target ? trie_utf8_fold : trie_latin_utf8_fold))
1261
1262 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len,          \
1263 uvc, charid, foldlen, foldbuf, uniflags) STMT_START {                               \
1264     STRLEN skiplen;                                                                 \
1265     switch (trie_type) {                                                            \
1266     case trie_utf8_fold:                                                            \
1267         if ( foldlen>0 ) {                                                          \
1268             uvc = utf8n_to_uvuni( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1269             foldlen -= len;                                                         \
1270             uscan += len;                                                           \
1271             len=0;                                                                  \
1272         } else {                                                                    \
1273             uvc = to_utf8_fold( (const U8*) uc, foldbuf, &foldlen );                \
1274             len = UTF8SKIP(uc);                                                     \
1275             skiplen = UNISKIP( uvc );                                               \
1276             foldlen -= skiplen;                                                     \
1277             uscan = foldbuf + skiplen;                                              \
1278         }                                                                           \
1279         break;                                                                      \
1280     case trie_latin_utf8_fold:                                                      \
1281         if ( foldlen>0 ) {                                                          \
1282             uvc = utf8n_to_uvuni( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1283             foldlen -= len;                                                         \
1284             uscan += len;                                                           \
1285             len=0;                                                                  \
1286         } else {                                                                    \
1287             len = 1;                                                                \
1288             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1);                 \
1289             skiplen = UNISKIP( uvc );                                               \
1290             foldlen -= skiplen;                                                     \
1291             uscan = foldbuf + skiplen;                                              \
1292         }                                                                           \
1293         break;                                                                      \
1294     case trie_utf8:                                                                 \
1295         uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags );        \
1296         break;                                                                      \
1297     case trie_plain:                                                                \
1298         uvc = (UV)*uc;                                                              \
1299         len = 1;                                                                    \
1300     }                                                                               \
1301     if (uvc < 256) {                                                                \
1302         charid = trie->charmap[ uvc ];                                              \
1303     }                                                                               \
1304     else {                                                                          \
1305         charid = 0;                                                                 \
1306         if (widecharmap) {                                                          \
1307             SV** const svpp = hv_fetch(widecharmap,                                 \
1308                         (char*)&uvc, sizeof(UV), 0);                                \
1309             if (svpp)                                                               \
1310                 charid = (U16)SvIV(*svpp);                                          \
1311         }                                                                           \
1312     }                                                                               \
1313 } STMT_END
1314
1315 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1316 STMT_START {                                              \
1317     while (s <= e) {                                      \
1318         if ( (CoNd)                                       \
1319              && (ln == 1 || folder(s, pat_string, ln))    \
1320              && (!reginfo || regtry(reginfo, &s)) )       \
1321             goto got_it;                                  \
1322         s++;                                              \
1323     }                                                     \
1324 } STMT_END
1325
1326 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1327 STMT_START {                                          \
1328     while (s < strend && s + (uskip = UTF8SKIP(s)) <= strend) {     \
1329         CoDe                                          \
1330         s += uskip;                                   \
1331     }                                                 \
1332 } STMT_END
1333
1334 #define REXEC_FBC_SCAN(CoDe)                          \
1335 STMT_START {                                          \
1336     while (s < strend) {                              \
1337         CoDe                                          \
1338         s++;                                          \
1339     }                                                 \
1340 } STMT_END
1341
1342 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1343 REXEC_FBC_UTF8_SCAN(                                  \
1344     if (CoNd) {                                       \
1345         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1346             goto got_it;                              \
1347         else                                          \
1348             tmp = doevery;                            \
1349     }                                                 \
1350     else                                              \
1351         tmp = 1;                                      \
1352 )
1353
1354 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1355 REXEC_FBC_SCAN(                                       \
1356     if (CoNd) {                                       \
1357         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1358             goto got_it;                              \
1359         else                                          \
1360             tmp = doevery;                            \
1361     }                                                 \
1362     else                                              \
1363         tmp = 1;                                      \
1364 )
1365
1366 #define REXEC_FBC_TRYIT               \
1367 if ((!reginfo || regtry(reginfo, &s))) \
1368     goto got_it
1369
1370 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd)                         \
1371     if (utf8_target) {                                             \
1372         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1373     }                                                          \
1374     else {                                                     \
1375         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1376     }
1377
1378 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd)      \
1379     if (utf8_target) {                                             \
1380         UtFpReLoAd;                                            \
1381         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1382     }                                                          \
1383     else {                                                     \
1384         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1385     }
1386
1387 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd)                   \
1388     PL_reg_flags |= RF_tainted;                                \
1389     if (utf8_target) {                                             \
1390         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1391     }                                                          \
1392     else {                                                     \
1393         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1394     }
1395
1396 #define DUMP_EXEC_POS(li,s,doutf8) \
1397     dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1398
1399
1400 #define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1401         tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';                         \
1402         tmp = TEST_NON_UTF8(tmp);                                              \
1403         REXEC_FBC_UTF8_SCAN(                                                   \
1404             if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1405                 tmp = !tmp;                                                    \
1406                 IF_SUCCESS;                                                    \
1407             }                                                                  \
1408             else {                                                             \
1409                 IF_FAIL;                                                       \
1410             }                                                                  \
1411         );                                                                     \
1412
1413 #define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \
1414         if (s == PL_bostr) {                                                   \
1415             tmp = '\n';                                                        \
1416         }                                                                      \
1417         else {                                                                 \
1418             U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);                 \
1419             tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);       \
1420         }                                                                      \
1421         tmp = TeSt1_UtF8;                                                      \
1422         LOAD_UTF8_CHARCLASS_ALNUM();                                                                \
1423         REXEC_FBC_UTF8_SCAN(                                                   \
1424             if (tmp == ! (TeSt2_UtF8)) { \
1425                 tmp = !tmp;                                                    \
1426                 IF_SUCCESS;                                                    \
1427             }                                                                  \
1428             else {                                                             \
1429                 IF_FAIL;                                                       \
1430             }                                                                  \
1431         );                                                                     \
1432
1433 /* The only difference between the BOUND and NBOUND cases is that
1434  * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
1435  * NBOUND.  This is accomplished by passing it in either the if or else clause,
1436  * with the other one being empty */
1437 #define FBC_BOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1438     FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1439
1440 #define FBC_BOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1441     FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1442
1443 #define FBC_NBOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1444     FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1445
1446 #define FBC_NBOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1447     FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1448
1449
1450 /* Common to the BOUND and NBOUND cases.  Unfortunately the UTF8 tests need to
1451  * be passed in completely with the variable name being tested, which isn't
1452  * such a clean interface, but this is easier to read than it was before.  We
1453  * are looking for the boundary (or non-boundary between a word and non-word
1454  * character.  The utf8 and non-utf8 cases have the same logic, but the details
1455  * must be different.  Find the "wordness" of the character just prior to this
1456  * one, and compare it with the wordness of this one.  If they differ, we have
1457  * a boundary.  At the beginning of the string, pretend that the previous
1458  * character was a new-line */
1459 #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1460     if (utf8_target) {                                                         \
1461                 UTF8_CODE \
1462     }                                                                          \
1463     else {  /* Not utf8 */                                                     \
1464         tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';                         \
1465         tmp = TEST_NON_UTF8(tmp);                                              \
1466         REXEC_FBC_SCAN(                                                        \
1467             if (tmp == ! TEST_NON_UTF8((U8) *s)) {                             \
1468                 tmp = !tmp;                                                    \
1469                 IF_SUCCESS;                                                    \
1470             }                                                                  \
1471             else {                                                             \
1472                 IF_FAIL;                                                       \
1473             }                                                                  \
1474         );                                                                     \
1475     }                                                                          \
1476     if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))           \
1477         goto got_it;
1478
1479 /* We know what class REx starts with.  Try to find this position... */
1480 /* if reginfo is NULL, its a dryrun */
1481 /* annoyingly all the vars in this routine have different names from their counterparts
1482    in regmatch. /grrr */
1483
1484 STATIC char *
1485 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1486     const char *strend, regmatch_info *reginfo)
1487 {
1488     dVAR;
1489     const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1490     char *pat_string;   /* The pattern's exactish string */
1491     char *pat_end;          /* ptr to end char of pat_string */
1492     re_fold_t folder;   /* Function for computing non-utf8 folds */
1493     const U8 *fold_array;   /* array for folding ords < 256 */
1494     STRLEN ln;
1495     STRLEN lnc;
1496     STRLEN uskip;
1497     U8 c1;
1498     U8 c2;
1499     char *e;
1500     I32 tmp = 1;        /* Scratch variable? */
1501     const bool utf8_target = PL_reg_match_utf8;
1502     UV utf8_fold_flags = 0;
1503     RXi_GET_DECL(prog,progi);
1504
1505     PERL_ARGS_ASSERT_FIND_BYCLASS;
1506
1507     /* We know what class it must start with. */
1508     switch (OP(c)) {
1509     case ANYOF:
1510         if (utf8_target) {
1511             REXEC_FBC_UTF8_CLASS_SCAN(
1512                       reginclass(prog, c, (U8*)s, utf8_target));
1513         }
1514         else {
1515             REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
1516         }
1517         break;
1518     case CANY:
1519         REXEC_FBC_SCAN(
1520             if (tmp && (!reginfo || regtry(reginfo, &s)))
1521                 goto got_it;
1522             else
1523                 tmp = doevery;
1524         );
1525         break;
1526
1527     case EXACTFA:
1528         if (UTF_PATTERN || utf8_target) {
1529             utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
1530             goto do_exactf_utf8;
1531         }
1532         fold_array = PL_fold_latin1;    /* Latin1 folds are not affected by */
1533         folder = foldEQ_latin1;         /* /a, except the sharp s one which */
1534         goto do_exactf_non_utf8;        /* isn't dealt with by these */
1535
1536     case EXACTF:
1537         if (utf8_target) {
1538
1539             /* regcomp.c already folded this if pattern is in UTF-8 */
1540             utf8_fold_flags = 0;
1541             goto do_exactf_utf8;
1542         }
1543         fold_array = PL_fold;
1544         folder = foldEQ;
1545         goto do_exactf_non_utf8;
1546
1547     case EXACTFL:
1548         if (UTF_PATTERN || utf8_target) {
1549             utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
1550             goto do_exactf_utf8;
1551         }
1552         fold_array = PL_fold_locale;
1553         folder = foldEQ_locale;
1554         goto do_exactf_non_utf8;
1555
1556     case EXACTFU_SS:
1557         if (UTF_PATTERN) {
1558             utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
1559         }
1560         goto do_exactf_utf8;
1561
1562     case EXACTFU_TRICKYFOLD:
1563     case EXACTFU:
1564         if (UTF_PATTERN || utf8_target) {
1565             utf8_fold_flags = (UTF_PATTERN) ? FOLDEQ_S2_ALREADY_FOLDED : 0;
1566             goto do_exactf_utf8;
1567         }
1568
1569         /* Any 'ss' in the pattern should have been replaced by regcomp,
1570          * so we don't have to worry here about this single special case
1571          * in the Latin1 range */
1572         fold_array = PL_fold_latin1;
1573         folder = foldEQ_latin1;
1574
1575         /* FALL THROUGH */
1576
1577     do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there
1578                            are no glitches with fold-length differences
1579                            between the target string and pattern */
1580
1581         /* The idea in the non-utf8 EXACTF* cases is to first find the
1582          * first character of the EXACTF* node and then, if necessary,
1583          * case-insensitively compare the full text of the node.  c1 is the
1584          * first character.  c2 is its fold.  This logic will not work for
1585          * Unicode semantics and the german sharp ss, which hence should
1586          * not be compiled into a node that gets here. */
1587         pat_string = STRING(c);
1588         ln  = STR_LEN(c);       /* length to match in octets/bytes */
1589
1590         /* We know that we have to match at least 'ln' bytes (which is the
1591          * same as characters, since not utf8).  If we have to match 3
1592          * characters, and there are only 2 availabe, we know without
1593          * trying that it will fail; so don't start a match past the
1594          * required minimum number from the far end */
1595         e = HOP3c(strend, -((I32)ln), s);
1596
1597         if (!reginfo && e < s) {
1598             e = s;                      /* Due to minlen logic of intuit() */
1599         }
1600
1601         c1 = *pat_string;
1602         c2 = fold_array[c1];
1603         if (c1 == c2) { /* If char and fold are the same */
1604             REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1605         }
1606         else {
1607             REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1608         }
1609         break;
1610
1611     do_exactf_utf8:
1612     {
1613         unsigned expansion;
1614
1615         /* If one of the operands is in utf8, we can't use the simpler folding
1616          * above, due to the fact that many different characters can have the
1617          * same fold, or portion of a fold, or different- length fold */
1618         pat_string = STRING(c);
1619         ln  = STR_LEN(c);       /* length to match in octets/bytes */
1620         pat_end = pat_string + ln;
1621         lnc = (UTF_PATTERN)     /* length to match in characters */
1622                 ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
1623                 : ln;
1624
1625         /* We have 'lnc' characters to match in the pattern, but because of
1626          * multi-character folding, each character in the target can match
1627          * up to 3 characters (Unicode guarantees it will never exceed
1628          * this) if it is utf8-encoded; and up to 2 if not (based on the
1629          * fact that the Latin 1 folds are already determined, and the
1630          * only multi-char fold in that range is the sharp-s folding to
1631          * 'ss'.  Thus, a pattern character can match as little as 1/3 of a
1632          * string character.  Adjust lnc accordingly, rounding up, so that
1633          * if we need to match at least 4+1/3 chars, that really is 5. */
1634         expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2;
1635         lnc = (lnc + expansion - 1) / expansion;
1636
1637         /* As in the non-UTF8 case, if we have to match 3 characters, and
1638          * only 2 are left, it's guaranteed to fail, so don't start a
1639          * match that would require us to go beyond the end of the string
1640          */
1641         e = HOP3c(strend, -((I32)lnc), s);
1642
1643         if (!reginfo && e < s) {
1644             e = s;                      /* Due to minlen logic of intuit() */
1645         }
1646
1647         /* XXX Note that we could recalculate e to stop the loop earlier,
1648          * as the worst case expansion above will rarely be met, and as we
1649          * go along we would usually find that e moves further to the left.
1650          * This would happen only after we reached the point in the loop
1651          * where if there were no expansion we should fail.  Unclear if
1652          * worth the expense */
1653
1654         while (s <= e) {
1655             char *my_strend= (char *)strend;
1656             if (foldEQ_utf8_flags(s, &my_strend, 0,  utf8_target,
1657                   pat_string, NULL, ln, cBOOL(UTF_PATTERN), utf8_fold_flags)
1658                 && (!reginfo || regtry(reginfo, &s)) )
1659             {
1660                 goto got_it;
1661             }
1662             s += (utf8_target) ? UTF8SKIP(s) : 1;
1663         }
1664         break;
1665     }
1666     case BOUNDL:
1667         PL_reg_flags |= RF_tainted;
1668         FBC_BOUND(isALNUM_LC,
1669                   isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
1670                   isALNUM_LC_utf8((U8*)s));
1671         break;
1672     case NBOUNDL:
1673         PL_reg_flags |= RF_tainted;
1674         FBC_NBOUND(isALNUM_LC,
1675                    isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
1676                    isALNUM_LC_utf8((U8*)s));
1677         break;
1678     case BOUND:
1679         FBC_BOUND(isWORDCHAR,
1680                   isALNUM_uni(tmp),
1681                   cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1682         break;
1683     case BOUNDA:
1684         FBC_BOUND_NOLOAD(isWORDCHAR_A,
1685                          isWORDCHAR_A(tmp),
1686                          isWORDCHAR_A((U8*)s));
1687         break;
1688     case NBOUND:
1689         FBC_NBOUND(isWORDCHAR,
1690                    isALNUM_uni(tmp),
1691                    cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1692         break;
1693     case NBOUNDA:
1694         FBC_NBOUND_NOLOAD(isWORDCHAR_A,
1695                           isWORDCHAR_A(tmp),
1696                           isWORDCHAR_A((U8*)s));
1697         break;
1698     case BOUNDU:
1699         FBC_BOUND(isWORDCHAR_L1,
1700                   isALNUM_uni(tmp),
1701                   cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1702         break;
1703     case NBOUNDU:
1704         FBC_NBOUND(isWORDCHAR_L1,
1705                    isALNUM_uni(tmp),
1706                    cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1707         break;
1708     case ALNUML:
1709         REXEC_FBC_CSCAN_TAINT(
1710             isALNUM_LC_utf8((U8*)s),
1711             isALNUM_LC(*s)
1712         );
1713         break;
1714     case ALNUMU:
1715         REXEC_FBC_CSCAN_PRELOAD(
1716             LOAD_UTF8_CHARCLASS_ALNUM(),
1717             swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
1718             isWORDCHAR_L1((U8) *s)
1719         );
1720         break;
1721     case ALNUM:
1722         REXEC_FBC_CSCAN_PRELOAD(
1723             LOAD_UTF8_CHARCLASS_ALNUM(),
1724             swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
1725             isWORDCHAR((U8) *s)
1726         );
1727         break;
1728     case ALNUMA:
1729         /* Don't need to worry about utf8, as it can match only a single
1730          * byte invariant character */
1731         REXEC_FBC_CLASS_SCAN( isWORDCHAR_A(*s));
1732         break;
1733     case NALNUMU:
1734         REXEC_FBC_CSCAN_PRELOAD(
1735             LOAD_UTF8_CHARCLASS_ALNUM(),
1736             !swash_fetch(PL_utf8_alnum,(U8*)s, utf8_target),
1737             ! isWORDCHAR_L1((U8) *s)
1738         );
1739         break;
1740     case NALNUM:
1741         REXEC_FBC_CSCAN_PRELOAD(
1742             LOAD_UTF8_CHARCLASS_ALNUM(),
1743             !swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target),
1744             ! isALNUM(*s)
1745         );
1746         break;
1747     case NALNUMA:
1748         REXEC_FBC_CSCAN(
1749             !isWORDCHAR_A(*s),
1750             !isWORDCHAR_A(*s)
1751         );
1752         break;
1753     case NALNUML:
1754         REXEC_FBC_CSCAN_TAINT(
1755             !isALNUM_LC_utf8((U8*)s),
1756             !isALNUM_LC(*s)
1757         );
1758         break;
1759     case SPACEU:
1760         REXEC_FBC_CSCAN(
1761             is_XPERLSPACE_utf8(s),
1762             isSPACE_L1((U8) *s)
1763         );
1764         break;
1765     case SPACE:
1766         REXEC_FBC_CSCAN(
1767             is_XPERLSPACE_utf8(s),
1768             isSPACE((U8) *s)
1769         );
1770         break;
1771     case SPACEA:
1772         /* Don't need to worry about utf8, as it can match only a single
1773          * byte invariant character */
1774         REXEC_FBC_CLASS_SCAN( isSPACE_A(*s));
1775         break;
1776     case SPACEL:
1777         REXEC_FBC_CSCAN_TAINT(
1778             isSPACE_LC_utf8((U8*)s),
1779             isSPACE_LC(*s)
1780         );
1781         break;
1782     case NSPACEU:
1783         REXEC_FBC_CSCAN(
1784             ! is_XPERLSPACE_utf8(s),
1785             ! isSPACE_L1((U8) *s)
1786         );
1787         break;
1788     case NSPACE:
1789         REXEC_FBC_CSCAN(
1790             ! is_XPERLSPACE_utf8(s),
1791             ! isSPACE((U8) *s)
1792         );
1793         break;
1794     case NSPACEA:
1795         REXEC_FBC_CSCAN(
1796             !isSPACE_A(*s),
1797             !isSPACE_A(*s)
1798         );
1799         break;
1800     case NSPACEL:
1801         REXEC_FBC_CSCAN_TAINT(
1802             !isSPACE_LC_utf8((U8*)s),
1803             !isSPACE_LC(*s)
1804         );
1805         break;
1806     case DIGIT:
1807         REXEC_FBC_CSCAN_PRELOAD(
1808             LOAD_UTF8_CHARCLASS_DIGIT(),
1809             swash_fetch(PL_utf8_digit,(U8*)s, utf8_target),
1810             isDIGIT(*s)
1811         );
1812         break;
1813     case DIGITA:
1814         /* Don't need to worry about utf8, as it can match only a single
1815          * byte invariant character */
1816         REXEC_FBC_CLASS_SCAN( isDIGIT_A(*s));
1817         break;
1818     case DIGITL:
1819         REXEC_FBC_CSCAN_TAINT(
1820             isDIGIT_LC_utf8((U8*)s),
1821             isDIGIT_LC(*s)
1822         );
1823         break;
1824     case NDIGIT:
1825         REXEC_FBC_CSCAN_PRELOAD(
1826             LOAD_UTF8_CHARCLASS_DIGIT(),
1827             !swash_fetch(PL_utf8_digit,(U8*)s, utf8_target),
1828             !isDIGIT(*s)
1829         );
1830         break;
1831     case NDIGITA:
1832         REXEC_FBC_CSCAN(
1833             !isDIGIT_A(*s),
1834             !isDIGIT_A(*s)
1835         );
1836         break;
1837     case NDIGITL:
1838         REXEC_FBC_CSCAN_TAINT(
1839             !isDIGIT_LC_utf8((U8*)s),
1840             !isDIGIT_LC(*s)
1841         );
1842         break;
1843     case LNBREAK:
1844         REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend),
1845                         is_LNBREAK_latin1_safe(s, strend)
1846         );
1847         break;
1848     case VERTWS:
1849         REXEC_FBC_CSCAN(
1850             is_VERTWS_utf8_safe(s, strend),
1851             is_VERTWS_latin1_safe(s, strend)
1852         );
1853         break;
1854     case NVERTWS:
1855         REXEC_FBC_CSCAN(
1856             !is_VERTWS_utf8_safe(s, strend),
1857             !is_VERTWS_latin1_safe(s, strend)
1858         );
1859         break;
1860     case HORIZWS:
1861         REXEC_FBC_CSCAN(
1862             is_HORIZWS_utf8_safe(s, strend),
1863             is_HORIZWS_latin1_safe(s, strend)
1864         );
1865         break;
1866     case NHORIZWS:
1867         REXEC_FBC_CSCAN(
1868             !is_HORIZWS_utf8_safe(s, strend),
1869             !is_HORIZWS_latin1_safe(s, strend)
1870         );
1871         break;
1872     case POSIXA:
1873         /* Don't need to worry about utf8, as it can match only a single
1874         * byte invariant character.  The flag in this node type is the
1875         * class number to pass to _generic_isCC() to build a mask for
1876         * searching in PL_charclass[] */
1877         REXEC_FBC_CLASS_SCAN( _generic_isCC_A(*s, FLAGS(c)));
1878         break;
1879     case NPOSIXA:
1880         REXEC_FBC_CSCAN(
1881             !_generic_isCC_A(*s, FLAGS(c)),
1882             !_generic_isCC_A(*s, FLAGS(c))
1883         );
1884         break;
1885
1886     case AHOCORASICKC:
1887     case AHOCORASICK:
1888         {
1889             DECL_TRIE_TYPE(c);
1890             /* what trie are we using right now */
1891             reg_ac_data *aho = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1892             reg_trie_data *trie = (reg_trie_data*)progi->data->data[ aho->trie ];
1893             HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1894
1895             const char *last_start = strend - trie->minlen;
1896 #ifdef DEBUGGING
1897             const char *real_start = s;
1898 #endif
1899             STRLEN maxlen = trie->maxlen;
1900             SV *sv_points;
1901             U8 **points; /* map of where we were in the input string
1902                             when reading a given char. For ASCII this
1903                             is unnecessary overhead as the relationship
1904                             is always 1:1, but for Unicode, especially
1905                             case folded Unicode this is not true. */
1906             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1907             U8 *bitmap=NULL;
1908
1909
1910             GET_RE_DEBUG_FLAGS_DECL;
1911
1912             /* We can't just allocate points here. We need to wrap it in
1913              * an SV so it gets freed properly if there is a croak while
1914              * running the match */
1915             ENTER;
1916             SAVETMPS;
1917             sv_points=newSV(maxlen * sizeof(U8 *));
1918             SvCUR_set(sv_points,
1919                 maxlen * sizeof(U8 *));
1920             SvPOK_on(sv_points);
1921             sv_2mortal(sv_points);
1922             points=(U8**)SvPV_nolen(sv_points );
1923             if ( trie_type != trie_utf8_fold
1924                  && (trie->bitmap || OP(c)==AHOCORASICKC) )
1925             {
1926                 if (trie->bitmap)
1927                     bitmap=(U8*)trie->bitmap;
1928                 else
1929                     bitmap=(U8*)ANYOF_BITMAP(c);
1930             }
1931             /* this is the Aho-Corasick algorithm modified a touch
1932                to include special handling for long "unknown char" sequences.
1933                The basic idea being that we use AC as long as we are dealing
1934                with a possible matching char, when we encounter an unknown char
1935                (and we have not encountered an accepting state) we scan forward
1936                until we find a legal starting char.
1937                AC matching is basically that of trie matching, except that when
1938                we encounter a failing transition, we fall back to the current
1939                states "fail state", and try the current char again, a process
1940                we repeat until we reach the root state, state 1, or a legal
1941                transition. If we fail on the root state then we can either
1942                terminate if we have reached an accepting state previously, or
1943                restart the entire process from the beginning if we have not.
1944
1945              */
1946             while (s <= last_start) {
1947                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1948                 U8 *uc = (U8*)s;
1949                 U16 charid = 0;
1950                 U32 base = 1;
1951                 U32 state = 1;
1952                 UV uvc = 0;
1953                 STRLEN len = 0;
1954                 STRLEN foldlen = 0;
1955                 U8 *uscan = (U8*)NULL;
1956                 U8 *leftmost = NULL;
1957 #ifdef DEBUGGING
1958                 U32 accepted_word= 0;
1959 #endif
1960                 U32 pointpos = 0;
1961
1962                 while ( state && uc <= (U8*)strend ) {
1963                     int failed=0;
1964                     U32 word = aho->states[ state ].wordnum;
1965
1966                     if( state==1 ) {
1967                         if ( bitmap ) {
1968                             DEBUG_TRIE_EXECUTE_r(
1969                                 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1970                                     dump_exec_pos( (char *)uc, c, strend, real_start,
1971                                         (char *)uc, utf8_target );
1972                                     PerlIO_printf( Perl_debug_log,
1973                                         " Scanning for legal start char...\n");
1974                                 }
1975                             );
1976                             if (utf8_target) {
1977                                 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1978                                     uc += UTF8SKIP(uc);
1979                                 }
1980                             } else {
1981                                 while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1982                                     uc++;
1983                                 }
1984                             }
1985                             s= (char *)uc;
1986                         }
1987                         if (uc >(U8*)last_start) break;
1988                     }
1989
1990                     if ( word ) {
1991                         U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
1992                         if (!leftmost || lpos < leftmost) {
1993                             DEBUG_r(accepted_word=word);
1994                             leftmost= lpos;
1995                         }
1996                         if (base==0) break;
1997
1998                     }
1999                     points[pointpos++ % maxlen]= uc;
2000                     if (foldlen || uc < (U8*)strend) {
2001                         REXEC_TRIE_READ_CHAR(trie_type, trie,
2002                                          widecharmap, uc,
2003                                          uscan, len, uvc, charid, foldlen,
2004                                          foldbuf, uniflags);
2005                         DEBUG_TRIE_EXECUTE_r({
2006                             dump_exec_pos( (char *)uc, c, strend,
2007                                         real_start, s, utf8_target);
2008                             PerlIO_printf(Perl_debug_log,
2009                                 " Charid:%3u CP:%4"UVxf" ",
2010                                  charid, uvc);
2011                         });
2012                     }
2013                     else {
2014                         len = 0;
2015                         charid = 0;
2016                     }
2017
2018
2019                     do {
2020 #ifdef DEBUGGING
2021                         word = aho->states[ state ].wordnum;
2022 #endif
2023                         base = aho->states[ state ].trans.base;
2024
2025                         DEBUG_TRIE_EXECUTE_r({
2026                             if (failed)
2027                                 dump_exec_pos( (char *)uc, c, strend, real_start,
2028                                     s,   utf8_target );
2029                             PerlIO_printf( Perl_debug_log,
2030                                 "%sState: %4"UVxf", word=%"UVxf,
2031                                 failed ? " Fail transition to " : "",
2032                                 (UV)state, (UV)word);
2033                         });
2034                         if ( base ) {
2035                             U32 tmp;
2036                             I32 offset;
2037                             if (charid &&
2038                                  ( ((offset = base + charid
2039                                     - 1 - trie->uniquecharcount)) >= 0)
2040                                  && ((U32)offset < trie->lasttrans)
2041                                  && trie->trans[offset].check == state
2042                                  && (tmp=trie->trans[offset].next))
2043                             {
2044                                 DEBUG_TRIE_EXECUTE_r(
2045                                     PerlIO_printf( Perl_debug_log," - legal\n"));
2046                                 state = tmp;
2047                                 break;
2048                             }
2049                             else {
2050                                 DEBUG_TRIE_EXECUTE_r(
2051                                     PerlIO_printf( Perl_debug_log," - fail\n"));
2052                                 failed = 1;
2053                                 state = aho->fail[state];
2054                             }
2055                         }
2056                         else {
2057                             /* we must be accepting here */
2058                             DEBUG_TRIE_EXECUTE_r(
2059                                     PerlIO_printf( Perl_debug_log," - accepting\n"));
2060                             failed = 1;
2061                             break;
2062                         }
2063                     } while(state);
2064                     uc += len;
2065                     if (failed) {
2066                         if (leftmost)
2067                             break;
2068                         if (!state) state = 1;
2069                     }
2070                 }
2071                 if ( aho->states[ state ].wordnum ) {
2072                     U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
2073                     if (!leftmost || lpos < leftmost) {
2074                         DEBUG_r(accepted_word=aho->states[ state ].wordnum);
2075                         leftmost = lpos;
2076                     }
2077                 }
2078                 if (leftmost) {
2079                     s = (char*)leftmost;
2080                     DEBUG_TRIE_EXECUTE_r({
2081                         PerlIO_printf(
2082                             Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
2083                             (UV)accepted_word, (IV)(s - real_start)
2084                         );
2085                     });
2086                     if (!reginfo || regtry(reginfo, &s)) {
2087                         FREETMPS;
2088                         LEAVE;
2089                         goto got_it;
2090                     }
2091                     s = HOPc(s,1);
2092                     DEBUG_TRIE_EXECUTE_r({
2093                         PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
2094                     });
2095                 } else {
2096                     DEBUG_TRIE_EXECUTE_r(
2097                         PerlIO_printf( Perl_debug_log,"No match.\n"));
2098                     break;
2099                 }
2100             }
2101             FREETMPS;
2102             LEAVE;
2103         }
2104         break;
2105     default:
2106         Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
2107         break;
2108     }
2109     return 0;
2110   got_it:
2111     return s;
2112 }
2113
2114
2115 /*
2116  - regexec_flags - match a regexp against a string
2117  */
2118 I32
2119 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
2120               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
2121 /* stringarg: the point in the string at which to begin matching */
2122 /* strend:    pointer to null at end of string */
2123 /* strbeg:    real beginning of string */
2124 /* minend:    end of match must be >= minend bytes after stringarg. */
2125 /* sv:        SV being matched: only used for utf8 flag, pos() etc; string
2126  *            itself is accessed via the pointers above */
2127 /* data:      May be used for some additional optimizations.
2128               Currently its only used, with a U32 cast, for transmitting
2129               the ganch offset when doing a /g match. This will change */
2130 /* nosave:    For optimizations. */
2131
2132 {
2133     dVAR;
2134     struct regexp *const prog = ReANY(rx);
2135     char *s;
2136     regnode *c;
2137     char *startpos = stringarg;
2138     I32 minlen;         /* must match at least this many chars */
2139     I32 dontbother = 0; /* how many characters not to try at end */
2140     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
2141     I32 scream_pos = -1;                /* Internal iterator of scream. */
2142     char *scream_olds = NULL;
2143     const bool utf8_target = cBOOL(DO_UTF8(sv));
2144     I32 multiline;
2145     RXi_GET_DECL(prog,progi);
2146     regmatch_info reginfo;  /* create some info to pass to regtry etc */
2147     regexp_paren_pair *swap = NULL;
2148     GET_RE_DEBUG_FLAGS_DECL;
2149
2150     PERL_ARGS_ASSERT_REGEXEC_FLAGS;
2151     PERL_UNUSED_ARG(data);
2152
2153     /* Be paranoid... */
2154     if (prog == NULL || startpos == NULL) {
2155         Perl_croak(aTHX_ "NULL regexp parameter");
2156         return 0;
2157     }
2158
2159     multiline = prog->extflags & RXf_PMf_MULTILINE;
2160     reginfo.prog = rx;   /* Yes, sorry that this is confusing.  */
2161
2162     RX_MATCH_UTF8_set(rx, utf8_target);
2163     DEBUG_EXECUTE_r(
2164         debug_start_match(rx, utf8_target, startpos, strend,
2165         "Matching");
2166     );
2167
2168     minlen = prog->minlen;
2169
2170     if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
2171         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2172                               "String too short [regexec_flags]...\n"));
2173         goto phooey;
2174     }
2175
2176
2177     /* Check validity of program. */
2178     if (UCHARAT(progi->program) != REG_MAGIC) {
2179         Perl_croak(aTHX_ "corrupted regexp program");
2180     }
2181
2182     PL_reg_flags = 0;
2183     PL_reg_state.re_state_eval_setup_done = FALSE;
2184     PL_reg_maxiter = 0;
2185
2186     if (RX_UTF8(rx))
2187         PL_reg_flags |= RF_utf8;
2188
2189     /* Mark beginning of line for ^ and lookbehind. */
2190     reginfo.bol = startpos; /* XXX not used ??? */
2191     PL_bostr  = strbeg;
2192     reginfo.sv = sv;
2193
2194     /* Mark end of line for $ (and such) */
2195     PL_regeol = strend;
2196
2197     /* see how far we have to get to not match where we matched before */
2198     reginfo.till = startpos+minend;
2199
2200     /* If there is a "must appear" string, look for it. */
2201     s = startpos;
2202
2203     if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
2204         MAGIC *mg;
2205         if (flags & REXEC_IGNOREPOS){   /* Means: check only at start */
2206             reginfo.ganch = startpos + prog->gofs;
2207             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2208               "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
2209         } else if (sv && SvTYPE(sv) >= SVt_PVMG
2210                   && SvMAGIC(sv)
2211                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
2212                   && mg->mg_len >= 0) {
2213             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
2214             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2215                 "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
2216
2217             if (prog->extflags & RXf_ANCH_GPOS) {
2218                 if (s > reginfo.ganch)
2219                     goto phooey;
2220                 s = reginfo.ganch - prog->gofs;
2221                 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2222                      "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
2223                 if (s < strbeg)
2224                     goto phooey;
2225             }
2226         }
2227         else if (data) {
2228             reginfo.ganch = strbeg + PTR2UV(data);
2229             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2230                  "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
2231
2232         } else {                                /* pos() not defined */
2233             reginfo.ganch = strbeg;
2234             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2235                  "GPOS: reginfo.ganch = strbeg\n"));
2236         }
2237     }
2238     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
2239         /* We have to be careful. If the previous successful match
2240            was from this regex we don't want a subsequent partially
2241            successful match to clobber the old results.
2242            So when we detect this possibility we add a swap buffer
2243            to the re, and switch the buffer each match. If we fail
2244            we switch it back, otherwise we leave it swapped.
2245         */
2246         swap = prog->offs;
2247         /* do we need a save destructor here for eval dies? */
2248         Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
2249         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
2250             "rex=0x%"UVxf" saving  offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
2251             PTR2UV(prog),
2252             PTR2UV(swap),
2253             PTR2UV(prog->offs)
2254         ));
2255     }
2256     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
2257         re_scream_pos_data d;
2258
2259         d.scream_olds = &scream_olds;
2260         d.scream_pos = &scream_pos;
2261         s = re_intuit_start(rx, sv, s, strend, flags, &d);
2262         if (!s) {
2263             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
2264             goto phooey;        /* not present */
2265         }
2266     }
2267
2268
2269
2270     /* Simplest case:  anchored match need be tried only once. */
2271     /*  [unless only anchor is BOL and multiline is set] */
2272     if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
2273         if (s == startpos && regtry(&reginfo, &startpos))
2274             goto got_it;
2275         else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2276                  || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
2277         {
2278             char *end;
2279
2280             if (minlen)
2281                 dontbother = minlen - 1;
2282             end = HOP3c(strend, -dontbother, strbeg) - 1;
2283             /* for multiline we only have to try after newlines */
2284             if (prog->check_substr || prog->check_utf8) {
2285                 /* because of the goto we can not easily reuse the macros for bifurcating the
2286                    unicode/non-unicode match modes here like we do elsewhere - demerphq */
2287                 if (utf8_target) {
2288                     if (s == startpos)
2289                         goto after_try_utf8;
2290                     while (1) {
2291                         if (regtry(&reginfo, &s)) {
2292                             goto got_it;
2293                         }
2294                       after_try_utf8:
2295                         if (s > end) {
2296                             goto phooey;
2297                         }
2298                         if (prog->extflags & RXf_USE_INTUIT) {
2299                             s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL);
2300                             if (!s) {
2301                                 goto phooey;
2302                             }
2303                         }
2304                         else {
2305                             s += UTF8SKIP(s);
2306                         }
2307                     }
2308                 } /* end search for check string in unicode */
2309                 else {
2310                     if (s == startpos) {
2311                         goto after_try_latin;
2312                     }
2313                     while (1) {
2314                         if (regtry(&reginfo, &s)) {
2315                             goto got_it;
2316                         }
2317                       after_try_latin:
2318                         if (s > end) {
2319                             goto phooey;
2320                         }
2321                         if (prog->extflags & RXf_USE_INTUIT) {
2322                             s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2323                             if (!s) {
2324                                 goto phooey;
2325                             }
2326                         }
2327                         else {
2328                             s++;
2329                         }
2330                     }
2331                 } /* end search for check string in latin*/
2332             } /* end search for check string */
2333             else { /* search for newline */
2334                 if (s > startpos) {
2335                     /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
2336                     s--;
2337                 }
2338                 /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
2339                 while (s <= end) { /* note it could be possible to match at the end of the string */
2340                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
2341                         if (regtry(&reginfo, &s))
2342                             goto got_it;
2343                     }
2344                 }
2345             } /* end search for newline */
2346         } /* end anchored/multiline check string search */
2347         goto phooey;
2348     } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
2349     {
2350         /* the warning about reginfo.ganch being used without initialization
2351            is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
2352            and we only enter this block when the same bit is set. */
2353         char *tmp_s = reginfo.ganch - prog->gofs;
2354
2355         if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
2356             goto got_it;
2357         goto phooey;
2358     }
2359
2360     /* Messy cases:  unanchored match. */
2361     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2362         /* we have /x+whatever/ */
2363         /* it must be a one character string (XXXX Except UTF_PATTERN?) */
2364         char ch;
2365 #ifdef DEBUGGING
2366         int did_match = 0;
2367 #endif
2368         if (utf8_target) {
2369             if (! prog->anchored_utf8) {
2370                 to_utf8_substr(prog);
2371             }
2372             ch = SvPVX_const(prog->anchored_utf8)[0];
2373             REXEC_FBC_SCAN(
2374                 if (*s == ch) {
2375                     DEBUG_EXECUTE_r( did_match = 1 );
2376                     if (regtry(&reginfo, &s)) goto got_it;
2377                     s += UTF8SKIP(s);
2378                     while (s < strend && *s == ch)
2379                         s += UTF8SKIP(s);
2380                 }
2381             );
2382
2383         }
2384         else {
2385             if (! prog->anchored_substr) {
2386                 if (! to_byte_substr(prog)) {
2387                     NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2388                 }
2389             }
2390             ch = SvPVX_const(prog->anchored_substr)[0];
2391             REXEC_FBC_SCAN(
2392                 if (*s == ch) {
2393                     DEBUG_EXECUTE_r( did_match = 1 );
2394                     if (regtry(&reginfo, &s)) goto got_it;
2395                     s++;
2396                     while (s < strend && *s == ch)
2397                         s++;
2398                 }
2399             );
2400         }
2401         DEBUG_EXECUTE_r(if (!did_match)
2402                 PerlIO_printf(Perl_debug_log,
2403                                   "Did not find anchored character...\n")
2404                );
2405     }
2406     else if (prog->anchored_substr != NULL
2407               || prog->anchored_utf8 != NULL
2408               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2409                   && prog->float_max_offset < strend - s)) {
2410         SV *must;
2411         I32 back_max;
2412         I32 back_min;
2413         char *last;
2414         char *last1;            /* Last position checked before */
2415 #ifdef DEBUGGING
2416         int did_match = 0;
2417 #endif
2418         if (prog->anchored_substr || prog->anchored_utf8) {
2419             if (utf8_target) {
2420                 if (! prog->anchored_utf8) {
2421                     to_utf8_substr(prog);
2422                 }
2423                 must = prog->anchored_utf8;
2424             }
2425             else {
2426                 if (! prog->anchored_substr) {
2427                     if (! to_byte_substr(prog)) {
2428                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2429                     }
2430                 }
2431                 must = prog->anchored_substr;
2432             }
2433             back_max = back_min = prog->anchored_offset;
2434         } else {
2435             if (utf8_target) {
2436                 if (! prog->float_utf8) {
2437                     to_utf8_substr(prog);
2438                 }
2439                 must = prog->float_utf8;
2440             }
2441             else {
2442                 if (! prog->float_substr) {
2443                     if (! to_byte_substr(prog)) {
2444                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2445                     }
2446                 }
2447                 must = prog->float_substr;
2448             }
2449             back_max = prog->float_max_offset;
2450             back_min = prog->float_min_offset;
2451         }
2452
2453         if (back_min<0) {
2454             last = strend;
2455         } else {
2456             last = HOP3c(strend,        /* Cannot start after this */
2457                   -(I32)(CHR_SVLEN(must)
2458                          - (SvTAIL(must) != 0) + back_min), strbeg);
2459         }
2460         if (s > PL_bostr)
2461             last1 = HOPc(s, -1);
2462         else
2463             last1 = s - 1;      /* bogus */
2464
2465         /* XXXX check_substr already used to find "s", can optimize if
2466            check_substr==must. */
2467         scream_pos = -1;
2468         dontbother = end_shift;
2469         strend = HOPc(strend, -dontbother);
2470         while ( (s <= last) &&
2471                 (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2472                                   (unsigned char*)strend, must,
2473                                   multiline ? FBMrf_MULTILINE : 0)) ) {
2474             DEBUG_EXECUTE_r( did_match = 1 );
2475             if (HOPc(s, -back_max) > last1) {
2476                 last1 = HOPc(s, -back_min);
2477                 s = HOPc(s, -back_max);
2478             }
2479             else {
2480                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2481
2482                 last1 = HOPc(s, -back_min);
2483                 s = t;
2484             }
2485             if (utf8_target) {
2486                 while (s <= last1) {
2487                     if (regtry(&reginfo, &s))
2488                         goto got_it;
2489                     if (s >= last1) {
2490                         s++; /* to break out of outer loop */
2491                         break;
2492                     }
2493                     s += UTF8SKIP(s);
2494                 }
2495             }
2496             else {
2497                 while (s <= last1) {
2498                     if (regtry(&reginfo, &s))
2499                         goto got_it;
2500                     s++;
2501                 }
2502             }
2503         }
2504         DEBUG_EXECUTE_r(if (!did_match) {
2505             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
2506                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2507             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2508                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2509                                ? "anchored" : "floating"),
2510                 quoted, RE_SV_TAIL(must));
2511         });
2512         goto phooey;
2513     }
2514     else if ( (c = progi->regstclass) ) {
2515         if (minlen) {
2516             const OPCODE op = OP(progi->regstclass);
2517             /* don't bother with what can't match */
2518             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2519                 strend = HOPc(strend, -(minlen - 1));
2520         }
2521         DEBUG_EXECUTE_r({
2522             SV * const prop = sv_newmortal();
2523             regprop(prog, prop, c);
2524             {
2525                 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
2526                     s,strend-s,60);
2527                 PerlIO_printf(Perl_debug_log,
2528                     "Matching stclass %.*s against %s (%d bytes)\n",
2529                     (int)SvCUR(prop), SvPVX_const(prop),
2530                      quoted, (int)(strend - s));
2531             }
2532         });
2533         if (find_byclass(prog, c, s, strend, &reginfo))
2534             goto got_it;
2535         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2536     }
2537     else {
2538         dontbother = 0;
2539         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2540             /* Trim the end. */
2541             char *last= NULL;
2542             SV* float_real;
2543             STRLEN len;
2544             const char *little;
2545
2546             if (utf8_target) {
2547                 if (! prog->float_utf8) {
2548                     to_utf8_substr(prog);
2549                 }
2550                 float_real = prog->float_utf8;
2551             }
2552             else {
2553                 if (! prog->float_substr) {
2554                     if (! to_byte_substr(prog)) {
2555                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2556                     }
2557                 }
2558                 float_real = prog->float_substr;
2559             }
2560
2561             little = SvPV_const(float_real, len);
2562             if (SvTAIL(float_real)) {
2563                     /* This means that float_real contains an artificial \n on
2564                      * the end due to the presence of something like this:
2565                      * /foo$/ where we can match both "foo" and "foo\n" at the
2566                      * end of the string.  So we have to compare the end of the
2567                      * string first against the float_real without the \n and
2568                      * then against the full float_real with the string.  We
2569                      * have to watch out for cases where the string might be
2570                      * smaller than the float_real or the float_real without
2571                      * the \n. */
2572                     char *checkpos= strend - len;
2573                     DEBUG_OPTIMISE_r(
2574                         PerlIO_printf(Perl_debug_log,
2575                             "%sChecking for float_real.%s\n",
2576                             PL_colors[4], PL_colors[5]));
2577                     if (checkpos + 1 < strbeg) {
2578                         /* can't match, even if we remove the trailing \n
2579                          * string is too short to match */
2580                         DEBUG_EXECUTE_r(
2581                             PerlIO_printf(Perl_debug_log,
2582                                 "%sString shorter than required trailing substring, cannot match.%s\n",
2583                                 PL_colors[4], PL_colors[5]));
2584                         goto phooey;
2585                     } else if (memEQ(checkpos + 1, little, len - 1)) {
2586                         /* can match, the end of the string matches without the
2587                          * "\n" */
2588                         last = checkpos + 1;
2589                     } else if (checkpos < strbeg) {
2590                         /* cant match, string is too short when the "\n" is
2591                          * included */
2592                         DEBUG_EXECUTE_r(
2593                             PerlIO_printf(Perl_debug_log,
2594                                 "%sString does not contain required trailing substring, cannot match.%s\n",
2595                                 PL_colors[4], PL_colors[5]));
2596                         goto phooey;
2597                     } else if (!multiline) {
2598                         /* non multiline match, so compare with the "\n" at the
2599                          * end of the string */
2600                         if (memEQ(checkpos, little, len)) {
2601                             last= checkpos;
2602                         } else {
2603                             DEBUG_EXECUTE_r(
2604                                 PerlIO_printf(Perl_debug_log,
2605                                     "%sString does not contain required trailing substring, cannot match.%s\n",
2606                                     PL_colors[4], PL_colors[5]));
2607                             goto phooey;
2608                         }
2609                     } else {
2610                         /* multiline match, so we have to search for a place
2611                          * where the full string is located */
2612                         goto find_last;
2613                     }
2614             } else {
2615                   find_last:
2616                     if (len)
2617                         last = rninstr(s, strend, little, little + len);
2618                     else
2619                         last = strend;  /* matching "$" */
2620             }
2621             if (!last) {
2622                 /* at one point this block contained a comment which was
2623                  * probably incorrect, which said that this was a "should not
2624                  * happen" case.  Even if it was true when it was written I am
2625                  * pretty sure it is not anymore, so I have removed the comment
2626                  * and replaced it with this one. Yves */
2627                 DEBUG_EXECUTE_r(
2628                     PerlIO_printf(Perl_debug_log,
2629                         "String does not contain required substring, cannot match.\n"
2630                     ));
2631                 goto phooey;
2632             }
2633             dontbother = strend - last + prog->float_min_offset;
2634         }
2635         if (minlen && (dontbother < minlen))
2636             dontbother = minlen - 1;
2637         strend -= dontbother;              /* this one's always in bytes! */
2638         /* We don't know much -- general case. */
2639         if (utf8_target) {
2640             for (;;) {
2641                 if (regtry(&reginfo, &s))
2642                     goto got_it;
2643                 if (s >= strend)
2644                     break;
2645                 s += UTF8SKIP(s);
2646             };
2647         }
2648         else {
2649             do {
2650                 if (regtry(&reginfo, &s))
2651                     goto got_it;
2652             } while (s++ < strend);
2653         }
2654     }
2655
2656     /* Failure. */
2657     goto phooey;
2658
2659 got_it:
2660     DEBUG_BUFFERS_r(
2661         if (swap)
2662             PerlIO_printf(Perl_debug_log,
2663                 "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
2664                 PTR2UV(prog),
2665                 PTR2UV(swap)
2666             );
2667     );
2668     Safefree(swap);
2669     RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2670
2671     if (PL_reg_state.re_state_eval_setup_done)
2672         restore_pos(aTHX_ prog);
2673     if (RXp_PAREN_NAMES(prog))
2674         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2675
2676     /* make sure $`, $&, $', and $digit will work later */
2677     if ( !(flags & REXEC_NOT_FIRST) ) {
2678         if (flags & REXEC_COPY_STR) {
2679 #ifdef PERL_ANY_COW
2680             if (SvCANCOW(sv)) {
2681                 if (DEBUG_C_TEST) {
2682                     PerlIO_printf(Perl_debug_log,
2683                                   "Copy on write: regexp capture, type %d\n",
2684                                   (int) SvTYPE(sv));
2685                 }
2686                 RX_MATCH_COPY_FREE(rx);
2687                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2688                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2689                 assert (SvPOKp(prog->saved_copy));
2690                 prog->sublen  = PL_regeol - strbeg;
2691                 prog->suboffset = 0;
2692                 prog->subcoffset = 0;
2693             } else
2694 #endif
2695             {
2696                 I32 min = 0;
2697                 I32 max = PL_regeol - strbeg;
2698                 I32 sublen;
2699
2700                 if (    (flags & REXEC_COPY_SKIP_POST)
2701                     && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
2702                     && !(PL_sawampersand & SAWAMPERSAND_RIGHT)
2703                 ) { /* don't copy $' part of string */
2704                     U32 n = 0;
2705                     max = -1;
2706                     /* calculate the right-most part of the string covered
2707                      * by a capture. Due to look-ahead, this may be to
2708                      * the right of $&, so we have to scan all captures */
2709                     while (n <= prog->lastparen) {
2710                         if (prog->offs[n].end > max)
2711                             max = prog->offs[n].end;
2712                         n++;
2713                     }
2714                     if (max == -1)
2715                         max = (PL_sawampersand & SAWAMPERSAND_LEFT)
2716                                 ? prog->offs[0].start
2717                                 : 0;
2718                     assert(max >= 0 && max <= PL_regeol - strbeg);
2719                 }
2720
2721                 if (    (flags & REXEC_COPY_SKIP_PRE)
2722                     && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) /* //p */
2723                     && !(PL_sawampersand & SAWAMPERSAND_LEFT)
2724                 ) { /* don't copy $` part of string */
2725                     U32 n = 0;
2726                     min = max;
2727                     /* calculate the left-most part of the string covered
2728                      * by a capture. Due to look-behind, this may be to
2729                      * the left of $&, so we have to scan all captures */
2730                     while (min && n <= prog->lastparen) {
2731                         if (   prog->offs[n].start != -1
2732                             && prog->offs[n].start < min)
2733                         {
2734                             min = prog->offs[n].start;
2735                         }
2736                         n++;
2737                     }
2738                     if ((PL_sawampersand & SAWAMPERSAND_RIGHT)
2739                         && min >  prog->offs[0].end
2740                     )
2741                         min = prog->offs[0].end;
2742
2743                 }
2744
2745                 assert(min >= 0 && min <= max && min <= PL_regeol - strbeg);
2746                 sublen = max - min;
2747
2748                 if (RX_MATCH_COPIED(rx)) {
2749                     if (sublen > prog->sublen)
2750                         prog->subbeg =
2751                                 (char*)saferealloc(prog->subbeg, sublen+1);
2752                 }
2753                 else
2754                     prog->subbeg = (char*)safemalloc(sublen+1);
2755                 Copy(strbeg + min, prog->subbeg, sublen, char);
2756                 prog->subbeg[sublen] = '\0';
2757                 prog->suboffset = min;
2758                 prog->sublen = sublen;
2759                 RX_MATCH_COPIED_on(rx);
2760             }
2761             prog->subcoffset = prog->suboffset;
2762             if (prog->suboffset && utf8_target) {
2763                 /* Convert byte offset to chars.
2764                  * XXX ideally should only compute this if @-/@+
2765                  * has been seen, a la PL_sawampersand ??? */
2766
2767                 /* If there's a direct correspondence between the
2768                  * string which we're matching and the original SV,
2769                  * then we can use the utf8 len cache associated with
2770                  * the SV. In particular, it means that under //g,
2771                  * sv_pos_b2u() will use the previously cached
2772                  * position to speed up working out the new length of
2773                  * subcoffset, rather than counting from the start of
2774                  * the string each time. This stops
2775                  *   $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g;
2776                  * from going quadratic */
2777                 if (SvPOKp(sv) && SvPVX(sv) == strbeg)
2778                     sv_pos_b2u(sv, &(prog->subcoffset));
2779                 else
2780                     prog->subcoffset = utf8_length((U8*)strbeg,
2781                                         (U8*)(strbeg+prog->suboffset));
2782             }
2783         }
2784         else {
2785             RX_MATCH_COPY_FREE(rx);
2786             prog->subbeg = strbeg;
2787             prog->suboffset = 0;
2788             prog->subcoffset = 0;
2789             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2790         }
2791     }
2792
2793     return 1;
2794
2795 phooey:
2796     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2797                           PL_colors[4], PL_colors[5]));
2798     if (PL_reg_state.re_state_eval_setup_done)
2799         restore_pos(aTHX_ prog);
2800     if (swap) {
2801         /* we failed :-( roll it back */
2802         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
2803             "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
2804             PTR2UV(prog),
2805             PTR2UV(prog->offs),
2806             PTR2UV(swap)
2807         ));
2808         Safefree(prog->offs);
2809         prog->offs = swap;
2810     }
2811     return 0;
2812 }
2813
2814
2815 /* Set which rex is pointed to by PL_reg_state, handling ref counting.
2816  * Do inc before dec, in case old and new rex are the same */
2817 #define SET_reg_curpm(Re2) \
2818     if (PL_reg_state.re_state_eval_setup_done) {    \
2819         (void)ReREFCNT_inc(Re2);                    \
2820         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));       \
2821         PM_SETRE((PL_reg_curpm), (Re2));            \
2822     }
2823
2824
2825 /*
2826  - regtry - try match at specific point
2827  */
2828 STATIC I32                      /* 0 failure, 1 success */
2829 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
2830 {
2831     dVAR;
2832     CHECKPOINT lastcp;
2833     REGEXP *const rx = reginfo->prog;
2834     regexp *const prog = ReANY(rx);
2835     I32 result;
2836     RXi_GET_DECL(prog,progi);
2837     GET_RE_DEBUG_FLAGS_DECL;
2838
2839     PERL_ARGS_ASSERT_REGTRY;
2840
2841     reginfo->cutpoint=NULL;
2842
2843     if ((prog->extflags & RXf_EVAL_SEEN)
2844         && !PL_reg_state.re_state_eval_setup_done)
2845     {
2846         MAGIC *mg;
2847
2848         PL_reg_state.re_state_eval_setup_done = TRUE;
2849         if (reginfo->sv) {
2850             /* Make $_ available to executed code. */
2851             if (reginfo->sv != DEFSV) {
2852                 SAVE_DEFSV;
2853                 DEFSV_set(reginfo->sv);
2854             }
2855
2856             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2857                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2858                 /* prepare for quick setting of pos */
2859 #ifdef PERL_OLD_COPY_ON_WRITE
2860                 if (SvIsCOW(reginfo->sv))
2861                     sv_force_normal_flags(reginfo->sv, 0);
2862 #endif
2863                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2864                                  &PL_vtbl_mglob, NULL, 0);
2865                 mg->mg_len = -1;
2866             }
2867             PL_reg_magic    = mg;
2868             PL_reg_oldpos   = mg->mg_len;
2869             SAVEDESTRUCTOR_X(restore_pos, prog);
2870         }
2871         if (!PL_reg_curpm) {
2872             Newxz(PL_reg_curpm, 1, PMOP);
2873 #ifdef USE_ITHREADS
2874             {
2875                 SV* const repointer = &PL_sv_undef;
2876                 /* this regexp is also owned by the new PL_reg_curpm, which
2877                    will try to free it.  */
2878                 av_push(PL_regex_padav, repointer);
2879                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2880                 PL_regex_pad = AvARRAY(PL_regex_padav);
2881             }
2882 #endif
2883         }
2884         SET_reg_curpm(rx);
2885         PL_reg_oldcurpm = PL_curpm;
2886         PL_curpm = PL_reg_curpm;
2887         if (RXp_MATCH_COPIED(prog)) {
2888             /*  Here is a serious problem: we cannot rewrite subbeg,
2889                 since it may be needed if this match fails.  Thus
2890                 $` inside (?{}) could fail... */
2891             PL_reg_oldsaved = prog->subbeg;
2892             PL_reg_oldsavedlen = prog->sublen;
2893             PL_reg_oldsavedoffset = prog->suboffset;
2894             PL_reg_oldsavedcoffset = prog->suboffset;
2895 #ifdef PERL_ANY_COW
2896             PL_nrs = prog->saved_copy;
2897 #endif
2898             RXp_MATCH_COPIED_off(prog);
2899         }
2900         else
2901             PL_reg_oldsaved = NULL;
2902         prog->subbeg = PL_bostr;
2903         prog->suboffset = 0;
2904         prog->subcoffset = 0;
2905         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2906     }
2907 #ifdef DEBUGGING
2908     PL_reg_starttry = *startposp;
2909 #endif
2910     prog->offs[0].start = *startposp - PL_bostr;
2911     prog->lastparen = 0;
2912     prog->lastcloseparen = 0;
2913     PL_regsize = 0;
2914
2915     /* XXXX What this code is doing here?!!!  There should be no need
2916        to do this again and again, prog->lastparen should take care of
2917        this!  --ilya*/
2918
2919     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2920      * Actually, the code in regcppop() (which Ilya may be meaning by
2921      * prog->lastparen), is not needed at all by the test suite
2922      * (op/regexp, op/pat, op/split), but that code is needed otherwise
2923      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2924      * Meanwhile, this code *is* needed for the
2925      * above-mentioned test suite tests to succeed.  The common theme
2926      * on those tests seems to be returning null fields from matches.
2927      * --jhi updated by dapm */
2928 #if 1
2929     if (prog->nparens) {
2930         regexp_paren_pair *pp = prog->offs;
2931         I32 i;
2932         for (i = prog->nparens; i > (I32)prog->lastparen; i--) {
2933             ++pp;
2934             pp->start = -1;
2935             pp->end = -1;
2936         }
2937     }
2938 #endif
2939     REGCP_SET(lastcp);
2940     result = regmatch(reginfo, *startposp, progi->program + 1);
2941     if (result != -1) {
2942         prog->offs[0].end = result;
2943         return 1;
2944     }
2945     if (reginfo->cutpoint)
2946         *startposp= reginfo->cutpoint;
2947     REGCP_UNWIND(lastcp);
2948     return 0;
2949 }
2950
2951
2952 #define sayYES goto yes
2953 #define sayNO goto no
2954 #define sayNO_SILENT goto no_silent
2955
2956 /* we dont use STMT_START/END here because it leads to
2957    "unreachable code" warnings, which are bogus, but distracting. */
2958 #define CACHEsayNO \
2959     if (ST.cache_mask) \
2960        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2961     sayNO
2962
2963 /* this is used to determine how far from the left messages like
2964    'failed...' are printed. It should be set such that messages
2965    are inline with the regop output that created them.
2966 */
2967 #define REPORT_CODE_OFF 32
2968
2969
2970 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2971 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2972 #define CHRTEST_NOT_A_CP_1 -999
2973 #define CHRTEST_NOT_A_CP_2 -998
2974
2975 #define SLAB_FIRST(s) (&(s)->states[0])
2976 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2977
2978 /* grab a new slab and return the first slot in it */
2979
2980 STATIC regmatch_state *
2981 S_push_slab(pTHX)
2982 {
2983 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2984     dMY_CXT;
2985 #endif
2986     regmatch_slab *s = PL_regmatch_slab->next;
2987     if (!s) {
2988         Newx(s, 1, regmatch_slab);
2989         s->prev = PL_regmatch_slab;
2990         s->next = NULL;
2991         PL_regmatch_slab->next = s;
2992     }
2993     PL_regmatch_slab = s;
2994     return SLAB_FIRST(s);
2995 }
2996
2997
2998 /* push a new state then goto it */
2999
3000 #define PUSH_STATE_GOTO(state, node, input) \
3001     pushinput = input; \
3002     scan = node; \
3003     st->resume_state = state; \
3004     goto push_state;
3005
3006 /* push a new state with success backtracking, then goto it */
3007
3008 #define PUSH_YES_STATE_GOTO(state, node, input) \
3009     pushinput = input; \
3010     scan = node; \
3011     st->resume_state = state; \
3012     goto push_yes_state;
3013
3014
3015
3016
3017 /*
3018
3019 regmatch() - main matching routine
3020
3021 This is basically one big switch statement in a loop. We execute an op,
3022 set 'next' to point the next op, and continue. If we come to a point which
3023 we may need to backtrack to on failure such as (A|B|C), we push a
3024 backtrack state onto the backtrack stack. On failure, we pop the top
3025 state, and re-enter the loop at the state indicated. If there are no more
3026 states to pop, we return failure.
3027
3028 Sometimes we also need to backtrack on success; for example /A+/, where
3029 after successfully matching one A, we need to go back and try to
3030 match another one; similarly for lookahead assertions: if the assertion
3031 completes successfully, we backtrack to the state just before the assertion
3032 and then carry on.  In these cases, the pushed state is marked as
3033 'backtrack on success too'. This marking is in fact done by a chain of
3034 pointers, each pointing to the previous 'yes' state. On success, we pop to
3035 the nearest yes state, discarding any intermediate failure-only states.
3036 Sometimes a yes state is pushed just to force some cleanup code to be
3037 called at the end of a successful match or submatch; e.g. (??{$re}) uses
3038 it to free the inner regex.
3039
3040 Note that failure backtracking rewinds the cursor position, while
3041 success backtracking leaves it alone.
3042
3043 A pattern is complete when the END op is executed, while a subpattern
3044 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
3045 ops trigger the "pop to last yes state if any, otherwise return true"
3046 behaviour.
3047
3048 A common convention in this function is to use A and B to refer to the two
3049 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
3050 the subpattern to be matched possibly multiple times, while B is the entire
3051 rest of the pattern. Variable and state names reflect this convention.
3052
3053 The states in the main switch are the union of ops and failure/success of
3054 substates associated with with that op.  For example, IFMATCH is the op
3055 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
3056 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
3057 successfully matched A and IFMATCH_A_fail is a state saying that we have
3058 just failed to match A. Resume states always come in pairs. The backtrack
3059 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
3060 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
3061 on success or failure.
3062
3063 The struct that holds a backtracking state is actually a big union, with
3064 one variant for each major type of op. The variable st points to the
3065 top-most backtrack struct. To make the code clearer, within each
3066 block of code we #define ST to alias the relevant union.
3067
3068 Here's a concrete example of a (vastly oversimplified) IFMATCH
3069 implementation:
3070
3071     switch (state) {
3072     ....
3073
3074 #define ST st->u.ifmatch
3075
3076     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3077         ST.foo = ...; // some state we wish to save
3078         ...
3079         // push a yes backtrack state with a resume value of
3080         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
3081         // first node of A:
3082         PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput);
3083         // NOTREACHED
3084
3085     case IFMATCH_A: // we have successfully executed A; now continue with B
3086         next = B;
3087         bar = ST.foo; // do something with the preserved value
3088         break;
3089
3090     case IFMATCH_A_fail: // A failed, so the assertion failed
3091         ...;   // do some housekeeping, then ...
3092         sayNO; // propagate the failure
3093
3094 #undef ST
3095
3096     ...
3097     }
3098
3099 For any old-timers reading this who are familiar with the old recursive
3100 approach, the code above is equivalent to:
3101
3102     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3103     {
3104         int foo = ...
3105         ...
3106         if (regmatch(A)) {
3107             next = B;
3108             bar = foo;
3109             break;
3110         }
3111         ...;   // do some housekeeping, then ...
3112         sayNO; // propagate the failure
3113     }
3114
3115 The topmost backtrack state, pointed to by st, is usually free. If you
3116 want to claim it, populate any ST.foo fields in it with values you wish to
3117 save, then do one of
3118
3119         PUSH_STATE_GOTO(resume_state, node, newinput);
3120         PUSH_YES_STATE_GOTO(resume_state, node, newinput);
3121
3122 which sets that backtrack state's resume value to 'resume_state', pushes a
3123 new free entry to the top of the backtrack stack, then goes to 'node'.
3124 On backtracking, the free slot is popped, and the saved state becomes the
3125 new free state. An ST.foo field in this new top state can be temporarily
3126 accessed to retrieve values, but once the main loop is re-entered, it
3127 becomes available for reuse.
3128
3129 Note that the depth of the backtrack stack constantly increases during the
3130 left-to-right execution of the pattern, rather than going up and down with
3131 the pattern nesting. For example the stack is at its maximum at Z at the
3132 end of the pattern, rather than at X in the following:
3133
3134     /(((X)+)+)+....(Y)+....Z/
3135
3136 The only exceptions to this are lookahead/behind assertions and the cut,
3137 (?>A), which pop all the backtrack states associated with A before
3138 continuing.
3139
3140 Backtrack state structs are allocated in slabs of about 4K in size.
3141 PL_regmatch_state and st always point to the currently active state,
3142 and PL_regmatch_slab points to the slab currently containing
3143 PL_regmatch_state.  The first time regmatch() is called, the first slab is
3144 allocated, and is never freed until interpreter destruction. When the slab
3145 is full, a new one is allocated and chained to the end. At exit from
3146 regmatch(), slabs allocated since entry are freed.
3147
3148 */
3149
3150
3151 #define DEBUG_STATE_pp(pp)                                  \
3152     DEBUG_STATE_r({                                         \
3153         DUMP_EXEC_POS(locinput, scan, utf8_target);                 \
3154         PerlIO_printf(Perl_debug_log,                       \
3155             "    %*s"pp" %s%s%s%s%s\n",                     \
3156             depth*2, "",                                    \
3157             PL_reg_name[st->resume_state],                     \
3158             ((st==yes_state||st==mark_state) ? "[" : ""),   \
3159             ((st==yes_state) ? "Y" : ""),                   \
3160             ((st==mark_state) ? "M" : ""),                  \
3161             ((st==yes_state||st==mark_state) ? "]" : "")    \
3162         );                                                  \
3163     });
3164
3165
3166 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
3167
3168 #ifdef DEBUGGING
3169
3170 STATIC void
3171 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
3172     const char *start, const char *end, const char *blurb)
3173 {
3174     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
3175
3176     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
3177
3178     if (!PL_colorset)
3179             reginitcolors();
3180     {
3181         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
3182             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
3183
3184         RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
3185             start, end - start, 60);
3186
3187         PerlIO_printf(Perl_debug_log,
3188             "%s%s REx%s %s against %s\n",
3189                        PL_colors[4], blurb, PL_colors[5], s0, s1);
3190
3191         if (utf8_target||utf8_pat)
3192             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
3193                 utf8_pat ? "pattern" : "",
3194                 utf8_pat && utf8_target ? " and " : "",
3195                 utf8_target ? "string" : ""
3196             );
3197     }
3198 }
3199
3200 STATIC void
3201 S_dump_exec_pos(pTHX_ const char *locinput,
3202                       const regnode *scan,
3203                       const char *loc_regeol,
3204                       const char *loc_bostr,
3205                       const char *loc_reg_starttry,
3206                       const bool utf8_target)
3207 {
3208     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
3209     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
3210     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
3211     /* The part of the string before starttry has one color
3212        (pref0_len chars), between starttry and current
3213        position another one (pref_len - pref0_len chars),
3214        after the current position the third one.
3215        We assume that pref0_len <= pref_len, otherwise we
3216        decrease pref0_len.  */
3217     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
3218         ? (5 + taill) - l : locinput - loc_bostr;
3219     int pref0_len;
3220
3221     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
3222
3223     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
3224         pref_len++;
3225     pref0_len = pref_len  - (locinput - loc_reg_starttry);
3226     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
3227         l = ( loc_regeol - locinput > (5 + taill) - pref_len
3228               ? (5 + taill) - pref_len : loc_regeol - locinput);
3229     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
3230         l--;
3231     if (pref0_len < 0)
3232         pref0_len = 0;
3233     if (pref0_len > pref_len)
3234         pref0_len = pref_len;
3235     {
3236         const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
3237
3238         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
3239             (locinput - pref_len),pref0_len, 60, 4, 5);
3240
3241         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3242                     (locinput - pref_len + pref0_len),
3243                     pref_len - pref0_len, 60, 2, 3);
3244
3245         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
3246                     locinput, loc_regeol - locinput, 10, 0, 1);
3247
3248         const STRLEN tlen=len0+len1+len2;
3249         PerlIO_printf(Perl_debug_log,
3250                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
3251                     (IV)(locinput - loc_bostr),
3252                     len0, s0,
3253                     len1, s1,
3254                     (docolor ? "" : "> <"),
3255                     len2, s2,
3256                     (int)(tlen > 19 ? 0 :  19 - tlen),
3257                     "");
3258     }
3259 }
3260
3261 #endif
3262
3263 /* reg_check_named_buff_matched()
3264  * Checks to see if a named buffer has matched. The data array of
3265  * buffer numbers corresponding to the buffer is expected to reside
3266  * in the regexp->data->data array in the slot stored in the ARG() of
3267  * node involved. Note that this routine doesn't actually care about the
3268  * name, that information is not preserved from compilation to execution.
3269  * Returns the index of the leftmost defined buffer with the given name
3270  * or 0 if non of the buffers matched.
3271  */
3272 STATIC I32
3273 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
3274 {
3275     I32 n;
3276     RXi_GET_DECL(rex,rexi);
3277     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
3278     I32 *nums=(I32*)SvPVX(sv_dat);
3279
3280     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3281
3282     for ( n=0; n<SvIVX(sv_dat); n++ ) {
3283         if ((I32)rex->lastparen >= nums[n] &&
3284             rex->offs[nums[n]].end != -1)
3285         {
3286             return nums[n];
3287         }
3288     }
3289     return 0;
3290 }
3291
3292
3293 /* free all slabs above current one  - called during LEAVE_SCOPE */
3294
3295 STATIC void
3296 S_clear_backtrack_stack(pTHX_ void *p)
3297 {
3298     regmatch_slab *s = PL_regmatch_slab->next;
3299     PERL_UNUSED_ARG(p);
3300
3301     if (!s)
3302         return;
3303     PL_regmatch_slab->next = NULL;
3304     while (s) {
3305         regmatch_slab * const osl = s;
3306         s = s->next;
3307         Safefree(osl);
3308     }
3309 }
3310 static bool
3311 S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p, U8* c1_utf8, int *c2p, U8* c2_utf8)
3312 {
3313     /* This function determines if there are one or two characters that match
3314      * the first character of the passed-in EXACTish node <text_node>, and if
3315      * so, returns them in the passed-in pointers.
3316      *
3317      * If it determines that no possible character in the target string can
3318      * match, it returns FALSE; otherwise TRUE.  (The FALSE situation occurs if
3319      * the first character in <text_node> requires UTF-8 to represent, and the
3320      * target string isn't in UTF-8.)
3321      *
3322      * If there are more than two characters that could match the beginning of
3323      * <text_node>, or if more context is required to determine a match or not,
3324      * it sets both *<c1p> and *<c2p> to CHRTEST_VOID.
3325      *
3326      * The motiviation behind this function is to allow the caller to set up
3327      * tight loops for matching.  If <text_node> is of type EXACT, there is
3328      * only one possible character that can match its first character, and so
3329      * the situation is quite simple.  But things get much more complicated if
3330      * folding is involved.  It may be that the first character of an EXACTFish
3331      * node doesn't participate in any possible fold, e.g., punctuation, so it
3332      * can be matched only by itself.  The vast majority of characters that are
3333      * in folds match just two things, their lower and upper-case equivalents.
3334      * But not all are like that; some have multiple possible matches, or match
3335      * sequences of more than one character.  This function sorts all that out.
3336      *
3337      * Consider the patterns A*B or A*?B where A and B are arbitrary.  In a
3338      * loop of trying to match A*, we know we can't exit where the thing
3339      * following it isn't a B.  And something can't be a B unless it is the
3340      * beginning of B.  By putting a quick test for that beginning in a tight
3341      * loop, we can rule out things that can't possibly be B without having to
3342      * break out of the loop, thus avoiding work.  Similarly, if A is a single
3343      * character, we can make a tight loop matching A*, using the outputs of
3344      * this function.
3345      *
3346      * If the target string to match isn't in UTF-8, and there aren't
3347      * complications which require CHRTEST_VOID, *<c1p> and *<c2p> are set to
3348      * the one or two possible octets (which are characters in this situation)
3349      * that can match.  In all cases, if there is only one character that can
3350      * match, *<c1p> and *<c2p> will be identical.
3351      *
3352      * If the target string is in UTF-8, the buffers pointed to by <c1_utf8>
3353      * and <c2_utf8> will contain the one or two UTF-8 sequences of bytes that
3354      * can match the beginning of <text_node>.  They should be declared with at
3355      * least length UTF8_MAXBYTES+1.  (If the target string isn't in UTF-8, it is
3356      * undefined what these contain.)  If one or both of the buffers are
3357      * invariant under UTF-8, *<c1p>, and *<c2p> will also be set to the
3358      * corresponding invariant.  If variant, the corresponding *<c1p> and/or
3359      * *<c2p> will be set to a negative number(s) that shouldn't match any code
3360      * point (unless inappropriately coerced to unsigned).   *<c1p> will equal
3361      * *<c2p> if and only if <c1_utf8> and <c2_utf8> are the same. */
3362
3363     const bool utf8_target = PL_reg_match_utf8;
3364
3365     UV c1 = CHRTEST_NOT_A_CP_1;
3366     UV c2 = CHRTEST_NOT_A_CP_2;
3367     bool use_chrtest_void = FALSE;
3368
3369     /* Used when we have both utf8 input and utf8 output, to avoid converting
3370      * to/from code points */
3371     bool utf8_has_been_setup = FALSE;
3372
3373     dVAR;
3374
3375     U8 *pat = (U8*)STRING(text_node);
3376
3377     if (OP(text_node) == EXACT) {
3378
3379         /* In an exact node, only one thing can be matched, that first
3380          * character.  If both the pat and the target are UTF-8, we can just
3381          * copy the input to the output, avoiding finding the code point of
3382          * that character */
3383         if (! UTF_PATTERN) {
3384             c2 = c1 = *pat;
3385         }
3386         else if (utf8_target) {
3387             Copy(pat, c1_utf8, UTF8SKIP(pat), U8);
3388             Copy(pat, c2_utf8, UTF8SKIP(pat), U8);
3389             utf8_has_been_setup = TRUE;
3390         }
3391         else {
3392             c2 = c1 = valid_utf8_to_uvchr(pat, NULL);
3393         }
3394     }
3395     else /* an EXACTFish node */
3396          if ((UTF_PATTERN
3397                     && is_MULTI_CHAR_FOLD_utf8_safe(pat,
3398                                                     pat + STR_LEN(text_node)))
3399              || (! UTF_PATTERN
3400                     && is_MULTI_CHAR_FOLD_latin1_safe(pat,
3401                                                     pat + STR_LEN(text_node))))
3402     {
3403         /* Multi-character folds require more context to sort out.  Also
3404          * PL_utf8_foldclosures used below doesn't handle them, so have to be
3405          * handled outside this routine */
3406         use_chrtest_void = TRUE;
3407     }
3408     else { /* an EXACTFish node which doesn't begin with a multi-char fold */
3409         c1 = (UTF_PATTERN) ? valid_utf8_to_uvchr(pat, NULL) : *pat;
3410         if (c1 > 256) {
3411             /* Load the folds hash, if not already done */
3412             SV** listp;
3413             if (! PL_utf8_foldclosures) {
3414                 if (! PL_utf8_tofold) {
3415                     U8 dummy[UTF8_MAXBYTES+1];
3416
3417                     /* Force loading this by folding an above-Latin1 char */
3418                     to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
3419                     assert(PL_utf8_tofold); /* Verify that worked */
3420                 }
3421                 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
3422             }
3423
3424             /* The fold closures data structure is a hash with the keys being
3425              * the UTF-8 of every character that is folded to, like 'k', and
3426              * the values each an array of all code points that fold to its
3427              * key.  e.g. [ 'k', 'K', KELVIN_SIGN ].  Multi-character folds are
3428              * not included */
3429             if ((! (listp = hv_fetch(PL_utf8_foldclosures,
3430                                      (char *) pat,
3431                                      UTF8SKIP(pat),
3432                                      FALSE))))
3433             {
3434                 /* Not found in the hash, therefore there are no folds
3435                  * containing it, so there is only a single character that
3436                  * could match */
3437                 c2 = c1;
3438             }
3439             else {  /* Does participate in folds */
3440                 AV* list = (AV*) *listp;
3441                 if (av_len(list) != 1) {
3442
3443                     /* If there aren't exactly two folds to this, it is outside
3444                      * the scope of this function */
3445                     use_chrtest_void = TRUE;
3446                 }
3447                 else {  /* There are two.  Get them */
3448                     SV** c_p = av_fetch(list, 0, FALSE);
3449                     if (c_p == NULL) {
3450                         Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
3451                     }
3452                     c1 = SvUV(*c_p);
3453
3454                     c_p = av_fetch(list, 1, FALSE);
3455                     if (c_p == NULL) {
3456                         Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
3457                     }
3458                     c2 = SvUV(*c_p);
3459
3460                     /* Folds that cross the 255/256 boundary are forbidden if
3461                      * EXACTFL, or EXACTFA and one is ASCIII.  Since the
3462                      * pattern character is above 256, and its only other match
3463                      * is below 256, the only legal match will be to itself.
3464                      * We have thrown away the original, so have to compute
3465                      * which is the one above 255 */
3466                     if ((c1 < 256) != (c2 < 256)) {
3467                         if (OP(text_node) == EXACTFL
3468                             || (OP(text_node) == EXACTFA
3469                                 && (isASCII(c1) || isASCII(c2))))
3470                         {
3471                             if (c1 < 256) {
3472                                 c1 = c2;
3473                             }
3474                             else {
3475                                 c2 = c1;
3476                             }
3477                         }
3478                     }
3479                 }
3480             }
3481         }
3482         else /* Here, c1 is < 255 */
3483              if (utf8_target
3484                  && HAS_NONLATIN1_FOLD_CLOSURE(c1)
3485                  && OP(text_node) != EXACTFL
3486                  && (OP(text_node) != EXACTFA || ! isASCII(c1)))
3487         {
3488             /* Here, there could be something above Latin1 in the target which
3489              * folds to this character in the pattern.  All such cases except
3490              * LATIN SMALL LETTER Y WITH DIAERESIS have more than two characters
3491              * involved in their folds, so are outside the scope of this
3492              * function */
3493             if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3494                 c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
3495             }
3496             else {
3497                 use_chrtest_void = TRUE;
3498             }
3499         }
3500         else { /* Here nothing above Latin1 can fold to the pattern character */
3501             switch (OP(text_node)) {
3502
3503                 case EXACTFL:   /* /l rules */
3504                     c2 = PL_fold_locale[c1];
3505                     break;
3506
3507                 case EXACTF:
3508                     if (! utf8_target) {    /* /d rules */
3509                         c2 = PL_fold[c1];
3510                         break;
3511                     }
3512                     /* FALLTHROUGH */
3513                     /* /u rules for all these.  This happens to work for
3514                      * EXACTFA as nothing in Latin1 folds to ASCII */
3515                 case EXACTFA:
3516                 case EXACTFU_TRICKYFOLD:
3517                 case EXACTFU_SS:
3518                 case EXACTFU:
3519                     c2 = PL_fold_latin1[c1];
3520                     break;
3521
3522                 default:
3523                     Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
3524                     assert(0); /* NOTREACHED */
3525             }
3526         }
3527     }
3528
3529     /* Here have figured things out.  Set up the returns */
3530     if (use_chrtest_void) {
3531         *c2p = *c1p = CHRTEST_VOID;
3532     }
3533     else if (utf8_target) {
3534         if (! utf8_has_been_setup) {    /* Don't have the utf8; must get it */
3535             uvchr_to_utf8(c1_utf8, c1);
3536             uvchr_to_utf8(c2_utf8, c2);
3537         }
3538
3539         /* Invariants are stored in both the utf8 and byte outputs; Use
3540          * negative numbers otherwise for the byte ones.  Make sure that the
3541          * byte ones are the same iff the utf8 ones are the same */
3542         *c1p = (UTF8_IS_INVARIANT(*c1_utf8)) ? *c1_utf8 : CHRTEST_NOT_A_CP_1;
3543         *c2p = (UTF8_IS_INVARIANT(*c2_utf8))
3544                 ? *c2_utf8
3545                 : (c1 == c2)
3546                   ? CHRTEST_NOT_A_CP_1
3547                   : CHRTEST_NOT_A_CP_2;
3548     }
3549     else if (c1 > 255) {
3550        if (c2 > 255) {  /* both possibilities are above what a non-utf8 string
3551                            can represent */
3552            return FALSE;
3553        }
3554
3555        *c1p = *c2p = c2;    /* c2 is the only representable value */
3556     }
3557     else {  /* c1 is representable; see about c2 */
3558        *c1p = c1;
3559        *c2p = (c2 < 256) ? c2 : c1;
3560     }
3561
3562     return TRUE;
3563 }
3564
3565 /* returns -1 on failure, $+[0] on success */
3566 STATIC I32
3567 S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
3568 {
3569 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3570     dMY_CXT;
3571 #endif
3572     dVAR;
3573     const bool utf8_target = PL_reg_match_utf8;
3574     const U32 uniflags = UTF8_ALLOW_DEFAULT;
3575     REGEXP *rex_sv = reginfo->prog;
3576     regexp *rex = ReANY(rex_sv);
3577     RXi_GET_DECL(rex,rexi);
3578     I32 oldsave;
3579     /* the current state. This is a cached copy of PL_regmatch_state */
3580     regmatch_state *st;
3581     /* cache heavy used fields of st in registers */
3582     regnode *scan;
3583     regnode *next;
3584     U32 n = 0;  /* general value; init to avoid compiler warning */
3585     I32 ln = 0; /* len or last;  init to avoid compiler warning */
3586     char *locinput = startpos;
3587     char *pushinput; /* where to continue after a PUSH */
3588     I32 nextchr;   /* is always set to UCHARAT(locinput) */
3589
3590     bool result = 0;        /* return value of S_regmatch */
3591     int depth = 0;          /* depth of backtrack stack */
3592     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
3593     const U32 max_nochange_depth =
3594         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
3595         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
3596     regmatch_state *yes_state = NULL; /* state to pop to on success of
3597                                                             subpattern */
3598     /* mark_state piggy backs on the yes_state logic so that when we unwind
3599        the stack on success we can update the mark_state as we go */
3600     regmatch_state *mark_state = NULL; /* last mark state we have seen */
3601     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
3602     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
3603     U32 state_num;
3604     bool no_final = 0;      /* prevent failure from backtracking? */
3605     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
3606     char *startpoint = locinput;
3607     SV *popmark = NULL;     /* are we looking for a mark? */
3608     SV *sv_commit = NULL;   /* last mark name seen in failure */
3609     SV *sv_yes_mark = NULL; /* last mark name we have seen
3610                                during a successful match */
3611     U32 lastopen = 0;       /* last open we saw */
3612     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
3613     SV* const oreplsv = GvSV(PL_replgv);
3614     /* these three flags are set by various ops to signal information to
3615      * the very next op. They have a useful lifetime of exactly one loop
3616      * iteration, and are not preserved or restored by state pushes/pops
3617      */
3618     bool sw = 0;            /* the condition value in (?(cond)a|b) */
3619     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
3620     int logical = 0;        /* the following EVAL is:
3621                                 0: (?{...})
3622                                 1: (?(?{...})X|Y)
3623                                 2: (??{...})
3624                                or the following IFMATCH/UNLESSM is:
3625                                 false: plain (?=foo)
3626                                 true:  used as a condition: (?(?=foo))
3627                             */
3628     PAD* last_pad = NULL;
3629     dMULTICALL;
3630     I32 gimme = G_SCALAR;
3631     CV *caller_cv = NULL;       /* who called us */
3632     CV *last_pushed_cv = NULL;  /* most recently called (?{}) CV */
3633     CHECKPOINT runops_cp;       /* savestack position before executing EVAL */
3634
3635 #ifdef DEBUGGING
3636     GET_RE_DEBUG_FLAGS_DECL;
3637 #endif
3638
3639     /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
3640     multicall_oldcatch = 0;
3641     multicall_cv = NULL;
3642     cx = NULL;
3643     PERL_UNUSED_VAR(multicall_cop);
3644     PERL_UNUSED_VAR(newsp);
3645
3646
3647     PERL_ARGS_ASSERT_REGMATCH;
3648
3649     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
3650             PerlIO_printf(Perl_debug_log,"regmatch start\n");
3651     }));
3652     /* on first ever call to regmatch, allocate first slab */
3653     if (!PL_regmatch_slab) {
3654         Newx(PL_regmatch_slab, 1, regmatch_slab);
3655         PL_regmatch_slab->prev = NULL;
3656         PL_regmatch_slab->next = NULL;
3657         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
3658     }
3659
3660     oldsave = PL_savestack_ix;
3661     SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
3662     SAVEVPTR(PL_regmatch_slab);
3663     SAVEVPTR(PL_regmatch_state);
3664
3665     /* grab next free state slot */
3666     st = ++PL_regmatch_state;
3667     if (st >  SLAB_LAST(PL_regmatch_slab))
3668         st = PL_regmatch_state = S_push_slab(aTHX);
3669
3670     /* Note that nextchr is a byte even in UTF */
3671     SET_nextchr;
3672     scan = prog;
3673     while (scan != NULL) {
3674
3675         DEBUG_EXECUTE_r( {
3676             SV * const prop = sv_newmortal();
3677             regnode *rnext=regnext(scan);
3678             DUMP_EXEC_POS( locinput, scan, utf8_target );
3679             regprop(rex, prop, scan);
3680
3681             PerlIO_printf(Perl_debug_log,
3682                     "%3"IVdf":%*s%s(%"IVdf")\n",
3683                     (IV)(scan - rexi->program), depth*2, "",
3684                     SvPVX_const(prop),
3685                     (PL_regkind[OP(scan)] == END || !rnext) ?
3686                         0 : (IV)(rnext - rexi->program));
3687         });
3688
3689         next = scan + NEXT_OFF(scan);
3690         if (next == scan)
3691             next = NULL;
3692         state_num = OP(scan);
3693
3694       reenter_switch:
3695
3696         SET_nextchr;
3697         assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS));
3698
3699         switch (state_num) {
3700         case BOL: /*  /^../  */
3701             if (locinput == PL_bostr)
3702             {
3703                 /* reginfo->till = reginfo->bol; */
3704                 break;
3705             }
3706             sayNO;
3707
3708         case MBOL: /*  /^../m  */
3709             if (locinput == PL_bostr ||
3710                 (!NEXTCHR_IS_EOS && locinput[-1] == '\n'))
3711             {
3712                 break;
3713             }
3714             sayNO;
3715
3716         case SBOL: /*  /^../s  */
3717             if (locinput == PL_bostr)
3718                 break;
3719             sayNO;
3720
3721         case GPOS: /*  \G  */
3722             if (locinput == reginfo->ganch)
3723                 break;
3724             sayNO;
3725
3726         case KEEPS: /*   \K  */
3727             /* update the startpoint */
3728             st->u.keeper.val = rex->offs[0].start;
3729             rex->offs[0].start = locinput - PL_bostr;
3730             PUSH_STATE_GOTO(KEEPS_next, next, locinput);
3731             assert(0); /*NOTREACHED*/
3732         case KEEPS_next_fail:
3733             /* rollback the start point change */
3734             rex->offs[0].start = st->u.keeper.val;
3735             sayNO_SILENT;
3736             assert(0); /*NOTREACHED*/
3737
3738         case EOL: /* /..$/  */
3739                 goto seol;
3740
3741         case MEOL: /* /..$/m  */
3742             if (!NEXTCHR_IS_EOS && nextchr != '\n')
3743                 sayNO;
3744             break;
3745
3746         case SEOL: /* /..$/s  */
3747           seol:
3748             if (!NEXTCHR_IS_EOS && nextchr != '\n')
3749                 sayNO;
3750             if (PL_regeol - locinput > 1)
3751                 sayNO;
3752             break;
3753
3754         case EOS: /*  \z  */
3755             if (!NEXTCHR_IS_EOS)
3756                 sayNO;
3757             break;
3758
3759         case SANY: /*  /./s  */
3760             if (NEXTCHR_IS_EOS)
3761                 sayNO;
3762             goto increment_locinput;
3763
3764         case CANY: /*  \C  */
3765             if (NEXTCHR_IS_EOS)
3766                 sayNO;
3767             locinput++;
3768             break;
3769
3770         case REG_ANY: /*  /./  */
3771             if ((NEXTCHR_IS_EOS) || nextchr == '\n')
3772                 sayNO;
3773             goto increment_locinput;
3774
3775
3776 #undef  ST
3777 #define ST st->u.trie
3778         case TRIEC: /* (ab|cd) with known charclass */
3779             /* In this case the charclass data is available inline so
3780                we can fail fast without a lot of extra overhead.
3781              */
3782             if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) {
3783                 DEBUG_EXECUTE_r(
3784                     PerlIO_printf(Perl_debug_log,
3785                               "%*s  %sfailed to match trie start class...%s\n",
3786                               REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3787                 );
3788                 sayNO_SILENT;
3789                 assert(0); /* NOTREACHED */
3790             }
3791             /* FALL THROUGH */
3792         case TRIE:  /* (ab|cd)  */
3793             /* the basic plan of execution of the trie is:
3794              * At the beginning, run though all the states, and
3795              * find the longest-matching word. Also remember the position
3796              * of the shortest matching word. For example, this pattern:
3797              *    1  2 3 4    5
3798              *    ab|a|x|abcd|abc
3799              * when matched against the string "abcde", will generate
3800              * accept states for all words except 3, with the longest
3801              * matching word being 4, and the shortest being 2 (with
3802              * the position being after char 1 of the string).
3803              *
3804              * Then for each matching word, in word order (i.e. 1,2,4,5),
3805              * we run the remainder of the pattern; on each try setting
3806              * the current position to the character following the word,
3807              * returning to try the next word on failure.
3808              *
3809              * We avoid having to build a list of words at runtime by
3810              * using a compile-time structure, wordinfo[].prev, which
3811              * gives, for each word, the previous accepting word (if any).
3812              * In the case above it would contain the mappings 1->2, 2->0,
3813              * 3->0, 4->5, 5->1.  We can use this table to generate, from
3814              * the longest word (4 above), a list of all words, by
3815              * following the list of prev pointers; this gives us the
3816              * unordered list 4,5,1,2. Then given the current word we have
3817              * just tried, we can go through the list and find the
3818              * next-biggest word to try (so if we just failed on word 2,
3819              * the next in the list is 4).
3820              *
3821              * Since at runtime we don't record the matching position in
3822              * the string for each word, we have to work that out for
3823              * each word we're about to process. The wordinfo table holds
3824              * the character length of each word; given that we recorded
3825              * at the start: the position of the shortest word and its
3826              * length in chars, we just need to move the pointer the
3827              * difference between the two char lengths. Depending on
3828              * Unicode status and folding, that's cheap or expensive.
3829              *
3830              * This algorithm is optimised for the case where are only a
3831              * small number of accept states, i.e. 0,1, or maybe 2.
3832              * With lots of accepts states, and having to try all of them,
3833              * it becomes quadratic on number of accept states to find all
3834              * the next words.
3835              */
3836
3837             {
3838                 /* what type of TRIE am I? (utf8 makes this contextual) */
3839                 DECL_TRIE_TYPE(scan);
3840
3841                 /* what trie are we using right now */
3842                 reg_trie_data * const trie
3843                     = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3844                 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3845                 U32 state = trie->startstate;
3846
3847                 if (   trie->bitmap
3848                     && (NEXTCHR_IS_EOS || !TRIE_BITMAP_TEST(trie, nextchr)))
3849                 {
3850                     if (trie->states[ state ].wordnum) {
3851                          DEBUG_EXECUTE_r(
3852                             PerlIO_printf(Perl_debug_log,
3853                                           "%*s  %smatched empty string...%s\n",
3854                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3855                         );
3856                         if (!trie->jump)
3857                             break;
3858                     } else {
3859                         DEBUG_EXECUTE_r(
3860                             PerlIO_printf(Perl_debug_log,
3861                                           "%*s  %sfailed to match trie start class...%s\n",
3862                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3863                         );
3864                         sayNO_SILENT;
3865                    }
3866                 }
3867
3868             {
3869                 U8 *uc = ( U8* )locinput;
3870
3871                 STRLEN len = 0;
3872                 STRLEN foldlen = 0;
3873                 U8 *uscan = (U8*)NULL;
3874                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3875                 U32 charcount = 0; /* how many input chars we have matched */
3876                 U32 accepted = 0; /* have we seen any accepting states? */
3877
3878                 ST.jump = trie->jump;
3879                 ST.me = scan;
3880                 ST.firstpos = NULL;
3881                 ST.longfold = FALSE; /* char longer if folded => it's harder */
3882                 ST.nextword = 0;
3883
3884                 /* fully traverse the TRIE; note the position of the
3885                    shortest accept state and the wordnum of the longest
3886                    accept state */
3887
3888                 while ( state && uc <= (U8*)PL_regeol ) {
3889                     U32 base = trie->states[ state ].trans.base;
3890                     UV uvc = 0;
3891                     U16 charid = 0;
3892                     U16 wordnum;
3893                     wordnum = trie->states[ state ].wordnum;
3894
3895                     if (wordnum) { /* it's an accept state */
3896                         if (!accepted) {
3897                             accepted = 1;
3898                             /* record first match position */
3899                             if (ST.longfold) {
3900                                 ST.firstpos = (U8*)locinput;
3901                                 ST.firstchars = 0;
3902                             }
3903                             else {
3904                                 ST.firstpos = uc;
3905                                 ST.firstchars = charcount;
3906                             }
3907                         }
3908                         if (!ST.nextword || wordnum < ST.nextword)
3909                             ST.nextword = wordnum;
3910                         ST.topword = wordnum;
3911                     }
3912
3913                     DEBUG_TRIE_EXECUTE_r({
3914                                 DUMP_EXEC_POS( (char *)uc, scan, utf8_target );
3915                                 PerlIO_printf( Perl_debug_log,
3916                                     "%*s  %sState: %4"UVxf" Accepted: %c ",
3917                                     2+depth * 2, "", PL_colors[4],
3918                                     (UV)state, (accepted ? 'Y' : 'N'));
3919                     });
3920
3921                     /* read a char and goto next state */
3922                     if ( base && (foldlen || uc < (U8*)PL_regeol)) {
3923                         I32 offset;
3924                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3925                                              uscan, len, uvc, charid, foldlen,
3926                                              foldbuf, uniflags);
3927                         charcount++;
3928      &nb