regexec.c

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