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