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