src/5012003/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 #include "re_defs.h"
  77
  78 #ifdef PERL_IN_XSUB_RE
  79 #  include "re_comp.h"
  80 #else
  81 #  include "regcomp.h"
  82 #endif
  83
  84 #define RF_tainted      1               /* tainted information used? */
  85 #define RF_warned       2               /* warned about big count? */
  86
  87 #define RF_utf8         8               /* Pattern contains multibyte chars? */
  88
  89 #define UTF ((PL_reg_flags & RF_utf8) != 0)
  90
  91 #define RS_init         1               /* eval environment created */
  92 #define RS_set          2               /* replsv value is set */
  93
  94 #ifndef STATIC
  95 #define STATIC  static
  96 #endif
  97
  98 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
  99
 100 /*
 101  * Forwards.
 102  */
 103
 104 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
 105 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
 106
 107 #define HOPc(pos,off) \
 108         (char *)(PL_reg_match_utf8 \
 109             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
 110             : (U8*)(pos + off))
 111 #define HOPBACKc(pos, off) \
 112         (char*)(PL_reg_match_utf8\
 113             ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
 114             : (pos - off >= PL_bostr)           \
 115                 ? (U8*)pos - off                \
 116                 : NULL)
 117
 118 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
 119 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
 120
 121 /* these are unrolled below in the CCC_TRY_XXX defined */
 122 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
 123     if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
 124
 125 /* Doesn't do an assert to verify that is correct */
 126 #define LOAD_UTF8_CHARCLASS_NO_CHECK(class) STMT_START { \
 127     if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)" "); LEAVE; } } STMT_END
 128
 129 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
 130 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
 131 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
 132
 133 #define LOAD_UTF8_CHARCLASS_GCB()  /* Grapheme cluster boundaries */        \
 134         LOAD_UTF8_CHARCLASS(X_begin, " ");                                  \
 135         LOAD_UTF8_CHARCLASS(X_non_hangul, "A");                             \
 136         /* These are utf8 constants, and not utf-ebcdic constants, so the   \
 137             * assert should likely and hopefully fail on an EBCDIC machine */ \
 138         LOAD_UTF8_CHARCLASS(X_extend, "\xcc\x80"); /* U+0300 */             \
 139                                                                             \
 140         /* No asserts are done for these, in case called on an early        \
 141             * Unicode version in which they map to nothing */               \
 142         LOAD_UTF8_CHARCLASS_NO_CHECK(X_prepend);/* U+0E40 "\xe0\xb9\x80" */ \
 143         LOAD_UTF8_CHARCLASS_NO_CHECK(X_L);          /* U+1100 "\xe1\x84\x80" */ \
 144         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV);     /* U+AC00 "\xea\xb0\x80" */ \
 145         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LVT);    /* U+AC01 "\xea\xb0\x81" */ \
 146         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV_LVT_V);/* U+AC01 "\xea\xb0\x81" */\
 147         LOAD_UTF8_CHARCLASS_NO_CHECK(X_T);      /* U+11A8 "\xe1\x86\xa8" */ \
 148         LOAD_UTF8_CHARCLASS_NO_CHECK(X_V)       /* U+1160 "\xe1\x85\xa0" */
 149
 150 /*
 151    We dont use PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS as the direct test
 152    so that it is possible to override the option here without having to
 153    rebuild the entire core. as we are required to do if we change regcomp.h
 154    which is where PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS is defined.
 155 */
 156 #if PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS
 157 #define BROKEN_UNICODE_CHARCLASS_MAPPINGS
 158 #endif
 159
 160 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
 161 #define LOAD_UTF8_CHARCLASS_PERL_WORD()   LOAD_UTF8_CHARCLASS_ALNUM()
 162 #define LOAD_UTF8_CHARCLASS_PERL_SPACE()  LOAD_UTF8_CHARCLASS_SPACE()
 163 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS_DIGIT()
 164 #define RE_utf8_perl_word   PL_utf8_alnum
 165 #define RE_utf8_perl_space  PL_utf8_space
 166 #define RE_utf8_posix_digit PL_utf8_digit
 167 #define perl_word  alnum
 168 #define perl_space space
 169 #define posix_digit digit
 170 #else
 171 #define LOAD_UTF8_CHARCLASS_PERL_WORD()   LOAD_UTF8_CHARCLASS(perl_word,"a")
 172 #define LOAD_UTF8_CHARCLASS_PERL_SPACE()  LOAD_UTF8_CHARCLASS(perl_space," ")
 173 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS(posix_digit,"0")
 174 #define RE_utf8_perl_word   PL_utf8_perl_word
 175 #define RE_utf8_perl_space  PL_utf8_perl_space
 176 #define RE_utf8_posix_digit PL_utf8_posix_digit
 177 #endif
 178
 179
 180 #define CCC_TRY_AFF(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC)                          \
 181         case NAMEL:                                                              \
 182             PL_reg_flags |= RF_tainted;                                                 \
 183             /* FALL THROUGH */                                                          \
 184         case NAME:                                                                     \
 185             if (!nextchr)                                                               \
 186                 sayNO;                                                                  \
 187             if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) {                                \
 188                 if (!CAT2(PL_utf8_,CLASS)) {                                            \
 189                     bool ok;                                                            \
 190                     ENTER;                                                              \
 191                     save_re_context();                                                  \
 192                     ok=CAT2(is_utf8_,CLASS)((const U8*)STR);                            \
 193                     assert(ok);                                                         \
 194                     LEAVE;                                                              \
 195                 }                                                                       \
 196                 if (!(OP(scan) == NAME                                                  \
 197                     ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)   \
 198                     : LCFUNC_utf8((U8*)locinput)))                                      \
 199                 {                                                                       \
 200                     sayNO;                                                              \
 201                 }                                                                       \
 202                 locinput += PL_utf8skip[nextchr];                                       \
 203                 nextchr = UCHARAT(locinput);                                            \
 204                 break;                                                                  \
 205             }                                                                           \
 206             if (!(OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr)))                  \
 207                 sayNO;                                                                  \
 208             nextchr = UCHARAT(++locinput);                                              \
 209             break
 210
 211 #define CCC_TRY_NEG(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC)                        \
 212         case NAMEL:                                                              \
 213             PL_reg_flags |= RF_tainted;                                                 \
 214             /* FALL THROUGH */                                                          \
 215         case NAME :                                                                     \
 216             if (!nextchr && locinput >= PL_regeol)                                      \
 217                 sayNO;                                                                  \
 218             if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) {                                \
 219                 if (!CAT2(PL_utf8_,CLASS)) {                                            \
 220                     bool ok;                                                            \
 221                     ENTER;                                                              \
 222                     save_re_context();                                                  \
 223                     ok=CAT2(is_utf8_,CLASS)((const U8*)STR);                            \
 224                     assert(ok);                                                         \
 225                     LEAVE;                                                              \
 226                 }                                                                       \
 227                 if ((OP(scan) == NAME                                                  \
 228                     ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)    \
 229                     : LCFUNC_utf8((U8*)locinput)))                                      \
 230                 {                                                                       \
 231                     sayNO;                                                              \
 232                 }                                                                       \
 233                 locinput += PL_utf8skip[nextchr];                                       \
 234                 nextchr = UCHARAT(locinput);                                            \
 235                 break;                                                                  \
 236             }                                                                           \
 237             if ((OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr)))                   \
 238                 sayNO;                                                                  \
 239             nextchr = UCHARAT(++locinput);                                              \
 240             break
 241
 242
 243
 244
 245
 246 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
 247
 248 /* for use after a quantifier and before an EXACT-like node -- japhy */
 249 /* it would be nice to rework regcomp.sym to generate this stuff. sigh */
 250 #define JUMPABLE(rn) (      \
 251     OP(rn) == OPEN ||       \
 252     (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
 253     OP(rn) == EVAL ||   \
 254     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 255     OP(rn) == PLUS || OP(rn) == MINMOD || \
 256     OP(rn) == KEEPS || (PL_regkind[OP(rn)] == VERB) || \
 257     (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
 258 )
 259 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
 260
 261 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
 262
 263 #if 0
 264 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
 265    we don't need this definition. */
 266 #define IS_TEXT(rn)   ( OP(rn)==EXACT   || OP(rn)==REF   || OP(rn)==NREF   )
 267 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  || OP(rn)==REFF  || OP(rn)==NREFF  )
 268 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
 269
 270 #else
 271 /* ... so we use this as its faster. */
 272 #define IS_TEXT(rn)   ( OP(rn)==EXACT   )
 273 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  )
 274 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
 275
 276 #endif
 277
 278 /*
 279   Search for mandatory following text node; for lookahead, the text must
 280   follow but for lookbehind (rn->flags != 0) we skip to the next step.
 281 */
 282 #define FIND_NEXT_IMPT(rn) STMT_START { \
 283     while (JUMPABLE(rn)) { \
 284         const OPCODE type = OP(rn); \
 285         if (type == SUSPEND || PL_regkind[type] == CURLY) \
 286             rn = NEXTOPER(NEXTOPER(rn)); \
 287         else if (type == PLUS) \
 288             rn = NEXTOPER(rn); \
 289         else if (type == IFMATCH) \
 290             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
 291         else rn += NEXT_OFF(rn); \
 292     } \
 293 } STMT_END
 294
 295
 296 static void restore_pos(pTHX_ void *arg);
 297
 298 STATIC CHECKPOINT
 299 S_regcppush(pTHX_ I32 parenfloor)
 300 {
 301     dVAR;
 302     const int retval = PL_savestack_ix;
 303 #define REGCP_PAREN_ELEMS 4
 304     const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
 305     int p;
 306     GET_RE_DEBUG_FLAGS_DECL;
 307
 308     if (paren_elems_to_push < 0)
 309         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
 310
 311 #define REGCP_OTHER_ELEMS 7
 312     SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
 313
 314     for (p = PL_regsize; p > parenfloor; p--) {
 315 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 316         SSPUSHINT(PL_regoffs[p].end);
 317         SSPUSHINT(PL_regoffs[p].start);
 318         SSPUSHPTR(PL_reg_start_tmp[p]);
 319         SSPUSHINT(p);
 320         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
 321           "     saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
 322                       (UV)p, (IV)PL_regoffs[p].start,
 323                       (IV)(PL_reg_start_tmp[p] - PL_bostr),
 324                       (IV)PL_regoffs[p].end
 325         ));
 326     }
 327 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 328     SSPUSHPTR(PL_regoffs);
 329     SSPUSHINT(PL_regsize);
 330     SSPUSHINT(*PL_reglastparen);
 331     SSPUSHINT(*PL_reglastcloseparen);
 332     SSPUSHPTR(PL_reginput);
 333 #define REGCP_FRAME_ELEMS 2
 334 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
 335  * are needed for the regexp context stack bookkeeping. */
 336     SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 337     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
 338
 339     return retval;
 340 }
 341
 342 /* These are needed since we do not localize EVAL nodes: */
 343 #define REGCP_SET(cp)                                           \
 344     DEBUG_STATE_r(                                              \
 345             PerlIO_printf(Perl_debug_log,                       \
 346                 "  Setting an EVAL scope, savestack=%"IVdf"\n", \
 347                 (IV)PL_savestack_ix));                          \
 348     cp = PL_savestack_ix
 349
 350 #define REGCP_UNWIND(cp)                                        \
 351     DEBUG_STATE_r(                                              \
 352         if (cp != PL_savestack_ix)                              \
 353             PerlIO_printf(Perl_debug_log,                       \
 354                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 355                 (IV)(cp), (IV)PL_savestack_ix));                \
 356     regcpblow(cp)
 357
 358 STATIC char *
 359 S_regcppop(pTHX_ const regexp *rex)
 360 {
 361     dVAR;
 362     U32 i;
 363     char *input;
 364     GET_RE_DEBUG_FLAGS_DECL;
 365
 366     PERL_ARGS_ASSERT_REGCPPOP;
 367
 368     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 369     i = SSPOPINT;
 370     assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 371     i = SSPOPINT; /* Parentheses elements to pop. */
 372     input = (char *) SSPOPPTR;
 373     *PL_reglastcloseparen = SSPOPINT;
 374     *PL_reglastparen = SSPOPINT;
 375     PL_regsize = SSPOPINT;
 376     PL_regoffs=(regexp_paren_pair *) SSPOPPTR;
 377
 378
 379     /* Now restore the parentheses context. */
 380     for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 381          i > 0; i -= REGCP_PAREN_ELEMS) {
 382         I32 tmps;
 383         U32 paren = (U32)SSPOPINT;
 384         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
 385         PL_regoffs[paren].start = SSPOPINT;
 386         tmps = SSPOPINT;
 387         if (paren <= *PL_reglastparen)
 388             PL_regoffs[paren].end = tmps;
 389         DEBUG_BUFFERS_r(
 390             PerlIO_printf(Perl_debug_log,
 391                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 392                           (UV)paren, (IV)PL_regoffs[paren].start,
 393                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
 394                           (IV)PL_regoffs[paren].end,
 395                           (paren > *PL_reglastparen ? "(no)" : ""));
 396         );
 397     }
 398     DEBUG_BUFFERS_r(
 399         if (*PL_reglastparen + 1 <= rex->nparens) {
 400             PerlIO_printf(Perl_debug_log,
 401                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
 402                           (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
 403         }
 404     );
 405 #if 1
 406     /* It would seem that the similar code in regtry()
 407      * already takes care of this, and in fact it is in
 408      * a better location to since this code can #if 0-ed out
 409      * but the code in regtry() is needed or otherwise tests
 410      * requiring null fields (pat.t#187 and split.t#{13,14}
 411      * (as of patchlevel 7877)  will fail.  Then again,
 412      * this code seems to be necessary or otherwise
 413      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
 414      * --jhi updated by dapm */
 415     for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
 416         if (i > PL_regsize)
 417             PL_regoffs[i].start = -1;
 418         PL_regoffs[i].end = -1;
 419     }
 420 #endif
 421     return input;
 422 }
 423
 424 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
 425
 426 /*
 427  * pregexec and friends
 428  */
 429
 430 #ifndef PERL_IN_XSUB_RE
 431 /*
 432  - pregexec - match a regexp against a string
 433  */
 434 I32
 435 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
 436          char *strbeg, I32 minend, SV *screamer, U32 nosave)
 437 /* strend: pointer to null at end of string */
 438 /* strbeg: real beginning of string */
 439 /* minend: end of match must be >=minend after stringarg. */
 440 /* nosave: For optimizations. */
 441 {
 442     PERL_ARGS_ASSERT_PREGEXEC;
 443
 444     return
 445         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 446                       nosave ? 0 : REXEC_COPY_STR);
 447 }
 448 #endif
 449
 450 /*
 451  * Need to implement the following flags for reg_anch:
 452  *
 453  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
 454  * USE_INTUIT_ML
 455  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
 456  * INTUIT_AUTORITATIVE_ML
 457  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
 458  * INTUIT_ONCE_ML
 459  *
 460  * Another flag for this function: SECOND_TIME (so that float substrs
 461  * with giant delta may be not rechecked).
 462  */
 463
 464 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 465
 466 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
 467    Otherwise, only SvCUR(sv) is used to get strbeg. */
 468
 469 /* XXXX We assume that strpos is strbeg unless sv. */
 470
 471 /* XXXX Some places assume that there is a fixed substring.
 472         An update may be needed if optimizer marks as "INTUITable"
 473         RExen without fixed substrings.  Similarly, it is assumed that
 474         lengths of all the strings are no more than minlen, thus they
 475         cannot come from lookahead.
 476         (Or minlen should take into account lookahead.)
 477   NOTE: Some of this comment is not correct. minlen does now take account
 478   of lookahead/behind. Further research is required. -- demerphq
 479
 480 */
 481
 482 /* A failure to find a constant substring means that there is no need to make
 483    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 484    finding a substring too deep into the string means that less calls to
 485    regtry() should be needed.
 486
 487    REx compiler's optimizer found 4 possible hints:
 488         a) Anchored substring;
 489         b) Fixed substring;
 490         c) Whether we are anchored (beginning-of-line or \G);
 491         d) First node (of those at offset 0) which may distingush positions;
 492    We use a)b)d) and multiline-part of c), and try to find a position in the
 493    string which does not contradict any of them.
 494  */
 495
 496 /* Most of decisions we do here should have been done at compile time.
 497    The nodes of the REx which we used for the search should have been
 498    deleted from the finite automaton. */
 499
 500 char *
 501 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
 502                      char *strend, const U32 flags, re_scream_pos_data *data)
 503 {
 504     dVAR;
 505     struct regexp *const prog = (struct regexp *)SvANY(rx);
 506     register I32 start_shift = 0;
 507     /* Should be nonnegative! */
 508     register I32 end_shift   = 0;
 509     register char *s;
 510     register SV *check;
 511     char *strbeg;
 512     char *t;
 513     const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
 514     I32 ml_anch;
 515     register char *other_last = NULL;   /* other substr checked before this */
 516     char *check_at = NULL;              /* check substr found at this pos */
 517     const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
 518     RXi_GET_DECL(prog,progi);
 519 #ifdef DEBUGGING
 520     const char * const i_strpos = strpos;
 521 #endif
 522     GET_RE_DEBUG_FLAGS_DECL;
 523
 524     PERL_ARGS_ASSERT_RE_INTUIT_START;
 525
 526     RX_MATCH_UTF8_set(rx,do_utf8);
 527
 528     if (RX_UTF8(rx)) {
 529         PL_reg_flags |= RF_utf8;
 530     }
 531     DEBUG_EXECUTE_r(
 532         debug_start_match(rx, do_utf8, strpos, strend,
 533             sv ? "Guessing start of match in sv for"
 534                : "Guessing start of match in string for");
 535               );
 536
 537     /* CHR_DIST() would be more correct here but it makes things slow. */
 538     if (prog->minlen > strend - strpos) {
 539         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 540                               "String too short... [re_intuit_start]\n"));
 541         goto fail;
 542     }
 543
 544     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
 545     PL_regeol = strend;
 546     if (do_utf8) {
 547         if (!prog->check_utf8 && prog->check_substr)
 548             to_utf8_substr(prog);
 549         check = prog->check_utf8;
 550     } else {
 551         if (!prog->check_substr && prog->check_utf8)
 552             to_byte_substr(prog);
 553         check = prog->check_substr;
 554     }
 555     if (check == &PL_sv_undef) {
 556         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 557                 "Non-utf8 string cannot match utf8 check string\n"));
 558         goto fail;
 559     }
 560     if (prog->extflags & RXf_ANCH) {    /* Match at beg-of-str or after \n */
 561         ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
 562                      || ( (prog->extflags & RXf_ANCH_BOL)
 563                           && !multiline ) );    /* Check after \n? */
 564
 565         if (!ml_anch) {
 566           if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
 567                 && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
 568                /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
 569                && sv && !SvROK(sv)
 570                && (strpos != strbeg)) {
 571               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 572               goto fail;
 573           }
 574           if (prog->check_offset_min == prog->check_offset_max &&
 575               !(prog->extflags & RXf_CANY_SEEN)) {
 576             /* Substring at constant offset from beg-of-str... */
 577             I32 slen;
 578
 579             s = HOP3c(strpos, prog->check_offset_min, strend);
 580
 581             if (SvTAIL(check)) {
 582                 slen = SvCUR(check);    /* >= 1 */
 583
 584                 if ( strend - s > slen || strend - s < slen - 1
 585                      || (strend - s == slen && strend[-1] != '\n')) {
 586                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 587                     goto fail_finish;
 588                 }
 589                 /* Now should match s[0..slen-2] */
 590                 slen--;
 591                 if (slen && (*SvPVX_const(check) != *s
 592                              || (slen > 1
 593                                  && memNE(SvPVX_const(check), s, slen)))) {
 594                   report_neq:
 595                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 596                     goto fail_finish;
 597                 }
 598             }
 599             else if (*SvPVX_const(check) != *s
 600                      || ((slen = SvCUR(check)) > 1
 601                          && memNE(SvPVX_const(check), s, slen)))
 602                 goto report_neq;
 603             check_at = s;
 604             goto success_at_start;
 605           }
 606         }
 607         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 608         s = strpos;
 609         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 610         end_shift = prog->check_end_shift;
 611
 612         if (!ml_anch) {
 613             const I32 end = prog->check_offset_max + CHR_SVLEN(check)
 614                                          - (SvTAIL(check) != 0);
 615             const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 616
 617             if (end_shift < eshift)
 618                 end_shift = eshift;
 619         }
 620     }
 621     else {                              /* Can match at random position */
 622         ml_anch = 0;
 623         s = strpos;
 624         start_shift = prog->check_offset_min;  /* okay to underestimate on CC */
 625         end_shift = prog->check_end_shift;
 626
 627         /* end shift should be non negative here */
 628     }
 629
 630 #ifdef QDEBUGGING       /* 7/99: reports of failure (with the older version) */
 631     if (end_shift < 0)
 632         Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
 633                    (IV)end_shift, RX_PRECOMP(prog));
 634 #endif
 635
 636   restart:
 637     /* Find a possible match in the region s..strend by looking for
 638        the "check" substring in the region corrected by start/end_shift. */
 639
 640     {
 641         I32 srch_start_shift = start_shift;
 642         I32 srch_end_shift = end_shift;
 643         if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
 644             srch_end_shift -= ((strbeg - s) - srch_start_shift);
 645             srch_start_shift = strbeg - s;
 646         }
 647     DEBUG_OPTIMISE_MORE_r({
 648         PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
 649             (IV)prog->check_offset_min,
 650             (IV)srch_start_shift,
 651             (IV)srch_end_shift,
 652             (IV)prog->check_end_shift);
 653     });
 654
 655     if (flags & REXEC_SCREAM) {
 656         I32 p = -1;                     /* Internal iterator of scream. */
 657         I32 * const pp = data ? data->scream_pos : &p;
 658
 659         if (PL_screamfirst[BmRARE(check)] >= 0
 660             || ( BmRARE(check) == '\n'
 661                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
 662                  && SvTAIL(check) ))
 663             s = screaminstr(sv, check,
 664                             srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
 665         else
 666             goto fail_finish;
 667         /* we may be pointing at the wrong string */
 668         if (s && RXp_MATCH_COPIED(prog))
 669             s = strbeg + (s - SvPVX_const(sv));
 670         if (data)
 671             *data->scream_olds = s;
 672     }
 673     else {
 674         U8* start_point;
 675         U8* end_point;
 676         if (prog->extflags & RXf_CANY_SEEN) {
 677             start_point= (U8*)(s + srch_start_shift);
 678             end_point= (U8*)(strend - srch_end_shift);
 679         } else {
 680             start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
 681             end_point= HOP3(strend, -srch_end_shift, strbeg);
 682         }
 683         DEBUG_OPTIMISE_MORE_r({
 684             PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
 685                 (int)(end_point - start_point),
 686                 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
 687                 start_point);
 688         });
 689
 690         s = fbm_instr( start_point, end_point,
 691                       check, multiline ? FBMrf_MULTILINE : 0);
 692     }
 693     }
 694     /* Update the count-of-usability, remove useless subpatterns,
 695         unshift s.  */
 696
 697     DEBUG_EXECUTE_r({
 698         RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 699             SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
 700         PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
 701                           (s ? "Found" : "Did not find"),
 702             (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)
 703                 ? "anchored" : "floating"),
 704             quoted,
 705             RE_SV_TAIL(check),
 706             (s ? " at offset " : "...\n") );
 707     });
 708
 709     if (!s)
 710         goto fail_finish;
 711     /* Finish the diagnostic message */
 712     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 713
 714     /* XXX dmq: first branch is for positive lookbehind...
 715        Our check string is offset from the beginning of the pattern.
 716        So we need to do any stclass tests offset forward from that
 717        point. I think. :-(
 718      */
 719
 720
 721
 722     check_at=s;
 723
 724
 725     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 726        Start with the other substr.
 727        XXXX no SCREAM optimization yet - and a very coarse implementation
 728        XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
 729                 *always* match.  Probably should be marked during compile...
 730        Probably it is right to do no SCREAM here...
 731      */
 732
 733     if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
 734                 : (prog->float_substr && prog->anchored_substr))
 735     {
 736         /* Take into account the "other" substring. */
 737         /* XXXX May be hopelessly wrong for UTF... */
 738         if (!other_last)
 739             other_last = strpos;
 740         if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
 741           do_other_anchored:
 742             {
 743                 char * const last = HOP3c(s, -start_shift, strbeg);
 744                 char *last1, *last2;
 745                 char * const saved_s = s;
 746                 SV* must;
 747
 748                 t = s - prog->check_offset_max;
 749                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 750                     && (!do_utf8
 751                         || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
 752                             && t > strpos)))
 753                     NOOP;
 754                 else
 755                     t = strpos;
 756                 t = HOP3c(t, prog->anchored_offset, strend);
 757                 if (t < other_last)     /* These positions already checked */
 758                     t = other_last;
 759                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 760                 if (last < last1)
 761                     last1 = last;
 762                 /* XXXX It is not documented what units *_offsets are in.
 763                    We assume bytes, but this is clearly wrong.
 764                    Meaning this code needs to be carefully reviewed for errors.
 765                    dmq.
 766                   */
 767
 768                 /* On end-of-str: see comment below. */
 769                 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
 770                 if (must == &PL_sv_undef) {
 771                     s = (char*)NULL;
 772                     DEBUG_r(must = prog->anchored_utf8);        /* for debug */
 773                 }
 774                 else
 775                     s = fbm_instr(
 776                         (unsigned char*)t,
 777                         HOP3(HOP3(last1, prog->anchored_offset, strend)
 778                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
 779                         must,
 780                         multiline ? FBMrf_MULTILINE : 0
 781                     );
 782                 DEBUG_EXECUTE_r({
 783                     RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 784                         SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 785                     PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
 786                         (s ? "Found" : "Contradicts"),
 787                         quoted, RE_SV_TAIL(must));
 788                 });
 789
 790
 791                 if (!s) {
 792                     if (last1 >= last2) {
 793                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 794                                                 ", giving up...\n"));
 795                         goto fail_finish;
 796                     }
 797                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 798                         ", trying floating at offset %ld...\n",
 799                         (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
 800                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 801                     s = HOP3c(last, 1, strend);
 802                     goto restart;
 803                 }
 804                 else {
 805                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 806                           (long)(s - i_strpos)));
 807                     t = HOP3c(s, -prog->anchored_offset, strbeg);
 808                     other_last = HOP3c(s, 1, strend);
 809                     s = saved_s;
 810                     if (t == strpos)
 811                         goto try_at_start;
 812                     goto try_at_offset;
 813                 }
 814             }
 815         }
 816         else {          /* Take into account the floating substring. */
 817             char *last, *last1;
 818             char * const saved_s = s;
 819             SV* must;
 820
 821             t = HOP3c(s, -start_shift, strbeg);
 822             last1 = last =
 823                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 824             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 825                 last = HOP3c(t, prog->float_max_offset, strend);
 826             s = HOP3c(t, prog->float_min_offset, strend);
 827             if (s < other_last)
 828                 s = other_last;
 829  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 830             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
 831             /* fbm_instr() takes into account exact value of end-of-str
 832                if the check is SvTAIL(ed).  Since false positives are OK,
 833                and end-of-str is not later than strend we are OK. */
 834             if (must == &PL_sv_undef) {
 835                 s = (char*)NULL;
 836                 DEBUG_r(must = prog->float_utf8);       /* for debug message */
 837             }
 838             else
 839                 s = fbm_instr((unsigned char*)s,
 840                               (unsigned char*)last + SvCUR(must)
 841                                   - (SvTAIL(must)!=0),
 842                               must, multiline ? FBMrf_MULTILINE : 0);
 843             DEBUG_EXECUTE_r({
 844                 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 845                     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 846                 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
 847                     (s ? "Found" : "Contradicts"),
 848                     quoted, RE_SV_TAIL(must));
 849             });
 850             if (!s) {
 851                 if (last1 == last) {
 852                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 853                                             ", giving up...\n"));
 854                     goto fail_finish;
 855                 }
 856                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 857                     ", trying anchored starting at offset %ld...\n",
 858                     (long)(saved_s + 1 - i_strpos)));
 859                 other_last = last;
 860                 s = HOP3c(t, 1, strend);
 861                 goto restart;
 862             }
 863             else {
 864                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 865                       (long)(s - i_strpos)));
 866                 other_last = s; /* Fix this later. --Hugo */
 867                 s = saved_s;
 868                 if (t == strpos)
 869                     goto try_at_start;
 870                 goto try_at_offset;
 871             }
 872         }
 873     }
 874
 875
 876     t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
 877
 878     DEBUG_OPTIMISE_MORE_r(
 879         PerlIO_printf(Perl_debug_log,
 880             "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
 881             (IV)prog->check_offset_min,
 882             (IV)prog->check_offset_max,
 883             (IV)(s-strpos),
 884             (IV)(t-strpos),
 885             (IV)(t-s),
 886             (IV)(strend-strpos)
 887         )
 888     );
 889
 890     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 891         && (!do_utf8
 892             || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
 893                  && t > strpos)))
 894     {
 895         /* Fixed substring is found far enough so that the match
 896            cannot start at strpos. */
 897       try_at_offset:
 898         if (ml_anch && t[-1] != '\n') {
 899             /* Eventually fbm_*() should handle this, but often
 900                anchored_offset is not 0, so this check will not be wasted. */
 901             /* XXXX In the code below we prefer to look for "^" even in
 902                presence of anchored substrings.  And we search even
 903                beyond the found float position.  These pessimizations
 904                are historical artefacts only.  */
 905           find_anchor:
 906             while (t < strend - prog->minlen) {
 907                 if (*t == '\n') {
 908                     if (t < check_at - prog->check_offset_min) {
 909                         if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
 910                             /* Since we moved from the found position,
 911                                we definitely contradict the found anchored
 912                                substr.  Due to the above check we do not
 913                                contradict "check" substr.
 914                                Thus we can arrive here only if check substr
 915                                is float.  Redo checking for "other"=="fixed".
 916                              */
 917                             strpos = t + 1;
 918                             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
 919                                 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
 920                             goto do_other_anchored;
 921                         }
 922                         /* We don't contradict the found floating substring. */
 923                         /* XXXX Why not check for STCLASS? */
 924                         s = t + 1;
 925                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
 926                             PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
 927                         goto set_useful;
 928                     }
 929                     /* Position contradicts check-string */
 930                     /* XXXX probably better to look for check-string
 931                        than for "\n", so one should lower the limit for t? */
 932                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
 933                         PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
 934                     other_last = strpos = s = t + 1;
 935                     goto restart;
 936                 }
 937                 t++;
 938             }
 939             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
 940                         PL_colors[0], PL_colors[1]));
 941             goto fail_finish;
 942         }
 943         else {
 944             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
 945                         PL_colors[0], PL_colors[1]));
 946         }
 947         s = t;
 948       set_useful:
 949         ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr);    /* hooray/5 */
 950     }
 951     else {
 952         /* The found string does not prohibit matching at strpos,
 953            - no optimization of calling REx engine can be performed,
 954            unless it was an MBOL and we are not after MBOL,
 955            or a future STCLASS check will fail this. */
 956       try_at_start:
 957         /* Even in this situation we may use MBOL flag if strpos is offset
 958            wrt the start of the string. */
 959         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
 960             && (strpos != strbeg) && strpos[-1] != '\n'
 961             /* May be due to an implicit anchor of m{.*foo}  */
 962             && !(prog->intflags & PREGf_IMPLICIT))
 963         {
 964             t = strpos;
 965             goto find_anchor;
 966         }
 967         DEBUG_EXECUTE_r( if (ml_anch)
 968             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
 969                           (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
 970         );
 971       success_at_start:
 972         if (!(prog->intflags & PREGf_NAUGHTY)   /* XXXX If strpos moved? */
 973             && (do_utf8 ? (
 974                 prog->check_utf8                /* Could be deleted already */
 975                 && --BmUSEFUL(prog->check_utf8) < 0
 976                 && (prog->check_utf8 == prog->float_utf8)
 977             ) : (
 978                 prog->check_substr              /* Could be deleted already */
 979                 && --BmUSEFUL(prog->check_substr) < 0
 980                 && (prog->check_substr == prog->float_substr)
 981             )))
 982         {
 983             /* If flags & SOMETHING - do not do it many times on the same match */
 984             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
 985             /* XXX Does the destruction order has to change with do_utf8? */
 986             SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
 987             SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
 988             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
 989             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
 990             check = NULL;                       /* abort */
 991             s = strpos;
 992             /* XXXX This is a remnant of the old implementation.  It
 993                     looks wasteful, since now INTUIT can use many
 994                     other heuristics. */
 995             prog->extflags &= ~RXf_USE_INTUIT;
 996         }
 997         else
 998             s = strpos;
 999     }
1000
1001     /* Last resort... */
1002     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
1003     /* trie stclasses are too expensive to use here, we are better off to
1004        leave it to regmatch itself */
1005     if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1006         /* minlen == 0 is possible if regstclass is \b or \B,
1007            and the fixed substr is ''$.
1008            Since minlen is already taken into account, s+1 is before strend;
1009            accidentally, minlen >= 1 guaranties no false positives at s + 1
1010            even for \b or \B.  But (minlen? 1 : 0) below assumes that
1011            regstclass does not come from lookahead...  */
1012         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
1013            This leaves EXACTF only, which is dealt with in find_byclass().  */
1014         const U8* const str = (U8*)STRING(progi->regstclass);
1015         const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1016                     ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
1017                     : 1);
1018         char * endpos;
1019         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1020             endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
1021         else if (prog->float_substr || prog->float_utf8)
1022             endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
1023         else
1024             endpos= strend;
1025
1026         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
1027                                       (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
1028
1029         t = s;
1030         s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
1031         if (!s) {
1032 #ifdef DEBUGGING
1033             const char *what = NULL;
1034 #endif
1035             if (endpos == strend) {
1036                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1037                                 "Could not match STCLASS...\n") );
1038                 goto fail;
1039             }
1040             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1041                                    "This position contradicts STCLASS...\n") );
1042             if ((prog->extflags & RXf_ANCH) && !ml_anch)
1043                 goto fail;
1044             /* Contradict one of substrings */
1045             if (prog->anchored_substr || prog->anchored_utf8) {
1046                 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
1047                     DEBUG_EXECUTE_r( what = "anchored" );
1048                   hop_and_restart:
1049                     s = HOP3c(t, 1, strend);
1050                     if (s + start_shift + end_shift > strend) {
1051                         /* XXXX Should be taken into account earlier? */
1052                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1053                                                "Could not match STCLASS...\n") );
1054                         goto fail;
1055                     }
1056                     if (!check)
1057                         goto giveup;
1058                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1059                                 "Looking for %s substr starting at offset %ld...\n",
1060                                  what, (long)(s + start_shift - i_strpos)) );
1061                     goto restart;
1062                 }
1063                 /* Have both, check_string is floating */
1064                 if (t + start_shift >= check_at) /* Contradicts floating=check */
1065                     goto retry_floating_check;
1066                 /* Recheck anchored substring, but not floating... */
1067                 s = check_at;
1068                 if (!check)
1069                     goto giveup;
1070                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1071                           "Looking for anchored substr starting at offset %ld...\n",
1072                           (long)(other_last - i_strpos)) );
1073                 goto do_other_anchored;
1074             }
1075             /* Another way we could have checked stclass at the
1076                current position only: */
1077             if (ml_anch) {
1078                 s = t = t + 1;
1079                 if (!check)
1080                     goto giveup;
1081                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1082                           "Looking for /%s^%s/m starting at offset %ld...\n",
1083                           PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
1084                 goto try_at_offset;
1085             }
1086             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))     /* Could have been deleted */
1087                 goto fail;
1088             /* Check is floating subtring. */
1089           retry_floating_check:
1090             t = check_at - start_shift;
1091             DEBUG_EXECUTE_r( what = "floating" );
1092             goto hop_and_restart;
1093         }
1094         if (t != s) {
1095             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1096                         "By STCLASS: moving %ld --> %ld\n",
1097                                   (long)(t - i_strpos), (long)(s - i_strpos))
1098                    );
1099         }
1100         else {
1101             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1102                                   "Does not contradict STCLASS...\n");
1103                    );
1104         }
1105     }
1106   giveup:
1107     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
1108                           PL_colors[4], (check ? "Guessed" : "Giving up"),
1109                           PL_colors[5], (long)(s - i_strpos)) );
1110     return s;
1111
1112   fail_finish:                          /* Substring not found */
1113     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
1114         BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1115   fail:
1116     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1117                           PL_colors[4], PL_colors[5]));
1118     return NULL;
1119 }
1120
1121 #define DECL_TRIE_TYPE(scan) \
1122     const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
1123                     trie_type = (scan->flags != EXACT) \
1124                               ? (do_utf8 ? trie_utf8_fold : (UTF ? trie_latin_utf8_fold : trie_plain)) \
1125                               : (do_utf8 ? trie_utf8 : trie_plain)
1126
1127 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len,  \
1128 uvc, charid, foldlen, foldbuf, uniflags) STMT_START {                       \
1129     switch (trie_type) {                                                    \
1130     case trie_utf8_fold:                                                    \
1131         if ( foldlen>0 ) {                                                  \
1132             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1133             foldlen -= len;                                                 \
1134             uscan += len;                                                   \
1135             len=0;                                                          \
1136         } else {                                                            \
1137             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1138             uvc = to_uni_fold( uvc, foldbuf, &foldlen );                    \
1139             foldlen -= UNISKIP( uvc );                                      \
1140             uscan = foldbuf + UNISKIP( uvc );                               \
1141         }                                                                   \
1142         break;                                                              \
1143     case trie_latin_utf8_fold:                                              \
1144         if ( foldlen>0 ) {                                                  \
1145             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );     \
1146             foldlen -= len;                                                 \
1147             uscan += len;                                                   \
1148             len=0;                                                          \
1149         } else {                                                            \
1150             len = 1;                                                        \
1151             uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen );               \
1152             foldlen -= UNISKIP( uvc );                                      \
1153             uscan = foldbuf + UNISKIP( uvc );                               \
1154         }                                                                   \
1155         break;                                                              \
1156     case trie_utf8:                                                         \
1157         uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );       \
1158         break;                                                              \
1159     case trie_plain:                                                        \
1160         uvc = (UV)*uc;                                                      \
1161         len = 1;                                                            \
1162     }                                                                       \
1163     if (uvc < 256) {                                                        \
1164         charid = trie->charmap[ uvc ];                                      \
1165     }                                                                       \
1166     else {                                                                  \
1167         charid = 0;                                                         \
1168         if (widecharmap) {                                                  \
1169             SV** const svpp = hv_fetch(widecharmap,                         \
1170                         (char*)&uvc, sizeof(UV), 0);                        \
1171             if (svpp)                                                       \
1172                 charid = (U16)SvIV(*svpp);                                  \
1173         }                                                                   \
1174     }                                                                       \
1175 } STMT_END
1176
1177 #define REXEC_FBC_EXACTISH_CHECK(CoNd)                 \
1178 {                                                      \
1179     char *my_strend= (char *)strend;                   \
1180     if ( (CoNd)                                        \
1181          && (ln == len ||                              \
1182              !ibcmp_utf8(s, &my_strend, 0,  do_utf8,   \
1183                         m, NULL, ln, (bool)UTF))       \
1184          && (!reginfo || regtry(reginfo, &s)) )        \
1185         goto got_it;                                   \
1186     else {                                             \
1187          U8 foldbuf[UTF8_MAXBYTES_CASE+1];             \
1188          uvchr_to_utf8(tmpbuf, c);                     \
1189          f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);  \
1190          if ( f != c                                   \
1191               && (f == c1 || f == c2)                  \
1192               && (ln == len ||                         \
1193                 !ibcmp_utf8(s, &my_strend, 0,  do_utf8,\
1194                               m, NULL, ln, (bool)UTF)) \
1195               && (!reginfo || regtry(reginfo, &s)) )   \
1196               goto got_it;                             \
1197     }                                                  \
1198 }                                                      \
1199 s += len
1200
1201 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1202 STMT_START {                                              \
1203     while (s <= e) {                                      \
1204         if ( (CoNd)                                       \
1205              && (ln == 1 || !(OP(c) == EXACTF             \
1206                               ? ibcmp(s, m, ln)           \
1207                               : ibcmp_locale(s, m, ln)))  \
1208              && (!reginfo || regtry(reginfo, &s)) )        \
1209             goto got_it;                                  \
1210         s++;                                              \
1211     }                                                     \
1212 } STMT_END
1213
1214 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1215 STMT_START {                                          \
1216     while (s + (uskip = UTF8SKIP(s)) <= strend) {     \
1217         CoDe                                          \
1218         s += uskip;                                   \
1219     }                                                 \
1220 } STMT_END
1221
1222 #define REXEC_FBC_SCAN(CoDe)                          \
1223 STMT_START {                                          \
1224     while (s < strend) {                              \
1225         CoDe                                          \
1226         s++;                                          \
1227     }                                                 \
1228 } STMT_END
1229
1230 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1231 REXEC_FBC_UTF8_SCAN(                                  \
1232     if (CoNd) {                                       \
1233         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1234             goto got_it;                              \
1235         else                                          \
1236             tmp = doevery;                            \
1237     }                                                 \
1238     else                                              \
1239         tmp = 1;                                      \
1240 )
1241
1242 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1243 REXEC_FBC_SCAN(                                       \
1244     if (CoNd) {                                       \
1245         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1246             goto got_it;                              \
1247         else                                          \
1248             tmp = doevery;                            \
1249     }                                                 \
1250     else                                              \
1251         tmp = 1;                                      \
1252 )
1253
1254 #define REXEC_FBC_TRYIT               \
1255 if ((!reginfo || regtry(reginfo, &s))) \
1256     goto got_it
1257
1258 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd)                         \
1259     if (do_utf8) {                                             \
1260         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1261     }                                                          \
1262     else {                                                     \
1263         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1264     }                                                          \
1265     break
1266
1267 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd)      \
1268     if (do_utf8) {                                             \
1269         UtFpReLoAd;                                            \
1270         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1271     }                                                          \
1272     else {                                                     \
1273         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1274     }                                                          \
1275     break
1276
1277 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd)                   \
1278     PL_reg_flags |= RF_tainted;                                \
1279     if (do_utf8) {                                             \
1280         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1281     }                                                          \
1282     else {                                                     \
1283         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1284     }                                                          \
1285     break
1286
1287 #define DUMP_EXEC_POS(li,s,doutf8) \
1288     dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1289
1290 /* We know what class REx starts with.  Try to find this position... */
1291 /* if reginfo is NULL, its a dryrun */
1292 /* annoyingly all the vars in this routine have different names from their counterparts
1293    in regmatch. /grrr */
1294
1295 STATIC char *
1296 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1297     const char *strend, regmatch_info *reginfo)
1298 {
1299         dVAR;
1300         const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1301         char *m;
1302         STRLEN ln;
1303         STRLEN lnc;
1304         register STRLEN uskip;
1305         unsigned int c1;
1306         unsigned int c2;
1307         char *e;
1308         register I32 tmp = 1;   /* Scratch variable? */
1309         register const bool do_utf8 = PL_reg_match_utf8;
1310         RXi_GET_DECL(prog,progi);
1311
1312         PERL_ARGS_ASSERT_FIND_BYCLASS;
1313
1314         /* We know what class it must start with. */
1315         switch (OP(c)) {
1316         case ANYOF:
1317             if (do_utf8) {
1318                  REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1319                           !UTF8_IS_INVARIANT((U8)s[0]) ?
1320                           reginclass(prog, c, (U8*)s, 0, do_utf8) :
1321                           REGINCLASS(prog, c, (U8*)s));
1322             }
1323             else {
1324                  while (s < strend) {
1325                       STRLEN skip = 1;
1326
1327                       if (REGINCLASS(prog, c, (U8*)s) ||
1328                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1329                            /* The assignment of 2 is intentional:
1330                             * for the folded sharp s, the skip is 2. */
1331                            (skip = SHARP_S_SKIP))) {
1332                            if (tmp && (!reginfo || regtry(reginfo, &s)))
1333                                 goto got_it;
1334                            else
1335                                 tmp = doevery;
1336                       }
1337                       else
1338                            tmp = 1;
1339                       s += skip;
1340                  }
1341             }
1342             break;
1343         case CANY:
1344             REXEC_FBC_SCAN(
1345                 if (tmp && (!reginfo || regtry(reginfo, &s)))
1346                     goto got_it;
1347                 else
1348                     tmp = doevery;
1349             );
1350             break;
1351         case EXACTF:
1352             m   = STRING(c);
1353             ln  = STR_LEN(c);   /* length to match in octets/bytes */
1354             lnc = (I32) ln;     /* length to match in characters */
1355             if (UTF) {
1356                 STRLEN ulen1, ulen2;
1357                 U8 *sm = (U8 *) m;
1358                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1359                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1360                 /* used by commented-out code below */
1361                 /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1362
1363                 /* XXX: Since the node will be case folded at compile
1364                    time this logic is a little odd, although im not
1365                    sure that its actually wrong. --dmq */
1366
1367                 c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1368                 c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1369
1370                 /* XXX: This is kinda strange. to_utf8_XYZ returns the
1371                    codepoint of the first character in the converted
1372                    form, yet originally we did the extra step.
1373                    No tests fail by commenting this code out however
1374                    so Ive left it out. -- dmq.
1375
1376                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1377                                     0, uniflags);
1378                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1379                                     0, uniflags);
1380                 */
1381
1382                 lnc = 0;
1383                 while (sm < ((U8 *) m + ln)) {
1384                     lnc++;
1385                     sm += UTF8SKIP(sm);
1386                 }
1387             }
1388             else {
1389                 c1 = *(U8*)m;
1390                 c2 = PL_fold[c1];
1391             }
1392             goto do_exactf;
1393         case EXACTFL:
1394             m   = STRING(c);
1395             ln  = STR_LEN(c);
1396             lnc = (I32) ln;
1397             c1 = *(U8*)m;
1398             c2 = PL_fold_locale[c1];
1399           do_exactf:
1400             e = HOP3c(strend, -((I32)lnc), s);
1401
1402             if (!reginfo && e < s)
1403                 e = s;                  /* Due to minlen logic of intuit() */
1404
1405             /* The idea in the EXACTF* cases is to first find the
1406              * first character of the EXACTF* node and then, if
1407              * necessary, case-insensitively compare the full
1408              * text of the node.  The c1 and c2 are the first
1409              * characters (though in Unicode it gets a bit
1410              * more complicated because there are more cases
1411              * than just upper and lower: one needs to use
1412              * the so-called folding case for case-insensitive
1413              * matching (called "loose matching" in Unicode).
1414              * ibcmp_utf8() will do just that. */
1415
1416             if (do_utf8 || UTF) {
1417                 UV c, f;
1418                 U8 tmpbuf [UTF8_MAXBYTES+1];
1419                 STRLEN len = 1;
1420                 STRLEN foldlen;
1421                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1422                 if (c1 == c2) {
1423                     /* Upper and lower of 1st char are equal -
1424                      * probably not a "letter". */
1425                     while (s <= e) {
1426                         if (do_utf8) {
1427                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1428                                            uniflags);
1429                         } else {
1430                             c = *((U8*)s);
1431                         }
1432                         REXEC_FBC_EXACTISH_CHECK(c == c1);
1433                     }
1434                 }
1435                 else {
1436                     while (s <= e) {
1437                         if (do_utf8) {
1438                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1439                                            uniflags);
1440                         } else {
1441                             c = *((U8*)s);
1442                         }
1443
1444                         /* Handle some of the three Greek sigmas cases.
1445                          * Note that not all the possible combinations
1446                          * are handled here: some of them are handled
1447                          * by the standard folding rules, and some of
1448                          * them (the character class or ANYOF cases)
1449                          * are handled during compiletime in
1450                          * regexec.c:S_regclass(). */
1451                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1452                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1453                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1454
1455                         REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1456                     }
1457                 }
1458             }
1459             else {
1460                 /* Neither pattern nor string are UTF8 */
1461                 if (c1 == c2)
1462                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1463                 else
1464                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1465             }
1466             break;
1467         case BOUNDL:
1468             PL_reg_flags |= RF_tainted;
1469             /* FALL THROUGH */
1470         case BOUND:
1471             if (do_utf8) {
1472                 if (s == PL_bostr)
1473                     tmp = '\n';
1474                 else {
1475                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1476                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1477                 }
1478                 tmp = ((OP(c) == BOUND ?
1479                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1480                 LOAD_UTF8_CHARCLASS_ALNUM();
1481                 REXEC_FBC_UTF8_SCAN(
1482                     if (tmp == !(OP(c) == BOUND ?
1483                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1484                                  isALNUM_LC_utf8((U8*)s)))
1485                     {
1486                         tmp = !tmp;
1487                         REXEC_FBC_TRYIT;
1488                 }
1489                 );
1490             }
1491             else {
1492                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1493                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1494                 REXEC_FBC_SCAN(
1495                     if (tmp ==
1496                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1497                         tmp = !tmp;
1498                         REXEC_FBC_TRYIT;
1499                 }
1500                 );
1501             }
1502             if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1503                 goto got_it;
1504             break;
1505         case NBOUNDL:
1506             PL_reg_flags |= RF_tainted;
1507             /* FALL THROUGH */
1508         case NBOUND:
1509             if (do_utf8) {
1510                 if (s == PL_bostr)
1511                     tmp = '\n';
1512                 else {
1513                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1514                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1515                 }
1516                 tmp = ((OP(c) == NBOUND ?
1517                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1518                 LOAD_UTF8_CHARCLASS_ALNUM();
1519                 REXEC_FBC_UTF8_SCAN(
1520                     if (tmp == !(OP(c) == NBOUND ?
1521                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1522                                  isALNUM_LC_utf8((U8*)s)))
1523                         tmp = !tmp;
1524                     else REXEC_FBC_TRYIT;
1525                 );
1526             }
1527             else {
1528                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1529                 tmp = ((OP(c) == NBOUND ?
1530                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1531                 REXEC_FBC_SCAN(
1532                     if (tmp ==
1533                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1534                         tmp = !tmp;
1535                     else REXEC_FBC_TRYIT;
1536                 );
1537             }
1538             if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1539                 goto got_it;
1540             break;
1541         case ALNUM:
1542             REXEC_FBC_CSCAN_PRELOAD(
1543                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1544                 swash_fetch(RE_utf8_perl_word, (U8*)s, do_utf8),
1545                 isALNUM(*s)
1546             );
1547         case ALNUML:
1548             REXEC_FBC_CSCAN_TAINT(
1549                 isALNUM_LC_utf8((U8*)s),
1550                 isALNUM_LC(*s)
1551             );
1552         case NALNUM:
1553             REXEC_FBC_CSCAN_PRELOAD(
1554                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1555                 !swash_fetch(RE_utf8_perl_word, (U8*)s, do_utf8),
1556                 !isALNUM(*s)
1557             );
1558         case NALNUML:
1559             REXEC_FBC_CSCAN_TAINT(
1560                 !isALNUM_LC_utf8((U8*)s),
1561                 !isALNUM_LC(*s)
1562             );
1563         case SPACE:
1564             REXEC_FBC_CSCAN_PRELOAD(
1565                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1566                 *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, do_utf8),
1567                 isSPACE(*s)
1568             );
1569         case SPACEL:
1570             REXEC_FBC_CSCAN_TAINT(
1571                 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1572                 isSPACE_LC(*s)
1573             );
1574         case NSPACE:
1575             REXEC_FBC_CSCAN_PRELOAD(
1576                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1577                 !(*s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, do_utf8)),
1578                 !isSPACE(*s)
1579             );
1580         case NSPACEL:
1581             REXEC_FBC_CSCAN_TAINT(
1582                 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1583                 !isSPACE_LC(*s)
1584             );
1585         case DIGIT:
1586             REXEC_FBC_CSCAN_PRELOAD(
1587                 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1588                 swash_fetch(RE_utf8_posix_digit,(U8*)s, do_utf8),
1589                 isDIGIT(*s)
1590             );
1591         case DIGITL:
1592             REXEC_FBC_CSCAN_TAINT(
1593                 isDIGIT_LC_utf8((U8*)s),
1594                 isDIGIT_LC(*s)
1595             );
1596         case NDIGIT:
1597             REXEC_FBC_CSCAN_PRELOAD(
1598                 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1599                 !swash_fetch(RE_utf8_posix_digit,(U8*)s, do_utf8),
1600                 !isDIGIT(*s)
1601             );
1602         case NDIGITL:
1603             REXEC_FBC_CSCAN_TAINT(
1604                 !isDIGIT_LC_utf8((U8*)s),
1605                 !isDIGIT_LC(*s)
1606             );
1607         case LNBREAK:
1608             REXEC_FBC_CSCAN(
1609                 is_LNBREAK_utf8(s),
1610                 is_LNBREAK_latin1(s)
1611             );
1612         case VERTWS:
1613             REXEC_FBC_CSCAN(
1614                 is_VERTWS_utf8(s),
1615                 is_VERTWS_latin1(s)
1616             );
1617         case NVERTWS:
1618             REXEC_FBC_CSCAN(
1619                 !is_VERTWS_utf8(s),
1620                 !is_VERTWS_latin1(s)
1621             );
1622         case HORIZWS:
1623             REXEC_FBC_CSCAN(
1624                 is_HORIZWS_utf8(s),
1625                 is_HORIZWS_latin1(s)
1626             );
1627         case NHORIZWS:
1628             REXEC_FBC_CSCAN(
1629                 !is_HORIZWS_utf8(s),
1630                 !is_HORIZWS_latin1(s)
1631             );
1632         case AHOCORASICKC:
1633         case AHOCORASICK:
1634             {
1635                 DECL_TRIE_TYPE(c);
1636                 /* what trie are we using right now */
1637                 reg_ac_data *aho
1638                     = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1639                 reg_trie_data *trie
1640                     = (reg_trie_data*)progi->data->data[ aho->trie ];
1641                 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1642
1643                 const char *last_start = strend - trie->minlen;
1644 #ifdef DEBUGGING
1645                 const char *real_start = s;
1646 #endif
1647                 STRLEN maxlen = trie->maxlen;
1648                 SV *sv_points;
1649                 U8 **points; /* map of where we were in the input string
1650                                 when reading a given char. For ASCII this
1651                                 is unnecessary overhead as the relationship
1652                                 is always 1:1, but for Unicode, especially
1653                                 case folded Unicode this is not true. */
1654                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1655                 U8 *bitmap=NULL;
1656
1657
1658                 GET_RE_DEBUG_FLAGS_DECL;
1659
1660                 /* We can't just allocate points here. We need to wrap it in
1661                  * an SV so it gets freed properly if there is a croak while
1662                  * running the match */
1663                 ENTER;
1664                 SAVETMPS;
1665                 sv_points=newSV(maxlen * sizeof(U8 *));
1666                 SvCUR_set(sv_points,
1667                     maxlen * sizeof(U8 *));
1668                 SvPOK_on(sv_points);
1669                 sv_2mortal(sv_points);
1670                 points=(U8**)SvPV_nolen(sv_points );
1671                 if ( trie_type != trie_utf8_fold
1672                      && (trie->bitmap || OP(c)==AHOCORASICKC) )
1673                 {
1674                     if (trie->bitmap)
1675                         bitmap=(U8*)trie->bitmap;
1676                     else
1677                         bitmap=(U8*)ANYOF_BITMAP(c);
1678                 }
1679                 /* this is the Aho-Corasick algorithm modified a touch
1680                    to include special handling for long "unknown char"
1681                    sequences. The basic idea being that we use AC as long
1682                    as we are dealing with a possible matching char, when
1683                    we encounter an unknown char (and we have not encountered
1684                    an accepting state) we scan forward until we find a legal
1685                    starting char.
1686                    AC matching is basically that of trie matching, except
1687                    that when we encounter a failing transition, we fall back
1688                    to the current states "fail state", and try the current char
1689                    again, a process we repeat until we reach the root state,
1690                    state 1, or a legal transition. If we fail on the root state
1691                    then we can either terminate if we have reached an accepting
1692                    state previously, or restart the entire process from the beginning
1693                    if we have not.
1694
1695                  */
1696                 while (s <= last_start) {
1697                     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1698                     U8 *uc = (U8*)s;
1699                     U16 charid = 0;
1700                     U32 base = 1;
1701                     U32 state = 1;
1702                     UV uvc = 0;
1703                     STRLEN len = 0;
1704                     STRLEN foldlen = 0;
1705                     U8 *uscan = (U8*)NULL;
1706                     U8 *leftmost = NULL;
1707 #ifdef DEBUGGING
1708                     U32 accepted_word= 0;
1709 #endif
1710                     U32 pointpos = 0;
1711
1712                     while ( state && uc <= (U8*)strend ) {
1713                         int failed=0;
1714                         U32 word = aho->states[ state ].wordnum;
1715
1716                         if( state==1 ) {
1717                             if ( bitmap ) {
1718                                 DEBUG_TRIE_EXECUTE_r(
1719                                     if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1720                                         dump_exec_pos( (char *)uc, c, strend, real_start,
1721                                             (char *)uc, do_utf8 );
1722                                         PerlIO_printf( Perl_debug_log,
1723                                             " Scanning for legal start char...\n");
1724                                     }
1725                                 );
1726                                 while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1727                                     uc++;
1728                                 }
1729                                 s= (char *)uc;
1730                             }
1731                             if (uc >(U8*)last_start) break;
1732                         }
1733
1734                         if ( word ) {
1735                             U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1736                             if (!leftmost || lpos < leftmost) {
1737                                 DEBUG_r(accepted_word=word);
1738                                 leftmost= lpos;
1739                             }
1740                             if (base==0) break;
1741
1742                         }
1743                         points[pointpos++ % maxlen]= uc;
1744                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1745                                              uscan, len, uvc, charid, foldlen,
1746                                              foldbuf, uniflags);
1747                         DEBUG_TRIE_EXECUTE_r({
1748                             dump_exec_pos( (char *)uc, c, strend, real_start,
1749                                 s,   do_utf8 );
1750                             PerlIO_printf(Perl_debug_log,
1751                                 " Charid:%3u CP:%4"UVxf" ",
1752                                  charid, uvc);
1753                         });
1754
1755                         do {
1756 #ifdef DEBUGGING
1757                             word = aho->states[ state ].wordnum;
1758 #endif
1759                             base = aho->states[ state ].trans.base;
1760
1761                             DEBUG_TRIE_EXECUTE_r({
1762                                 if (failed)
1763                                     dump_exec_pos( (char *)uc, c, strend, real_start,
1764                                         s,   do_utf8 );
1765                                 PerlIO_printf( Perl_debug_log,
1766                                     "%sState: %4"UVxf", word=%"UVxf,
1767                                     failed ? " Fail transition to " : "",
1768                                     (UV)state, (UV)word);
1769                             });
1770                             if ( base ) {
1771                                 U32 tmp;
1772                                 if (charid &&
1773                                      (base + charid > trie->uniquecharcount )
1774                                      && (base + charid - 1 - trie->uniquecharcount
1775                                             < trie->lasttrans)
1776                                      && trie->trans[base + charid - 1 -
1777                                             trie->uniquecharcount].check == state
1778                                      && (tmp=trie->trans[base + charid - 1 -
1779                                         trie->uniquecharcount ].next))
1780                                 {
1781                                     DEBUG_TRIE_EXECUTE_r(
1782                                         PerlIO_printf( Perl_debug_log," - legal\n"));
1783                                     state = tmp;
1784                                     break;
1785                                 }
1786                                 else {
1787                                     DEBUG_TRIE_EXECUTE_r(
1788                                         PerlIO_printf( Perl_debug_log," - fail\n"));
1789                                     failed = 1;
1790                                     state = aho->fail[state];
1791                                 }
1792                             }
1793                             else {
1794                                 /* we must be accepting here */
1795                                 DEBUG_TRIE_EXECUTE_r(
1796                                         PerlIO_printf( Perl_debug_log," - accepting\n"));
1797                                 failed = 1;
1798                                 break;
1799                             }
1800                         } while(state);
1801                         uc += len;
1802                         if (failed) {
1803                             if (leftmost)
1804                                 break;
1805                             if (!state) state = 1;
1806                         }
1807                     }
1808                     if ( aho->states[ state ].wordnum ) {
1809                         U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1810                         if (!leftmost || lpos < leftmost) {
1811                             DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1812                             leftmost = lpos;
1813                         }
1814                     }
1815                     if (leftmost) {
1816                         s = (char*)leftmost;
1817                         DEBUG_TRIE_EXECUTE_r({
1818                             PerlIO_printf(
1819                                 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1820                                 (UV)accepted_word, (IV)(s - real_start)
1821                             );
1822                         });
1823                         if (!reginfo || regtry(reginfo, &s)) {
1824                             FREETMPS;
1825                             LEAVE;
1826                             goto got_it;
1827                         }
1828                         s = HOPc(s,1);
1829                         DEBUG_TRIE_EXECUTE_r({
1830                             PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1831                         });
1832                     } else {
1833                         DEBUG_TRIE_EXECUTE_r(
1834                             PerlIO_printf( Perl_debug_log,"No match.\n"));
1835                         break;
1836                     }
1837                 }
1838                 FREETMPS;
1839                 LEAVE;
1840             }
1841             break;
1842         default:
1843             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1844             break;
1845         }
1846         return 0;
1847       got_it:
1848         return s;
1849 }
1850
1851
1852 /*
1853  - regexec_flags - match a regexp against a string
1854  */
1855 I32
1856 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
1857               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1858 /* strend: pointer to null at end of string */
1859 /* strbeg: real beginning of string */
1860 /* minend: end of match must be >=minend after stringarg. */
1861 /* data: May be used for some additional optimizations.
1862          Currently its only used, with a U32 cast, for transmitting
1863          the ganch offset when doing a /g match. This will change */
1864 /* nosave: For optimizations. */
1865 {
1866     dVAR;
1867     struct regexp *const prog = (struct regexp *)SvANY(rx);
1868     /*register*/ char *s;
1869     register regnode *c;
1870     /*register*/ char *startpos = stringarg;
1871     I32 minlen;         /* must match at least this many chars */
1872     I32 dontbother = 0; /* how many characters not to try at end */
1873     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1874     I32 scream_pos = -1;                /* Internal iterator of scream. */
1875     char *scream_olds = NULL;
1876     const bool do_utf8 = (bool)DO_UTF8(sv);
1877     I32 multiline;
1878     RXi_GET_DECL(prog,progi);
1879     regmatch_info reginfo;  /* create some info to pass to regtry etc */
1880     regexp_paren_pair *swap = NULL;
1881     GET_RE_DEBUG_FLAGS_DECL;
1882
1883     PERL_ARGS_ASSERT_REGEXEC_FLAGS;
1884     PERL_UNUSED_ARG(data);
1885
1886     /* Be paranoid... */
1887     if (prog == NULL || startpos == NULL) {
1888         Perl_croak(aTHX_ "NULL regexp parameter");
1889         return 0;
1890     }
1891
1892     multiline = prog->extflags & RXf_PMf_MULTILINE;
1893     reginfo.prog = rx;   /* Yes, sorry that this is confusing.  */
1894
1895     RX_MATCH_UTF8_set(rx, do_utf8);
1896     DEBUG_EXECUTE_r(
1897         debug_start_match(rx, do_utf8, startpos, strend,
1898         "Matching");
1899     );
1900
1901     minlen = prog->minlen;
1902
1903     if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1904         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1905                               "String too short [regexec_flags]...\n"));
1906         goto phooey;
1907     }
1908
1909
1910     /* Check validity of program. */
1911     if (UCHARAT(progi->program) != REG_MAGIC) {
1912         Perl_croak(aTHX_ "corrupted regexp program");
1913     }
1914
1915     PL_reg_flags = 0;
1916     PL_reg_eval_set = 0;
1917     PL_reg_maxiter = 0;
1918
1919     if (RX_UTF8(rx))
1920         PL_reg_flags |= RF_utf8;
1921
1922     /* Mark beginning of line for ^ and lookbehind. */
1923     reginfo.bol = startpos; /* XXX not used ??? */
1924     PL_bostr  = strbeg;
1925     reginfo.sv = sv;
1926
1927     /* Mark end of line for $ (and such) */
1928     PL_regeol = strend;
1929
1930     /* see how far we have to get to not match where we matched before */
1931     reginfo.till = startpos+minend;
1932
1933     /* If there is a "must appear" string, look for it. */
1934     s = startpos;
1935
1936     if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
1937         MAGIC *mg;
1938         if (flags & REXEC_IGNOREPOS){   /* Means: check only at start */
1939             reginfo.ganch = startpos + prog->gofs;
1940             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1941               "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
1942         } else if (sv && SvTYPE(sv) >= SVt_PVMG
1943                   && SvMAGIC(sv)
1944                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1945                   && mg->mg_len >= 0) {
1946             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
1947             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1948                 "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
1949
1950             if (prog->extflags & RXf_ANCH_GPOS) {
1951                 if (s > reginfo.ganch)
1952                     goto phooey;
1953                 s = reginfo.ganch - prog->gofs;
1954                 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1955                      "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
1956                 if (s < strbeg)
1957                     goto phooey;
1958             }
1959         }
1960         else if (data) {
1961             reginfo.ganch = strbeg + PTR2UV(data);
1962             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1963                  "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
1964
1965         } else {                                /* pos() not defined */
1966             reginfo.ganch = strbeg;
1967             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1968                  "GPOS: reginfo.ganch = strbeg\n"));
1969         }
1970     }
1971     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
1972         /* We have to be careful. If the previous successful match
1973            was from this regex we don't want a subsequent partially
1974            successful match to clobber the old results.
1975            So when we detect this possibility we add a swap buffer
1976            to the re, and switch the buffer each match. If we fail
1977            we switch it back, otherwise we leave it swapped.
1978         */
1979         swap = prog->offs;
1980         /* do we need a save destructor here for eval dies? */
1981         Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
1982     }
1983     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1984         re_scream_pos_data d;
1985
1986         d.scream_olds = &scream_olds;
1987         d.scream_pos = &scream_pos;
1988         s = re_intuit_start(rx, sv, s, strend, flags, &d);
1989         if (!s) {
1990             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1991             goto phooey;        /* not present */
1992         }
1993     }
1994
1995
1996
1997     /* Simplest case:  anchored match need be tried only once. */
1998     /*  [unless only anchor is BOL and multiline is set] */
1999     if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
2000         if (s == startpos && regtry(&reginfo, &startpos))
2001             goto got_it;
2002         else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2003                  || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
2004         {
2005             char *end;
2006
2007             if (minlen)
2008                 dontbother = minlen - 1;
2009             end = HOP3c(strend, -dontbother, strbeg) - 1;
2010             /* for multiline we only have to try after newlines */
2011             if (prog->check_substr || prog->check_utf8) {
2012                 /* because of the goto we can not easily reuse the macros for bifurcating the
2013                    unicode/non-unicode match modes here like we do elsewhere - demerphq */
2014                 if (do_utf8) {
2015                     if (s == startpos)
2016                         goto after_try_utf8;
2017                     while (1) {
2018                         if (regtry(&reginfo, &s)) {
2019                             goto got_it;
2020                         }
2021                       after_try_utf8:
2022                         if (s > end) {
2023                             goto phooey;
2024                         }
2025                         if (prog->extflags & RXf_USE_INTUIT) {
2026                             s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL);
2027                             if (!s) {
2028                                 goto phooey;
2029                             }
2030                         }
2031                         else {
2032                             s += UTF8SKIP(s);
2033                         }
2034                     }
2035                 } /* end search for check string in unicode */
2036                 else {
2037                     if (s == startpos) {
2038                         goto after_try_latin;
2039                     }
2040                     while (1) {
2041                         if (regtry(&reginfo, &s)) {
2042                             goto got_it;
2043                         }
2044                       after_try_latin:
2045                         if (s > end) {
2046                             goto phooey;
2047                         }
2048                         if (prog->extflags & RXf_USE_INTUIT) {
2049                             s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2050                             if (!s) {
2051                                 goto phooey;
2052                             }
2053                         }
2054                         else {
2055                             s++;
2056                         }
2057                     }
2058                 } /* end search for check string in latin*/
2059             } /* end search for check string */
2060             else { /* search for newline */
2061                 if (s > startpos) {
2062                     /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
2063                     s--;
2064                 }
2065                 /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
2066                 while (s < end) {
2067                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
2068                         if (regtry(&reginfo, &s))
2069                             goto got_it;
2070                     }
2071                 }
2072             } /* end search for newline */
2073         } /* end anchored/multiline check string search */
2074         goto phooey;
2075     } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
2076     {
2077         /* the warning about reginfo.ganch being used without intialization
2078            is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
2079            and we only enter this block when the same bit is set. */
2080         char *tmp_s = reginfo.ganch - prog->gofs;
2081
2082         if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
2083             goto got_it;
2084         goto phooey;
2085     }
2086
2087     /* Messy cases:  unanchored match. */
2088     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2089         /* we have /x+whatever/ */
2090         /* it must be a one character string (XXXX Except UTF?) */
2091         char ch;
2092 #ifdef DEBUGGING
2093         int did_match = 0;
2094 #endif
2095         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2096             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2097         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
2098
2099         if (do_utf8) {
2100             REXEC_FBC_SCAN(
2101                 if (*s == ch) {
2102                     DEBUG_EXECUTE_r( did_match = 1 );
2103                     if (regtry(&reginfo, &s)) goto got_it;
2104                     s += UTF8SKIP(s);
2105                     while (s < strend && *s == ch)
2106                         s += UTF8SKIP(s);
2107                 }
2108             );
2109         }
2110         else {
2111             REXEC_FBC_SCAN(
2112                 if (*s == ch) {
2113                     DEBUG_EXECUTE_r( did_match = 1 );
2114                     if (regtry(&reginfo, &s)) goto got_it;
2115                     s++;
2116                     while (s < strend && *s == ch)
2117                         s++;
2118                 }
2119             );
2120         }
2121         DEBUG_EXECUTE_r(if (!did_match)
2122                 PerlIO_printf(Perl_debug_log,
2123                                   "Did not find anchored character...\n")
2124                );
2125     }
2126     else if (prog->anchored_substr != NULL
2127               || prog->anchored_utf8 != NULL
2128               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2129                   && prog->float_max_offset < strend - s)) {
2130         SV *must;
2131         I32 back_max;
2132         I32 back_min;
2133         char *last;
2134         char *last1;            /* Last position checked before */
2135 #ifdef DEBUGGING
2136         int did_match = 0;
2137 #endif
2138         if (prog->anchored_substr || prog->anchored_utf8) {
2139             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2140                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2141             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
2142             back_max = back_min = prog->anchored_offset;
2143         } else {
2144             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2145                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2146             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2147             back_max = prog->float_max_offset;
2148             back_min = prog->float_min_offset;
2149         }
2150
2151
2152         if (must == &PL_sv_undef)
2153             /* could not downgrade utf8 check substring, so must fail */
2154             goto phooey;
2155
2156         if (back_min<0) {
2157             last = strend;
2158         } else {
2159             last = HOP3c(strend,        /* Cannot start after this */
2160                   -(I32)(CHR_SVLEN(must)
2161                          - (SvTAIL(must) != 0) + back_min), strbeg);
2162         }
2163         if (s > PL_bostr)
2164             last1 = HOPc(s, -1);
2165         else
2166             last1 = s - 1;      /* bogus */
2167
2168         /* XXXX check_substr already used to find "s", can optimize if
2169            check_substr==must. */
2170         scream_pos = -1;
2171         dontbother = end_shift;
2172         strend = HOPc(strend, -dontbother);
2173         while ( (s <= last) &&
2174                 ((flags & REXEC_SCREAM)
2175                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2176                                     end_shift, &scream_pos, 0))
2177                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2178                                   (unsigned char*)strend, must,
2179                                   multiline ? FBMrf_MULTILINE : 0))) ) {
2180             /* we may be pointing at the wrong string */
2181             if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2182                 s = strbeg + (s - SvPVX_const(sv));
2183             DEBUG_EXECUTE_r( did_match = 1 );
2184             if (HOPc(s, -back_max) > last1) {
2185                 last1 = HOPc(s, -back_min);
2186                 s = HOPc(s, -back_max);
2187             }
2188             else {
2189                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2190
2191                 last1 = HOPc(s, -back_min);
2192                 s = t;
2193             }
2194             if (do_utf8) {
2195                 while (s <= last1) {
2196                     if (regtry(&reginfo, &s))
2197                         goto got_it;
2198                     s += UTF8SKIP(s);
2199                 }
2200             }
2201             else {
2202                 while (s <= last1) {
2203                     if (regtry(&reginfo, &s))
2204                         goto got_it;
2205                     s++;
2206                 }
2207             }
2208         }
2209         DEBUG_EXECUTE_r(if (!did_match) {
2210             RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
2211                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2212             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2213                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2214                                ? "anchored" : "floating"),
2215                 quoted, RE_SV_TAIL(must));
2216         });
2217         goto phooey;
2218     }
2219     else if ( (c = progi->regstclass) ) {
2220         if (minlen) {
2221             const OPCODE op = OP(progi->regstclass);
2222             /* don't bother with what can't match */
2223             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2224                 strend = HOPc(strend, -(minlen - 1));
2225         }
2226         DEBUG_EXECUTE_r({
2227             SV * const prop = sv_newmortal();
2228             regprop(prog, prop, c);
2229             {
2230                 RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
2231                     s,strend-s,60);
2232                 PerlIO_printf(Perl_debug_log,
2233                     "Matching stclass %.*s against %s (%d chars)\n",
2234                     (int)SvCUR(prop), SvPVX_const(prop),
2235                      quoted, (int)(strend - s));
2236             }
2237         });
2238         if (find_byclass(prog, c, s, strend, &reginfo))
2239             goto got_it;
2240         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2241     }
2242     else {
2243         dontbother = 0;
2244         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2245             /* Trim the end. */
2246             char *last;
2247             SV* float_real;
2248
2249             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2250                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2251             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2252
2253             if (flags & REXEC_SCREAM) {
2254                 last = screaminstr(sv, float_real, s - strbeg,
2255                                    end_shift, &scream_pos, 1); /* last one */
2256                 if (!last)
2257                     last = scream_olds; /* Only one occurrence. */
2258                 /* we may be pointing at the wrong string */
2259                 else if (RXp_MATCH_COPIED(prog))
2260                     s = strbeg + (s - SvPVX_const(sv));
2261             }
2262             else {
2263                 STRLEN len;
2264                 const char * const little = SvPV_const(float_real, len);
2265
2266                 if (SvTAIL(float_real)) {
2267                     if (memEQ(strend - len + 1, little, len - 1))
2268                         last = strend - len + 1;
2269                     else if (!multiline)
2270                         last = memEQ(strend - len, little, len)
2271                             ? strend - len : NULL;
2272                     else
2273                         goto find_last;
2274                 } else {
2275                   find_last:
2276                     if (len)
2277                         last = rninstr(s, strend, little, little + len);
2278                     else
2279                         last = strend;  /* matching "$" */
2280                 }
2281             }
2282             if (last == NULL) {
2283                 DEBUG_EXECUTE_r(
2284                     PerlIO_printf(Perl_debug_log,
2285                         "%sCan't trim the tail, match fails (should not happen)%s\n",
2286                         PL_colors[4], PL_colors[5]));
2287                 goto phooey; /* Should not happen! */
2288             }
2289             dontbother = strend - last + prog->float_min_offset;
2290         }
2291         if (minlen && (dontbother < minlen))
2292             dontbother = minlen - 1;
2293         strend -= dontbother;              /* this one's always in bytes! */
2294         /* We don't know much -- general case. */
2295         if (do_utf8) {
2296             for (;;) {
2297                 if (regtry(&reginfo, &s))
2298                     goto got_it;
2299                 if (s >= strend)
2300                     break;
2301                 s += UTF8SKIP(s);
2302             };
2303         }
2304         else {
2305             do {
2306                 if (regtry(&reginfo, &s))
2307                     goto got_it;
2308             } while (s++ < strend);
2309         }
2310     }
2311
2312     /* Failure. */
2313     goto phooey;
2314
2315 got_it:
2316     Safefree(swap);
2317     RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2318
2319     if (PL_reg_eval_set)
2320         restore_pos(aTHX_ prog);
2321     if (RXp_PAREN_NAMES(prog))
2322         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2323
2324     /* make sure $`, $&, $', and $digit will work later */
2325     if ( !(flags & REXEC_NOT_FIRST) ) {
2326         RX_MATCH_COPY_FREE(rx);
2327         if (flags & REXEC_COPY_STR) {
2328             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2329 #ifdef PERL_OLD_COPY_ON_WRITE
2330             if ((SvIsCOW(sv)
2331                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2332                 if (DEBUG_C_TEST) {
2333                     PerlIO_printf(Perl_debug_log,
2334                                   "Copy on write: regexp capture, type %d\n",
2335                                   (int) SvTYPE(sv));
2336                 }
2337                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2338                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2339                 assert (SvPOKp(prog->saved_copy));
2340             } else
2341 #endif
2342             {
2343                 RX_MATCH_COPIED_on(rx);
2344                 s = savepvn(strbeg, i);
2345                 prog->subbeg = s;
2346             }
2347             prog->sublen = i;
2348         }
2349         else {
2350             prog->subbeg = strbeg;
2351             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2352         }
2353     }
2354
2355     return 1;
2356
2357 phooey:
2358     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2359                           PL_colors[4], PL_colors[5]));
2360     if (PL_reg_eval_set)
2361         restore_pos(aTHX_ prog);
2362     if (swap) {
2363         /* we failed :-( roll it back */
2364         Safefree(prog->offs);
2365         prog->offs = swap;
2366     }
2367
2368     return 0;
2369 }
2370
2371
2372 /*
2373  - regtry - try match at specific point
2374  */
2375 STATIC I32                      /* 0 failure, 1 success */
2376 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2377 {
2378     dVAR;
2379     CHECKPOINT lastcp;
2380     REGEXP *const rx = reginfo->prog;
2381     regexp *const prog = (struct regexp *)SvANY(rx);
2382     RXi_GET_DECL(prog,progi);
2383     GET_RE_DEBUG_FLAGS_DECL;
2384
2385     PERL_ARGS_ASSERT_REGTRY;
2386
2387     reginfo->cutpoint=NULL;
2388
2389     if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2390         MAGIC *mg;
2391
2392         PL_reg_eval_set = RS_init;
2393         DEBUG_EXECUTE_r(DEBUG_s(
2394             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2395                           (IV)(PL_stack_sp - PL_stack_base));
2396             ));
2397         SAVESTACK_CXPOS();
2398         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2399         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2400         SAVETMPS;
2401         /* Apparently this is not needed, judging by wantarray. */
2402         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2403            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2404
2405         if (reginfo->sv) {
2406             /* Make $_ available to executed code. */
2407             if (reginfo->sv != DEFSV) {
2408                 SAVE_DEFSV;
2409                 DEFSV_set(reginfo->sv);
2410             }
2411
2412             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2413                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2414                 /* prepare for quick setting of pos */
2415 #ifdef PERL_OLD_COPY_ON_WRITE
2416                 if (SvIsCOW(reginfo->sv))
2417                     sv_force_normal_flags(reginfo->sv, 0);
2418 #endif
2419                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2420                                  &PL_vtbl_mglob, NULL, 0);
2421                 mg->mg_len = -1;
2422             }
2423             PL_reg_magic    = mg;
2424             PL_reg_oldpos   = mg->mg_len;
2425             SAVEDESTRUCTOR_X(restore_pos, prog);
2426         }
2427         if (!PL_reg_curpm) {
2428             Newxz(PL_reg_curpm, 1, PMOP);
2429 #ifdef USE_ITHREADS
2430             {
2431                 SV* const repointer = &PL_sv_undef;
2432                 /* this regexp is also owned by the new PL_reg_curpm, which
2433                    will try to free it.  */
2434                 av_push(PL_regex_padav, repointer);
2435                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2436                 PL_regex_pad = AvARRAY(PL_regex_padav);
2437             }
2438 #endif
2439         }
2440 #ifdef USE_ITHREADS
2441         /* It seems that non-ithreads works both with and without this code.
2442            So for efficiency reasons it seems best not to have the code
2443            compiled when it is not needed.  */
2444         /* This is safe against NULLs: */
2445         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2446         /* PM_reg_curpm owns a reference to this regexp.  */
2447         ReREFCNT_inc(rx);
2448 #endif
2449         PM_SETRE(PL_reg_curpm, rx);
2450         PL_reg_oldcurpm = PL_curpm;
2451         PL_curpm = PL_reg_curpm;
2452         if (RXp_MATCH_COPIED(prog)) {
2453             /*  Here is a serious problem: we cannot rewrite subbeg,
2454                 since it may be needed if this match fails.  Thus
2455                 $` inside (?{}) could fail... */
2456             PL_reg_oldsaved = prog->subbeg;
2457             PL_reg_oldsavedlen = prog->sublen;
2458 #ifdef PERL_OLD_COPY_ON_WRITE
2459             PL_nrs = prog->saved_copy;
2460 #endif
2461             RXp_MATCH_COPIED_off(prog);
2462         }
2463         else
2464             PL_reg_oldsaved = NULL;
2465         prog->subbeg = PL_bostr;
2466         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2467     }
2468     DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2469     prog->offs[0].start = *startpos - PL_bostr;
2470     PL_reginput = *startpos;
2471     PL_reglastparen = &prog->lastparen;
2472     PL_reglastcloseparen = &prog->lastcloseparen;
2473     prog->lastparen = 0;
2474     prog->lastcloseparen = 0;
2475     PL_regsize = 0;
2476     PL_regoffs = prog->offs;
2477     if (PL_reg_start_tmpl <= prog->nparens) {
2478         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2479         if(PL_reg_start_tmp)
2480             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2481         else
2482             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2483     }
2484
2485     /* XXXX What this code is doing here?!!!  There should be no need
2486        to do this again and again, PL_reglastparen should take care of
2487        this!  --ilya*/
2488
2489     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2490      * Actually, the code in regcppop() (which Ilya may be meaning by
2491      * PL_reglastparen), is not needed at all by the test suite
2492      * (op/regexp, op/pat, op/split), but that code is needed otherwise
2493      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2494      * Meanwhile, this code *is* needed for the
2495      * above-mentioned test suite tests to succeed.  The common theme
2496      * on those tests seems to be returning null fields from matches.
2497      * --jhi updated by dapm */
2498 #if 1
2499     if (prog->nparens) {
2500         regexp_paren_pair *pp = PL_regoffs;
2501         register I32 i;
2502         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2503             ++pp;
2504             pp->start = -1;
2505             pp->end = -1;
2506         }
2507     }
2508 #endif
2509     REGCP_SET(lastcp);
2510     if (regmatch(reginfo, progi->program + 1)) {
2511         PL_regoffs[0].end = PL_reginput - PL_bostr;
2512         return 1;
2513     }
2514     if (reginfo->cutpoint)
2515         *startpos= reginfo->cutpoint;
2516     REGCP_UNWIND(lastcp);
2517     return 0;
2518 }
2519
2520
2521 #define sayYES goto yes
2522 #define sayNO goto no
2523 #define sayNO_SILENT goto no_silent
2524
2525 /* we dont use STMT_START/END here because it leads to
2526    "unreachable code" warnings, which are bogus, but distracting. */
2527 #define CACHEsayNO \
2528     if (ST.cache_mask) \
2529        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2530     sayNO
2531
2532 /* this is used to determine how far from the left messages like
2533    'failed...' are printed. It should be set such that messages
2534    are inline with the regop output that created them.
2535 */
2536 #define REPORT_CODE_OFF 32
2537
2538
2539 /* Make sure there is a test for this +1 options in re_tests */
2540 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2541
2542 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2543 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2544
2545 #define SLAB_FIRST(s) (&(s)->states[0])
2546 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2547
2548 /* grab a new slab and return the first slot in it */
2549
2550 STATIC regmatch_state *
2551 S_push_slab(pTHX)
2552 {
2553 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2554     dMY_CXT;
2555 #endif
2556     regmatch_slab *s = PL_regmatch_slab->next;
2557     if (!s) {
2558         Newx(s, 1, regmatch_slab);
2559         s->prev = PL_regmatch_slab;
2560         s->next = NULL;
2561         PL_regmatch_slab->next = s;
2562     }
2563     PL_regmatch_slab = s;
2564     return SLAB_FIRST(s);
2565 }
2566
2567
2568 /* push a new state then goto it */
2569
2570 #define PUSH_STATE_GOTO(state, node) \
2571     scan = node; \
2572     st->resume_state = state; \
2573     goto push_state;
2574
2575 /* push a new state with success backtracking, then goto it */
2576
2577 #define PUSH_YES_STATE_GOTO(state, node) \
2578     scan = node; \
2579     st->resume_state = state; \
2580     goto push_yes_state;
2581
2582
2583
2584 /*
2585
2586 regmatch() - main matching routine
2587
2588 This is basically one big switch statement in a loop. We execute an op,
2589 set 'next' to point the next op, and continue. If we come to a point which
2590 we may need to backtrack to on failure such as (A|B|C), we push a
2591 backtrack state onto the backtrack stack. On failure, we pop the top
2592 state, and re-enter the loop at the state indicated. If there are no more
2593 states to pop, we return failure.
2594
2595 Sometimes we also need to backtrack on success; for example /A+/, where
2596 after successfully matching one A, we need to go back and try to
2597 match another one; similarly for lookahead assertions: if the assertion
2598 completes successfully, we backtrack to the state just before the assertion
2599 and then carry on.  In these cases, the pushed state is marked as
2600 'backtrack on success too'. This marking is in fact done by a chain of
2601 pointers, each pointing to the previous 'yes' state. On success, we pop to
2602 the nearest yes state, discarding any intermediate failure-only states.
2603 Sometimes a yes state is pushed just to force some cleanup code to be
2604 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2605 it to free the inner regex.
2606
2607 Note that failure backtracking rewinds the cursor position, while
2608 success backtracking leaves it alone.
2609
2610 A pattern is complete when the END op is executed, while a subpattern
2611 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2612 ops trigger the "pop to last yes state if any, otherwise return true"
2613 behaviour.
2614
2615 A common convention in this function is to use A and B to refer to the two
2616 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2617 the subpattern to be matched possibly multiple times, while B is the entire
2618 rest of the pattern. Variable and state names reflect this convention.
2619
2620 The states in the main switch are the union of ops and failure/success of
2621 substates associated with with that op.  For example, IFMATCH is the op
2622 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2623 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2624 successfully matched A and IFMATCH_A_fail is a state saying that we have
2625 just failed to match A. Resume states always come in pairs. The backtrack
2626 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2627 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2628 on success or failure.
2629
2630 The struct that holds a backtracking state is actually a big union, with
2631 one variant for each major type of op. The variable st points to the
2632 top-most backtrack struct. To make the code clearer, within each
2633 block of code we #define ST to alias the relevant union.
2634
2635 Here's a concrete example of a (vastly oversimplified) IFMATCH
2636 implementation:
2637
2638     switch (state) {
2639     ....
2640
2641 #define ST st->u.ifmatch
2642
2643     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2644         ST.foo = ...; // some state we wish to save
2645         ...
2646         // push a yes backtrack state with a resume value of
2647         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2648         // first node of A:
2649         PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2650         // NOTREACHED
2651
2652     case IFMATCH_A: // we have successfully executed A; now continue with B
2653         next = B;
2654         bar = ST.foo; // do something with the preserved value
2655         break;
2656
2657     case IFMATCH_A_fail: // A failed, so the assertion failed
2658         ...;   // do some housekeeping, then ...
2659         sayNO; // propagate the failure
2660
2661 #undef ST
2662
2663     ...
2664     }
2665
2666 For any old-timers reading this who are familiar with the old recursive
2667 approach, the code above is equivalent to:
2668
2669     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2670     {
2671         int foo = ...
2672         ...
2673         if (regmatch(A)) {
2674             next = B;
2675             bar = foo;
2676             break;
2677         }
2678         ...;   // do some housekeeping, then ...
2679         sayNO; // propagate the failure
2680     }
2681
2682 The topmost backtrack state, pointed to by st, is usually free. If you
2683 want to claim it, populate any ST.foo fields in it with values you wish to
2684 save, then do one of
2685
2686         PUSH_STATE_GOTO(resume_state, node);
2687         PUSH_YES_STATE_GOTO(resume_state, node);
2688
2689 which sets that backtrack state's resume value to 'resume_state', pushes a
2690 new free entry to the top of the backtrack stack, then goes to 'node'.
2691 On backtracking, the free slot is popped, and the saved state becomes the
2692 new free state. An ST.foo field in this new top state can be temporarily
2693 accessed to retrieve values, but once the main loop is re-entered, it
2694 becomes available for reuse.
2695
2696 Note that the depth of the backtrack stack constantly increases during the
2697 left-to-right execution of the pattern, rather than going up and down with
2698 the pattern nesting. For example the stack is at its maximum at Z at the
2699 end of the pattern, rather than at X in the following:
2700
2701     /(((X)+)+)+....(Y)+....Z/
2702
2703 The only exceptions to this are lookahead/behind assertions and the cut,
2704 (?>A), which pop all the backtrack states associated with A before
2705 continuing.
2706
2707 Bascktrack state structs are allocated in slabs of about 4K in size.
2708 PL_regmatch_state and st always point to the currently active state,
2709 and PL_regmatch_slab points to the slab currently containing
2710 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2711 allocated, and is never freed until interpreter destruction. When the slab
2712 is full, a new one is allocated and chained to the end. At exit from
2713 regmatch(), slabs allocated since entry are freed.
2714
2715 */
2716
2717
2718 #define DEBUG_STATE_pp(pp)                                  \
2719     DEBUG_STATE_r({                                         \
2720         DUMP_EXEC_POS(locinput, scan, do_utf8);             \
2721         PerlIO_printf(Perl_debug_log,                       \
2722             "    %*s"pp" %s%s%s%s%s\n",                     \
2723             depth*2, "",                                    \
2724             PL_reg_name[st->resume_state],                     \
2725             ((st==yes_state||st==mark_state) ? "[" : ""),   \
2726             ((st==yes_state) ? "Y" : ""),                   \
2727             ((st==mark_state) ? "M" : ""),                  \
2728             ((st==yes_state||st==mark_state) ? "]" : "")    \
2729         );                                                  \
2730     });
2731
2732
2733 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2734
2735 #ifdef DEBUGGING
2736
2737 STATIC void
2738 S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8,
2739     const char *start, const char *end, const char *blurb)
2740 {
2741     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2742
2743     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2744
2745     if (!PL_colorset)
2746             reginitcolors();
2747     {
2748         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2749             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
2750
2751         RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2752             start, end - start, 60);
2753
2754         PerlIO_printf(Perl_debug_log,
2755             "%s%s REx%s %s against %s\n",
2756                        PL_colors[4], blurb, PL_colors[5], s0, s1);
2757
2758         if (do_utf8||utf8_pat)
2759             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2760                 utf8_pat ? "pattern" : "",
2761                 utf8_pat && do_utf8 ? " and " : "",
2762                 do_utf8 ? "string" : ""
2763             );
2764     }
2765 }
2766
2767 STATIC void
2768 S_dump_exec_pos(pTHX_ const char *locinput,
2769                       const regnode *scan,
2770                       const char *loc_regeol,
2771                       const char *loc_bostr,
2772                       const char *loc_reg_starttry,
2773                       const bool do_utf8)
2774 {
2775     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2776     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2777     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2778     /* The part of the string before starttry has one color
2779        (pref0_len chars), between starttry and current
2780        position another one (pref_len - pref0_len chars),
2781        after the current position the third one.
2782        We assume that pref0_len <= pref_len, otherwise we
2783        decrease pref0_len.  */
2784     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2785         ? (5 + taill) - l : locinput - loc_bostr;
2786     int pref0_len;
2787
2788     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2789
2790     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2791         pref_len++;
2792     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2793     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2794         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2795               ? (5 + taill) - pref_len : loc_regeol - locinput);
2796     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2797         l--;
2798     if (pref0_len < 0)
2799         pref0_len = 0;
2800     if (pref0_len > pref_len)
2801         pref0_len = pref_len;
2802     {
2803         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2804
2805         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2806             (locinput - pref_len),pref0_len, 60, 4, 5);
2807
2808         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2809                     (locinput - pref_len + pref0_len),
2810                     pref_len - pref0_len, 60, 2, 3);
2811
2812         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2813                     locinput, loc_regeol - locinput, 10, 0, 1);
2814
2815         const STRLEN tlen=len0+len1+len2;
2816         PerlIO_printf(Perl_debug_log,
2817                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2818                     (IV)(locinput - loc_bostr),
2819                     len0, s0,
2820                     len1, s1,
2821                     (docolor ? "" : "> <"),
2822                     len2, s2,
2823                     (int)(tlen > 19 ? 0 :  19 - tlen),
2824                     "");
2825     }
2826 }
2827
2828 #endif
2829
2830 /* reg_check_named_buff_matched()
2831  * Checks to see if a named buffer has matched. The data array of
2832  * buffer numbers corresponding to the buffer is expected to reside
2833  * in the regexp->data->data array in the slot stored in the ARG() of
2834  * node involved. Note that this routine doesn't actually care about the
2835  * name, that information is not preserved from compilation to execution.
2836  * Returns the index of the leftmost defined buffer with the given name
2837  * or 0 if non of the buffers matched.
2838  */
2839 STATIC I32
2840 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2841 {
2842     I32 n;
2843     RXi_GET_DECL(rex,rexi);
2844     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
2845     I32 *nums=(I32*)SvPVX(sv_dat);
2846
2847     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
2848
2849     for ( n=0; n<SvIVX(sv_dat); n++ ) {
2850         if ((I32)*PL_reglastparen >= nums[n] &&
2851             PL_regoffs[nums[n]].end != -1)
2852         {
2853             return nums[n];
2854         }
2855     }
2856     return 0;
2857 }
2858
2859
2860 /* free all slabs above current one  - called during LEAVE_SCOPE */
2861
2862 STATIC void
2863 S_clear_backtrack_stack(pTHX_ void *p)
2864 {
2865     regmatch_slab *s = PL_regmatch_slab->next;
2866     PERL_UNUSED_ARG(p);
2867
2868     if (!s)
2869         return;
2870     PL_regmatch_slab->next = NULL;
2871     while (s) {
2872         regmatch_slab * const osl = s;
2873         s = s->next;
2874         Safefree(osl);
2875     }
2876 }
2877
2878
2879 #define SETREX(Re1,Re2) \
2880     if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2881     Re1 = (Re2)
2882
2883 STATIC I32                      /* 0 failure, 1 success */
2884 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2885 {
2886 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2887     dMY_CXT;
2888 #endif
2889     dVAR;
2890     register const bool do_utf8 = PL_reg_match_utf8;
2891     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2892     REGEXP *rex_sv = reginfo->prog;
2893     regexp *rex = (struct regexp *)SvANY(rex_sv);
2894     RXi_GET_DECL(rex,rexi);
2895     I32 oldsave;
2896     /* the current state. This is a cached copy of PL_regmatch_state */
2897     register regmatch_state *st;
2898     /* cache heavy used fields of st in registers */
2899     register regnode *scan;
2900     register regnode *next;
2901     register U32 n = 0; /* general value; init to avoid compiler warning */
2902     register I32 ln = 0; /* len or last;  init to avoid compiler warning */
2903     register char *locinput = PL_reginput;
2904     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2905
2906     bool result = 0;        /* return value of S_regmatch */
2907     int depth = 0;          /* depth of backtrack stack */
2908     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
2909     const U32 max_nochange_depth =
2910         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
2911         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
2912     regmatch_state *yes_state = NULL; /* state to pop to on success of
2913                                                             subpattern */
2914     /* mark_state piggy backs on the yes_state logic so that when we unwind
2915        the stack on success we can update the mark_state as we go */
2916     regmatch_state *mark_state = NULL; /* last mark state we have seen */
2917     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2918     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2919     U32 state_num;
2920     bool no_final = 0;      /* prevent failure from backtracking? */
2921     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
2922     char *startpoint = PL_reginput;
2923     SV *popmark = NULL;     /* are we looking for a mark? */
2924     SV *sv_commit = NULL;   /* last mark name seen in failure */
2925     SV *sv_yes_mark = NULL; /* last mark name we have seen
2926                                during a successfull match */
2927     U32 lastopen = 0;       /* last open we saw */
2928     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2929     SV* const oreplsv = GvSV(PL_replgv);
2930     /* these three flags are set by various ops to signal information to
2931      * the very next op. They have a useful lifetime of exactly one loop
2932      * iteration, and are not preserved or restored by state pushes/pops
2933      */
2934     bool sw = 0;            /* the condition value in (?(cond)a|b) */
2935     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
2936     int logical = 0;        /* the following EVAL is:
2937                                 0: (?{...})
2938                                 1: (?(?{...})X|Y)
2939                                 2: (??{...})
2940                                or the following IFMATCH/UNLESSM is:
2941                                 false: plain (?=foo)
2942                                 true:  used as a condition: (?(?=foo))
2943                             */
2944 #ifdef DEBUGGING
2945     GET_RE_DEBUG_FLAGS_DECL;
2946 #endif
2947
2948     PERL_ARGS_ASSERT_REGMATCH;
2949
2950     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
2951             PerlIO_printf(Perl_debug_log,"regmatch start\n");
2952     }));
2953     /* on first ever call to regmatch, allocate first slab */
2954     if (!PL_regmatch_slab) {
2955         Newx(PL_regmatch_slab, 1, regmatch_slab);
2956         PL_regmatch_slab->prev = NULL;
2957         PL_regmatch_slab->next = NULL;
2958         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2959     }
2960
2961     oldsave = PL_savestack_ix;
2962     SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
2963     SAVEVPTR(PL_regmatch_slab);
2964     SAVEVPTR(PL_regmatch_state);
2965
2966     /* grab next free state slot */
2967     st = ++PL_regmatch_state;
2968     if (st >  SLAB_LAST(PL_regmatch_slab))
2969         st = PL_regmatch_state = S_push_slab(aTHX);
2970
2971     /* Note that nextchr is a byte even in UTF */
2972     nextchr = UCHARAT(locinput);
2973     scan = prog;
2974     while (scan != NULL) {
2975
2976         DEBUG_EXECUTE_r( {
2977             SV * const prop = sv_newmortal();
2978             regnode *rnext=regnext(scan);
2979             DUMP_EXEC_POS( locinput, scan, do_utf8 );
2980             regprop(rex, prop, scan);
2981
2982             PerlIO_printf(Perl_debug_log,
2983                     "%3"IVdf":%*s%s(%"IVdf")\n",
2984                     (IV)(scan - rexi->program), depth*2, "",
2985                     SvPVX_const(prop),
2986                     (PL_regkind[OP(scan)] == END || !rnext) ?
2987                         0 : (IV)(rnext - rexi->program));
2988         });
2989
2990         next = scan + NEXT_OFF(scan);
2991         if (next == scan)
2992             next = NULL;
2993         state_num = OP(scan);
2994
2995         REH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);
2996       reenter_switch:
2997
2998         assert(PL_reglastparen == &rex->lastparen);
2999         assert(PL_reglastcloseparen == &rex->lastcloseparen);
3000         assert(PL_regoffs == rex->offs);
3001
3002         switch (state_num) {
3003         case BOL:
3004             if (locinput == PL_bostr)
3005             {
3006                 /* reginfo->till = reginfo->bol; */
3007                 break;
3008             }
3009             sayNO;
3010         case MBOL:
3011             if (locinput == PL_bostr ||
3012                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
3013             {
3014                 break;
3015             }
3016             sayNO;
3017         case SBOL:
3018             if (locinput == PL_bostr)
3019                 break;
3020             sayNO;
3021         case GPOS:
3022             if (locinput == reginfo->ganch)
3023                 break;
3024             sayNO;
3025
3026         case KEEPS:
3027             /* update the startpoint */
3028             st->u.keeper.val = PL_regoffs[0].start;
3029             PL_reginput = locinput;
3030             PL_regoffs[0].start = locinput - PL_bostr;
3031             PUSH_STATE_GOTO(KEEPS_next, next);
3032             /*NOT-REACHED*/
3033         case KEEPS_next_fail:
3034             /* rollback the start point change */
3035             PL_regoffs[0].start = st->u.keeper.val;
3036             sayNO_SILENT;
3037             /*NOT-REACHED*/
3038         case EOL:
3039                 goto seol;
3040         case MEOL:
3041             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3042                 sayNO;
3043             break;
3044         case SEOL:
3045           seol:
3046             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3047                 sayNO;
3048             if (PL_regeol - locinput > 1)
3049                 sayNO;
3050             break;
3051         case EOS:
3052             if (PL_regeol != locinput)
3053                 sayNO;
3054             break;
3055         case SANY:
3056             if (!nextchr && locinput >= PL_regeol)
3057                 sayNO;
3058             if (do_utf8) {
3059                 locinput += PL_utf8skip[nextchr];
3060                 if (locinput > PL_regeol)
3061                     sayNO;
3062                 nextchr = UCHARAT(locinput);
3063             }
3064             else
3065                 nextchr = UCHARAT(++locinput);
3066             break;
3067         case CANY:
3068             if (!nextchr && locinput >= PL_regeol)
3069                 sayNO;
3070             nextchr = UCHARAT(++locinput);
3071             break;
3072         case REG_ANY:
3073             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
3074                 sayNO;
3075             if (do_utf8) {
3076                 locinput += PL_utf8skip[nextchr];
3077                 if (locinput > PL_regeol)
3078                     sayNO;
3079                 nextchr = UCHARAT(locinput);
3080             }
3081             else
3082                 nextchr = UCHARAT(++locinput);
3083             break;
3084
3085 #undef  ST
3086 #define ST st->u.trie
3087         case TRIEC:
3088             /* In this case the charclass data is available inline so
3089                we can fail fast without a lot of extra overhead.
3090              */
3091             if (scan->flags == EXACT || !do_utf8) {
3092                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3093                     DEBUG_EXECUTE_r(
3094                         PerlIO_printf(Perl_debug_log,
3095                                   "%*s  %sfailed to match trie start class...%s\n",
3096                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3097                     );
3098                     sayNO_SILENT;
3099                     /* NOTREACHED */
3100                 }
3101             }
3102             /* FALL THROUGH */
3103         case TRIE:
3104             {
3105                 /* what type of TRIE am I? (utf8 makes this contextual) */
3106                 DECL_TRIE_TYPE(scan);
3107
3108                 /* what trie are we using right now */
3109                 reg_trie_data * const trie
3110                     = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3111                 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3112                 U32 state = trie->startstate;
3113
3114                 if (trie->bitmap && trie_type != trie_utf8_fold &&
3115                     !TRIE_BITMAP_TEST(trie,*locinput)
3116                 ) {
3117                     if (trie->states[ state ].wordnum) {
3118                          DEBUG_EXECUTE_r(
3119                             PerlIO_printf(Perl_debug_log,
3120                                           "%*s  %smatched empty string...%s\n",
3121                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3122                         );
3123                         break;
3124                     } else {
3125                         DEBUG_EXECUTE_r(
3126                             PerlIO_printf(Perl_debug_log,
3127                                           "%*s  %sfailed to match trie start class...%s\n",
3128                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3129                         );
3130                         sayNO_SILENT;
3131                    }
3132                 }
3133
3134             {
3135                 U8 *uc = ( U8* )locinput;
3136
3137                 STRLEN len = 0;
3138                 STRLEN foldlen = 0;
3139                 U8 *uscan = (U8*)NULL;
3140                 STRLEN bufflen=0;
3141                 SV *sv_accept_buff = NULL;
3142                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3143
3144                 ST.accepted = 0; /* how many accepting states we have seen */
3145                 ST.B = next;
3146                 ST.jump = trie->jump;
3147                 ST.me = scan;
3148                 /*
3149                    traverse the TRIE keeping track of all accepting states
3150                    we transition through until we get to a failing node.
3151                 */
3152
3153                 while ( state && uc <= (U8*)PL_regeol ) {
3154                     U32 base = trie->states[ state ].trans.base;
3155                     UV uvc = 0;
3156                     U16 charid;
3157                     /* We use charid to hold the wordnum as we don't use it
3158                        for charid until after we have done the wordnum logic.
3159                        We define an alias just so that the wordnum logic reads
3160                        more naturally. */
3161
3162 #define got_wordnum charid
3163                     got_wordnum = trie->states[ state ].wordnum;
3164
3165                     if ( got_wordnum ) {
3166                         if ( ! ST.accepted ) {
3167                             ENTER;
3168                             SAVETMPS; /* XXX is this necessary? dmq */
3169                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
3170                             sv_accept_buff=newSV(bufflen *
3171                                             sizeof(reg_trie_accepted) - 1);
3172                             SvCUR_set(sv_accept_buff, 0);
3173                             SvPOK_on(sv_accept_buff);
3174                             sv_2mortal(sv_accept_buff);
3175                             SAVETMPS;
3176                             ST.accept_buff =
3177                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
3178                         }
3179                         do {
3180                             if (ST.accepted >= bufflen) {
3181                                 bufflen *= 2;
3182                                 ST.accept_buff =(reg_trie_accepted*)
3183                                     SvGROW(sv_accept_buff,
3184                                         bufflen * sizeof(reg_trie_accepted));
3185                             }
3186                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
3187                                 + sizeof(reg_trie_accepted));
3188
3189
3190                             ST.accept_buff[ST.accepted].wordnum = got_wordnum;
3191                             ST.accept_buff[ST.accepted].endpos = uc;
3192                             ++ST.accepted;
3193                         } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
3194                     }
3195 #undef got_wordnum
3196
3197                     DEBUG_TRIE_EXECUTE_r({
3198                                 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
3199                                 PerlIO_printf( Perl_debug_log,
3200                                     "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
3201                                     2+depth * 2, "", PL_colors[4],
3202                                     (UV)state, (UV)ST.accepted );
3203                     });
3204
3205                     if ( base ) {
3206                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3207                                              uscan, len, uvc, charid, foldlen,
3208                                              foldbuf, uniflags);
3209
3210                         if (charid &&
3211                              (base + charid > trie->uniquecharcount )
3212                              && (base + charid - 1 - trie->uniquecharcount
3213                                     < trie->lasttrans)
3214                              && trie->trans[base + charid - 1 -
3215                                     trie->uniquecharcount].check == state)
3216                         {
3217                             state = trie->trans[base + charid - 1 -
3218                                 trie->uniquecharcount ].next;
3219                         }
3220                         else {
3221                             state = 0;
3222                         }
3223                         uc += len;
3224
3225                     }
3226                     else {
3227                         state = 0;
3228                     }
3229                     DEBUG_TRIE_EXECUTE_r(
3230                         PerlIO_printf( Perl_debug_log,
3231                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3232                             charid, uvc, (UV)state, PL_colors[5] );
3233                     );
3234                 }
3235                 if (!ST.accepted )
3236                    sayNO;
3237
3238                 DEBUG_EXECUTE_r(
3239                     PerlIO_printf( Perl_debug_log,
3240                         "%*s  %sgot %"IVdf" possible matches%s\n",
3241                         REPORT_CODE_OFF + depth * 2, "",
3242                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3243                 );
3244             }}
3245             goto trie_first_try; /* jump into the fail handler */
3246             /* NOTREACHED */
3247         case TRIE_next_fail: /* we failed - try next alterative */
3248             if ( ST.jump) {
3249                 REGCP_UNWIND(ST.cp);
3250                 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3251                     PL_regoffs[n].end = -1;
3252                 *PL_reglastparen = n;
3253             }
3254           trie_first_try:
3255             if (do_cutgroup) {
3256                 do_cutgroup = 0;
3257                 no_final = 0;
3258             }
3259
3260             if ( ST.jump) {
3261                 ST.lastparen = *PL_reglastparen;
3262                 REGCP_SET(ST.cp);
3263             }
3264             if ( ST.accepted == 1 ) {
3265                 /* only one choice left - just continue */
3266                 DEBUG_EXECUTE_r({
3267                     AV *const trie_words
3268                         = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3269                     SV ** const tmp = av_fetch( trie_words,
3270                         ST.accept_buff[ 0 ].wordnum-1, 0 );
3271                     SV *sv= tmp ? sv_newmortal() : NULL;
3272
3273                     PerlIO_printf( Perl_debug_log,
3274                         "%*s  %sonly one match left: #%d <%s>%s\n",
3275                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3276                         ST.accept_buff[ 0 ].wordnum,
3277                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3278                                 PL_colors[0], PL_colors[1],
3279                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3280                             )
3281                         : "not compiled under -Dr",
3282                         PL_colors[5] );
3283                 });
3284                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3285                 /* in this case we free tmps/leave before we call regmatch
3286                    as we wont be using accept_buff again. */
3287
3288                 locinput = PL_reginput;
3289                 nextchr = UCHARAT(locinput);
3290                 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
3291                     scan = ST.B;
3292                 else
3293                     scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3294                 if (!has_cutgroup) {
3295                     FREETMPS;
3296                     LEAVE;
3297                 } else {
3298                     ST.accepted--;
3299                     PUSH_YES_STATE_GOTO(TRIE_next, scan);
3300                 }
3301
3302                 continue; /* execute rest of RE */
3303             }
3304
3305             if ( !ST.accepted-- ) {
3306                 DEBUG_EXECUTE_r({
3307                     PerlIO_printf( Perl_debug_log,
3308                         "%*s  %sTRIE failed...%s\n",
3309                         REPORT_CODE_OFF+depth*2, "",
3310                         PL_colors[4],
3311                         PL_colors[5] );
3312                 });
3313                 FREETMPS;
3314                 LEAVE;
3315                 sayNO_SILENT;
3316                 /*NOTREACHED*/
3317             }
3318
3319             /*
3320                There are at least two accepting states left.  Presumably
3321                the number of accepting states is going to be low,
3322                typically two. So we simply scan through to find the one
3323                with lowest wordnum.  Once we find it, we swap the last
3324                state into its place and decrement the size. We then try to
3325                match the rest of the pattern at the point where the word
3326                ends. If we succeed, control just continues along the
3327                regex; if we fail we return here to try the next accepting
3328                state
3329              */
3330
3331             {
3332                 U32 best = 0;
3333                 U32 cur;
3334                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3335                     DEBUG_TRIE_EXECUTE_r(
3336                         PerlIO_printf( Perl_debug_log,
3337                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3338                             REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3339                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3340                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3341                     );
3342
3343                     if (ST.accept_buff[cur].wordnum <
3344                             ST.accept_buff[best].wordnum)
3345                         best = cur;
3346                 }
3347
3348                 DEBUG_EXECUTE_r({
3349                     AV *const trie_words
3350                         = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3351                     SV ** const tmp = av_fetch( trie_words,
3352                         ST.accept_buff[ best ].wordnum - 1, 0 );
3353                     regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
3354                                     ST.B :
3355                                     ST.me + ST.jump[ST.accept_buff[best].wordnum];
3356                     SV *sv= tmp ? sv_newmortal() : NULL;
3357
3358                     PerlIO_printf( Perl_debug_log,
3359                         "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3360                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3361                         ST.accept_buff[best].wordnum,
3362                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3363                                 PL_colors[0], PL_colors[1],
3364                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3365                             ) : "not compiled under -Dr",
3366                             REG_NODE_NUM(nextop),
3367                         PL_colors[5] );
3368                 });
3369
3370                 if ( best<ST.accepted ) {
3371                     reg_trie_accepted tmp = ST.accept_buff[ best ];
3372                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3373                     ST.accept_buff[ ST.accepted ] = tmp;
3374                     best = ST.accepted;
3375                 }
3376                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3377                 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3378                     scan = ST.B;
3379                 } else {
3380                     scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3381                 }
3382                 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3383                 /* NOTREACHED */
3384             }
3385             /* NOTREACHED */
3386         case TRIE_next:
3387             /* we dont want to throw this away, see bug 57042*/
3388             if (oreplsv != GvSV(PL_replgv))
3389                 sv_setsv(oreplsv, GvSV(PL_replgv));
3390             FREETMPS;
3391             LEAVE;
3392             sayYES;
3393 #undef  ST
3394
3395         case EXACT: {
3396             char *s = STRING(scan);
3397             ln = STR_LEN(scan);
3398             if (do_utf8 != UTF) {
3399                 /* The target and the pattern have differing utf8ness. */
3400                 char *l = locinput;
3401                 const char * const e = s + ln;
3402
3403                 if (do_utf8) {
3404                     /* The target is utf8, the pattern is not utf8. */
3405                     while (s < e) {
3406                         STRLEN ulen;
3407                         if (l >= PL_regeol)
3408                              sayNO;
3409                         if (NATIVE_TO_UNI(*(U8*)s) !=
3410                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3411                                             uniflags))
3412                              sayNO;
3413                         l += ulen;
3414                         s ++;
3415                     }
3416                 }
3417                 else {
3418                     /* The target is not utf8, the pattern is utf8. */
3419                     while (s < e) {
3420                         STRLEN ulen;
3421                         if (l >= PL_regeol)
3422                             sayNO;
3423                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3424                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3425                                            uniflags))
3426                             sayNO;
3427                         s += ulen;
3428                         l ++;
3429                     }
3430                 }
3431                 locinput = l;
3432                 nextchr = UCHARAT(locinput);
3433                 break;
3434             }
3435             /* The target and the pattern have the same utf8ness. */
3436             /* Inline the first character, for speed. */
3437             if (UCHARAT(s) != nextchr)
3438                 sayNO;
3439             if (PL_regeol - locinput < ln)
3440                 sayNO;
3441             if (ln > 1 && memNE(s, locinput, ln))
3442                 sayNO;
3443             locinput += ln;
3444             nextchr = UCHARAT(locinput);
3445             break;
3446             }
3447         case EXACTFL:
3448             PL_reg_flags |= RF_tainted;
3449             /* FALL THROUGH */
3450         case EXACTF: {
3451             char * const s = STRING(scan);
3452             ln = STR_LEN(scan);
3453
3454             if (do_utf8 || UTF) {
3455               /* Either target or the pattern are utf8. */
3456                 const char * const l = locinput;
3457                 char *e = PL_regeol;
3458
3459                 if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
3460                                l, &e, 0,  do_utf8)) {
3461                      /* One more case for the sharp s:
3462                       * pack("U0U*", 0xDF) =~ /ss/i,
3463                       * the 0xC3 0x9F are the UTF-8
3464                       * byte sequence for the U+00DF. */
3465
3466                      if (!(do_utf8 &&
3467                            toLOWER(s[0]) == 's' &&
3468                            ln >= 2 &&
3469                            toLOWER(s[1]) == 's' &&
3470                            (U8)l[0] == 0xC3 &&
3471                            e - l >= 2 &&
3472                            (U8)l[1] == 0x9F))
3473                           sayNO;
3474                 }
3475                 locinput = e;
3476                 nextchr = UCHARAT(locinput);
3477                 break;
3478             }
3479
3480             /* Neither the target and the pattern are utf8. */
3481
3482             /* Inline the first character, for speed. */
3483             if (UCHARAT(s) != nextchr &&
3484                 UCHARAT(s) != ((OP(scan) == EXACTF)
3485                                ? PL_fold : PL_fold_locale)[nextchr])
3486                 sayNO;
3487             if (PL_regeol - locinput < ln)
3488                 sayNO;
3489             if (ln > 1 && (OP(scan) == EXACTF
3490                            ? ibcmp(s, locinput, ln)
3491                            : ibcmp_locale(s, locinput, ln)))
3492                 sayNO;
3493             locinput += ln;
3494             nextchr = UCHARAT(locinput);
3495             break;
3496             }
3497         case BOUNDL:
3498         case NBOUNDL:
3499             PL_reg_flags |= RF_tainted;
3500             /* FALL THROUGH */
3501         case BOUND:
3502         case NBOUND:
3503             /* was last char in word? */
3504             if (do_utf8) {
3505                 if (locinput == PL_bostr)
3506                     ln = '\n';
3507                 else {
3508                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3509
3510                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3511                 }
3512                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3513                     ln = isALNUM_uni(ln);
3514                     LOAD_UTF8_CHARCLASS_ALNUM();
3515                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3516                 }
3517                 else {
3518                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3519                     n = isALNUM_LC_utf8((U8*)locinput);
3520                 }
3521             }
3522             else {
3523                 ln = (locinput != PL_bostr) ?
3524                     UCHARAT(locinput - 1) : '\n';
3525                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3526                     ln = isALNUM(ln);
3527                     n = isALNUM(nextchr);
3528                 }
3529                 else {
3530                     ln = isALNUM_LC(ln);
3531                     n = isALNUM_LC(nextchr);
3532                 }
3533             }
3534             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3535                                     OP(scan) == BOUNDL))
3536                     sayNO;
3537             break;
3538         case ANYOF:
3539             if (do_utf8) {
3540                 STRLEN inclasslen = PL_regeol - locinput;
3541
3542                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3543                     goto anyof_fail;
3544                 if (locinput >= PL_regeol)
3545                     sayNO;
3546                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3547                 nextchr = UCHARAT(locinput);
3548                 break;
3549             }
3550             else {
3551                 if (nextchr < 0)
3552                     nextchr = UCHARAT(locinput);
3553                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3554                     goto anyof_fail;
3555                 if (!nextchr && locinput >= PL_regeol)
3556                     sayNO;
3557                 nextchr = UCHARAT(++locinput);
3558                 break;
3559             }
3560         anyof_fail:
3561             /* If we might have the case of the German sharp s
3562              * in a casefolding Unicode character class. */
3563
3564             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3565                  locinput += SHARP_S_SKIP;
3566                  nextchr = UCHARAT(locinput);
3567             }
3568             else
3569                  sayNO;
3570             break;
3571         /* Special char classes - The defines start on line 129 or so */
3572         CCC_TRY_AFF( ALNUM,  ALNUML, perl_word,   "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3573         CCC_TRY_NEG(NALNUM, NALNUML, perl_word,   "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3574
3575         CCC_TRY_AFF( SPACE,  SPACEL, perl_space,  " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3576         CCC_TRY_NEG(NSPACE, NSPACEL, perl_space,  " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3577
3578         CCC_TRY_AFF( DIGIT,  DIGITL, posix_digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3579         CCC_TRY_NEG(NDIGIT, NDIGITL, posix_digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3580
3581         case CLUMP: /* Match \X: logical Unicode character.  This is defined as
3582                        a Unicode extended Grapheme Cluster */
3583             /* From http://www.unicode.org/reports/tr29 (5.2 version).  An
3584               extended Grapheme Cluster is:
3585
3586                CR LF
3587                | Prepend* Begin Extend*
3588                | .
3589
3590                Begin is (Hangul-syllable | ! Control)
3591                Extend is (Grapheme_Extend | Spacing_Mark)
3592                Control is [ GCB_Control CR LF ]
3593
3594                The discussion below shows how the code for CLUMP is derived
3595                from this regex.  Note that most of these concepts are from
3596                property values of the Grapheme Cluster Boundary (GCB) property.
3597                No code point can have multiple property values for a given
3598                property.  Thus a code point in Prepend can't be in Control, but
3599                it must be in !Control.  This is why Control above includes
3600                GCB_Control plus CR plus LF.  The latter two are used in the GCB
3601                property separately, and so can't be in GCB_Control, even though
3602                they logically are controls.  Control is not the same as gc=cc,
3603                but includes format and other characters as well.
3604
3605                The Unicode definition of Hangul-syllable is:
3606                    L+
3607                    | (L* ( ( V | LV ) V* | LVT ) T*)
3608                    | T+
3609                   )
3610                Each of these is a value for the GCB property, and hence must be
3611                disjoint, so the order they are tested is immaterial, so the
3612                above can safely be changed to
3613                    T+
3614                    | L+
3615                    | (L* ( LVT | ( V | LV ) V*) T*)
3616
3617                The last two terms can be combined like this:
3618                    L* ( L
3619                         | (( LVT | ( V | LV ) V*) T*))
3620
3621                And refactored into this:
3622                    L* (L | LVT T* | V  V* T* | LV  V* T*)
3623
3624                That means that if we have seen any L's at all we can quit
3625                there, but if the next character is a LVT, a V or and LV we
3626                should keep going.
3627
3628                There is a subtlety with Prepend* which showed up in testing.
3629                Note that the Begin, and only the Begin is required in:
3630                 | Prepend* Begin Extend*
3631                Also, Begin contains '! Control'.  A Prepend must be a '!
3632                Control', which means it must be a Begin.  What it comes down to
3633                is that if we match Prepend* and then find no suitable Begin
3634                afterwards, that if we backtrack the last Prepend, that one will
3635                be a suitable Begin.
3636             */
3637
3638             if (locinput >= PL_regeol)
3639                 sayNO;
3640             if  (! do_utf8) {
3641
3642                 /* Match either CR LF  or '.', as all the other possibilities
3643                  * require utf8 */
3644                 locinput++;         /* Match the . or CR */
3645                 if (nextchr == '\r'
3646                     && locinput < PL_regeol
3647                     && UCHARAT(locinput) == '\n') locinput++;
3648             }
3649             else {
3650
3651                 /* Utf8: See if is ( CR LF ); already know that locinput <
3652                  * PL_regeol, so locinput+1 is in bounds */
3653                 if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
3654                     locinput += 2;
3655                 }
3656                 else {
3657                     /* In case have to backtrack to beginning, then match '.' */
3658                     char *starting = locinput;
3659
3660                     /* In case have to backtrack the last prepend */
3661                     char *previous_prepend = 0;
3662
3663                     LOAD_UTF8_CHARCLASS_GCB();
3664
3665                     /* Match (prepend)* */
3666                     while (locinput < PL_regeol
3667                            && swash_fetch(PL_utf8_X_prepend,
3668                                           (U8*)locinput, do_utf8))
3669                     {
3670                         previous_prepend = locinput;
3671                         locinput += UTF8SKIP(locinput);
3672                     }
3673
3674                     /* As noted above, if we matched a prepend character, but
3675                      * the next thing won't match, back off the last prepend we
3676                      * matched, as it is guaranteed to match the begin */
3677                     if (previous_prepend
3678                         && (locinput >=  PL_regeol
3679                             || ! swash_fetch(PL_utf8_X_begin,
3680                                              (U8*)locinput, do_utf8)))
3681                     {
3682                         locinput = previous_prepend;
3683                     }
3684
3685                     /* Note that here we know PL_regeol > locinput, as we
3686                      * tested that upon input to this switch case, and if we
3687                      * moved locinput forward, we tested the result just above
3688                      * and it either passed, or we backed off so that it will
3689                      * now pass */
3690                     if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, do_utf8)) {
3691
3692                         /* Here did not match the required 'Begin' in the
3693                          * second term.  So just match the very first
3694                          * character, the '.' of the final term of the regex */
3695                         locinput = starting + UTF8SKIP(starting);
3696                     } else {
3697
3698                         /* Here is the beginning of a character that can have
3699                          * an extender.  It is either a hangul syllable, or a
3700                          * non-control */
3701                         if (swash_fetch(PL_utf8_X_non_hangul,
3702                                         (U8*)locinput, do_utf8))
3703                         {
3704
3705                             /* Here not a Hangul syllable, must be a
3706                              * ('!  * Control') */
3707                             locinput += UTF8SKIP(locinput);
3708                         } else {
3709
3710                             /* Here is a Hangul syllable.  It can be composed
3711                              * of several individual characters.  One
3712                              * possibility is T+ */
3713                             if (swash_fetch(PL_utf8_X_T,
3714                                             (U8*)locinput, do_utf8))
3715                             {
3716                                 while (locinput < PL_regeol
3717                                         && swash_fetch(PL_utf8_X_T,
3718                                                         (U8*)locinput, do_utf8))
3719                                 {
3720                                     locinput += UTF8SKIP(locinput);
3721                                 }
3722                             } else {
3723
3724                                 /* Here, not T+, but is a Hangul.  That means
3725                                  * it is one of the others: L, LV, LVT or V,
3726                                  * and matches:
3727                                  * L* (L | LVT T* | V  V* T* | LV  V* T*) */
3728
3729                                 /* Match L*           */
3730                                 while (locinput < PL_regeol
3731                                         && swash_fetch(PL_utf8_X_L,
3732                                                         (U8*)locinput, do_utf8))
3733                                 {
3734                                     locinput += UTF8SKIP(locinput);
3735                                 }
3736
3737                                 /* Here, have exhausted L*.  If the next
3738                                  * character is not an LV, LVT nor V, it means
3739                                  * we had to have at least one L, so matches L+
3740                                  * in the original equation, we have a complete
3741                                  * hangul syllable.  Are done. */
3742
3743                                 if (locinput < PL_regeol
3744                                     && swash_fetch(PL_utf8_X_LV_LVT_V,
3745                                                     (U8*)locinput, do_utf8))
3746                                 {
3747
3748                                     /* Otherwise keep going.  Must be LV, LVT
3749                                      * or V.  See if LVT */
3750                                     if (swash_fetch(PL_utf8_X_LVT,
3751                                                     (U8*)locinput, do_utf8))
3752                                     {
3753                                         locinput += UTF8SKIP(locinput);
3754                                     } else {
3755
3756                                         /* Must be  V or LV.  Take it, then
3757                                          * match V*     */
3758                                         locinput += UTF8SKIP(locinput);
3759                                         while (locinput < PL_regeol
3760                                                 && swash_fetch(PL_utf8_X_V,
3761                                                          (U8*)locinput, do_utf8))
3762                                         {
3763                                             locinput += UTF8SKIP(locinput);
3764                                         }
3765                                     }
3766
3767                                     /* And any of LV, LVT, or V can be followed
3768                                      * by T*            */
3769                                     while (locinput < PL_regeol
3770                                            && swash_fetch(PL_utf8_X_T,
3771                                                            (U8*)locinput,
3772                                                            do_utf8))
3773                                     {
3774                                         locinput += UTF8SKIP(locinput);
3775                                     }
3776                                 }
3777                             }
3778                         }
3779
3780                         /* Match any extender */
3781                         while (locinput < PL_regeol
3782                                 && swash_fetch(PL_utf8_X_extend,
3783                                                 (U8*)locinput, do_utf8))
3784                         {
3785                             locinput += UTF8SKIP(locinput);
3786                         }
3787                     }
3788                 }
3789                 if (locinput > PL_regeol) sayNO;
3790             }
3791             nextchr = UCHARAT(locinput);
3792             break;
3793
3794         case NREFFL:
3795         {
3796             char *s;
3797             char type;
3798             PL_reg_flags |= RF_tainted;
3799             /* FALL THROUGH */
3800         case NREF:
3801         case NREFF:
3802             type = OP(scan);
3803             n = reg_check_named_buff_matched(rex,scan);
3804
3805             if ( n ) {
3806                 type = REF + ( type - NREF );
3807                 goto do_ref;
3808             } else {
3809                 sayNO;
3810             }
3811             /* unreached */
3812         case REFFL:
3813             PL_reg_flags |= RF_tainted;
3814             /* FALL THROUGH */
3815         case REF:
3816         case REFF:
3817             n = ARG(scan);  /* which paren pair */
3818             type = OP(scan);
3819           do_ref:
3820             ln = PL_regoffs[n].start;
3821             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3822             if (*PL_reglastparen < n || ln == -1)
3823                 sayNO;                  /* Do not match unless seen CLOSEn. */
3824             if (ln == PL_regoffs[n].end)
3825                 break;
3826
3827             s = PL_bostr + ln;
3828             if (do_utf8 && type != REF) {       /* REF can do byte comparison */
3829                 char *l = locinput;
3830                 const char *e = PL_bostr + PL_regoffs[n].end;
3831                 /*
3832                  * Note that we can't do the "other character" lookup trick as
3833                  * in the 8-bit case (no pun intended) because in Unicode we
3834                  * have to map both upper and title case to lower case.
3835                  */
3836                 if (type == REFF) {
3837                     while (s < e) {
3838                         STRLEN ulen1, ulen2;
3839                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3840                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3841
3842                         if (l >= PL_regeol)
3843                             sayNO;
3844                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3845                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3846                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3847                             sayNO;
3848                         s += ulen1;
3849                         l += ulen2;
3850                     }
3851                 }
3852                 locinput = l;
3853                 nextchr = UCHARAT(locinput);
3854                 break;
3855             }
3856
3857             /* Inline the first character, for speed. */
3858             if (UCHARAT(s) != nextchr &&
3859                 (type == REF ||
3860                  (UCHARAT(s) != (type == REFF
3861                                   ? PL_fold : PL_fold_locale)[nextchr])))
3862                 sayNO;
3863             ln = PL_regoffs[n].end - ln;
3864             if (locinput + ln > PL_regeol)
3865                 sayNO;
3866             if (ln > 1 && (type == REF
3867                            ? memNE(s, locinput, ln)
3868                            : (type == REFF
3869                               ? ibcmp(s, locinput, ln)
3870                               : ibcmp_locale(s, locinput, ln))))
3871                 sayNO;
3872             locinput += ln;
3873             nextchr = UCHARAT(locinput);
3874             break;
3875         }
3876         case NOTHING:
3877         case TAIL:
3878             break;
3879         case BACK:
3880             break;
3881
3882 #undef  ST
3883 #define ST st->u.eval
3884         {
3885             SV *ret;
3886             REGEXP *re_sv;
3887             regexp *re;
3888             regexp_internal *rei;
3889             regnode *startpoint;
3890
3891         case GOSTART:
3892         case GOSUB: /*    /(...(?1))/   /(...(?&foo))/   */
3893             if (cur_eval && cur_eval->locinput==locinput) {
3894                 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3895                     Perl_croak(aTHX_ "Infinite recursion in regex");
3896                 if ( ++nochange_depth > max_nochange_depth )
3897                     Perl_croak(aTHX_
3898                         "Pattern subroutine nesting without pos change"
3899                         " exceeded limit in regex");
3900             } else {
3901                 nochange_depth = 0;
3902             }
3903             re_sv = rex_sv;
3904             re = rex;
3905             rei = rexi;
3906             (void)ReREFCNT_inc(rex_sv);
3907             if (OP(scan)==GOSUB) {
3908                 startpoint = scan + ARG2L(scan);
3909                 ST.close_paren = ARG(scan);
3910             } else {
3911                 startpoint = rei->program+1;
3912                 ST.close_paren = 0;
3913             }
3914             goto eval_recurse_doit;
3915             /* NOTREACHED */
3916         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3917             if (cur_eval && cur_eval->locinput==locinput) {
3918                 if ( ++nochange_depth > max_nochange_depth )
3919                     Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3920             } else {
3921                 nochange_depth = 0;
3922             }
3923             {
3924                 /* execute the code in the {...} */
3925                 dSP;
3926                 SV ** const before = SP;
3927                 OP_4tree * const oop = PL_op;
3928                 COP * const ocurcop = PL_curcop;
3929                 PAD *old_comppad;
3930                 char *saved_regeol = PL_regeol;
3931
3932                 n = ARG(scan);
3933                 PL_op = (OP_4tree*)rexi->data->data[n];
3934                 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3935                     "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3936                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3937                 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3938
3939                 if (sv_yes_mark) {
3940                     SV *sv_mrk = get_sv("REGMARK", 1);
3941                     sv_setsv(sv_mrk, sv_yes_mark);
3942                 }
3943
3944                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3945                 SPAGAIN;
3946                 if (SP == before)
3947                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3948                 else {
3949                     ret = POPs;
3950                     PUTBACK;
3951                 }
3952
3953                 PL_op = oop;
3954                 PAD_RESTORE_LOCAL(old_comppad);
3955                 PL_curcop = ocurcop;
3956                 PL_regeol = saved_regeol;
3957                 if (!logical) {
3958                     /* /(?{...})/ */
3959                     sv_setsv(save_scalar(PL_replgv), ret);
3960                     break;
3961                 }
3962             }
3963             if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3964                 logical = 0;
3965                 {
3966                     /* extract RE object from returned value; compiling if
3967                      * necessary */
3968                     MAGIC *mg = NULL;
3969                     REGEXP *rx = NULL;
3970
3971                     if (SvROK(ret)) {
3972                         SV *const sv = SvRV(ret);
3973
3974                         if (SvTYPE(sv) == SVt_REGEXP) {
3975                             rx = (REGEXP*) sv;
3976                         } else if (SvSMAGICAL(sv)) {
3977                             mg = mg_find(sv, PERL_MAGIC_qr);
3978                             assert(mg);
3979                         }
3980                     } else if (SvTYPE(ret) == SVt_REGEXP) {
3981                         rx = (REGEXP*) ret;
3982                     } else if (SvSMAGICAL(ret)) {
3983                         if (SvGMAGICAL(ret)) {
3984                             /* I don't believe that there is ever qr magic
3985                                here.  */
3986                             assert(!mg_find(ret, PERL_MAGIC_qr));
3987                             sv_unmagic(ret, PERL_MAGIC_qr);
3988                         }
3989                         else {
3990                             mg = mg_find(ret, PERL_MAGIC_qr);
3991                             /* testing suggests mg only ends up non-NULL for
3992                                scalars who were upgraded and compiled in the
3993                                else block below. In turn, this is only
3994                                triggered in the "postponed utf8 string" tests
3995                                in t/op/pat.t  */
3996                         }
3997                     }
3998
3999                     if (mg) {
4000                         rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
4001                         assert(rx);
4002                     }
4003                     if (rx) {
4004                         rx = reg_temp_copy(NULL, rx);
4005                     }
4006                     else {
4007                         U32 pm_flags = 0;
4008                         const I32 osize = PL_regsize;
4009
4010                         if (DO_UTF8(ret)) {
4011                             assert (SvUTF8(ret));
4012                         } else if (SvUTF8(ret)) {
4013                             /* Not doing UTF-8, despite what the SV says. Is
4014                                this only if we're trapped in use 'bytes'?  */
4015                             /* Make a copy of the octet sequence, but without
4016                                the flag on, as the compiler now honours the
4017                                SvUTF8 flag on ret.  */
4018                             STRLEN len;
4019                             const char *const p = SvPV(ret, len);
4020                             ret = newSVpvn_flags(p, len, SVs_TEMP);
4021                         }
4022                         rx = CALLREGCOMP(ret, pm_flags);
4023                         if (!(SvFLAGS(ret)
4024                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
4025                                  | SVs_GMG))) {
4026                             /* This isn't a first class regexp. Instead, it's
4027                                caching a regexp onto an existing, Perl visible
4028                                scalar.  */
4029                             sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
4030                         }
4031                         PL_regsize = osize;
4032                     }
4033                     re_sv = rx;
4034                     re = (struct regexp *)SvANY(rx);
4035                 }
4036                 RXp_MATCH_COPIED_off(re);
4037                 re->subbeg = rex->subbeg;
4038                 re->sublen = rex->sublen;
4039                 rei = RXi_GET(re);
4040                 DEBUG_EXECUTE_r(
4041                     debug_start_match(re_sv, do_utf8, locinput, PL_regeol,
4042                         "Matching embedded");
4043                 );
4044                 startpoint = rei->program + 1;
4045                 ST.close_paren = 0; /* only used for GOSUB */
4046                 /* borrowed from regtry */
4047                 if (PL_reg_start_tmpl <= re->nparens) {
4048                     PL_reg_start_tmpl = re->nparens*3/2 + 3;
4049                     if(PL_reg_start_tmp)
4050                         Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4051                     else
4052                         Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4053                 }
4054
4055         eval_recurse_doit: /* Share code with GOSUB below this line */
4056                 /* run the pattern returned from (??{...}) */
4057                 ST.cp = regcppush(0);   /* Save *all* the positions. */
4058                 REGCP_SET(ST.lastcp);
4059
4060                 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
4061
4062                 /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
4063                 PL_reglastparen = &re->lastparen;
4064                 PL_reglastcloseparen = &re->lastcloseparen;
4065                 re->lastparen = 0;
4066                 re->lastcloseparen = 0;
4067
4068                 PL_reginput = locinput;
4069                 PL_regsize = 0;
4070
4071                 /* XXXX This is too dramatic a measure... */
4072                 PL_reg_maxiter = 0;
4073
4074                 ST.toggle_reg_flags = PL_reg_flags;
4075                 if (RX_UTF8(re_sv))
4076                     PL_reg_flags |= RF_utf8;
4077                 else
4078                     PL_reg_flags &= ~RF_utf8;
4079                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
4080
4081                 ST.prev_rex = rex_sv;
4082                 ST.prev_curlyx = cur_curlyx;
4083                 SETREX(rex_sv,re_sv);
4084                 rex = re;
4085                 rexi = rei;
4086                 cur_curlyx = NULL;
4087                 ST.B = next;
4088                 ST.prev_eval = cur_eval;
4089                 cur_eval = st;
4090                 /* now continue from first node in postoned RE */
4091                 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
4092                 /* NOTREACHED */
4093             }
4094             /* logical is 1,   /(?(?{...})X|Y)/ */
4095             sw = (bool)SvTRUE(ret);
4096             logical = 0;
4097             break;
4098         }
4099
4100         case EVAL_AB: /* cleanup after a successful (??{A})B */
4101             /* note: this is called twice; first after popping B, then A */
4102             PL_reg_flags ^= ST.toggle_reg_flags;
4103             ReREFCNT_dec(rex_sv);
4104             SETREX(rex_sv,ST.prev_rex);
4105             rex = (struct regexp *)SvANY(rex_sv);
4106             rexi = RXi_GET(rex);
4107             regcpblow(ST.cp);
4108             cur_eval = ST.prev_eval;
4109             cur_curlyx = ST.prev_curlyx;
4110
4111             /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4112             PL_reglastparen = &rex->lastparen;
4113             PL_reglastcloseparen = &rex->lastcloseparen;
4114             /* also update PL_regoffs */
4115             PL_regoffs = rex->offs;
4116
4117             /* XXXX This is too dramatic a measure... */
4118             PL_reg_maxiter = 0;
4119             if ( nochange_depth )
4120                 nochange_depth--;
4121             sayYES;
4122
4123
4124         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
4125             /* note: this is called twice; first after popping B, then A */
4126             PL_reg_flags ^= ST.toggle_reg_flags;
4127             ReREFCNT_dec(rex_sv);
4128             SETREX(rex_sv,ST.prev_rex);
4129             rex = (struct regexp *)SvANY(rex_sv);
4130             rexi = RXi_GET(rex);
4131             /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4132             PL_reglastparen = &rex->lastparen;
4133             PL_reglastcloseparen = &rex->lastcloseparen;
4134
4135             PL_reginput = locinput;
4136             REGCP_UNWIND(ST.lastcp);
4137             regcppop(rex);
4138             cur_eval = ST.prev_eval;
4139             cur_curlyx = ST.prev_curlyx;
4140             /* XXXX This is too dramatic a measure... */
4141             PL_reg_maxiter = 0;
4142             if ( nochange_depth )
4143                 nochange_depth--;
4144             sayNO_SILENT;
4145 #undef ST
4146
4147         case OPEN:
4148             n = ARG(scan);  /* which paren pair */
4149             PL_reg_start_tmp[n] = locinput;
4150             if (n > PL_regsize)
4151                 PL_regsize = n;
4152             lastopen = n;
4153             break;
4154         case CLOSE:
4155             n = ARG(scan);  /* which paren pair */
4156             PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
4157             PL_regoffs[n].end = locinput - PL_bostr;
4158             /*if (n > PL_regsize)
4159                 PL_regsize = n;*/
4160             if (n > *PL_reglastparen)
4161                 *PL_reglastparen = n;
4162             *PL_reglastcloseparen = n;
4163             if (cur_eval && cur_eval->u.eval.close_paren == n) {
4164                 goto fake_end;
4165             }
4166             break;
4167         case ACCEPT:
4168             if (ARG(scan)){
4169                 regnode *cursor;
4170                 for (cursor=scan;
4171                      cursor && OP(cursor)!=END;
4172                      cursor=regnext(cursor))
4173                 {
4174                     if ( OP(cursor)==CLOSE ){
4175                         n = ARG(cursor);
4176                         if ( n <= lastopen ) {
4177                             PL_regoffs[n].start
4178                                 = PL_reg_start_tmp[n] - PL_bostr;
4179                             PL_regoffs[n].end = locinput - PL_bostr;
4180                             /*if (n > PL_regsize)
4181                             PL_regsize = n;*/
4182                             if (n > *PL_reglastparen)
4183                                 *PL_reglastparen = n;
4184                             *PL_reglastcloseparen = n;
4185                             if ( n == ARG(scan) || (cur_eval &&
4186                                 cur_eval->u.eval.close_paren == n))
4187                                 break;
4188                         }
4189                     }
4190                 }
4191             }
4192             goto fake_end;
4193             /*NOTREACHED*/
4194         case GROUPP:
4195             n = ARG(scan);  /* which paren pair */
4196             sw = (bool)(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
4197             break;
4198         case NGROUPP:
4199             /* reg_check_named_buff_matched returns 0 for no match */
4200             sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
4201             break;
4202         case INSUBP:
4203             n = ARG(scan);
4204             sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
4205             break;
4206         case DEFINEP:
4207             sw = 0;
4208             break;
4209         case IFTHEN:
4210             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
4211             if (sw)
4212                 next = NEXTOPER(NEXTOPER(scan));
4213             else {
4214                 next = scan + ARG(scan);
4215                 if (OP(next) == IFTHEN) /* Fake one. */
4216                     next = NEXTOPER(NEXTOPER(next));
4217             }
4218             break;
4219         case LOGICAL:
4220             logical = scan->flags;
4221             break;
4222
4223 /*******************************************************************
4224
4225 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
4226 pattern, where A and B are subpatterns. (For simple A, CURLYM or
4227 STAR/PLUS/CURLY/CURLYN are used instead.)
4228
4229 A*B is compiled as <CURLYX><A><WHILEM><B>
4230
4231 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
4232 state, which contains the current count, initialised to -1. It also sets
4233 cur_curlyx to point to this state, with any previous value saved in the
4234 state block.
4235
4236 CURLYX then jumps straight to the WHILEM op, rather than executing A,
4237 since the pattern may possibly match zero times (i.e. it's a while {} loop
4238 rather than a do {} while loop).
4239
4240 Each entry to WHILEM represents a successful match of A. The count in the
4241 CURLYX block is incremented, another WHILEM state is pushed, and execution
4242 passes to A or B depending on greediness and the current count.
4243
4244 For example, if matching against the string a1a2a3b (where the aN are
4245 substrings that match /A/), then the match progresses as follows: (the
4246 pushed states are interspersed with the bits of strings matched so far):
4247
4248     <CURLYX cnt=-1>
4249     <CURLYX cnt=0><WHILEM>
4250     <CURLYX cnt=1><WHILEM> a1 <WHILEM>
4251     <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
4252     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
4253     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
4254
4255 (Contrast this with something like CURLYM, which maintains only a single
4256 backtrack state:
4257
4258     <CURLYM cnt=0> a1
4259     a1 <CURLYM cnt=1> a2
4260     a1 a2 <CURLYM cnt=2> a3
4261     a1 a2 a3 <CURLYM cnt=3> b
4262 )
4263
4264 Each WHILEM state block marks a point to backtrack to upon partial failure
4265 of A or B, and also contains some minor state data related to that
4266 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
4267 overall state, such as the count, and pointers to the A and B ops.
4268
4269 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
4270 must always point to the *current* CURLYX block, the rules are:
4271
4272 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
4273 and set cur_curlyx to point the new block.
4274
4275 When popping the CURLYX block after a successful or unsuccessful match,
4276 restore the previous cur_curlyx.
4277
4278 When WHILEM is about to execute B, save the current cur_curlyx, and set it
4279 to the outer one saved in the CURLYX block.
4280
4281 When popping the WHILEM block after a successful or unsuccessful B match,
4282 restore the previous cur_curlyx.
4283
4284 Here's an example for the pattern (AI* BI)*BO
4285 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
4286
4287 cur_
4288 curlyx backtrack stack
4289 ------ ---------------
4290 NULL
4291 CO     <CO prev=NULL> <WO>
4292 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4293 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4294 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
4295
4296 At this point the pattern succeeds, and we work back down the stack to
4297 clean up, restoring as we go:
4298
4299 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4300 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4301 CO     <CO prev=NULL> <WO>
4302 NULL
4303
4304 *******************************************************************/
4305
4306 #define ST st->u.curlyx
4307
4308         case CURLYX:    /* start of /A*B/  (for complex A) */
4309         {
4310             /* No need to save/restore up to this paren */
4311             I32 parenfloor = scan->flags;
4312
4313             assert(next); /* keep Coverity happy */
4314             if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4315                 next += ARG(next);
4316
4317             /* XXXX Probably it is better to teach regpush to support
4318                parenfloor > PL_regsize... */
4319             if (parenfloor > (I32)*PL_reglastparen)
4320                 parenfloor = *PL_reglastparen; /* Pessimization... */
4321
4322             ST.prev_curlyx= cur_curlyx;
4323             cur_curlyx = st;
4324             ST.cp = PL_savestack_ix;
4325
4326             /* these fields contain the state of the current curly.
4327              * they are accessed by subsequent WHILEMs */
4328             ST.parenfloor = parenfloor;
4329             ST.min = ARG1(scan);
4330             ST.max = ARG2(scan);
4331             ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4332             ST.B = next;
4333             ST.minmod = minmod;
4334             minmod = 0;
4335             ST.count = -1;      /* this will be updated by WHILEM */
4336             ST.lastloc = NULL;  /* this will be updated by WHILEM */
4337
4338             PL_reginput = locinput;
4339             PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4340             /* NOTREACHED */
4341         }
4342
4343         case CURLYX_end: /* just finished matching all of A*B */
4344             cur_curlyx = ST.prev_curlyx;
4345             sayYES;
4346             /* NOTREACHED */
4347
4348         case CURLYX_end_fail: /* just failed to match all of A*B */
4349             regcpblow(ST.cp);
4350             cur_curlyx = ST.prev_curlyx;
4351             sayNO;
4352             /* NOTREACHED */
4353
4354
4355 #undef ST
4356 #define ST st->u.whilem
4357
4358         case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
4359         {
4360             /* see the discussion above about CURLYX/WHILEM */
4361             I32 n;
4362             assert(cur_curlyx); /* keep Coverity happy */
4363             n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4364             ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4365             ST.cache_offset = 0;
4366             ST.cache_mask = 0;
4367
4368             PL_reginput = locinput;
4369
4370             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4371                   "%*s  whilem: matched %ld out of %ld..%ld\n",
4372                   REPORT_CODE_OFF+depth*2, "", (long)n,
4373                   (long)cur_curlyx->u.curlyx.min,
4374                   (long)cur_curlyx->u.curlyx.max)
4375             );
4376
4377             /* First just match a string of min A's. */
4378
4379             if (n < cur_curlyx->u.curlyx.min) {
4380                 cur_curlyx->u.curlyx.lastloc = locinput;
4381                 PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
4382                 /* NOTREACHED */
4383             }
4384
4385             /* If degenerate A matches "", assume A done. */
4386
4387             if (locinput == cur_curlyx->u.curlyx.lastloc) {
4388                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4389                    "%*s  whilem: empty match detected, trying continuation...\n",
4390                    REPORT_CODE_OFF+depth*2, "")
4391                 );
4392                 goto do_whilem_B_max;
4393             }
4394
4395             /* super-linear cache processing */
4396
4397             if (scan->flags) {
4398
4399                 if (!PL_reg_maxiter) {
4400                     /* start the countdown: Postpone detection until we
4401                      * know the match is not *that* much linear. */
4402                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4403                     /* possible overflow for long strings and many CURLYX's */
4404                     if (PL_reg_maxiter < 0)
4405                         PL_reg_maxiter = I32_MAX;
4406                     PL_reg_leftiter = PL_reg_maxiter;
4407                 }
4408
4409                 if (PL_reg_leftiter-- == 0) {
4410                     /* initialise cache */
4411                     const I32 size = (PL_reg_maxiter + 7)/8;
4412                     if (PL_reg_poscache) {
4413                         if ((I32)PL_reg_poscache_size < size) {
4414                             Renew(PL_reg_poscache, size, char);
4415                             PL_reg_poscache_size = size;
4416                         }
4417                         Zero(PL_reg_poscache, size, char);
4418                     }
4419                     else {
4420                         PL_reg_poscache_size = size;
4421                         Newxz(PL_reg_poscache, size, char);
4422                     }
4423                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4424       "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4425                               PL_colors[4], PL_colors[5])
4426                     );
4427                 }
4428
4429                 if (PL_reg_leftiter < 0) {
4430                     /* have we already failed at this position? */
4431                     I32 offset, mask;
4432                     offset  = (scan->flags & 0xf) - 1
4433                                 + (locinput - PL_bostr)  * (scan->flags>>4);
4434                     mask    = 1 << (offset % 8);
4435                     offset /= 8;
4436                     if (PL_reg_poscache[offset] & mask) {
4437                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4438                             "%*s  whilem: (cache) already tried at this position...\n",
4439                             REPORT_CODE_OFF+depth*2, "")
4440                         );
4441                         sayNO; /* cache records failure */
4442                     }
4443                     ST.cache_offset = offset;
4444                     ST.cache_mask   = mask;
4445                 }
4446             }
4447
4448             /* Prefer B over A for minimal matching. */
4449
4450             if (cur_curlyx->u.curlyx.minmod) {
4451                 ST.save_curlyx = cur_curlyx;
4452                 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4453                 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4454                 REGCP_SET(ST.lastcp);
4455                 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4456                 /* NOTREACHED */
4457             }
4458
4459             /* Prefer A over B for maximal matching. */
4460
4461             if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
4462                 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4463                 cur_curlyx->u.curlyx.lastloc = locinput;
4464                 REGCP_SET(ST.lastcp);
4465                 PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
4466                 /* NOTREACHED */
4467             }
4468             goto do_whilem_B_max;
4469         }
4470         /* NOTREACHED */
4471
4472         case WHILEM_B_min: /* just matched B in a minimal match */
4473         case WHILEM_B_max: /* just matched B in a maximal match */
4474             cur_curlyx = ST.save_curlyx;
4475             sayYES;
4476             /* NOTREACHED */
4477
4478         case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4479             cur_curlyx = ST.save_curlyx;
4480             cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4481             cur_curlyx->u.curlyx.count--;
4482             CACHEsayNO;
4483             /* NOTREACHED */
4484
4485         case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4486             REGCP_UNWIND(ST.lastcp);
4487             regcppop(rex);
4488             /* FALL THROUGH */
4489         case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4490             cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4491             cur_curlyx->u.curlyx.count--;
4492             CACHEsayNO;
4493             /* NOTREACHED */
4494
4495         case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4496             REGCP_UNWIND(ST.lastcp);
4497             regcppop(rex);      /* Restore some previous $<digit>s? */
4498             PL_reginput = locinput;
4499             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4500                 "%*s  whilem: failed, trying continuation...\n",
4501                 REPORT_CODE_OFF+depth*2, "")
4502             );
4503           do_whilem_B_max:
4504             if (cur_curlyx->u.curlyx.count >= REG_INFTY
4505                 && ckWARN(WARN_REGEXP)
4506                 && !(PL_reg_flags & RF_warned))
4507             {
4508                 PL_reg_flags |= RF_warned;
4509                 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4510                      "Complex regular subexpression recursion",
4511                      REG_INFTY - 1);
4512             }
4513
4514             /* now try B */
4515             ST.save_curlyx = cur_curlyx;
4516             cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4517             PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4518             /* NOTREACHED */
4519
4520         case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4521             cur_curlyx = ST.save_curlyx;
4522             REGCP_UNWIND(ST.lastcp);
4523             regcppop(rex);
4524
4525             if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
4526                 /* Maximum greed exceeded */
4527                 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4528                     && ckWARN(WARN_REGEXP)
4529                     && !(PL_reg_flags & RF_warned))
4530                 {
4531                     PL_reg_flags |= RF_warned;
4532                     Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4533                         "%s limit (%d) exceeded",
4534                         "Complex regular subexpression recursion",
4535                         REG_INFTY - 1);
4536                 }
4537                 cur_curlyx->u.curlyx.count--;
4538                 CACHEsayNO;
4539             }
4540
4541             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4542                 "%*s  trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4543             );
4544             /* Try grabbing another A and see if it helps. */
4545             PL_reginput = locinput;
4546             cur_curlyx->u.curlyx.lastloc = locinput;
4547             ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4548             REGCP_SET(ST.lastcp);
4549             PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
4550             /* NOTREACHED */
4551
4552 #undef  ST
4553 #define ST st->u.branch
4554
4555         case BRANCHJ:       /*  /(...|A|...)/ with long next pointer */
4556             next = scan + ARG(scan);
4557             if (next == scan)
4558                 next = NULL;
4559             scan = NEXTOPER(scan);
4560             /* FALL THROUGH */
4561
4562         case BRANCH:        /*  /(...|A|...)/ */
4563             scan = NEXTOPER(scan); /* scan now points to inner node */
4564             ST.lastparen = *PL_reglastparen;
4565             ST.next_branch = next;
4566             REGCP_SET(ST.cp);
4567             PL_reginput = locinput;
4568
4569             /* Now go into the branch */
4570             if (has_cutgroup) {
4571                 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4572             } else {
4573                 PUSH_STATE_GOTO(BRANCH_next, scan);
4574             }
4575             /* NOTREACHED */
4576         case CUTGROUP:
4577             PL_reginput = locinput;
4578             sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4579                 MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4580             PUSH_STATE_GOTO(CUTGROUP_next,next);
4581             /* NOTREACHED */
4582         case CUTGROUP_next_fail:
4583             do_cutgroup = 1;
4584             no_final = 1;
4585             if (st->u.mark.mark_name)
4586                 sv_commit = st->u.mark.mark_name;
4587             sayNO;
4588             /* NOTREACHED */
4589         case BRANCH_next:
4590             sayYES;
4591             /* NOTREACHED */
4592         case BRANCH_next_fail: /* that branch failed; try the next, if any */
4593             if (do_cutgroup) {
4594                 do_cutgroup = 0;
4595                 no_final = 0;
4596             }
4597             REGCP_UNWIND(ST.cp);
4598             for (n = *PL_reglastparen; n > ST.lastparen; n--)
4599                 PL_regoffs[n].end = -1;
4600             *PL_reglastparen = n;
4601             /*dmq: *PL_reglastcloseparen = n; */
4602             scan = ST.next_branch;
4603             /* no more branches? */
4604             if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4605                 DEBUG_EXECUTE_r({
4606                     PerlIO_printf( Perl_debug_log,
4607                         "%*s  %sBRANCH failed...%s\n",
4608                         REPORT_CODE_OFF+depth*2, "",
4609                         PL_colors[4],
4610                         PL_colors[5] );
4611                 });
4612                 sayNO_SILENT;
4613             }
4614             continue; /* execute next BRANCH[J] op */
4615             /* NOTREACHED */
4616
4617         case MINMOD:
4618             minmod = 1;
4619             break;
4620
4621 #undef  ST
4622 #define ST st->u.curlym
4623
4624         case CURLYM:    /* /A{m,n}B/ where A is fixed-length */
4625
4626             /* This is an optimisation of CURLYX that enables us to push
4627              * only a single backtracking state, no matter how many matches
4628              * there are in {m,n}. It relies on the pattern being constant
4629              * length, with no parens to influence future backrefs
4630              */
4631
4632             ST.me = scan;
4633             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4634
4635             /* if paren positive, emulate an OPEN/CLOSE around A */
4636             if (ST.me->flags) {
4637                 U32 paren = ST.me->flags;
4638                 if (paren > PL_regsize)
4639                     PL_regsize = paren;
4640                 if (paren > *PL_reglastparen)
4641                     *PL_reglastparen = paren;
4642                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4643             }
4644             ST.A = scan;
4645             ST.B = next;
4646             ST.alen = 0;
4647             ST.count = 0;
4648             ST.minmod = minmod;
4649             minmod = 0;
4650             ST.c1 = CHRTEST_UNINIT;
4651             REGCP_SET(ST.cp);
4652
4653             if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4654                 goto curlym_do_B;
4655
4656           curlym_do_A: /* execute the A in /A{m,n}B/  */
4657             PL_reginput = locinput;
4658             PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4659             /* NOTREACHED */
4660
4661         case CURLYM_A: /* we've just matched an A */
4662             locinput = st->locinput;
4663             nextchr = UCHARAT(locinput);
4664
4665             ST.count++;
4666             /* after first match, determine A's length: u.curlym.alen */
4667             if (ST.count == 1) {
4668                 if (PL_reg_match_utf8) {
4669                     char *s = locinput;
4670                     while (s < PL_reginput) {
4671                         ST.alen++;
4672                         s += UTF8SKIP(s);
4673                     }
4674                 }
4675                 else {
4676                     ST.alen = PL_reginput - locinput;
4677                 }
4678                 if (ST.alen == 0)
4679                     ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4680             }
4681             DEBUG_EXECUTE_r(
4682                 PerlIO_printf(Perl_debug_log,
4683                           "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4684                           (int)(REPORT_CODE_OFF+(depth*2)), "",
4685                           (IV) ST.count, (IV)ST.alen)
4686             );
4687
4688             locinput = PL_reginput;
4689
4690             if (cur_eval && cur_eval->u.eval.close_paren &&
4691                 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4692                 goto fake_end;
4693
4694             {
4695                 I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
4696                 if ( max == REG_INFTY || ST.count < max )
4697                     goto curlym_do_A; /* try to match another A */
4698             }
4699             goto curlym_do_B; /* try to match B */
4700
4701         case CURLYM_A_fail: /* just failed to match an A */
4702             REGCP_UNWIND(ST.cp);
4703
4704             if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4705                 || (cur_eval && cur_eval->u.eval.close_paren &&
4706                     cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4707                 sayNO;
4708
4709           curlym_do_B: /* execute the B in /A{m,n}B/  */
4710             PL_reginput = locinput;
4711             if (ST.c1 == CHRTEST_UNINIT) {
4712                 /* calculate c1 and c2 for possible match of 1st char
4713                  * following curly */
4714                 ST.c1 = ST.c2 = CHRTEST_VOID;
4715                 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4716                     regnode *text_node = ST.B;
4717                     if (! HAS_TEXT(text_node))
4718                         FIND_NEXT_IMPT(text_node);
4719                     /* this used to be
4720
4721                         (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4722
4723                         But the former is redundant in light of the latter.
4724
4725                         if this changes back then the macro for
4726                         IS_TEXT and friends need to change.
4727                      */
4728                     if (PL_regkind[OP(text_node)] == EXACT)
4729                     {
4730
4731                         ST.c1 = (U8)*STRING(text_node);
4732                         ST.c2 =
4733                             (IS_TEXTF(text_node))
4734                             ? PL_fold[ST.c1]
4735                             : (IS_TEXTFL(text_node))
4736                                 ? PL_fold_locale[ST.c1]
4737                                 : ST.c1;
4738                     }
4739                 }
4740             }
4741
4742             DEBUG_EXECUTE_r(
4743                 PerlIO_printf(Perl_debug_log,
4744                     "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
4745                     (int)(REPORT_CODE_OFF+(depth*2)),
4746                     "", (IV)ST.count)
4747                 );
4748             if (ST.c1 != CHRTEST_VOID
4749                     && UCHARAT(PL_reginput) != ST.c1
4750                     && UCHARAT(PL_reginput) != ST.c2)
4751             {
4752                 /* simulate B failing */
4753                 DEBUG_OPTIMISE_r(
4754                     PerlIO_printf(Perl_debug_log,
4755                         "%*s  CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
4756                         (int)(REPORT_CODE_OFF+(depth*2)),"",
4757                         (IV)ST.c1,(IV)ST.c2
4758                 ));
4759                 state_num = CURLYM_B_fail;
4760                 goto reenter_switch;
4761             }
4762
4763             if (ST.me->flags) {
4764                 /* mark current A as captured */
4765                 I32 paren = ST.me->flags;
4766                 if (ST.count) {
4767                     PL_regoffs[paren].start
4768                         = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4769                     PL_regoffs[paren].end = PL_reginput - PL_bostr;
4770                     /*dmq: *PL_reglastcloseparen = paren; */
4771                 }
4772                 else
4773                     PL_regoffs[paren].end = -1;
4774                 if (cur_eval && cur_eval->u.eval.close_paren &&
4775                     cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4776                 {
4777                     if (ST.count)
4778                         goto fake_end;
4779                     else
4780                         sayNO;
4781                 }
4782             }
4783
4784             PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4785             /* NOTREACHED */
4786
4787         case CURLYM_B_fail: /* just failed to match a B */
4788             REGCP_UNWIND(ST.cp);
4789             if (ST.minmod) {
4790                 I32 max = ARG2(ST.me);
4791                 if (max != REG_INFTY && ST.count == max)
4792                     sayNO;
4793                 goto curlym_do_A; /* try to match a further A */
4794             }
4795             /* backtrack one A */
4796             if (ST.count == ARG1(ST.me) /* min */)
4797                 sayNO;
4798             ST.count--;
4799             locinput = HOPc(locinput, -ST.alen);
4800             goto curlym_do_B; /* try to match B */
4801
4802 #undef ST
4803 #define ST st->u.curly
4804
4805 #define CURLY_SETPAREN(paren, success) \
4806     if (paren) { \
4807         if (success) { \
4808             PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
4809             PL_regoffs[paren].end = locinput - PL_bostr; \
4810             *PL_reglastcloseparen = paren; \
4811         } \
4812         else \
4813             PL_regoffs[paren].end = -1; \
4814     }
4815
4816         case STAR:              /*  /A*B/ where A is width 1 */
4817             ST.paren = 0;
4818             ST.min = 0;
4819             ST.max = REG_INFTY;
4820             scan = NEXTOPER(scan);
4821             goto repeat;
4822         case PLUS:              /*  /A+B/ where A is width 1 */
4823             ST.paren = 0;
4824             ST.min = 1;
4825             ST.max = REG_INFTY;
4826             scan = NEXTOPER(scan);
4827             goto repeat;
4828         case CURLYN:            /*  /(A){m,n}B/ where A is width 1 */
4829             ST.paren = scan->flags;     /* Which paren to set */
4830             if (ST.paren > PL_regsize)
4831                 PL_regsize = ST.paren;
4832             if (ST.paren > *PL_reglastparen)
4833                 *PL_reglastparen = ST.paren;
4834             ST.min = ARG1(scan);  /* min to match */
4835             ST.max = ARG2(scan);  /* max to match */
4836             if (cur_eval && cur_eval->u.eval.close_paren &&
4837                 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4838                 ST.min=1;
4839                 ST.max=1;
4840             }
4841             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4842             goto repeat;
4843         case CURLY:             /*  /A{m,n}B/ where A is width 1 */
4844             ST.paren = 0;
4845             ST.min = ARG1(scan);  /* min to match */
4846             ST.max = ARG2(scan);  /* max to match */
4847             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4848           repeat:
4849             /*
4850             * Lookahead to avoid useless match attempts
4851             * when we know what character comes next.
4852             *
4853             * Used to only do .*x and .*?x, but now it allows
4854             * for )'s, ('s and (?{ ... })'s to be in the way
4855             * of the quantifier and the EXACT-like node.  -- japhy
4856             */
4857
4858             if (ST.min > ST.max) /* XXX make this a compile-time check? */
4859                 sayNO;
4860             if (HAS_TEXT(next) || JUMPABLE(next)) {
4861                 U8 *s;
4862                 regnode *text_node = next;
4863
4864                 if (! HAS_TEXT(text_node))
4865                     FIND_NEXT_IMPT(text_node);
4866
4867                 if (! HAS_TEXT(text_node))
4868                     ST.c1 = ST.c2 = CHRTEST_VOID;
4869                 else {
4870                     if ( PL_regkind[OP(text_node)] != EXACT ) {
4871                         ST.c1 = ST.c2 = CHRTEST_VOID;
4872                         goto assume_ok_easy;
4873                     }
4874                     else
4875                         s = (U8*)STRING(text_node);
4876
4877                     /*  Currently we only get here when
4878
4879                         PL_rekind[OP(text_node)] == EXACT
4880
4881                         if this changes back then the macro for IS_TEXT and
4882                         friends need to change. */
4883                     if (!UTF) {
4884                         ST.c2 = ST.c1 = *s;
4885                         if (IS_TEXTF(text_node))
4886                             ST.c2 = PL_fold[ST.c1];
4887                         else if (IS_TEXTFL(text_node))
4888                             ST.c2 = PL_fold_locale[ST.c1];
4889                     }
4890                     else { /* UTF */
4891                         if (IS_TEXTF(text_node)) {
4892                              STRLEN ulen1, ulen2;
4893                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4894                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4895
4896                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4897                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4898 #ifdef EBCDIC
4899                              ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4900                                                     ckWARN(WARN_UTF8) ?
4901                                                     0 : UTF8_ALLOW_ANY);
4902                              ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4903                                                     ckWARN(WARN_UTF8) ?
4904                                                     0 : UTF8_ALLOW_ANY);
4905 #else
4906                              ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4907                                                     uniflags);
4908                              ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4909                                                     uniflags);
4910 #endif
4911                         }
4912                         else {
4913                             ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4914                                                      uniflags);
4915                         }
4916                     }
4917                 }
4918             }
4919             else
4920                 ST.c1 = ST.c2 = CHRTEST_VOID;
4921         assume_ok_easy:
4922
4923             ST.A = scan;
4924             ST.B = next;
4925             PL_reginput = locinput;
4926             if (minmod) {
4927                 minmod = 0;
4928                 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4929                     sayNO;
4930                 ST.count = ST.min;
4931                 locinput = PL_reginput;
4932                 REGCP_SET(ST.cp);
4933                 if (ST.c1 == CHRTEST_VOID)
4934                     goto curly_try_B_min;
4935
4936                 ST.oldloc = locinput;
4937
4938                 /* set ST.maxpos to the furthest point along the
4939                  * string that could possibly match */
4940                 if  (ST.max == REG_INFTY) {
4941                     ST.maxpos = PL_regeol - 1;
4942                     if (do_utf8)
4943                         while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4944                             ST.maxpos--;
4945                 }
4946                 else if (do_utf8) {
4947                     int m = ST.max - ST.min;
4948                     for (ST.maxpos = locinput;
4949                          m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4950                         ST.maxpos += UTF8SKIP(ST.maxpos);
4951                 }
4952                 else {
4953                     ST.maxpos = locinput + ST.max - ST.min;
4954                     if (ST.maxpos >= PL_regeol)
4955                         ST.maxpos = PL_regeol - 1;
4956                 }
4957                 goto curly_try_B_min_known;
4958
4959             }
4960             else {
4961                 ST.count = regrepeat(rex, ST.A, ST.max, depth);
4962                 locinput = PL_reginput;
4963                 if (ST.count < ST.min)
4964                     sayNO;
4965                 if ((ST.count > ST.min)
4966                     && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4967                 {
4968                     /* A{m,n} must come at the end of the string, there's
4969                      * no point in backing off ... */
4970                     ST.min = ST.count;
4971                     /* ...except that $ and \Z can match before *and* after
4972                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4973                        We may back off by one in this case. */
4974                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4975                         ST.min--;
4976                 }
4977                 REGCP_SET(ST.cp);
4978                 goto curly_try_B_max;
4979             }
4980             /* NOTREACHED */
4981
4982
4983         case CURLY_B_min_known_fail:
4984             /* failed to find B in a non-greedy match where c1,c2 valid */
4985             if (ST.paren && ST.count)
4986                 PL_regoffs[ST.paren].end = -1;
4987
4988             PL_reginput = locinput;     /* Could be reset... */
4989             REGCP_UNWIND(ST.cp);
4990             /* Couldn't or didn't -- move forward. */
4991             ST.oldloc = locinput;
4992             if (do_utf8)
4993                 locinput += UTF8SKIP(locinput);
4994             else
4995                 locinput++;
4996             ST.count++;
4997           curly_try_B_min_known:
4998              /* find the next place where 'B' could work, then call B */
4999             {
5000                 int n;
5001                 if (do_utf8) {
5002                     n = (ST.oldloc == locinput) ? 0 : 1;
5003                     if (ST.c1 == ST.c2) {
5004                         STRLEN len;
5005                         /* set n to utf8_distance(oldloc, locinput) */
5006                         while (locinput <= ST.maxpos &&
5007                                utf8n_to_uvchr((U8*)locinput,
5008                                               UTF8_MAXBYTES, &len,
5009                                               uniflags) != (UV)ST.c1) {
5010                             locinput += len;
5011                             n++;
5012                         }
5013                     }
5014                     else {
5015                         /* set n to utf8_distance(oldloc, locinput) */
5016                         while (locinput <= ST.maxpos) {
5017                             STRLEN len;
5018                             const UV c = utf8n_to_uvchr((U8*)locinput,
5019                                                   UTF8_MAXBYTES, &len,
5020                                                   uniflags);
5021                             if (c == (UV)ST.c1 || c == (UV)ST.c2)
5022                                 break;
5023                             locinput += len;
5024                             n++;
5025                         }
5026                     }
5027                 }
5028                 else {
5029                     if (ST.c1 == ST.c2) {
5030                         while (locinput <= ST.maxpos &&
5031                                UCHARAT(locinput) != ST.c1)
5032                             locinput++;
5033                     }
5034                     else {
5035                         while (locinput <= ST.maxpos
5036                                && UCHARAT(locinput) != ST.c1
5037                                && UCHARAT(locinput) != ST.c2)
5038                             locinput++;
5039                     }
5040                     n = locinput - ST.oldloc;
5041                 }
5042                 if (locinput > ST.maxpos)
5043                     sayNO;
5044                 /* PL_reginput == oldloc now */
5045                 if (n) {
5046                     ST.count += n;
5047                     if (regrepeat(rex, ST.A, n, depth) < n)
5048                         sayNO;
5049                 }
5050                 PL_reginput = locinput;
5051                 CURLY_SETPAREN(ST.paren, ST.count);
5052                 if (cur_eval && cur_eval->u.eval.close_paren &&
5053                     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5054                     goto fake_end;
5055                 }
5056                 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
5057             }
5058             /* NOTREACHED */
5059
5060
5061         case CURLY_B_min_fail:
5062             /* failed to find B in a non-greedy match where c1,c2 invalid */
5063             if (ST.paren && ST.count)
5064                 PL_regoffs[ST.paren].end = -1;
5065
5066             REGCP_UNWIND(ST.cp);
5067             /* failed -- move forward one */
5068             PL_reginput = locinput;
5069             if (regrepeat(rex, ST.A, 1, depth)) {
5070                 ST.count++;
5071                 locinput = PL_reginput;
5072                 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
5073                         ST.count > 0)) /* count overflow ? */
5074                 {
5075                   curly_try_B_min:
5076                     CURLY_SETPAREN(ST.paren, ST.count);
5077                     if (cur_eval && cur_eval->u.eval.close_paren &&
5078                         cur_eval->u.eval.close_paren == (U32)ST.paren) {
5079                         goto fake_end;
5080                     }
5081                     PUSH_STATE_GOTO(CURLY_B_min, ST.B);
5082                 }
5083             }
5084             sayNO;
5085             /* NOTREACHED */
5086
5087
5088         curly_try_B_max:
5089             /* a successful greedy match: now try to match B */
5090             if (cur_eval && cur_eval->u.eval.close_paren &&
5091                 cur_eval->u.eval.close_paren == (U32)ST.paren) {
5092                 goto fake_end;
5093             }
5094             {
5095                 UV c = 0;
5096                 if (ST.c1 != CHRTEST_VOID)
5097                     c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
5098                                            UTF8_MAXBYTES, 0, uniflags)
5099                                 : (UV) UCHARAT(PL_reginput);
5100                 /* If it could work, try it. */
5101                 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
5102                     CURLY_SETPAREN(ST.paren, ST.count);
5103                     PUSH_STATE_GOTO(CURLY_B_max, ST.B);
5104                     /* NOTREACHED */
5105                 }
5106             }
5107             /* FALL THROUGH */
5108         case CURLY_B_max_fail:
5109             /* failed to find B in a greedy match */
5110             if (ST.paren && ST.count)
5111                 PL_regoffs[ST.paren].end = -1;
5112
5113             REGCP_UNWIND(ST.cp);
5114             /*  back up. */
5115             if (--ST.count < ST.min)
5116                 sayNO;
5117             PL_reginput = locinput = HOPc(locinput, -1);
5118             goto curly_try_B_max;
5119
5120 #undef ST
5121
5122         case END:
5123             fake_end:
5124             if (cur_eval) {
5125                 /* we've just finished A in /(??{A})B/; now continue with B */
5126                 I32 tmpix;
5127                 st->u.eval.toggle_reg_flags
5128                             = cur_eval->u.eval.toggle_reg_flags;
5129                 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
5130
5131                 st->u.eval.prev_rex = rex_sv;           /* inner */
5132                 SETREX(rex_sv,cur_eval->u.eval.prev_rex);
5133                 rex = (struct regexp *)SvANY(rex_sv);
5134                 rexi = RXi_GET(rex);
5135                 cur_curlyx = cur_eval->u.eval.prev_curlyx;
5136                 ReREFCNT_inc(rex_sv);
5137                 st->u.eval.cp = regcppush(0);   /* Save *all* the positions. */
5138
5139                 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
5140                 PL_reglastparen = &rex->lastparen;
5141                 PL_reglastcloseparen = &rex->lastcloseparen;
5142
5143                 REGCP_SET(st->u.eval.lastcp);
5144                 PL_reginput = locinput;
5145
5146                 /* Restore parens of the outer rex without popping the
5147                  * savestack */
5148                 tmpix = PL_savestack_ix;
5149                 PL_savestack_ix = cur_eval->u.eval.lastcp;
5150                 regcppop(rex);
5151                 PL_savestack_ix = tmpix;
5152
5153                 st->u.eval.prev_eval = cur_eval;
5154                 cur_eval = cur_eval->u.eval.prev_eval;
5155                 DEBUG_EXECUTE_r(
5156                     PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ... %"UVxf"\n",
5157                                       REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
5158                 if ( nochange_depth )
5159                     nochange_depth--;
5160
5161                 PUSH_YES_STATE_GOTO(EVAL_AB,
5162                         st->u.eval.prev_eval->u.eval.B); /* match B */
5163             }
5164
5165             if (locinput < reginfo->till) {
5166                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5167                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
5168                                       PL_colors[4],
5169                                       (long)(locinput - PL_reg_starttry),
5170                                       (long)(reginfo->till - PL_reg_starttry),
5171                                       PL_colors[5]));
5172
5173                 sayNO_SILENT;           /* Cannot match: too short. */
5174             }
5175             PL_reginput = locinput;     /* put where regtry can find it */
5176             sayYES;                     /* Success! */
5177
5178         case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
5179             DEBUG_EXECUTE_r(
5180             PerlIO_printf(Perl_debug_log,
5181                 "%*s  %ssubpattern success...%s\n",
5182                 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
5183             PL_reginput = locinput;     /* put where regtry can find it */
5184             sayYES;                     /* Success! */
5185
5186 #undef  ST
5187 #define ST st->u.ifmatch
5188
5189         case SUSPEND:   /* (?>A) */
5190             ST.wanted = 1;
5191             PL_reginput = locinput;
5192             goto do_ifmatch;
5193
5194         case UNLESSM:   /* -ve lookaround: (?!A), or with flags, (?<!A) */
5195             ST.wanted = 0;
5196             goto ifmatch_trivial_fail_test;
5197
5198         case IFMATCH:   /* +ve lookaround: (?=A), or with flags, (?<=A) */
5199             ST.wanted = 1;
5200           ifmatch_trivial_fail_test:
5201             if (scan->flags) {
5202                 char * const s = HOPBACKc(locinput, scan->flags);
5203                 if (!s) {
5204                     /* trivial fail */
5205                     if (logical) {
5206                         logical = 0;
5207                         sw = 1 - (bool)ST.wanted;
5208                     }
5209                     else if (ST.wanted)
5210                         sayNO;
5211                     next = scan + ARG(scan);
5212                     if (next == scan)
5213                         next = NULL;
5214                     break;
5215                 }
5216                 PL_reginput = s;
5217             }
5218             else
5219                 PL_reginput = locinput;
5220
5221           do_ifmatch:
5222             ST.me = scan;
5223             ST.logical = logical;
5224             logical = 0; /* XXX: reset state of logical once it has been saved into ST */
5225
5226             /* execute body of (?...A) */
5227             PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
5228             /* NOTREACHED */
5229
5230         case IFMATCH_A_fail: /* body of (?...A) failed */
5231             ST.wanted = !ST.wanted;
5232             /* FALL THROUGH */
5233
5234         case IFMATCH_A: /* body of (?...A) succeeded */
5235             if (ST.logical) {
5236                 sw = (bool)ST.wanted;
5237             }
5238             else if (!ST.wanted)
5239                 sayNO;
5240
5241             if (OP(ST.me) == SUSPEND)
5242                 locinput = PL_reginput;
5243             else {
5244                 locinput = PL_reginput = st->locinput;
5245                 nextchr = UCHARAT(locinput);
5246             }
5247             scan = ST.me + ARG(ST.me);
5248             if (scan == ST.me)
5249                 scan = NULL;
5250             continue; /* execute B */
5251
5252 #undef ST
5253
5254         case LONGJMP:
5255             next = scan + ARG(scan);
5256             if (next == scan)
5257                 next = NULL;
5258             break;
5259         case COMMIT:
5260             reginfo->cutpoint = PL_regeol;
5261             /* FALLTHROUGH */
5262         case PRUNE:
5263             PL_reginput = locinput;
5264             if (!scan->flags)
5265                 sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5266             PUSH_STATE_GOTO(COMMIT_next,next);
5267             /* NOTREACHED */
5268         case COMMIT_next_fail:
5269             no_final = 1;
5270             /* FALLTHROUGH */
5271         case OPFAIL:
5272             sayNO;
5273             /* NOTREACHED */
5274
5275 #define ST st->u.mark
5276         case MARKPOINT:
5277             ST.prev_mark = mark_state;
5278             ST.mark_name = sv_commit = sv_yes_mark
5279                 = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5280             mark_state = st;
5281             ST.mark_loc = PL_reginput = locinput;
5282             PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5283             /* NOTREACHED */
5284         case MARKPOINT_next:
5285             mark_state = ST.prev_mark;
5286             sayYES;
5287             /* NOTREACHED */
5288         case MARKPOINT_next_fail:
5289             if (popmark && sv_eq(ST.mark_name,popmark))
5290             {
5291                 if (ST.mark_loc > startpoint)
5292                     reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5293                 popmark = NULL; /* we found our mark */
5294                 sv_commit = ST.mark_name;
5295
5296                 DEBUG_EXECUTE_r({
5297                         PerlIO_printf(Perl_debug_log,
5298                             "%*s  %ssetting cutpoint to mark:%"SVf"...%s\n",
5299                             REPORT_CODE_OFF+depth*2, "",
5300                             PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
5301                 });
5302             }
5303             mark_state = ST.prev_mark;
5304             sv_yes_mark = mark_state ?
5305                 mark_state->u.mark.mark_name : NULL;
5306             sayNO;
5307             /* NOTREACHED */
5308         case SKIP:
5309             PL_reginput = locinput;
5310             if (scan->flags) {
5311                 /* (*SKIP) : if we fail we cut here*/
5312                 ST.mark_name = NULL;
5313                 ST.mark_loc = locinput;
5314                 PUSH_STATE_GOTO(SKIP_next,next);
5315             } else {
5316                 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5317                    otherwise do nothing.  Meaning we need to scan
5318                  */
5319                 regmatch_state *cur = mark_state;
5320                 SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5321
5322                 while (cur) {
5323                     if ( sv_eq( cur->u.mark.mark_name,
5324                                 find ) )
5325                     {
5326                         ST.mark_name = find;
5327                         PUSH_STATE_GOTO( SKIP_next, next );
5328                     }
5329                     cur = cur->u.mark.prev_mark;
5330                 }
5331             }
5332             /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5333             break;
5334         case SKIP_next_fail:
5335             if (ST.mark_name) {
5336                 /* (*CUT:NAME) - Set up to search for the name as we
5337                    collapse the stack*/
5338                 popmark = ST.mark_name;
5339             } else {
5340                 /* (*CUT) - No name, we cut here.*/
5341                 if (ST.mark_loc > startpoint)
5342                     reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5343                 /* but we set sv_commit to latest mark_name if there
5344                    is one so they can test to see how things lead to this
5345                    cut */
5346                 if (mark_state)
5347                     sv_commit=mark_state->u.mark.mark_name;
5348             }
5349             no_final = 1;
5350             sayNO;
5351             /* NOTREACHED */
5352 #undef ST
5353         case FOLDCHAR:
5354             n = ARG(scan);
5355             if ( n == (U32)what_len_TRICKYFOLD(locinput,do_utf8,ln) ) {
5356                 locinput += ln;
5357             } else if ( 0xDF == n && !do_utf8 && !UTF ) {
5358                 sayNO;
5359             } else  {
5360                 U8 folded[UTF8_MAXBYTES_CASE+1];
5361                 STRLEN foldlen;
5362                 const char * const l = locinput;
5363                 char *e = PL_regeol;
5364                 to_uni_fold(n, folded, &foldlen);
5365
5366                 if (ibcmp_utf8((const char*) folded, 0,  foldlen, 1,
5367                                l, &e, 0,  do_utf8)) {
5368                         sayNO;
5369                 }
5370                 locinput = e;
5371             }
5372             nextchr = UCHARAT(locinput);
5373             break;
5374         case LNBREAK:
5375             if ((n=is_LNBREAK(locinput,do_utf8))) {
5376                 locinput += n;
5377                 nextchr = UCHARAT(locinput);
5378             } else
5379                 sayNO;
5380             break;
5381
5382 #define CASE_CLASS(nAmE)                              \
5383         case nAmE:                                    \
5384             if ((n=is_##nAmE(locinput,do_utf8))) {    \
5385                 locinput += n;                        \
5386                 nextchr = UCHARAT(locinput);          \
5387             } else                                    \
5388                 sayNO;                                \
5389             break;                                    \
5390         case N##nAmE:                                 \
5391             if ((n=is_##nAmE(locinput,do_utf8))) {    \
5392                 sayNO;                                \
5393             } else {                                  \
5394                 locinput += UTF8SKIP(locinput);       \
5395                 nextchr = UCHARAT(locinput);          \
5396             }                                         \
5397             break
5398
5399         CASE_CLASS(VERTWS);
5400         CASE_CLASS(HORIZWS);
5401 #undef CASE_CLASS
5402
5403         default:
5404             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5405                           PTR2UV(scan), OP(scan));
5406             Perl_croak(aTHX_ "regexp memory corruption");
5407
5408         } /* end switch */
5409
5410         /* switch break jumps here */
5411         scan = next; /* prepare to execute the next op and ... */
5412         continue;    /* ... jump back to the top, reusing st */
5413         /* NOTREACHED */
5414
5415       push_yes_state:
5416         /* push a state that backtracks on success */
5417         st->u.yes.prev_yes_state = yes_state;
5418         yes_state = st;
5419         /* FALL THROUGH */
5420       push_state:
5421         /* push a new regex state, then continue at scan  */
5422         {
5423             regmatch_state *newst;
5424
5425             DEBUG_STACK_r({
5426                 regmatch_state *cur = st;
5427                 regmatch_state *curyes = yes_state;
5428                 int curd = depth;
5429                 regmatch_slab *slab = PL_regmatch_slab;
5430                 for (;curd > -1;cur--,curd--) {
5431                     if (cur < SLAB_FIRST(slab)) {
5432                         slab = slab->prev;
5433                         cur = SLAB_LAST(slab);
5434                     }
5435                     PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5436                         REPORT_CODE_OFF + 2 + depth * 2,"",
5437                         curd, PL_reg_name[cur->resume_state],
5438                         (curyes == cur) ? "yes" : ""
5439                     );
5440                     if (curyes == cur)
5441                         curyes = cur->u.yes.prev_yes_state;
5442                 }
5443             } else
5444                 DEBUG_STATE_pp("push")
5445             );
5446             depth++;
5447             st->locinput = locinput;
5448             newst = st+1;
5449             if (newst >  SLAB_LAST(PL_regmatch_slab))
5450                 newst = S_push_slab(aTHX);
5451             PL_regmatch_state = newst;
5452
5453             locinput = PL_reginput;
5454             nextchr = UCHARAT(locinput);
5455             st = newst;
5456             continue;
5457             /* NOTREACHED */
5458         }
5459     }
5460
5461     /*
5462     * We get here only if there's trouble -- normally "case END" is
5463     * the terminating point.
5464     */
5465     Perl_croak(aTHX_ "corrupted regexp pointers");
5466     /*NOTREACHED*/
5467     sayNO;
5468
5469 yes:
5470     if (yes_state) {
5471         /* we have successfully completed a subexpression, but we must now
5472          * pop to the state marked by yes_state and continue from there */
5473         assert(st != yes_state);
5474 #ifdef DEBUGGING
5475         while (st != yes_state) {
5476             st--;
5477             if (st < SLAB_FIRST(PL_regmatch_slab)) {
5478                 PL_regmatch_slab = PL_regmatch_slab->prev;
5479                 st = SLAB_LAST(PL_regmatch_slab);
5480             }
5481             DEBUG_STATE_r({
5482                 if (no_final) {
5483                     DEBUG_STATE_pp("pop (no final)");
5484                 } else {
5485                     DEBUG_STATE_pp("pop (yes)");
5486                 }
5487             });
5488             depth--;
5489         }
5490 #else
5491         while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5492             || yes_state > SLAB_LAST(PL_regmatch_slab))
5493         {
5494             /* not in this slab, pop slab */
5495             depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5496             PL_regmatch_slab = PL_regmatch_slab->prev;
5497             st = SLAB_LAST(PL_regmatch_slab);
5498         }
5499         depth -= (st - yes_state);
5500 #endif
5501         st = yes_state;
5502         yes_state = st->u.yes.prev_yes_state;
5503         PL_regmatch_state = st;
5504
5505         if (no_final) {
5506             locinput= st->locinput;
5507             nextchr = UCHARAT(locinput);
5508         }
5509         state_num = st->resume_state + no_final;
5510         goto reenter_switch;
5511     }
5512
5513     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5514                           PL_colors[4], PL_colors[5]));
5515
5516     if (PL_reg_eval_set) {
5517         /* each successfully executed (?{...}) block does the equivalent of
5518          *   local $^R = do {...}
5519          * When popping the save stack, all these locals would be undone;
5520          * bypass this by setting the outermost saved $^R to the latest
5521          * value */
5522         if (oreplsv != GvSV(PL_replgv))
5523             sv_setsv(oreplsv, GvSV(PL_replgv));
5524     }
5525     result = 1;
5526     goto final_exit;
5527
5528 no:
5529     DEBUG_EXECUTE_r(
5530         PerlIO_printf(Perl_debug_log,
5531             "%*s  %sfailed...%s\n",
5532             REPORT_CODE_OFF+depth*2, "",
5533             PL_colors[4], PL_colors[5])
5534         );
5535
5536 no_silent:
5537     if (no_final) {
5538         if (yes_state) {
5539             goto yes;
5540         } else {
5541             goto final_exit;
5542         }
5543     }
5544     if (depth) {
5545         /* there's a previous state to backtrack to */
5546         st--;
5547         if (st < SLAB_FIRST(PL_regmatch_slab)) {
5548             PL_regmatch_slab = PL_regmatch_slab->prev;
5549             st = SLAB_LAST(PL_regmatch_slab);
5550         }
5551         PL_regmatch_state = st;
5552         locinput= st->locinput;
5553         nextchr = UCHARAT(locinput);
5554
5555         DEBUG_STATE_pp("pop");
5556         depth--;
5557         if (yes_state == st)
5558             yes_state = st->u.yes.prev_yes_state;
5559
5560         state_num = st->resume_state + 1; /* failure = success + 1 */
5561         goto reenter_switch;
5562     }
5563     result = 0;
5564
5565   final_exit:
5566     if (rex->intflags & PREGf_VERBARG_SEEN) {
5567         SV *sv_err = get_sv("REGERROR", 1);
5568         SV *sv_mrk = get_sv("REGMARK", 1);
5569         if (result) {
5570             sv_commit = &PL_sv_no;
5571             if (!sv_yes_mark)
5572                 sv_yes_mark = &PL_sv_yes;
5573         } else {
5574             if (!sv_commit)
5575                 sv_commit = &PL_sv_yes;
5576             sv_yes_mark = &PL_sv_no;
5577         }
5578         sv_setsv(sv_err, sv_commit);
5579         sv_setsv(sv_mrk, sv_yes_mark);
5580     }
5581
5582     /* clean up; in particular, free all slabs above current one */
5583     LEAVE_SCOPE(oldsave);
5584
5585     return result;
5586 }
5587
5588 /*
5589  - regrepeat - repeatedly match something simple, report how many
5590  */
5591 /*
5592  * [This routine now assumes that it will only match on things of length 1.
5593  * That was true before, but now we assume scan - reginput is the count,
5594  * rather than incrementing count on every character.  [Er, except utf8.]]
5595  */
5596 STATIC I32
5597 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5598 {
5599     dVAR;
5600     register char *scan;
5601     register I32 c;
5602     register char *loceol = PL_regeol;
5603     register I32 hardcount = 0;
5604     register bool do_utf8 = PL_reg_match_utf8;
5605 #ifndef DEBUGGING
5606     PERL_UNUSED_ARG(depth);
5607 #endif
5608
5609     PERL_ARGS_ASSERT_REGREPEAT;
5610
5611     scan = PL_reginput;
5612     if (max == REG_INFTY)
5613         max = I32_MAX;
5614     else if (max < loceol - scan)
5615         loceol = scan + max;
5616     switch (OP(p)) {
5617     case REG_ANY:
5618         if (do_utf8) {
5619             loceol = PL_regeol;
5620             while (scan < loceol && hardcount < max && *scan != '\n') {
5621                 scan += UTF8SKIP(scan);
5622                 hardcount++;
5623             }
5624         } else {
5625             while (scan < loceol && *scan != '\n')
5626                 scan++;
5627         }
5628         break;
5629     case SANY:
5630         if (do_utf8) {
5631             loceol = PL_regeol;
5632             while (scan < loceol && hardcount < max) {
5633                 scan += UTF8SKIP(scan);
5634                 hardcount++;
5635             }
5636         }
5637         else
5638             scan = loceol;
5639         break;
5640     case CANY:
5641         scan = loceol;
5642         break;
5643     case EXACT:         /* length of string is 1 */
5644         c = (U8)*STRING(p);
5645         while (scan < loceol && UCHARAT(scan) == c)
5646             scan++;
5647         break;
5648     case EXACTF:        /* length of string is 1 */
5649         c = (U8)*STRING(p);
5650         while (scan < loceol &&
5651                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5652             scan++;
5653         break;
5654     case EXACTFL:       /* length of string is 1 */
5655         PL_reg_flags |= RF_tainted;
5656         c = (U8)*STRING(p);
5657         while (scan < loceol &&
5658                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5659             scan++;
5660         break;
5661     case ANYOF:
5662         if (do_utf8) {
5663             loceol = PL_regeol;
5664             while (hardcount < max && scan < loceol &&
5665                    reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
5666                 scan += UTF8SKIP(scan);
5667                 hardcount++;
5668             }
5669         } else {
5670             while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5671                 scan++;
5672         }
5673         break;
5674     case ALNUM:
5675         if (do_utf8) {
5676             loceol = PL_regeol;
5677             LOAD_UTF8_CHARCLASS_ALNUM();
5678             while (hardcount < max && scan < loceol &&
5679                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5680                 scan += UTF8SKIP(scan);
5681                 hardcount++;
5682             }
5683         } else {
5684             while (scan < loceol && isALNUM(*scan))
5685                 scan++;
5686         }
5687         break;
5688     case ALNUML:
5689         PL_reg_flags |= RF_tainted;
5690         if (do_utf8) {
5691             loceol = PL_regeol;
5692             while (hardcount < max && scan < loceol &&
5693                    isALNUM_LC_utf8((U8*)scan)) {
5694                 scan += UTF8SKIP(scan);
5695                 hardcount++;
5696             }
5697         } else {
5698             while (scan < loceol && isALNUM_LC(*scan))
5699                 scan++;
5700         }
5701         break;
5702     case NALNUM:
5703         if (do_utf8) {
5704             loceol = PL_regeol;
5705             LOAD_UTF8_CHARCLASS_ALNUM();
5706             while (hardcount < max && scan < loceol &&
5707                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5708                 scan += UTF8SKIP(scan);
5709                 hardcount++;
5710             }
5711         } else {
5712             while (scan < loceol && !isALNUM(*scan))
5713                 scan++;
5714         }
5715         break;
5716     case NALNUML:
5717         PL_reg_flags |= RF_tainted;
5718         if (do_utf8) {
5719             loceol = PL_regeol;
5720             while (hardcount < max && scan < loceol &&
5721                    !isALNUM_LC_utf8((U8*)scan)) {
5722                 scan += UTF8SKIP(scan);
5723                 hardcount++;
5724             }
5725         } else {
5726             while (scan < loceol && !isALNUM_LC(*scan))
5727                 scan++;
5728         }
5729         break;
5730     case SPACE:
5731         if (do_utf8) {
5732             loceol = PL_regeol;
5733             LOAD_UTF8_CHARCLASS_SPACE();
5734             while (hardcount < max && scan < loceol &&
5735                    (*scan == ' ' ||
5736                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5737                 scan += UTF8SKIP(scan);
5738                 hardcount++;
5739             }
5740         } else {
5741             while (scan < loceol && isSPACE(*scan))
5742                 scan++;
5743         }
5744         break;
5745     case SPACEL:
5746         PL_reg_flags |= RF_tainted;
5747         if (do_utf8) {
5748             loceol = PL_regeol;
5749             while (hardcount < max && scan < loceol &&
5750                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5751                 scan += UTF8SKIP(scan);
5752                 hardcount++;
5753             }
5754         } else {
5755             while (scan < loceol && isSPACE_LC(*scan))
5756                 scan++;
5757         }
5758         break;
5759     case NSPACE:
5760         if (do_utf8) {
5761             loceol = PL_regeol;
5762             LOAD_UTF8_CHARCLASS_SPACE();
5763             while (hardcount < max && scan < loceol &&
5764                    !(*scan == ' ' ||
5765                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5766                 scan += UTF8SKIP(scan);
5767                 hardcount++;
5768             }
5769         } else {
5770             while (scan < loceol && !isSPACE(*scan))
5771                 scan++;
5772         }
5773         break;
5774     case NSPACEL:
5775         PL_reg_flags |= RF_tainted;
5776         if (do_utf8) {
5777             loceol = PL_regeol;
5778             while (hardcount < max && scan < loceol &&
5779                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5780                 scan += UTF8SKIP(scan);
5781                 hardcount++;
5782             }
5783         } else {
5784             while (scan < loceol && !isSPACE_LC(*scan))
5785                 scan++;
5786         }
5787         break;
5788     case DIGIT:
5789         if (do_utf8) {
5790             loceol = PL_regeol;
5791             LOAD_UTF8_CHARCLASS_DIGIT();
5792             while (hardcount < max && scan < loceol &&
5793                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5794                 scan += UTF8SKIP(scan);
5795                 hardcount++;
5796             }
5797         } else {
5798             while (scan < loceol && isDIGIT(*scan))
5799                 scan++;
5800         }
5801         break;
5802     case NDIGIT:
5803         if (do_utf8) {
5804             loceol = PL_regeol;
5805             LOAD_UTF8_CHARCLASS_DIGIT();
5806             while (hardcount < max && scan < loceol &&
5807                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5808                 scan += UTF8SKIP(scan);
5809                 hardcount++;
5810             }
5811         } else {
5812             while (scan < loceol && !isDIGIT(*scan))
5813                 scan++;
5814         }
5815     case LNBREAK:
5816         if (do_utf8) {
5817             loceol = PL_regeol;
5818             while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
5819                 scan += c;
5820                 hardcount++;
5821             }
5822         } else {
5823             /*
5824               LNBREAK can match two latin chars, which is ok,
5825               because we have a null terminated string, but we
5826               have to use hardcount in this situation
5827             */
5828             while (scan < loceol && (c=is_LNBREAK_latin1(scan)))  {
5829                 scan+=c;
5830                 hardcount++;
5831             }
5832         }
5833         break;
5834     case HORIZWS:
5835         if (do_utf8) {
5836             loceol = PL_regeol;
5837             while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
5838                 scan += c;
5839                 hardcount++;
5840             }
5841         } else {
5842             while (scan < loceol && is_HORIZWS_latin1(scan))
5843                 scan++;
5844         }
5845         break;
5846     case NHORIZWS:
5847         if (do_utf8) {
5848             loceol = PL_regeol;
5849             while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
5850                 scan += UTF8SKIP(scan);
5851                 hardcount++;
5852             }
5853         } else {
5854             while (scan < loceol && !is_HORIZWS_latin1(scan))
5855                 scan++;
5856
5857         }
5858         break;
5859     case VERTWS:
5860         if (do_utf8) {
5861             loceol = PL_regeol;
5862             while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
5863                 scan += c;
5864                 hardcount++;
5865             }
5866         } else {
5867             while (scan < loceol && is_VERTWS_latin1(scan))
5868                 scan++;
5869
5870         }
5871         break;
5872     case NVERTWS:
5873         if (do_utf8) {
5874             loceol = PL_regeol;
5875             while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
5876                 scan += UTF8SKIP(scan);
5877                 hardcount++;
5878             }
5879         } else {
5880             while (scan < loceol && !is_VERTWS_latin1(scan))
5881                 scan++;
5882
5883         }
5884         break;
5885
5886     default:            /* Called on something of 0 width. */
5887         break;          /* So match right here or not at all. */
5888     }
5889
5890     if (hardcount)
5891         c = hardcount;
5892     else
5893         c = scan - PL_reginput;
5894     PL_reginput = scan;
5895
5896     DEBUG_r({
5897         GET_RE_DEBUG_FLAGS_DECL;
5898         DEBUG_EXECUTE_r({
5899             SV * const prop = sv_newmortal();
5900             regprop(prog, prop, p);
5901             PerlIO_printf(Perl_debug_log,
5902                         "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
5903                         REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5904         });
5905     });
5906
5907     return(c);
5908 }
5909
5910
5911 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5912 /*
5913 - regclass_swash - prepare the utf8 swash
5914 */
5915
5916 SV *
5917 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5918 {
5919     dVAR;
5920     SV *sw  = NULL;
5921     SV *si  = NULL;
5922     SV *alt = NULL;
5923     RXi_GET_DECL(prog,progi);
5924     const struct reg_data * const data = prog ? progi->data : NULL;
5925
5926     PERL_ARGS_ASSERT_REGCLASS_SWASH;
5927
5928     if (data && data->count) {
5929         const U32 n = ARG(node);
5930
5931         if (data->what[n] == 's') {
5932             SV * const rv = MUTABLE_SV(data->data[n]);
5933             AV * const av = MUTABLE_AV(SvRV(rv));
5934             SV **const ary = AvARRAY(av);
5935             SV **a, **b;
5936
5937             /* See the end of regcomp.c:S_regclass() for
5938              * documentation of these array elements. */
5939
5940             si = *ary;
5941             a  = SvROK(ary[1]) ? &ary[1] : NULL;
5942             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
5943
5944             if (a)
5945                 sw = *a;
5946             else if (si && doinit) {
5947                 sw = swash_init("utf8", "", si, 1, 0);
5948                 (void)av_store(av, 1, sw);
5949             }
5950             if (b)
5951                 alt = *b;
5952         }
5953     }
5954
5955     if (listsvp)
5956         *listsvp = si;
5957     if (altsvp)
5958         *altsvp  = alt;
5959
5960     return sw;
5961 }
5962 #endif
5963
5964 /*
5965  - reginclass - determine if a character falls into a character class
5966
5967   The n is the ANYOF regnode, the p is the target string, lenp
5968   is pointer to the maximum length of how far to go in the p
5969   (if the lenp is zero, UTF8SKIP(p) is used),
5970   do_utf8 tells whether the target string is in UTF-8.
5971
5972  */
5973
5974 STATIC bool
5975 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5976 {
5977     dVAR;
5978     const char flags = ANYOF_FLAGS(n);
5979     bool match = FALSE;
5980     UV c = *p;
5981     STRLEN len = 0;
5982     STRLEN plen;
5983
5984     PERL_ARGS_ASSERT_REGINCLASS;
5985
5986     if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5987         c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5988                 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
5989                 | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
5990                 /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
5991                  * UTF8_ALLOW_FFFF */
5992         if (len == (STRLEN)-1)
5993             Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5994     }
5995
5996     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5997     if (do_utf8 || (flags & ANYOF_UNICODE)) {
5998         if (lenp)
5999             *lenp = 0;
6000         if (do_utf8 && !ANYOF_RUNTIME(n)) {
6001             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
6002                 match = TRUE;
6003         }
6004         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
6005             match = TRUE;
6006         if (!match) {
6007             AV *av;
6008             SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
6009
6010             if (sw) {
6011                 U8 * utf8_p;
6012                 if (do_utf8) {
6013                     utf8_p = (U8 *) p;
6014                 } else {
6015                     STRLEN len = 1;
6016                     utf8_p = bytes_to_utf8(p, &len);
6017                 }
6018                 if (swash_fetch(sw, utf8_p, 1))
6019                     match = TRUE;
6020                 else if (flags & ANYOF_FOLD) {
6021                     if (!match && lenp && av) {
6022                         I32 i;
6023                         for (i = 0; i <= av_len(av); i++) {
6024                             SV* const sv = *av_fetch(av, i, FALSE);
6025                             STRLEN len;
6026                             const char * const s = SvPV_const(sv, len);
6027                             if (len <= plen && memEQ(s, (char*)utf8_p, len)) {
6028                                 *lenp = len;
6029                                 match = TRUE;
6030                                 break;
6031                             }
6032                         }
6033                     }
6034                     if (!match) {
6035                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
6036
6037                         STRLEN tmplen;
6038                         to_utf8_fold(utf8_p, tmpbuf, &tmplen);
6039                         if (swash_fetch(sw, tmpbuf, 1))
6040                             match = TRUE;
6041                     }
6042                 }
6043
6044                 /* If we allocated a string above, free it */
6045                 if (! do_utf8) Safefree(utf8_p);
6046             }
6047         }
6048         if (match && lenp && *lenp == 0)
6049             *lenp = UNISKIP(NATIVE_TO_UNI(c));
6050     }
6051     if (!match && c < 256) {
6052         if (ANYOF_BITMAP_TEST(n, c))
6053             match = TRUE;
6054         else if (flags & ANYOF_FOLD) {
6055             U8 f;
6056
6057             if (flags & ANYOF_LOCALE) {
6058                 PL_reg_flags |= RF_tainted;
6059                 f = PL_fold_locale[c];
6060             }
6061             else
6062                 f = PL_fold[c];
6063             if (f != c && ANYOF_BITMAP_TEST(n, f))
6064                 match = TRUE;
6065         }
6066
6067         if (!match && (flags & ANYOF_CLASS)) {
6068             PL_reg_flags |= RF_tainted;
6069             if (
6070                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
6071                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
6072                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
6073                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
6074                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
6075                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
6076                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
6077                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
6078                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
6079                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
6080                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
6081                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
6082                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
6083                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
6084                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
6085                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
6086                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
6087                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
6088                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
6089                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
6090                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
6091                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
6092                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
6093                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
6094                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
6095                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
6096                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
6097                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
6098                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
6099                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
6100                 ) /* How's that for a conditional? */
6101             {
6102                 match = TRUE;
6103             }
6104         }
6105     }
6106
6107     return (flags & ANYOF_INVERT) ? !match : match;
6108 }
6109
6110 STATIC U8 *
6111 S_reghop3(U8 *s, I32 off, const U8* lim)
6112 {
6113     dVAR;
6114
6115     PERL_ARGS_ASSERT_REGHOP3;
6116
6117     if (off >= 0) {
6118         while (off-- && s < lim) {
6119             /* XXX could check well-formedness here */
6120             s += UTF8SKIP(s);
6121         }
6122     }
6123     else {
6124         while (off++ && s > lim) {
6125             s--;
6126             if (UTF8_IS_CONTINUED(*s)) {
6127                 while (s > lim && UTF8_IS_CONTINUATION(*s))
6128                     s--;
6129             }
6130             /* XXX could check well-formedness here */
6131         }
6132     }
6133     return s;
6134 }
6135
6136 #ifdef XXX_dmq
6137 /* there are a bunch of places where we use two reghop3's that should
6138    be replaced with this routine. but since thats not done yet
6139    we ifdef it out - dmq
6140 */
6141 STATIC U8 *
6142 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
6143 {
6144     dVAR;
6145
6146     PERL_ARGS_ASSERT_REGHOP4;
6147
6148     if (off >= 0) {
6149         while (off-- && s < rlim) {
6150             /* XXX could check well-formedness here */
6151             s += UTF8SKIP(s);
6152         }
6153     }
6154     else {
6155         while (off++ && s > llim) {
6156             s--;
6157             if (UTF8_IS_CONTINUED(*s)) {
6158                 while (s > llim && UTF8_IS_CONTINUATION(*s))
6159                     s--;
6160             }
6161             /* XXX could check well-formedness here */
6162         }
6163     }
6164     return s;
6165 }
6166 #endif
6167
6168 STATIC U8 *
6169 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
6170 {
6171     dVAR;
6172
6173     PERL_ARGS_ASSERT_REGHOPMAYBE3;
6174
6175     if (off >= 0) {
6176         while (off-- && s < lim) {
6177             /* XXX could check well-formedness here */
6178             s += UTF8SKIP(s);
6179         }
6180         if (off >= 0)
6181             return NULL;
6182     }
6183     else {
6184         while (off++ && s > lim) {
6185             s--;
6186             if (UTF8_IS_CONTINUED(*s)) {
6187                 while (s > lim && UTF8_IS_CONTINUATION(*s))
6188                     s--;
6189             }
6190             /* XXX could check well-formedness here */
6191         }
6192         if (off <= 0)
6193             return NULL;
6194     }
6195     return s;
6196 }
6197
6198 static void
6199 restore_pos(pTHX_ void *arg)
6200 {
6201     dVAR;
6202     regexp * const rex = (regexp *)arg;
6203     if (PL_reg_eval_set) {
6204         if (PL_reg_oldsaved) {
6205             rex->subbeg = PL_reg_oldsaved;
6206             rex->sublen = PL_reg_oldsavedlen;
6207 #ifdef PERL_OLD_COPY_ON_WRITE
6208             rex->saved_copy = PL_nrs;
6209 #endif
6210             RXp_MATCH_COPIED_on(rex);
6211         }
6212         PL_reg_magic->mg_len = PL_reg_oldpos;
6213         PL_reg_eval_set = 0;
6214         PL_curpm = PL_reg_oldcurpm;
6215     }
6216 }
6217
6218 STATIC void
6219 S_to_utf8_substr(pTHX_ register regexp *prog)
6220 {
6221     int i = 1;
6222
6223     PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
6224
6225     do {
6226         if (prog->substrs->data[i].substr
6227             && !prog->substrs->data[i].utf8_substr) {
6228             SV* const sv = newSVsv(prog->substrs->data[i].substr);
6229             prog->substrs->data[i].utf8_substr = sv;
6230             sv_utf8_upgrade(sv);
6231             if (SvVALID(prog->substrs->data[i].substr)) {
6232                 const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
6233                 if (flags & FBMcf_TAIL) {
6234                     /* Trim the trailing \n that fbm_compile added last
6235                        time.  */
6236                     SvCUR_set(sv, SvCUR(sv) - 1);
6237                     /* Whilst this makes the SV technically "invalid" (as its
6238                        buffer is no longer followed by "\0") when fbm_compile()
6239                        adds the "\n" back, a "\0" is restored.  */
6240                 }
6241                 fbm_compile(sv, flags);
6242             }
6243             if (prog->substrs->data[i].substr == prog->check_substr)
6244                 prog->check_utf8 = sv;
6245         }
6246     } while (i--);
6247 }
6248
6249 STATIC void
6250 S_to_byte_substr(pTHX_ register regexp *prog)
6251 {
6252     dVAR;
6253     int i = 1;
6254
6255     PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
6256
6257     do {
6258         if (prog->substrs->data[i].utf8_substr
6259             && !prog->substrs->data[i].substr) {
6260             SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
6261             if (sv_utf8_downgrade(sv, TRUE)) {
6262                 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
6263                     const U8 flags
6264                         = BmFLAGS(prog->substrs->data[i].utf8_substr);
6265                     if (flags & FBMcf_TAIL) {
6266                         /* Trim the trailing \n that fbm_compile added last
6267                            time.  */
6268                         SvCUR_set(sv, SvCUR(sv) - 1);
6269                     }
6270                     fbm_compile(sv, flags);
6271                 }
6272             } else {
6273                 SvREFCNT_dec(sv);
6274                 sv = &PL_sv_undef;
6275             }
6276             prog->substrs->data[i].substr = sv;
6277             if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
6278                 prog->check_substr = sv;
6279         }
6280     } while (i--);
6281 }
6282
6283 /*
6284  * Local variables:
6285  * c-indentation-style: bsd
6286  * c-basic-offset: 4
6287  * indent-tabs-mode: t
6288  * End:
6289  *
6290  * ex: set ts=8 sts=4 sw=4 noet:
6291  */