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