regexec.c

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