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