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