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