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