src/5012000/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                 if (s == startpos)
2013                     goto after_try;
2014                 while (1) {
2015                     if (regtry(&reginfo, &s))
2016                         goto got_it;
2017                   after_try:
2018                     if (s > end)
2019                         goto phooey;
2020                     if (prog->extflags & RXf_USE_INTUIT) {
2021                         s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2022                         if (!s)
2023                             goto phooey;
2024                     }
2025                     else
2026                         s++;
2027                 }
2028             } else {
2029                 if (s > startpos)
2030                     s--;
2031                 while (s < end) {
2032                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
2033                         if (regtry(&reginfo, &s))
2034                             goto got_it;
2035                     }
2036                 }
2037             }
2038         }
2039         goto phooey;
2040     } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
2041     {
2042         /* the warning about reginfo.ganch being used without intialization
2043            is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
2044            and we only enter this block when the same bit is set. */
2045         char *tmp_s = reginfo.ganch - prog->gofs;
2046
2047         if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
2048             goto got_it;
2049         goto phooey;
2050     }
2051
2052     /* Messy cases:  unanchored match. */
2053     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2054         /* we have /x+whatever/ */
2055         /* it must be a one character string (XXXX Except UTF?) */
2056         char ch;
2057 #ifdef DEBUGGING
2058         int did_match = 0;
2059 #endif
2060         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2061             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2062         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
2063
2064         if (do_utf8) {
2065             REXEC_FBC_SCAN(
2066                 if (*s == ch) {
2067                     DEBUG_EXECUTE_r( did_match = 1 );
2068                     if (regtry(&reginfo, &s)) goto got_it;
2069                     s += UTF8SKIP(s);
2070                     while (s < strend && *s == ch)
2071                         s += UTF8SKIP(s);
2072                 }
2073             );
2074         }
2075         else {
2076             REXEC_FBC_SCAN(
2077                 if (*s == ch) {
2078                     DEBUG_EXECUTE_r( did_match = 1 );
2079                     if (regtry(&reginfo, &s)) goto got_it;
2080                     s++;
2081                     while (s < strend && *s == ch)
2082                         s++;
2083                 }
2084             );
2085         }
2086         DEBUG_EXECUTE_r(if (!did_match)
2087                 PerlIO_printf(Perl_debug_log,
2088                                   "Did not find anchored character...\n")
2089                );
2090     }
2091     else if (prog->anchored_substr != NULL
2092               || prog->anchored_utf8 != NULL
2093               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2094                   && prog->float_max_offset < strend - s)) {
2095         SV *must;
2096         I32 back_max;
2097         I32 back_min;
2098         char *last;
2099         char *last1;            /* Last position checked before */
2100 #ifdef DEBUGGING
2101         int did_match = 0;
2102 #endif
2103         if (prog->anchored_substr || prog->anchored_utf8) {
2104             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2105                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2106             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
2107             back_max = back_min = prog->anchored_offset;
2108         } else {
2109             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2110                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2111             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2112             back_max = prog->float_max_offset;
2113             back_min = prog->float_min_offset;
2114         }
2115
2116
2117         if (must == &PL_sv_undef)
2118             /* could not downgrade utf8 check substring, so must fail */
2119             goto phooey;
2120
2121         if (back_min<0) {
2122             last = strend;
2123         } else {
2124             last = HOP3c(strend,        /* Cannot start after this */
2125                   -(I32)(CHR_SVLEN(must)
2126                          - (SvTAIL(must) != 0) + back_min), strbeg);
2127         }
2128         if (s > PL_bostr)
2129             last1 = HOPc(s, -1);
2130         else
2131             last1 = s - 1;      /* bogus */
2132
2133         /* XXXX check_substr already used to find "s", can optimize if
2134            check_substr==must. */
2135         scream_pos = -1;
2136         dontbother = end_shift;
2137         strend = HOPc(strend, -dontbother);
2138         while ( (s <= last) &&
2139                 ((flags & REXEC_SCREAM)
2140                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2141                                     end_shift, &scream_pos, 0))
2142                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2143                                   (unsigned char*)strend, must,
2144                                   multiline ? FBMrf_MULTILINE : 0))) ) {
2145             /* we may be pointing at the wrong string */
2146             if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2147                 s = strbeg + (s - SvPVX_const(sv));
2148             DEBUG_EXECUTE_r( did_match = 1 );
2149             if (HOPc(s, -back_max) > last1) {
2150                 last1 = HOPc(s, -back_min);
2151                 s = HOPc(s, -back_max);
2152             }
2153             else {
2154                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2155
2156                 last1 = HOPc(s, -back_min);
2157                 s = t;
2158             }
2159             if (do_utf8) {
2160                 while (s <= last1) {
2161                     if (regtry(&reginfo, &s))
2162                         goto got_it;
2163                     s += UTF8SKIP(s);
2164                 }
2165             }
2166             else {
2167                 while (s <= last1) {
2168                     if (regtry(&reginfo, &s))
2169                         goto got_it;
2170                     s++;
2171                 }
2172             }
2173         }
2174         DEBUG_EXECUTE_r(if (!did_match) {
2175             RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
2176                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2177             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2178                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2179                                ? "anchored" : "floating"),
2180                 quoted, RE_SV_TAIL(must));
2181         });
2182         goto phooey;
2183     }
2184     else if ( (c = progi->regstclass) ) {
2185         if (minlen) {
2186             const OPCODE op = OP(progi->regstclass);
2187             /* don't bother with what can't match */
2188             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2189                 strend = HOPc(strend, -(minlen - 1));
2190         }
2191         DEBUG_EXECUTE_r({
2192             SV * const prop = sv_newmortal();
2193             regprop(prog, prop, c);
2194             {
2195                 RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
2196                     s,strend-s,60);
2197                 PerlIO_printf(Perl_debug_log,
2198                     "Matching stclass %.*s against %s (%d chars)\n",
2199                     (int)SvCUR(prop), SvPVX_const(prop),
2200                      quoted, (int)(strend - s));
2201             }
2202         });
2203         if (find_byclass(prog, c, s, strend, &reginfo))
2204             goto got_it;
2205         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2206     }
2207     else {
2208         dontbother = 0;
2209         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2210             /* Trim the end. */
2211             char *last;
2212             SV* float_real;
2213
2214             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2215                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2216             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2217
2218             if (flags & REXEC_SCREAM) {
2219                 last = screaminstr(sv, float_real, s - strbeg,
2220                                    end_shift, &scream_pos, 1); /* last one */
2221                 if (!last)
2222                     last = scream_olds; /* Only one occurrence. */
2223                 /* we may be pointing at the wrong string */
2224                 else if (RXp_MATCH_COPIED(prog))
2225                     s = strbeg + (s - SvPVX_const(sv));
2226             }
2227             else {
2228                 STRLEN len;
2229                 const char * const little = SvPV_const(float_real, len);
2230
2231                 if (SvTAIL(float_real)) {
2232                     if (memEQ(strend - len + 1, little, len - 1))
2233                         last = strend - len + 1;
2234                     else if (!multiline)
2235                         last = memEQ(strend - len, little, len)
2236                             ? strend - len : NULL;
2237                     else
2238                         goto find_last;
2239                 } else {
2240                   find_last:
2241                     if (len)
2242                         last = rninstr(s, strend, little, little + len);
2243                     else
2244                         last = strend;  /* matching "$" */
2245                 }
2246             }
2247             if (last == NULL) {
2248                 DEBUG_EXECUTE_r(
2249                     PerlIO_printf(Perl_debug_log,
2250                         "%sCan't trim the tail, match fails (should not happen)%s\n",
2251                         PL_colors[4], PL_colors[5]));
2252                 goto phooey; /* Should not happen! */
2253             }
2254             dontbother = strend - last + prog->float_min_offset;
2255         }
2256         if (minlen && (dontbother < minlen))
2257             dontbother = minlen - 1;
2258         strend -= dontbother;              /* this one's always in bytes! */
2259         /* We don't know much -- general case. */
2260         if (do_utf8) {
2261             for (;;) {
2262                 if (regtry(&reginfo, &s))
2263                     goto got_it;
2264                 if (s >= strend)
2265                     break;
2266                 s += UTF8SKIP(s);
2267             };
2268         }
2269         else {
2270             do {
2271                 if (regtry(&reginfo, &s))
2272                     goto got_it;
2273             } while (s++ < strend);
2274         }
2275     }
2276
2277     /* Failure. */
2278     goto phooey;
2279
2280 got_it:
2281     Safefree(swap);
2282     RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2283
2284     if (PL_reg_eval_set)
2285         restore_pos(aTHX_ prog);
2286     if (RXp_PAREN_NAMES(prog))
2287         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2288
2289     /* make sure $`, $&, $', and $digit will work later */
2290     if ( !(flags & REXEC_NOT_FIRST) ) {
2291         RX_MATCH_COPY_FREE(rx);
2292         if (flags & REXEC_COPY_STR) {
2293             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2294 #ifdef PERL_OLD_COPY_ON_WRITE
2295             if ((SvIsCOW(sv)
2296                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2297                 if (DEBUG_C_TEST) {
2298                     PerlIO_printf(Perl_debug_log,
2299                                   "Copy on write: regexp capture, type %d\n",
2300                                   (int) SvTYPE(sv));
2301                 }
2302                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2303                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2304                 assert (SvPOKp(prog->saved_copy));
2305             } else
2306 #endif
2307             {
2308                 RX_MATCH_COPIED_on(rx);
2309                 s = savepvn(strbeg, i);
2310                 prog->subbeg = s;
2311             }
2312             prog->sublen = i;
2313         }
2314         else {
2315             prog->subbeg = strbeg;
2316             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2317         }
2318     }
2319
2320     return 1;
2321
2322 phooey:
2323     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2324                           PL_colors[4], PL_colors[5]));
2325     if (PL_reg_eval_set)
2326         restore_pos(aTHX_ prog);
2327     if (swap) {
2328         /* we failed :-( roll it back */
2329         Safefree(prog->offs);
2330         prog->offs = swap;
2331     }
2332
2333     return 0;
2334 }
2335
2336
2337 /*
2338  - regtry - try match at specific point
2339  */
2340 STATIC I32                      /* 0 failure, 1 success */
2341 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2342 {
2343     dVAR;
2344     CHECKPOINT lastcp;
2345     REGEXP *const rx = reginfo->prog;
2346     regexp *const prog = (struct regexp *)SvANY(rx);
2347     RXi_GET_DECL(prog,progi);
2348     GET_RE_DEBUG_FLAGS_DECL;
2349
2350     PERL_ARGS_ASSERT_REGTRY;
2351
2352     reginfo->cutpoint=NULL;
2353
2354     if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2355         MAGIC *mg;
2356
2357         PL_reg_eval_set = RS_init;
2358         DEBUG_EXECUTE_r(DEBUG_s(
2359             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2360                           (IV)(PL_stack_sp - PL_stack_base));
2361             ));
2362         SAVESTACK_CXPOS();
2363         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2364         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2365         SAVETMPS;
2366         /* Apparently this is not needed, judging by wantarray. */
2367         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2368            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2369
2370         if (reginfo->sv) {
2371             /* Make $_ available to executed code. */
2372             if (reginfo->sv != DEFSV) {
2373                 SAVE_DEFSV;
2374                 DEFSV_set(reginfo->sv);
2375             }
2376
2377             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2378                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2379                 /* prepare for quick setting of pos */
2380 #ifdef PERL_OLD_COPY_ON_WRITE
2381                 if (SvIsCOW(reginfo->sv))
2382                     sv_force_normal_flags(reginfo->sv, 0);
2383 #endif
2384                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2385                                  &PL_vtbl_mglob, NULL, 0);
2386                 mg->mg_len = -1;
2387             }
2388             PL_reg_magic    = mg;
2389             PL_reg_oldpos   = mg->mg_len;
2390             SAVEDESTRUCTOR_X(restore_pos, prog);
2391         }
2392         if (!PL_reg_curpm) {
2393             Newxz(PL_reg_curpm, 1, PMOP);
2394 #ifdef USE_ITHREADS
2395             {
2396                 SV* const repointer = &PL_sv_undef;
2397                 /* this regexp is also owned by the new PL_reg_curpm, which
2398                    will try to free it.  */
2399                 av_push(PL_regex_padav, repointer);
2400                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2401                 PL_regex_pad = AvARRAY(PL_regex_padav);
2402             }
2403 #endif
2404         }
2405 #ifdef USE_ITHREADS
2406         /* It seems that non-ithreads works both with and without this code.
2407            So for efficiency reasons it seems best not to have the code
2408            compiled when it is not needed.  */
2409         /* This is safe against NULLs: */
2410         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2411         /* PM_reg_curpm owns a reference to this regexp.  */
2412         ReREFCNT_inc(rx);
2413 #endif
2414         PM_SETRE(PL_reg_curpm, rx);
2415         PL_reg_oldcurpm = PL_curpm;
2416         PL_curpm = PL_reg_curpm;
2417         if (RXp_MATCH_COPIED(prog)) {
2418             /*  Here is a serious problem: we cannot rewrite subbeg,
2419                 since it may be needed if this match fails.  Thus
2420                 $` inside (?{}) could fail... */
2421             PL_reg_oldsaved = prog->subbeg;
2422             PL_reg_oldsavedlen = prog->sublen;
2423 #ifdef PERL_OLD_COPY_ON_WRITE
2424             PL_nrs = prog->saved_copy;
2425 #endif
2426             RXp_MATCH_COPIED_off(prog);
2427         }
2428         else
2429             PL_reg_oldsaved = NULL;
2430         prog->subbeg = PL_bostr;
2431         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2432     }
2433     DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2434     prog->offs[0].start = *startpos - PL_bostr;
2435     PL_reginput = *startpos;
2436     PL_reglastparen = &prog->lastparen;
2437     PL_reglastcloseparen = &prog->lastcloseparen;
2438     prog->lastparen = 0;
2439     prog->lastcloseparen = 0;
2440     PL_regsize = 0;
2441     PL_regoffs = prog->offs;
2442     if (PL_reg_start_tmpl <= prog->nparens) {
2443         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2444         if(PL_reg_start_tmp)
2445             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2446         else
2447             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2448     }
2449
2450     /* XXXX What this code is doing here?!!!  There should be no need
2451        to do this again and again, PL_reglastparen should take care of
2452        this!  --ilya*/
2453
2454     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2455      * Actually, the code in regcppop() (which Ilya may be meaning by
2456      * PL_reglastparen), is not needed at all by the test suite
2457      * (op/regexp, op/pat, op/split), but that code is needed otherwise
2458      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2459      * Meanwhile, this code *is* needed for the
2460      * above-mentioned test suite tests to succeed.  The common theme
2461      * on those tests seems to be returning null fields from matches.
2462      * --jhi updated by dapm */
2463 #if 1
2464     if (prog->nparens) {
2465         regexp_paren_pair *pp = PL_regoffs;
2466         register I32 i;
2467         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2468             ++pp;
2469             pp->start = -1;
2470             pp->end = -1;
2471         }
2472     }
2473 #endif
2474     REGCP_SET(lastcp);
2475     if (regmatch(reginfo, progi->program + 1)) {
2476         PL_regoffs[0].end = PL_reginput - PL_bostr;
2477         return 1;
2478     }
2479     if (reginfo->cutpoint)
2480         *startpos= reginfo->cutpoint;
2481     REGCP_UNWIND(lastcp);
2482     return 0;
2483 }
2484
2485
2486 #define sayYES goto yes
2487 #define sayNO goto no
2488 #define sayNO_SILENT goto no_silent
2489
2490 /* we dont use STMT_START/END here because it leads to
2491    "unreachable code" warnings, which are bogus, but distracting. */
2492 #define CACHEsayNO \
2493     if (ST.cache_mask) \
2494        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2495     sayNO
2496
2497 /* this is used to determine how far from the left messages like
2498    'failed...' are printed. It should be set such that messages
2499    are inline with the regop output that created them.
2500 */
2501 #define REPORT_CODE_OFF 32
2502
2503
2504 /* Make sure there is a test for this +1 options in re_tests */
2505 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2506
2507 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2508 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2509
2510 #define SLAB_FIRST(s) (&(s)->states[0])
2511 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2512
2513 /* grab a new slab and return the first slot in it */
2514
2515 STATIC regmatch_state *
2516 S_push_slab(pTHX)
2517 {
2518 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2519     dMY_CXT;
2520 #endif
2521     regmatch_slab *s = PL_regmatch_slab->next;
2522     if (!s) {
2523         Newx(s, 1, regmatch_slab);
2524         s->prev = PL_regmatch_slab;
2525         s->next = NULL;
2526         PL_regmatch_slab->next = s;
2527     }
2528     PL_regmatch_slab = s;
2529     return SLAB_FIRST(s);
2530 }
2531
2532
2533 /* push a new state then goto it */
2534
2535 #define PUSH_STATE_GOTO(state, node) \
2536     scan = node; \
2537     st->resume_state = state; \
2538     goto push_state;
2539
2540 /* push a new state with success backtracking, then goto it */
2541
2542 #define PUSH_YES_STATE_GOTO(state, node) \
2543     scan = node; \
2544     st->resume_state = state; \
2545     goto push_yes_state;
2546
2547
2548
2549 /*
2550
2551 regmatch() - main matching routine
2552
2553 This is basically one big switch statement in a loop. We execute an op,
2554 set 'next' to point the next op, and continue. If we come to a point which
2555 we may need to backtrack to on failure such as (A|B|C), we push a
2556 backtrack state onto the backtrack stack. On failure, we pop the top
2557 state, and re-enter the loop at the state indicated. If there are no more
2558 states to pop, we return failure.
2559
2560 Sometimes we also need to backtrack on success; for example /A+/, where
2561 after successfully matching one A, we need to go back and try to
2562 match another one; similarly for lookahead assertions: if the assertion
2563 completes successfully, we backtrack to the state just before the assertion
2564 and then carry on.  In these cases, the pushed state is marked as
2565 'backtrack on success too'. This marking is in fact done by a chain of
2566 pointers, each pointing to the previous 'yes' state. On success, we pop to
2567 the nearest yes state, discarding any intermediate failure-only states.
2568 Sometimes a yes state is pushed just to force some cleanup code to be
2569 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2570 it to free the inner regex.
2571
2572 Note that failure backtracking rewinds the cursor position, while
2573 success backtracking leaves it alone.
2574
2575 A pattern is complete when the END op is executed, while a subpattern
2576 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2577 ops trigger the "pop to last yes state if any, otherwise return true"
2578 behaviour.
2579
2580 A common convention in this function is to use A and B to refer to the two
2581 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2582 the subpattern to be matched possibly multiple times, while B is the entire
2583 rest of the pattern. Variable and state names reflect this convention.
2584
2585 The states in the main switch are the union of ops and failure/success of
2586 substates associated with with that op.  For example, IFMATCH is the op
2587 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2588 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2589 successfully matched A and IFMATCH_A_fail is a state saying that we have
2590 just failed to match A. Resume states always come in pairs. The backtrack
2591 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2592 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2593 on success or failure.
2594
2595 The struct that holds a backtracking state is actually a big union, with
2596 one variant for each major type of op. The variable st points to the
2597 top-most backtrack struct. To make the code clearer, within each
2598 block of code we #define ST to alias the relevant union.
2599
2600 Here's a concrete example of a (vastly oversimplified) IFMATCH
2601 implementation:
2602
2603     switch (state) {
2604     ....
2605
2606 #define ST st->u.ifmatch
2607
2608     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2609         ST.foo = ...; // some state we wish to save
2610         ...
2611         // push a yes backtrack state with a resume value of
2612         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2613         // first node of A:
2614         PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2615         // NOTREACHED
2616
2617     case IFMATCH_A: // we have successfully executed A; now continue with B
2618         next = B;
2619         bar = ST.foo; // do something with the preserved value
2620         break;
2621
2622     case IFMATCH_A_fail: // A failed, so the assertion failed
2623         ...;   // do some housekeeping, then ...
2624         sayNO; // propagate the failure
2625
2626 #undef ST
2627
2628     ...
2629     }
2630
2631 For any old-timers reading this who are familiar with the old recursive
2632 approach, the code above is equivalent to:
2633
2634     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2635     {
2636         int foo = ...
2637         ...
2638         if (regmatch(A)) {
2639             next = B;
2640             bar = foo;
2641             break;
2642         }
2643         ...;   // do some housekeeping, then ...
2644         sayNO; // propagate the failure
2645     }
2646
2647 The topmost backtrack state, pointed to by st, is usually free. If you
2648 want to claim it, populate any ST.foo fields in it with values you wish to
2649 save, then do one of
2650
2651         PUSH_STATE_GOTO(resume_state, node);
2652         PUSH_YES_STATE_GOTO(resume_state, node);
2653
2654 which sets that backtrack state's resume value to 'resume_state', pushes a
2655 new free entry to the top of the backtrack stack, then goes to 'node'.
2656 On backtracking, the free slot is popped, and the saved state becomes the
2657 new free state. An ST.foo field in this new top state can be temporarily
2658 accessed to retrieve values, but once the main loop is re-entered, it
2659 becomes available for reuse.
2660
2661 Note that the depth of the backtrack stack constantly increases during the
2662 left-to-right execution of the pattern, rather than going up and down with
2663 the pattern nesting. For example the stack is at its maximum at Z at the
2664 end of the pattern, rather than at X in the following:
2665
2666     /(((X)+)+)+....(Y)+....Z/
2667
2668 The only exceptions to this are lookahead/behind assertions and the cut,
2669 (?>A), which pop all the backtrack states associated with A before
2670 continuing.
2671
2672 Bascktrack state structs are allocated in slabs of about 4K in size.
2673 PL_regmatch_state and st always point to the currently active state,
2674 and PL_regmatch_slab points to the slab currently containing
2675 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2676 allocated, and is never freed until interpreter destruction. When the slab
2677 is full, a new one is allocated and chained to the end. At exit from
2678 regmatch(), slabs allocated since entry are freed.
2679
2680 */
2681
2682
2683 #define DEBUG_STATE_pp(pp)                                  \
2684     DEBUG_STATE_r({                                         \
2685         DUMP_EXEC_POS(locinput, scan, do_utf8);             \
2686         PerlIO_printf(Perl_debug_log,                       \
2687             "    %*s"pp" %s%s%s%s%s\n",                     \
2688             depth*2, "",                                    \
2689             PL_reg_name[st->resume_state],                     \
2690             ((st==yes_state||st==mark_state) ? "[" : ""),   \
2691             ((st==yes_state) ? "Y" : ""),                   \
2692             ((st==mark_state) ? "M" : ""),                  \
2693             ((st==yes_state||st==mark_state) ? "]" : "")    \
2694         );                                                  \
2695     });
2696
2697
2698 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2699
2700 #ifdef DEBUGGING
2701
2702 STATIC void
2703 S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8,
2704     const char *start, const char *end, const char *blurb)
2705 {
2706     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2707
2708     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2709
2710     if (!PL_colorset)
2711             reginitcolors();
2712     {
2713         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2714             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
2715
2716         RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2717             start, end - start, 60);
2718
2719         PerlIO_printf(Perl_debug_log,
2720             "%s%s REx%s %s against %s\n",
2721                        PL_colors[4], blurb, PL_colors[5], s0, s1);
2722
2723         if (do_utf8||utf8_pat)
2724             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2725                 utf8_pat ? "pattern" : "",
2726                 utf8_pat && do_utf8 ? " and " : "",
2727                 do_utf8 ? "string" : ""
2728             );
2729     }
2730 }
2731
2732 STATIC void
2733 S_dump_exec_pos(pTHX_ const char *locinput,
2734                       const regnode *scan,
2735                       const char *loc_regeol,
2736                       const char *loc_bostr,
2737                       const char *loc_reg_starttry,
2738                       const bool do_utf8)
2739 {
2740     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2741     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2742     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2743     /* The part of the string before starttry has one color
2744        (pref0_len chars), between starttry and current
2745        position another one (pref_len - pref0_len chars),
2746        after the current position the third one.
2747        We assume that pref0_len <= pref_len, otherwise we
2748        decrease pref0_len.  */
2749     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2750         ? (5 + taill) - l : locinput - loc_bostr;
2751     int pref0_len;
2752
2753     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2754
2755     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2756         pref_len++;
2757     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2758     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2759         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2760               ? (5 + taill) - pref_len : loc_regeol - locinput);
2761     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2762         l--;
2763     if (pref0_len < 0)
2764         pref0_len = 0;
2765     if (pref0_len > pref_len)
2766         pref0_len = pref_len;
2767     {
2768         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2769
2770         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2771             (locinput - pref_len),pref0_len, 60, 4, 5);
2772
2773         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2774                     (locinput - pref_len + pref0_len),
2775                     pref_len - pref0_len, 60, 2, 3);
2776
2777         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2778                     locinput, loc_regeol - locinput, 10, 0, 1);
2779
2780         const STRLEN tlen=len0+len1+len2;
2781         PerlIO_printf(Perl_debug_log,
2782                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2783                     (IV)(locinput - loc_bostr),
2784                     len0, s0,
2785                     len1, s1,
2786                     (docolor ? "" : "> <"),
2787                     len2, s2,
2788                     (int)(tlen > 19 ? 0 :  19 - tlen),
2789                     "");
2790     }
2791 }
2792
2793 #endif
2794
2795 /* reg_check_named_buff_matched()
2796  * Checks to see if a named buffer has matched. The data array of
2797  * buffer numbers corresponding to the buffer is expected to reside
2798  * in the regexp->data->data array in the slot stored in the ARG() of
2799  * node involved. Note that this routine doesn't actually care about the
2800  * name, that information is not preserved from compilation to execution.
2801  * Returns the index of the leftmost defined buffer with the given name
2802  * or 0 if non of the buffers matched.
2803  */
2804 STATIC I32
2805 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2806 {
2807     I32 n;
2808     RXi_GET_DECL(rex,rexi);
2809     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
2810     I32 *nums=(I32*)SvPVX(sv_dat);
2811
2812     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
2813
2814     for ( n=0; n<SvIVX(sv_dat); n++ ) {
2815         if ((I32)*PL_reglastparen >= nums[n] &&
2816             PL_regoffs[nums[n]].end != -1)
2817         {
2818             return nums[n];
2819         }
2820     }
2821     return 0;
2822 }
2823
2824
2825 /* free all slabs above current one  - called during LEAVE_SCOPE */
2826
2827 STATIC void
2828 S_clear_backtrack_stack(pTHX_ void *p)
2829 {
2830     regmatch_slab *s = PL_regmatch_slab->next;
2831     PERL_UNUSED_ARG(p);
2832
2833     if (!s)
2834         return;
2835     PL_regmatch_slab->next = NULL;
2836     while (s) {
2837         regmatch_slab * const osl = s;
2838         s = s->next;
2839         Safefree(osl);
2840     }
2841 }
2842
2843
2844 #define SETREX(Re1,Re2) \
2845     if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2846     Re1 = (Re2)
2847
2848 STATIC I32                      /* 0 failure, 1 success */
2849 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2850 {
2851 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2852     dMY_CXT;
2853 #endif
2854     dVAR;
2855     register const bool do_utf8 = PL_reg_match_utf8;
2856     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2857     REGEXP *rex_sv = reginfo->prog;
2858     regexp *rex = (struct regexp *)SvANY(rex_sv);
2859     RXi_GET_DECL(rex,rexi);
2860     I32 oldsave;
2861     /* the current state. This is a cached copy of PL_regmatch_state */
2862     register regmatch_state *st;
2863     /* cache heavy used fields of st in registers */
2864     register regnode *scan;
2865     register regnode *next;
2866     register U32 n = 0; /* general value; init to avoid compiler warning */
2867     register I32 ln = 0; /* len or last;  init to avoid compiler warning */
2868     register char *locinput = PL_reginput;
2869     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2870
2871     bool result = 0;        /* return value of S_regmatch */
2872     int depth = 0;          /* depth of backtrack stack */
2873     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
2874     const U32 max_nochange_depth =
2875         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
2876         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
2877     regmatch_state *yes_state = NULL; /* state to pop to on success of
2878                                                             subpattern */
2879     /* mark_state piggy backs on the yes_state logic so that when we unwind
2880        the stack on success we can update the mark_state as we go */
2881     regmatch_state *mark_state = NULL; /* last mark state we have seen */
2882     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2883     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2884     U32 state_num;
2885     bool no_final = 0;      /* prevent failure from backtracking? */
2886     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
2887     char *startpoint = PL_reginput;
2888     SV *popmark = NULL;     /* are we looking for a mark? */
2889     SV *sv_commit = NULL;   /* last mark name seen in failure */
2890     SV *sv_yes_mark = NULL; /* last mark name we have seen
2891                                during a successfull match */
2892     U32 lastopen = 0;       /* last open we saw */
2893     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2894     SV* const oreplsv = GvSV(PL_replgv);
2895     /* these three flags are set by various ops to signal information to
2896      * the very next op. They have a useful lifetime of exactly one loop
2897      * iteration, and are not preserved or restored by state pushes/pops
2898      */
2899     bool sw = 0;            /* the condition value in (?(cond)a|b) */
2900     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
2901     int logical = 0;        /* the following EVAL is:
2902                                 0: (?{...})
2903                                 1: (?(?{...})X|Y)
2904                                 2: (??{...})
2905                                or the following IFMATCH/UNLESSM is:
2906                                 false: plain (?=foo)
2907                                 true:  used as a condition: (?(?=foo))
2908                             */
2909 #ifdef DEBUGGING
2910     GET_RE_DEBUG_FLAGS_DECL;
2911 #endif
2912
2913     PERL_ARGS_ASSERT_REGMATCH;
2914
2915     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
2916             PerlIO_printf(Perl_debug_log,"regmatch start\n");
2917     }));
2918     /* on first ever call to regmatch, allocate first slab */
2919     if (!PL_regmatch_slab) {
2920         Newx(PL_regmatch_slab, 1, regmatch_slab);
2921         PL_regmatch_slab->prev = NULL;
2922         PL_regmatch_slab->next = NULL;
2923         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2924     }
2925
2926     oldsave = PL_savestack_ix;
2927     SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
2928     SAVEVPTR(PL_regmatch_slab);
2929     SAVEVPTR(PL_regmatch_state);
2930
2931     /* grab next free state slot */
2932     st = ++PL_regmatch_state;
2933     if (st >  SLAB_LAST(PL_regmatch_slab))
2934         st = PL_regmatch_state = S_push_slab(aTHX);
2935
2936     /* Note that nextchr is a byte even in UTF */
2937     nextchr = UCHARAT(locinput);
2938     scan = prog;
2939     while (scan != NULL) {
2940
2941         DEBUG_EXECUTE_r( {
2942             SV * const prop = sv_newmortal();
2943             regnode *rnext=regnext(scan);
2944             DUMP_EXEC_POS( locinput, scan, do_utf8 );
2945             regprop(rex, prop, scan);
2946
2947             PerlIO_printf(Perl_debug_log,
2948                     "%3"IVdf":%*s%s(%"IVdf")\n",
2949                     (IV)(scan - rexi->program), depth*2, "",
2950                     SvPVX_const(prop),
2951                     (PL_regkind[OP(scan)] == END || !rnext) ?
2952                         0 : (IV)(rnext - rexi->program));
2953         });
2954
2955         next = scan + NEXT_OFF(scan);
2956         if (next == scan)
2957             next = NULL;
2958         state_num = OP(scan);
2959
2960         REH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);
2961       reenter_switch:
2962
2963         assert(PL_reglastparen == &rex->lastparen);
2964         assert(PL_reglastcloseparen == &rex->lastcloseparen);
2965         assert(PL_regoffs == rex->offs);
2966
2967         switch (state_num) {
2968         case BOL:
2969             if (locinput == PL_bostr)
2970             {
2971                 /* reginfo->till = reginfo->bol; */
2972                 break;
2973             }
2974             sayNO;
2975         case MBOL:
2976             if (locinput == PL_bostr ||
2977                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2978             {
2979                 break;
2980             }
2981             sayNO;
2982         case SBOL:
2983             if (locinput == PL_bostr)
2984                 break;
2985             sayNO;
2986         case GPOS:
2987             if (locinput == reginfo->ganch)
2988                 break;
2989             sayNO;
2990
2991         case KEEPS:
2992             /* update the startpoint */
2993             st->u.keeper.val = PL_regoffs[0].start;
2994             PL_reginput = locinput;
2995             PL_regoffs[0].start = locinput - PL_bostr;
2996             PUSH_STATE_GOTO(KEEPS_next, next);
2997             /*NOT-REACHED*/
2998         case KEEPS_next_fail:
2999             /* rollback the start point change */
3000             PL_regoffs[0].start = st->u.keeper.val;
3001             sayNO_SILENT;
3002             /*NOT-REACHED*/
3003         case EOL:
3004                 goto seol;
3005         case MEOL:
3006             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3007                 sayNO;
3008             break;
3009         case SEOL:
3010           seol:
3011             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3012                 sayNO;
3013             if (PL_regeol - locinput > 1)
3014                 sayNO;
3015             break;
3016         case EOS:
3017             if (PL_regeol != locinput)
3018                 sayNO;
3019             break;
3020         case SANY:
3021             if (!nextchr && locinput >= PL_regeol)
3022                 sayNO;
3023             if (do_utf8) {
3024                 locinput += PL_utf8skip[nextchr];
3025                 if (locinput > PL_regeol)
3026                     sayNO;
3027                 nextchr = UCHARAT(locinput);
3028             }
3029             else
3030                 nextchr = UCHARAT(++locinput);
3031             break;
3032         case CANY:
3033             if (!nextchr && locinput >= PL_regeol)
3034                 sayNO;
3035             nextchr = UCHARAT(++locinput);
3036             break;
3037         case REG_ANY:
3038             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
3039                 sayNO;
3040             if (do_utf8) {
3041                 locinput += PL_utf8skip[nextchr];
3042                 if (locinput > PL_regeol)
3043                     sayNO;
3044                 nextchr = UCHARAT(locinput);
3045             }
3046             else
3047                 nextchr = UCHARAT(++locinput);
3048             break;
3049
3050 #undef  ST
3051 #define ST st->u.trie
3052         case TRIEC:
3053             /* In this case the charclass data is available inline so
3054                we can fail fast without a lot of extra overhead.
3055              */
3056             if (scan->flags == EXACT || !do_utf8) {
3057                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3058                     DEBUG_EXECUTE_r(
3059                         PerlIO_printf(Perl_debug_log,
3060                                   "%*s  %sfailed to match trie start class...%s\n",
3061                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3062                     );
3063                     sayNO_SILENT;
3064                     /* NOTREACHED */
3065                 }
3066             }
3067             /* FALL THROUGH */
3068         case TRIE:
3069             {
3070                 /* what type of TRIE am I? (utf8 makes this contextual) */
3071                 DECL_TRIE_TYPE(scan);
3072
3073                 /* what trie are we using right now */
3074                 reg_trie_data * const trie
3075                     = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3076                 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3077                 U32 state = trie->startstate;
3078
3079                 if (trie->bitmap && trie_type != trie_utf8_fold &&
3080                     !TRIE_BITMAP_TEST(trie,*locinput)
3081                 ) {
3082                     if (trie->states[ state ].wordnum) {
3083                          DEBUG_EXECUTE_r(
3084                             PerlIO_printf(Perl_debug_log,
3085                                           "%*s  %smatched empty string...%s\n",
3086                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3087                         );
3088                         break;
3089                     } else {
3090                         DEBUG_EXECUTE_r(
3091                             PerlIO_printf(Perl_debug_log,
3092                                           "%*s  %sfailed to match trie start class...%s\n",
3093                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3094                         );
3095                         sayNO_SILENT;
3096                    }
3097                 }
3098
3099             {
3100                 U8 *uc = ( U8* )locinput;
3101
3102                 STRLEN len = 0;
3103                 STRLEN foldlen = 0;
3104                 U8 *uscan = (U8*)NULL;
3105                 STRLEN bufflen=0;
3106                 SV *sv_accept_buff = NULL;
3107                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3108
3109                 ST.accepted = 0; /* how many accepting states we have seen */
3110                 ST.B = next;
3111                 ST.jump = trie->jump;
3112                 ST.me = scan;
3113                 /*
3114                    traverse the TRIE keeping track of all accepting states
3115                    we transition through until we get to a failing node.
3116                 */
3117
3118                 while ( state && uc <= (U8*)PL_regeol ) {
3119                     U32 base = trie->states[ state ].trans.base;
3120                     UV uvc = 0;
3121                     U16 charid;
3122                     /* We use charid to hold the wordnum as we don't use it
3123                        for charid until after we have done the wordnum logic.
3124                        We define an alias just so that the wordnum logic reads
3125                        more naturally. */
3126
3127 #define got_wordnum charid
3128                     got_wordnum = trie->states[ state ].wordnum;
3129
3130                     if ( got_wordnum ) {
3131                         if ( ! ST.accepted ) {
3132                             ENTER;
3133                             SAVETMPS; /* XXX is this necessary? dmq */
3134                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
3135                             sv_accept_buff=newSV(bufflen *
3136                                             sizeof(reg_trie_accepted) - 1);
3137                             SvCUR_set(sv_accept_buff, 0);
3138                             SvPOK_on(sv_accept_buff);
3139                             sv_2mortal(sv_accept_buff);
3140                             SAVETMPS;
3141                             ST.accept_buff =
3142                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
3143                         }
3144                         do {
3145                             if (ST.accepted >= bufflen) {
3146                                 bufflen *= 2;
3147                                 ST.accept_buff =(reg_trie_accepted*)
3148                                     SvGROW(sv_accept_buff,
3149                                         bufflen * sizeof(reg_trie_accepted));
3150                             }
3151                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
3152                                 + sizeof(reg_trie_accepted));
3153
3154
3155                             ST.accept_buff[ST.accepted].wordnum = got_wordnum;
3156                             ST.accept_buff[ST.accepted].endpos = uc;
3157                             ++ST.accepted;
3158                         } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
3159                     }
3160 #undef got_wordnum
3161
3162                     DEBUG_TRIE_EXECUTE_r({
3163                                 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
3164                                 PerlIO_printf( Perl_debug_log,
3165                                     "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
3166                                     2+depth * 2, "", PL_colors[4],
3167                                     (UV)state, (UV)ST.accepted );
3168                     });
3169
3170                     if ( base ) {
3171                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3172                                              uscan, len, uvc, charid, foldlen,
3173                                              foldbuf, uniflags);
3174
3175                         if (charid &&
3176                              (base + charid > trie->uniquecharcount )
3177                              && (base + charid - 1 - trie->uniquecharcount
3178                                     < trie->lasttrans)
3179                              && trie->trans[base + charid - 1 -
3180                                     trie->uniquecharcount].check == state)
3181                         {
3182                             state = trie->trans[base + charid - 1 -
3183                                 trie->uniquecharcount ].next;
3184                         }
3185                         else {
3186                             state = 0;
3187                         }
3188                         uc += len;
3189
3190                     }
3191                     else {
3192                         state = 0;
3193                     }
3194                     DEBUG_TRIE_EXECUTE_r(
3195                         PerlIO_printf( Perl_debug_log,
3196                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3197                             charid, uvc, (UV)state, PL_colors[5] );
3198                     );
3199                 }
3200                 if (!ST.accepted )
3201                    sayNO;
3202
3203                 DEBUG_EXECUTE_r(
3204                     PerlIO_printf( Perl_debug_log,
3205                         "%*s  %sgot %"IVdf" possible matches%s\n",
3206                         REPORT_CODE_OFF + depth * 2, "",
3207                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3208                 );
3209             }}
3210             goto trie_first_try; /* jump into the fail handler */
3211             /* NOTREACHED */
3212         case TRIE_next_fail: /* we failed - try next alterative */
3213             if ( ST.jump) {
3214                 REGCP_UNWIND(ST.cp);
3215                 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3216                     PL_regoffs[n].end = -1;
3217                 *PL_reglastparen = n;
3218             }
3219           trie_first_try:
3220             if (do_cutgroup) {
3221                 do_cutgroup = 0;
3222                 no_final = 0;
3223             }
3224
3225             if ( ST.jump) {
3226                 ST.lastparen = *PL_reglastparen;
3227                 REGCP_SET(ST.cp);
3228             }
3229             if ( ST.accepted == 1 ) {
3230                 /* only one choice left - just continue */
3231                 DEBUG_EXECUTE_r({
3232                     AV *const trie_words
3233                         = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3234                     SV ** const tmp = av_fetch( trie_words,
3235                         ST.accept_buff[ 0 ].wordnum-1, 0 );
3236                     SV *sv= tmp ? sv_newmortal() : NULL;
3237
3238                     PerlIO_printf( Perl_debug_log,
3239                         "%*s  %sonly one match left: #%d <%s>%s\n",
3240                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3241                         ST.accept_buff[ 0 ].wordnum,
3242                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3243                                 PL_colors[0], PL_colors[1],
3244                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3245                             )
3246                         : "not compiled under -Dr",
3247                         PL_colors[5] );
3248                 });
3249                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3250                 /* in this case we free tmps/leave before we call regmatch
3251                    as we wont be using accept_buff again. */
3252
3253                 locinput = PL_reginput;
3254                 nextchr = UCHARAT(locinput);
3255                 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
3256                     scan = ST.B;
3257                 else
3258                     scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3259                 if (!has_cutgroup) {
3260                     FREETMPS;
3261                     LEAVE;
3262                 } else {
3263                     ST.accepted--;
3264                     PUSH_YES_STATE_GOTO(TRIE_next, scan);
3265                 }
3266
3267                 continue; /* execute rest of RE */
3268             }
3269
3270             if ( !ST.accepted-- ) {
3271                 DEBUG_EXECUTE_r({
3272                     PerlIO_printf( Perl_debug_log,
3273                         "%*s  %sTRIE failed...%s\n",
3274                         REPORT_CODE_OFF+depth*2, "",
3275                         PL_colors[4],
3276                         PL_colors[5] );
3277                 });
3278                 FREETMPS;
3279                 LEAVE;
3280                 sayNO_SILENT;
3281                 /*NOTREACHED*/
3282             }
3283
3284             /*
3285                There are at least two accepting states left.  Presumably
3286                the number of accepting states is going to be low,
3287                typically two. So we simply scan through to find the one
3288                with lowest wordnum.  Once we find it, we swap the last
3289                state into its place and decrement the size. We then try to
3290                match the rest of the pattern at the point where the word
3291                ends. If we succeed, control just continues along the
3292                regex; if we fail we return here to try the next accepting
3293                state
3294              */
3295
3296             {
3297                 U32 best = 0;
3298                 U32 cur;
3299                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3300                     DEBUG_TRIE_EXECUTE_r(
3301                         PerlIO_printf( Perl_debug_log,
3302                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3303                             REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3304                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3305                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3306                     );
3307
3308                     if (ST.accept_buff[cur].wordnum <
3309                             ST.accept_buff[best].wordnum)
3310                         best = cur;
3311                 }
3312
3313                 DEBUG_EXECUTE_r({
3314                     AV *const trie_words
3315                         = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3316                     SV ** const tmp = av_fetch( trie_words,
3317                         ST.accept_buff[ best ].wordnum - 1, 0 );
3318                     regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
3319                                     ST.B :
3320                                     ST.me + ST.jump[ST.accept_buff[best].wordnum];
3321                     SV *sv= tmp ? sv_newmortal() : NULL;
3322
3323                     PerlIO_printf( Perl_debug_log,
3324                         "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3325                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3326                         ST.accept_buff[best].wordnum,
3327                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3328                                 PL_colors[0], PL_colors[1],
3329                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3330                             ) : "not compiled under -Dr",
3331                             REG_NODE_NUM(nextop),
3332                         PL_colors[5] );
3333                 });
3334
3335                 if ( best<ST.accepted ) {
3336                     reg_trie_accepted tmp = ST.accept_buff[ best ];
3337                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3338                     ST.accept_buff[ ST.accepted ] = tmp;
3339                     best = ST.accepted;
3340                 }
3341                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3342                 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3343                     scan = ST.B;
3344                 } else {
3345                     scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3346                 }
3347                 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3348                 /* NOTREACHED */
3349             }
3350             /* NOTREACHED */
3351         case TRIE_next:
3352             /* we dont want to throw this away, see bug 57042*/
3353             if (oreplsv != GvSV(PL_replgv))
3354                 sv_setsv(oreplsv, GvSV(PL_replgv));
3355             FREETMPS;
3356             LEAVE;
3357             sayYES;
3358 #undef  ST
3359
3360         case EXACT: {
3361             char *s = STRING(scan);
3362             ln = STR_LEN(scan);
3363             if (do_utf8 != UTF) {
3364                 /* The target and the pattern have differing utf8ness. */
3365                 char *l = locinput;
3366                 const char * const e = s + ln;
3367
3368                 if (do_utf8) {
3369                     /* The target is utf8, the pattern is not utf8. */
3370                     while (s < e) {
3371                         STRLEN ulen;
3372                         if (l >= PL_regeol)
3373                              sayNO;
3374                         if (NATIVE_TO_UNI(*(U8*)s) !=
3375                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3376                                             uniflags))
3377                              sayNO;
3378                         l += ulen;
3379                         s ++;
3380                     }
3381                 }
3382                 else {
3383                     /* The target is not utf8, the pattern is utf8. */
3384                     while (s < e) {
3385                         STRLEN ulen;
3386                         if (l >= PL_regeol)
3387                             sayNO;
3388                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3389                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3390                                            uniflags))
3391                             sayNO;
3392                         s += ulen;
3393                         l ++;
3394                     }
3395                 }
3396                 locinput = l;
3397                 nextchr = UCHARAT(locinput);
3398                 break;
3399             }
3400             /* The target and the pattern have the same utf8ness. */
3401             /* Inline the first character, for speed. */
3402             if (UCHARAT(s) != nextchr)
3403                 sayNO;
3404             if (PL_regeol - locinput < ln)
3405                 sayNO;
3406             if (ln > 1 && memNE(s, locinput, ln))
3407                 sayNO;
3408             locinput += ln;
3409             nextchr = UCHARAT(locinput);
3410             break;
3411             }
3412         case EXACTFL:
3413             PL_reg_flags |= RF_tainted;
3414             /* FALL THROUGH */
3415         case EXACTF: {
3416             char * const s = STRING(scan);
3417             ln = STR_LEN(scan);
3418
3419             if (do_utf8 || UTF) {
3420               /* Either target or the pattern are utf8. */
3421                 const char * const l = locinput;
3422                 char *e = PL_regeol;
3423
3424                 if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
3425                                l, &e, 0,  do_utf8)) {
3426                      /* One more case for the sharp s:
3427                       * pack("U0U*", 0xDF) =~ /ss/i,
3428                       * the 0xC3 0x9F are the UTF-8
3429                       * byte sequence for the U+00DF. */
3430
3431                      if (!(do_utf8 &&
3432                            toLOWER(s[0]) == 's' &&
3433                            ln >= 2 &&
3434                            toLOWER(s[1]) == 's' &&
3435                            (U8)l[0] == 0xC3 &&
3436                            e - l >= 2 &&
3437                            (U8)l[1] == 0x9F))
3438                           sayNO;
3439                 }
3440                 locinput = e;
3441                 nextchr = UCHARAT(locinput);
3442                 break;
3443             }
3444
3445             /* Neither the target and the pattern are utf8. */
3446
3447             /* Inline the first character, for speed. */
3448             if (UCHARAT(s) != nextchr &&
3449                 UCHARAT(s) != ((OP(scan) == EXACTF)
3450                                ? PL_fold : PL_fold_locale)[nextchr])
3451                 sayNO;
3452             if (PL_regeol - locinput < ln)
3453                 sayNO;
3454             if (ln > 1 && (OP(scan) == EXACTF
3455                            ? ibcmp(s, locinput, ln)
3456                            : ibcmp_locale(s, locinput, ln)))
3457                 sayNO;
3458             locinput += ln;
3459             nextchr = UCHARAT(locinput);
3460             break;
3461             }
3462         case BOUNDL:
3463         case NBOUNDL:
3464             PL_reg_flags |= RF_tainted;
3465             /* FALL THROUGH */
3466         case BOUND:
3467         case NBOUND:
3468             /* was last char in word? */
3469             if (do_utf8) {
3470                 if (locinput == PL_bostr)
3471                     ln = '\n';
3472                 else {
3473                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3474
3475                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3476                 }
3477                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3478                     ln = isALNUM_uni(ln);
3479                     LOAD_UTF8_CHARCLASS_ALNUM();
3480                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3481                 }
3482                 else {
3483                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3484                     n = isALNUM_LC_utf8((U8*)locinput);
3485                 }
3486             }
3487             else {
3488                 ln = (locinput != PL_bostr) ?
3489                     UCHARAT(locinput - 1) : '\n';
3490                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3491                     ln = isALNUM(ln);
3492                     n = isALNUM(nextchr);
3493                 }
3494                 else {
3495                     ln = isALNUM_LC(ln);
3496                     n = isALNUM_LC(nextchr);
3497                 }
3498             }
3499             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3500                                     OP(scan) == BOUNDL))
3501                     sayNO;
3502             break;
3503         case ANYOF:
3504             if (do_utf8) {
3505                 STRLEN inclasslen = PL_regeol - locinput;
3506
3507                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3508                     goto anyof_fail;
3509                 if (locinput >= PL_regeol)
3510                     sayNO;
3511                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3512                 nextchr = UCHARAT(locinput);
3513                 break;
3514             }
3515             else {
3516                 if (nextchr < 0)
3517                     nextchr = UCHARAT(locinput);
3518                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3519                     goto anyof_fail;
3520                 if (!nextchr && locinput >= PL_regeol)
3521                     sayNO;
3522                 nextchr = UCHARAT(++locinput);
3523                 break;
3524             }
3525         anyof_fail:
3526             /* If we might have the case of the German sharp s
3527              * in a casefolding Unicode character class. */
3528
3529             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3530                  locinput += SHARP_S_SKIP;
3531                  nextchr = UCHARAT(locinput);
3532             }
3533             else
3534                  sayNO;
3535             break;
3536         /* Special char classes - The defines start on line 129 or so */
3537         CCC_TRY_AFF( ALNUM,  ALNUML, perl_word,   "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3538         CCC_TRY_NEG(NALNUM, NALNUML, perl_word,   "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3539
3540         CCC_TRY_AFF( SPACE,  SPACEL, perl_space,  " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3541         CCC_TRY_NEG(NSPACE, NSPACEL, perl_space,  " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3542
3543         CCC_TRY_AFF( DIGIT,  DIGITL, posix_digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3544         CCC_TRY_NEG(NDIGIT, NDIGITL, posix_digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3545
3546         case CLUMP: /* Match \X: logical Unicode character.  This is defined as
3547                        a Unicode extended Grapheme Cluster */
3548             /* From http://www.unicode.org/reports/tr29 (5.2 version).  An
3549               extended Grapheme Cluster is:
3550
3551                CR LF
3552                | Prepend* Begin Extend*
3553                | .
3554
3555                Begin is (Hangul-syllable | ! Control)
3556                Extend is (Grapheme_Extend | Spacing_Mark)
3557                Control is [ GCB_Control CR LF ]
3558
3559                The discussion below shows how the code for CLUMP is derived
3560                from this regex.  Note that most of these concepts are from
3561                property values of the Grapheme Cluster Boundary (GCB) property.
3562                No code point can have multiple property values for a given
3563                property.  Thus a code point in Prepend can't be in Control, but
3564                it must be in !Control.  This is why Control above includes
3565                GCB_Control plus CR plus LF.  The latter two are used in the GCB
3566                property separately, and so can't be in GCB_Control, even though
3567                they logically are controls.  Control is not the same as gc=cc,
3568                but includes format and other characters as well.
3569
3570                The Unicode definition of Hangul-syllable is:
3571                    L+
3572                    | (L* ( ( V | LV ) V* | LVT ) T*)
3573                    | T+
3574                   )
3575                Each of these is a value for the GCB property, and hence must be
3576                disjoint, so the order they are tested is immaterial, so the
3577                above can safely be changed to
3578                    T+
3579                    | L+
3580                    | (L* ( LVT | ( V | LV ) V*) T*)
3581
3582                The last two terms can be combined like this:
3583                    L* ( L
3584                         | (( LVT | ( V | LV ) V*) T*))
3585
3586                And refactored into this:
3587                    L* (L | LVT T* | V  V* T* | LV  V* T*)
3588
3589                That means that if we have seen any L's at all we can quit
3590                there, but if the next character is a LVT, a V or and LV we
3591                should keep going.
3592
3593                There is a subtlety with Prepend* which showed up in testing.
3594                Note that the Begin, and only the Begin is required in:
3595                 | Prepend* Begin Extend*
3596                Also, Begin contains '! Control'.  A Prepend must be a '!
3597                Control', which means it must be a Begin.  What it comes down to
3598                is that if we match Prepend* and then find no suitable Begin
3599                afterwards, that if we backtrack the last Prepend, that one will
3600                be a suitable Begin.
3601             */
3602
3603             if (locinput >= PL_regeol)
3604                 sayNO;
3605             if  (! do_utf8) {
3606
3607                 /* Match either CR LF  or '.', as all the other possibilities
3608                  * require utf8 */
3609                 locinput++;         /* Match the . or CR */
3610                 if (nextchr == '\r'
3611                     && locinput < PL_regeol
3612                     && UCHARAT(locinput) == '\n') locinput++;
3613             }
3614             else {
3615
3616                 /* Utf8: See if is ( CR LF ); already know that locinput <
3617                  * PL_regeol, so locinput+1 is in bounds */
3618                 if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
3619                     locinput += 2;
3620                 }
3621                 else {
3622                     /* In case have to backtrack to beginning, then match '.' */
3623                     char *starting = locinput;
3624
3625                     /* In case have to backtrack the last prepend */
3626                     char *previous_prepend = 0;
3627
3628                     LOAD_UTF8_CHARCLASS_GCB();
3629
3630                     /* Match (prepend)* */
3631                     while (locinput < PL_regeol
3632                            && swash_fetch(PL_utf8_X_prepend,
3633                                           (U8*)locinput, do_utf8))
3634                     {
3635                         previous_prepend = locinput;
3636                         locinput += UTF8SKIP(locinput);
3637                     }
3638
3639                     /* As noted above, if we matched a prepend character, but
3640                      * the next thing won't match, back off the last prepend we
3641                      * matched, as it is guaranteed to match the begin */
3642                     if (previous_prepend
3643                         && (locinput >=  PL_regeol
3644                             || ! swash_fetch(PL_utf8_X_begin,
3645                                              (U8*)locinput, do_utf8)))
3646                     {
3647                         locinput = previous_prepend;
3648                     }
3649
3650                     /* Note that here we know PL_regeol > locinput, as we
3651                      * tested that upon input to this switch case, and if we
3652                      * moved locinput forward, we tested the result just above
3653                      * and it either passed, or we backed off so that it will
3654                      * now pass */
3655                     if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, do_utf8)) {
3656
3657                         /* Here did not match the required 'Begin' in the
3658                          * second term.  So just match the very first
3659                          * character, the '.' of the final term of the regex */
3660                         locinput = starting + UTF8SKIP(starting);
3661                     } else {
3662
3663                         /* Here is the beginning of a character that can have
3664                          * an extender.  It is either a hangul syllable, or a
3665                          * non-control */
3666                         if (swash_fetch(PL_utf8_X_non_hangul,
3667                                         (U8*)locinput, do_utf8))
3668                         {
3669
3670                             /* Here not a Hangul syllable, must be a
3671                              * ('!  * Control') */
3672                             locinput += UTF8SKIP(locinput);
3673                         } else {
3674
3675                             /* Here is a Hangul syllable.  It can be composed
3676                              * of several individual characters.  One
3677                              * possibility is T+ */
3678                             if (swash_fetch(PL_utf8_X_T,
3679                                             (U8*)locinput, do_utf8))
3680                             {
3681                                 while (locinput < PL_regeol
3682                                         && swash_fetch(PL_utf8_X_T,
3683                                                         (U8*)locinput, do_utf8))
3684                                 {
3685                                     locinput += UTF8SKIP(locinput);
3686                                 }
3687                             } else {
3688
3689                                 /* Here, not T+, but is a Hangul.  That means
3690                                  * it is one of the others: L, LV, LVT or V,
3691                                  * and matches:
3692                                  * L* (L | LVT T* | V  V* T* | LV  V* T*) */
3693
3694                                 /* Match L*           */
3695                                 while (locinput < PL_regeol
3696                                         && swash_fetch(PL_utf8_X_L,
3697                                                         (U8*)locinput, do_utf8))
3698                                 {
3699                                     locinput += UTF8SKIP(locinput);
3700                                 }
3701
3702                                 /* Here, have exhausted L*.  If the next
3703                                  * character is not an LV, LVT nor V, it means
3704                                  * we had to have at least one L, so matches L+
3705                                  * in the original equation, we have a complete
3706                                  * hangul syllable.  Are done. */
3707
3708                                 if (locinput < PL_regeol
3709                                     && swash_fetch(PL_utf8_X_LV_LVT_V,
3710                                                     (U8*)locinput, do_utf8))
3711                                 {
3712
3713                                     /* Otherwise keep going.  Must be LV, LVT
3714                                      * or V.  See if LVT */
3715                                     if (swash_fetch(PL_utf8_X_LVT,
3716                                                     (U8*)locinput, do_utf8))
3717                                     {
3718                                         locinput += UTF8SKIP(locinput);
3719                                     } else {
3720
3721                                         /* Must be  V or LV.  Take it, then
3722                                          * match V*     */
3723                                         locinput += UTF8SKIP(locinput);
3724                                         while (locinput < PL_regeol
3725                                                 && swash_fetch(PL_utf8_X_V,
3726                                                          (U8*)locinput, do_utf8))
3727                                         {
3728                                             locinput += UTF8SKIP(locinput);
3729                                         }
3730                                     }
3731
3732                                     /* And any of LV, LVT, or V can be followed
3733                                      * by T*            */
3734                                     while (locinput < PL_regeol
3735                                            && swash_fetch(PL_utf8_X_T,
3736                                                            (U8*)locinput,
3737                                                            do_utf8))
3738                                     {
3739                                         locinput += UTF8SKIP(locinput);
3740                                     }
3741                                 }
3742                             }
3743                         }
3744
3745                         /* Match any extender */
3746                         while (locinput < PL_regeol
3747                                 && swash_fetch(PL_utf8_X_extend,
3748                                                 (U8*)locinput, do_utf8))
3749                         {
3750                             locinput += UTF8SKIP(locinput);
3751                         }
3752                     }
3753                 }
3754                 if (locinput > PL_regeol) sayNO;
3755             }
3756             nextchr = UCHARAT(locinput);
3757             break;
3758
3759         case NREFFL:
3760         {
3761             char *s;
3762             char type;
3763             PL_reg_flags |= RF_tainted;
3764             /* FALL THROUGH */
3765         case NREF:
3766         case NREFF:
3767             type = OP(scan);
3768             n = reg_check_named_buff_matched(rex,scan);
3769
3770             if ( n ) {
3771                 type = REF + ( type - NREF );
3772                 goto do_ref;
3773             } else {
3774                 sayNO;
3775             }
3776             /* unreached */
3777         case REFFL:
3778             PL_reg_flags |= RF_tainted;
3779             /* FALL THROUGH */
3780         case REF:
3781         case REFF:
3782             n = ARG(scan);  /* which paren pair */
3783             type = OP(scan);
3784           do_ref:
3785             ln = PL_regoffs[n].start;
3786             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3787             if (*PL_reglastparen < n || ln == -1)
3788                 sayNO;                  /* Do not match unless seen CLOSEn. */
3789             if (ln == PL_regoffs[n].end)
3790                 break;
3791
3792             s = PL_bostr + ln;
3793             if (do_utf8 && type != REF) {       /* REF can do byte comparison */
3794                 char *l = locinput;
3795                 const char *e = PL_bostr + PL_regoffs[n].end;
3796                 /*
3797                  * Note that we can't do the "other character" lookup trick as
3798                  * in the 8-bit case (no pun intended) because in Unicode we
3799                  * have to map both upper and title case to lower case.
3800                  */
3801                 if (type == REFF) {
3802                     while (s < e) {
3803                         STRLEN ulen1, ulen2;
3804                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3805                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3806
3807                         if (l >= PL_regeol)
3808                             sayNO;
3809                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3810                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3811                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3812                             sayNO;
3813                         s += ulen1;
3814                         l += ulen2;
3815                     }
3816                 }
3817                 locinput = l;
3818                 nextchr = UCHARAT(locinput);
3819                 break;
3820             }
3821
3822             /* Inline the first character, for speed. */
3823             if (UCHARAT(s) != nextchr &&
3824                 (type == REF ||
3825                  (UCHARAT(s) != (type == REFF
3826                                   ? PL_fold : PL_fold_locale)[nextchr])))
3827                 sayNO;
3828             ln = PL_regoffs[n].end - ln;
3829             if (locinput + ln > PL_regeol)
3830                 sayNO;
3831             if (ln > 1 && (type == REF
3832                            ? memNE(s, locinput, ln)
3833                            : (type == REFF
3834                               ? ibcmp(s, locinput, ln)
3835                               : ibcmp_locale(s, locinput, ln))))
3836                 sayNO;
3837             locinput += ln;
3838             nextchr = UCHARAT(locinput);
3839             break;
3840         }
3841         case NOTHING:
3842         case TAIL:
3843             break;
3844         case BACK:
3845             break;
3846
3847 #undef  ST
3848 #define ST st->u.eval
3849         {
3850             SV *ret;
3851             REGEXP *re_sv;
3852             regexp *re;
3853             regexp_internal *rei;
3854             regnode *startpoint;
3855
3856         case GOSTART:
3857         case GOSUB: /*    /(...(?1))/   /(...(?&foo))/   */
3858             if (cur_eval && cur_eval->locinput==locinput) {
3859                 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3860                     Perl_croak(aTHX_ "Infinite recursion in regex");
3861                 if ( ++nochange_depth > max_nochange_depth )
3862                     Perl_croak(aTHX_
3863                         "Pattern subroutine nesting without pos change"
3864                         " exceeded limit in regex");
3865             } else {
3866                 nochange_depth = 0;
3867             }
3868             re_sv = rex_sv;
3869             re = rex;
3870             rei = rexi;
3871             (void)ReREFCNT_inc(rex_sv);
3872             if (OP(scan)==GOSUB) {
3873                 startpoint = scan + ARG2L(scan);
3874                 ST.close_paren = ARG(scan);
3875             } else {
3876                 startpoint = rei->program+1;
3877                 ST.close_paren = 0;
3878             }
3879             goto eval_recurse_doit;
3880             /* NOTREACHED */
3881         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3882             if (cur_eval && cur_eval->locinput==locinput) {
3883                 if ( ++nochange_depth > max_nochange_depth )
3884                     Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3885             } else {
3886                 nochange_depth = 0;
3887             }
3888             {
3889                 /* execute the code in the {...} */
3890                 dSP;
3891                 SV ** const before = SP;
3892                 OP_4tree * const oop = PL_op;
3893                 COP * const ocurcop = PL_curcop;
3894                 PAD *old_comppad;
3895                 char *saved_regeol = PL_regeol;
3896
3897                 n = ARG(scan);
3898                 PL_op = (OP_4tree*)rexi->data->data[n];
3899                 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3900                     "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3901                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3902                 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3903
3904                 if (sv_yes_mark) {
3905                     SV *sv_mrk = get_sv("REGMARK", 1);
3906                     sv_setsv(sv_mrk, sv_yes_mark);
3907                 }
3908
3909                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3910                 SPAGAIN;
3911                 if (SP == before)
3912                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3913                 else {
3914                     ret = POPs;
3915                     PUTBACK;
3916                 }
3917
3918                 PL_op = oop;
3919                 PAD_RESTORE_LOCAL(old_comppad);
3920                 PL_curcop = ocurcop;
3921                 PL_regeol = saved_regeol;
3922                 if (!logical) {
3923                     /* /(?{...})/ */
3924                     sv_setsv(save_scalar(PL_replgv), ret);
3925                     break;
3926                 }
3927             }
3928             if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3929                 logical = 0;
3930                 {
3931                     /* extract RE object from returned value; compiling if
3932                      * necessary */
3933                     MAGIC *mg = NULL;
3934                     REGEXP *rx = NULL;
3935
3936                     if (SvROK(ret)) {
3937                         SV *const sv = SvRV(ret);
3938
3939                         if (SvTYPE(sv) == SVt_REGEXP) {
3940                             rx = (REGEXP*) sv;
3941                         } else if (SvSMAGICAL(sv)) {
3942                             mg = mg_find(sv, PERL_MAGIC_qr);
3943                             assert(mg);
3944                         }
3945                     } else if (SvTYPE(ret) == SVt_REGEXP) {
3946                         rx = (REGEXP*) ret;
3947                     } else if (SvSMAGICAL(ret)) {
3948                         if (SvGMAGICAL(ret)) {
3949                             /* I don't believe that there is ever qr magic
3950                                here.  */
3951                             assert(!mg_find(ret, PERL_MAGIC_qr));
3952                             sv_unmagic(ret, PERL_MAGIC_qr);
3953                         }
3954                         else {
3955                             mg = mg_find(ret, PERL_MAGIC_qr);
3956                             /* testing suggests mg only ends up non-NULL for
3957                                scalars who were upgraded and compiled in the
3958                                else block below. In turn, this is only
3959                                triggered in the "postponed utf8 string" tests
3960                                in t/op/pat.t  */
3961                         }
3962                     }
3963
3964                     if (mg) {
3965                         rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
3966                         assert(rx);
3967                     }
3968                     if (rx) {
3969                         rx = reg_temp_copy(NULL, rx);
3970                     }
3971                     else {
3972                         U32 pm_flags = 0;
3973                         const I32 osize = PL_regsize;
3974
3975                         if (DO_UTF8(ret)) {
3976                             assert (SvUTF8(ret));
3977                         } else if (SvUTF8(ret)) {
3978                             /* Not doing UTF-8, despite what the SV says. Is
3979                                this only if we're trapped in use 'bytes'?  */
3980                             /* Make a copy of the octet sequence, but without
3981                                the flag on, as the compiler now honours the
3982                                SvUTF8 flag on ret.  */
3983                             STRLEN len;
3984                             const char *const p = SvPV(ret, len);
3985                             ret = newSVpvn_flags(p, len, SVs_TEMP);
3986                         }
3987                         rx = CALLREGCOMP(ret, pm_flags);
3988                         if (!(SvFLAGS(ret)
3989                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3990                                  | SVs_GMG))) {
3991                             /* This isn't a first class regexp. Instead, it's
3992                                caching a regexp onto an existing, Perl visible
3993                                scalar.  */
3994                             sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
3995                         }
3996                         PL_regsize = osize;
3997                     }
3998                     re_sv = rx;
3999                     re = (struct regexp *)SvANY(rx);
4000                 }
4001                 RXp_MATCH_COPIED_off(re);
4002                 re->subbeg = rex->subbeg;
4003                 re->sublen = rex->sublen;
4004                 rei = RXi_GET(re);
4005                 DEBUG_EXECUTE_r(
4006                     debug_start_match(re_sv, do_utf8, locinput, PL_regeol,
4007                         "Matching embedded");
4008                 );
4009                 startpoint = rei->program + 1;
4010                 ST.close_paren = 0; /* only used for GOSUB */
4011                 /* borrowed from regtry */
4012                 if (PL_reg_start_tmpl <= re->nparens) {
4013                     PL_reg_start_tmpl = re->nparens*3/2 + 3;
4014                     if(PL_reg_start_tmp)
4015                         Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4016                     else
4017                         Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4018                 }
4019
4020         eval_recurse_doit: /* Share code with GOSUB below this line */
4021                 /* run the pattern returned from (??{...}) */
4022                 ST.cp = regcppush(0);   /* Save *all* the positions. */
4023                 REGCP_SET(ST.lastcp);
4024
4025                 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
4026
4027                 /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
4028                 PL_reglastparen = &re->lastparen;
4029                 PL_reglastcloseparen = &re->lastcloseparen;
4030                 re->lastparen = 0;
4031                 re->lastcloseparen = 0;
4032
4033                 PL_reginput = locinput;
4034                 PL_regsize = 0;
4035
4036                 /* XXXX This is too dramatic a measure... */
4037                 PL_reg_maxiter = 0;
4038
4039                 ST.toggle_reg_flags = PL_reg_flags;
4040                 if (RX_UTF8(re_sv))
4041                     PL_reg_flags |= RF_utf8;
4042                 else
4043                     PL_reg_flags &= ~RF_utf8;
4044                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
4045
4046                 ST.prev_rex = rex_sv;
4047                 ST.prev_curlyx = cur_curlyx;
4048                 SETREX(rex_sv,re_sv);
4049                 rex = re;
4050                 rexi = rei;
4051                 cur_curlyx = NULL;
4052                 ST.B = next;
4053                 ST.prev_eval = cur_eval;
4054                 cur_eval = st;
4055                 /* now continue from first node in postoned RE */
4056                 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
4057                 /* NOTREACHED */
4058             }
4059             /* logical is 1,   /(?(?{...})X|Y)/ */
4060             sw = (bool)SvTRUE(ret);
4061             logical = 0;
4062             break;
4063         }
4064
4065         case EVAL_AB: /* cleanup after a successful (??{A})B */
4066             /* note: this is called twice; first after popping B, then A */
4067             PL_reg_flags ^= ST.toggle_reg_flags;
4068             ReREFCNT_dec(rex_sv);
4069             SETREX(rex_sv,ST.prev_rex);
4070             rex = (struct regexp *)SvANY(rex_sv);
4071             rexi = RXi_GET(rex);
4072             regcpblow(ST.cp);
4073             cur_eval = ST.prev_eval;
4074             cur_curlyx = ST.prev_curlyx;
4075
4076             /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4077             PL_reglastparen = &rex->lastparen;
4078             PL_reglastcloseparen = &rex->lastcloseparen;
4079             /* also update PL_regoffs */
4080             PL_regoffs = rex->offs;
4081
4082             /* XXXX This is too dramatic a measure... */
4083             PL_reg_maxiter = 0;
4084             if ( nochange_depth )
4085                 nochange_depth--;
4086             sayYES;
4087
4088
4089         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
4090             /* note: this is called twice; first after popping B, then A */
4091             PL_reg_flags ^= ST.toggle_reg_flags;
4092             ReREFCNT_dec(rex_sv);
4093             SETREX(rex_sv,ST.prev_rex);
4094             rex = (struct regexp *)SvANY(rex_sv);
4095             rexi = RXi_GET(rex);
4096             /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4097             PL_reglastparen = &rex->lastparen;
4098             PL_reglastcloseparen = &rex->lastcloseparen;
4099
4100             PL_reginput = locinput;
4101             REGCP_UNWIND(ST.lastcp);
4102             regcppop(rex);
4103             cur_eval = ST.prev_eval;
4104             cur_curlyx = ST.prev_curlyx;
4105             /* XXXX This is too dramatic a measure... */
4106             PL_reg_maxiter = 0;
4107             if ( nochange_depth )
4108                 nochange_depth--;
4109             sayNO_SILENT;
4110 #undef ST
4111
4112         case OPEN:
4113             n = ARG(scan);  /* which paren pair */
4114             PL_reg_start_tmp[n] = locinput;
4115             if (n > PL_regsize)
4116                 PL_regsize = n;
4117             lastopen = n;
4118             break;
4119         case CLOSE:
4120             n = ARG(scan);  /* which paren pair */
4121             PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
4122             PL_regoffs[n].end = locinput - PL_bostr;
4123             /*if (n > PL_regsize)
4124                 PL_regsize = n;*/
4125             if (n > *PL_reglastparen)
4126                 *PL_reglastparen = n;
4127             *PL_reglastcloseparen = n;
4128             if (cur_eval && cur_eval->u.eval.close_paren == n) {
4129                 goto fake_end;
4130             }
4131             break;
4132         case ACCEPT:
4133             if (ARG(scan)){
4134                 regnode *cursor;
4135                 for (cursor=scan;
4136                      cursor && OP(cursor)!=END;
4137                      cursor=regnext(cursor))
4138                 {
4139                     if ( OP(cursor)==CLOSE ){
4140                         n = ARG(cursor);
4141                         if ( n <= lastopen ) {
4142                             PL_regoffs[n].start
4143                                 = PL_reg_start_tmp[n] - PL_bostr;
4144                             PL_regoffs[n].end = locinput - PL_bostr;
4145                             /*if (n > PL_regsize)
4146                             PL_regsize = n;*/
4147                             if (n > *PL_reglastparen)
4148                                 *PL_reglastparen = n;
4149                             *PL_reglastcloseparen = n;
4150                             if ( n == ARG(scan) || (cur_eval &&
4151                                 cur_eval->u.eval.close_paren == n))
4152                                 break;
4153                         }
4154                     }
4155                 }
4156             }
4157             goto fake_end;
4158             /*NOTREACHED*/
4159         case GROUPP:
4160             n = ARG(scan);  /* which paren pair */
4161             sw = (bool)(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
4162             break;
4163         case NGROUPP:
4164             /* reg_check_named_buff_matched returns 0 for no match */
4165             sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
4166             break;
4167         case INSUBP:
4168             n = ARG(scan);
4169             sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
4170             break;
4171         case DEFINEP:
4172             sw = 0;
4173             break;
4174         case IFTHEN:
4175             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
4176             if (sw)
4177                 next = NEXTOPER(NEXTOPER(scan));
4178             else {
4179                 next = scan + ARG(scan);
4180                 if (OP(next) == IFTHEN) /* Fake one. */
4181                     next = NEXTOPER(NEXTOPER(next));
4182             }
4183             break;
4184         case LOGICAL:
4185             logical = scan->flags;
4186             break;
4187
4188 /*******************************************************************
4189
4190 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
4191 pattern, where A and B are subpatterns. (For simple A, CURLYM or
4192 STAR/PLUS/CURLY/CURLYN are used instead.)
4193
4194 A*B is compiled as <CURLYX><A><WHILEM><B>
4195
4196 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
4197 state, which contains the current count, initialised to -1. It also sets
4198 cur_curlyx to point to this state, with any previous value saved in the
4199 state block.
4200
4201 CURLYX then jumps straight to the WHILEM op, rather than executing A,
4202 since the pattern may possibly match zero times (i.e. it's a while {} loop
4203 rather than a do {} while loop).
4204
4205 Each entry to WHILEM represents a successful match of A. The count in the
4206 CURLYX block is incremented, another WHILEM state is pushed, and execution
4207 passes to A or B depending on greediness and the current count.
4208
4209 For example, if matching against the string a1a2a3b (where the aN are
4210 substrings that match /A/), then the match progresses as follows: (the
4211 pushed states are interspersed with the bits of strings matched so far):
4212
4213     <CURLYX cnt=-1>
4214     <CURLYX cnt=0><WHILEM>
4215     <CURLYX cnt=1><WHILEM> a1 <WHILEM>
4216     <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
4217     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
4218     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
4219
4220 (Contrast this with something like CURLYM, which maintains only a single
4221 backtrack state:
4222
4223     <CURLYM cnt=0> a1
4224     a1 <CURLYM cnt=1> a2
4225     a1 a2 <CURLYM cnt=2> a3
4226     a1 a2 a3 <CURLYM cnt=3> b
4227 )
4228
4229 Each WHILEM state block marks a point to backtrack to upon partial failure
4230 of A or B, and also contains some minor state data related to that
4231 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
4232 overall state, such as the count, and pointers to the A and B ops.
4233
4234 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
4235 must always point to the *current* CURLYX block, the rules are:
4236
4237 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
4238 and set cur_curlyx to point the new block.
4239
4240 When popping the CURLYX block after a successful or unsuccessful match,
4241 restore the previous cur_curlyx.
4242
4243 When WHILEM is about to execute B, save the current cur_curlyx, and set it
4244 to the outer one saved in the CURLYX block.
4245
4246 When popping the WHILEM block after a successful or unsuccessful B match,
4247 restore the previous cur_curlyx.
4248
4249 Here's an example for the pattern (AI* BI)*BO
4250 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
4251
4252 cur_
4253 curlyx backtrack stack
4254 ------ ---------------
4255 NULL
4256 CO     <CO prev=NULL> <WO>
4257 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4258 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4259 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
4260
4261 At this point the pattern succeeds, and we work back down the stack to
4262 clean up, restoring as we go:
4263
4264 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4265 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4266 CO     <CO prev=NULL> <WO>
4267 NULL
4268
4269 *******************************************************************/
4270
4271 #define ST st->u.curlyx
4272
4273         case CURLYX:    /* start of /A*B/  (for complex A) */
4274         {
4275             /* No need to save/restore up to this paren */
4276             I32 parenfloor = scan->flags;
4277
4278             assert(next); /* keep Coverity happy */
4279             if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4280                 next += ARG(next);
4281
4282             /* XXXX Probably it is better to teach regpush to support
4283                parenfloor > PL_regsize... */
4284             if (parenfloor > (I32)*PL_reglastparen)
4285                 parenfloor = *PL_reglastparen; /* Pessimization... */
4286
4287             ST.prev_curlyx= cur_curlyx;
4288             cur_curlyx = st;
4289             ST.cp = PL_savestack_ix;
4290
4291             /* these fields contain the state of the current curly.
4292              * they are accessed by subsequent WHILEMs */
4293             ST.parenfloor = parenfloor;
4294             ST.min = ARG1(scan);
4295             ST.max = ARG2(scan);
4296             ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4297             ST.B = next;
4298             ST.minmod = minmod;
4299             minmod = 0;
4300             ST.count = -1;      /* this will be updated by WHILEM */
4301             ST.lastloc = NULL;  /* this will be updated by WHILEM */
4302
4303             PL_reginput = locinput;
4304             PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4305             /* NOTREACHED */
4306         }
4307
4308         case CURLYX_end: /* just finished matching all of A*B */
4309             cur_curlyx = ST.prev_curlyx;
4310             sayYES;
4311             /* NOTREACHED */
4312
4313         case CURLYX_end_fail: /* just failed to match all of A*B */
4314             regcpblow(ST.cp);
4315             cur_curlyx = ST.prev_curlyx;
4316             sayNO;
4317             /* NOTREACHED */
4318
4319
4320 #undef ST
4321 #define ST st->u.whilem
4322
4323         case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
4324         {
4325             /* see the discussion above about CURLYX/WHILEM */
4326             I32 n;
4327             assert(cur_curlyx); /* keep Coverity happy */
4328             n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4329             ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4330             ST.cache_offset = 0;
4331             ST.cache_mask = 0;
4332
4333             PL_reginput = locinput;
4334
4335             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4336                   "%*s  whilem: matched %ld out of %ld..%ld\n",
4337                   REPORT_CODE_OFF+depth*2, "", (long)n,
4338                   (long)cur_curlyx->u.curlyx.min,
4339                   (long)cur_curlyx->u.curlyx.max)
4340             );
4341
4342             /* First just match a string of min A's. */
4343
4344             if (n < cur_curlyx->u.curlyx.min) {
4345                 cur_curlyx->u.curlyx.lastloc = locinput;
4346                 PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
4347                 /* NOTREACHED */
4348             }
4349
4350             /* If degenerate A matches "", assume A done. */
4351
4352             if (locinput == cur_curlyx->u.curlyx.lastloc) {
4353                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4354                    "%*s  whilem: empty match detected, trying continuation...\n",
4355                    REPORT_CODE_OFF+depth*2, "")
4356                 );
4357                 goto do_whilem_B_max;
4358             }
4359
4360             /* super-linear cache processing */
4361
4362             if (scan->flags) {
4363
4364                 if (!PL_reg_maxiter) {
4365                     /* start the countdown: Postpone detection until we
4366                      * know the match is not *that* much linear. */
4367                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4368                     /* possible overflow for long strings and many CURLYX's */
4369                     if (PL_reg_maxiter < 0)
4370                         PL_reg_maxiter = I32_MAX;
4371                     PL_reg_leftiter = PL_reg_maxiter;
4372                 }
4373
4374                 if (PL_reg_leftiter-- == 0) {
4375                     /* initialise cache */
4376                     const I32 size = (PL_reg_maxiter + 7)/8;
4377                     if (PL_reg_poscache) {
4378                         if ((I32)PL_reg_poscache_size < size) {
4379                             Renew(PL_reg_poscache, size, char);
4380                             PL_reg_poscache_size = size;
4381                         }
4382                         Zero(PL_reg_poscache, size, char);
4383                     }
4384                     else {
4385                         PL_reg_poscache_size = size;
4386                         Newxz(PL_reg_poscache, size, char);
4387                     }
4388                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4389       "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4390                               PL_colors[4], PL_colors[5])
4391                     );
4392                 }
4393
4394                 if (PL_reg_leftiter < 0) {
4395                     /* have we already failed at this position? */
4396                     I32 offset, mask;
4397                     offset  = (scan->flags & 0xf) - 1
4398                                 + (locinput - PL_bostr)  * (scan->flags>>4);
4399                     mask    = 1 << (offset % 8);
4400                     offset /= 8;
4401                     if (PL_reg_poscache[offset] & mask) {
4402                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4403                             "%*s  whilem: (cache) already tried at this position...\n",
4404                             REPORT_CODE_OFF+depth*2, "")
4405                         );
4406                         sayNO; /* cache records failure */
4407                     }
4408                     ST.cache_offset = offset;
4409                     ST.cache_mask   = mask;
4410                 }
4411             }
4412
4413             /* Prefer B over A for minimal matching. */
4414
4415             if (cur_curlyx->u.curlyx.minmod) {
4416                 ST.save_curlyx = cur_curlyx;
4417                 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4418                 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4419                 REGCP_SET(ST.lastcp);
4420                 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4421                 /* NOTREACHED */
4422             }
4423
4424             /* Prefer A over B for maximal matching. */
4425
4426             if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
4427                 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4428                 cur_curlyx->u.curlyx.lastloc = locinput;
4429                 REGCP_SET(ST.lastcp);
4430                 PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
4431                 /* NOTREACHED */
4432             }
4433             goto do_whilem_B_max;
4434         }
4435         /* NOTREACHED */
4436
4437         case WHILEM_B_min: /* just matched B in a minimal match */
4438         case WHILEM_B_max: /* just matched B in a maximal match */
4439             cur_curlyx = ST.save_curlyx;
4440             sayYES;
4441             /* NOTREACHED */
4442
4443         case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4444             cur_curlyx = ST.save_curlyx;
4445             cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4446             cur_curlyx->u.curlyx.count--;
4447             CACHEsayNO;
4448             /* NOTREACHED */
4449
4450         case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4451             REGCP_UNWIND(ST.lastcp);
4452             regcppop(rex);
4453             /* FALL THROUGH */
4454         case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4455             cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4456             cur_curlyx->u.curlyx.count--;
4457             CACHEsayNO;
4458             /* NOTREACHED */
4459
4460         case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4461             REGCP_UNWIND(ST.lastcp);
4462             regcppop(rex);      /* Restore some previous $<digit>s? */
4463             PL_reginput = locinput;
4464             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4465                 "%*s  whilem: failed, trying continuation...\n",
4466                 REPORT_CODE_OFF+depth*2, "")
4467             );
4468           do_whilem_B_max:
4469             if (cur_curlyx->u.curlyx.count >= REG_INFTY
4470                 && ckWARN(WARN_REGEXP)
4471                 && !(PL_reg_flags & RF_warned))
4472             {
4473                 PL_reg_flags |= RF_warned;
4474                 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4475                      "Complex regular subexpression recursion",
4476                      REG_INFTY - 1);
4477             }
4478
4479             /* now try B */
4480             ST.save_curlyx = cur_curlyx;
4481             cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4482             PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4483             /* NOTREACHED */
4484
4485         case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4486             cur_curlyx = ST.save_curlyx;
4487             REGCP_UNWIND(ST.lastcp);
4488             regcppop(rex);
4489
4490             if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
4491                 /* Maximum greed exceeded */
4492                 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4493                     && ckWARN(WARN_REGEXP)
4494                     && !(PL_reg_flags & RF_warned))
4495                 {
4496                     PL_reg_flags |= RF_warned;
4497                     Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4498                         "%s limit (%d) exceeded",
4499                         "Complex regular subexpression recursion",
4500                         REG_INFTY - 1);
4501                 }
4502                 cur_curlyx->u.curlyx.count--;
4503                 CACHEsayNO;
4504             }
4505
4506             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4507                 "%*s  trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4508             );
4509             /* Try grabbing another A and see if it helps. */
4510             PL_reginput = locinput;
4511             cur_curlyx->u.curlyx.lastloc = locinput;
4512             ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4513             REGCP_SET(ST.lastcp);
4514             PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
4515             /* NOTREACHED */
4516
4517 #undef  ST
4518 #define ST st->u.branch
4519
4520         case BRANCHJ:       /*  /(...|A|...)/ with long next pointer */
4521             next = scan + ARG(scan);
4522             if (next == scan)
4523                 next = NULL;
4524             scan = NEXTOPER(scan);
4525             /* FALL THROUGH */
4526
4527         case BRANCH:        /*  /(...|A|...)/ */
4528             scan = NEXTOPER(scan); /* scan now points to inner node */
4529             ST.lastparen = *PL_reglastparen;
4530             ST.next_branch = next;
4531             REGCP_SET(ST.cp);
4532             PL_reginput = locinput;
4533
4534             /* Now go into the branch */
4535             if (has_cutgroup) {
4536                 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4537             } else {
4538                 PUSH_STATE_GOTO(BRANCH_next, scan);
4539             }
4540             /* NOTREACHED */
4541         case CUTGROUP:
4542             PL_reginput = locinput;
4543             sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4544                 MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4545             PUSH_STATE_GOTO(CUTGROUP_next,next);
4546             /* NOTREACHED */
4547         case CUTGROUP_next_fail:
4548             do_cutgroup = 1;
4549             no_final = 1;
4550             if (st->u.mark.mark_name)
4551                 sv_commit = st->u.mark.mark_name;
4552             sayNO;
4553             /* NOTREACHED */
4554         case BRANCH_next:
4555             sayYES;
4556             /* NOTREACHED */
4557         case BRANCH_next_fail: /* that branch failed; try the next, if any */
4558             if (do_cutgroup) {
4559                 do_cutgroup = 0;
4560                 no_final = 0;
4561             }
4562             REGCP_UNWIND(ST.cp);
4563             for (n = *PL_reglastparen; n > ST.lastparen; n--)
4564                 PL_regoffs[n].end = -1;
4565             *PL_reglastparen = n;
4566             /*dmq: *PL_reglastcloseparen = n; */
4567             scan = ST.next_branch;
4568             /* no more branches? */
4569             if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4570                 DEBUG_EXECUTE_r({
4571                     PerlIO_printf( Perl_debug_log,
4572                         "%*s  %sBRANCH failed...%s\n",
4573                         REPORT_CODE_OFF+depth*2, "",
4574                         PL_colors[4],
4575                         PL_colors[5] );
4576                 });
4577                 sayNO_SILENT;
4578             }
4579             continue; /* execute next BRANCH[J] op */
4580             /* NOTREACHED */
4581
4582         case MINMOD:
4583             minmod = 1;
4584             break;
4585
4586 #undef  ST
4587 #define ST st->u.curlym
4588
4589         case CURLYM:    /* /A{m,n}B/ where A is fixed-length */
4590
4591             /* This is an optimisation of CURLYX that enables us to push
4592              * only a single backtracking state, no matter how many matches
4593              * there are in {m,n}. It relies on the pattern being constant
4594              * length, with no parens to influence future backrefs
4595              */
4596
4597             ST.me = scan;
4598             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4599
4600             /* if paren positive, emulate an OPEN/CLOSE around A */
4601             if (ST.me->flags) {
4602                 U32 paren = ST.me->flags;
4603                 if (paren > PL_regsize)
4604                     PL_regsize = paren;
4605                 if (paren > *PL_reglastparen)
4606                     *PL_reglastparen = paren;
4607                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4608             }
4609             ST.A = scan;
4610             ST.B = next;
4611             ST.alen = 0;
4612             ST.count = 0;
4613             ST.minmod = minmod;
4614             minmod = 0;
4615             ST.c1 = CHRTEST_UNINIT;
4616             REGCP_SET(ST.cp);
4617
4618             if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4619                 goto curlym_do_B;
4620
4621           curlym_do_A: /* execute the A in /A{m,n}B/  */
4622             PL_reginput = locinput;
4623             PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4624             /* NOTREACHED */
4625
4626         case CURLYM_A: /* we've just matched an A */
4627             locinput = st->locinput;
4628             nextchr = UCHARAT(locinput);
4629
4630             ST.count++;
4631             /* after first match, determine A's length: u.curlym.alen */
4632             if (ST.count == 1) {
4633                 if (PL_reg_match_utf8) {
4634                     char *s = locinput;
4635                     while (s < PL_reginput) {
4636                         ST.alen++;
4637                         s += UTF8SKIP(s);
4638                     }
4639                 }
4640                 else {
4641                     ST.alen = PL_reginput - locinput;
4642                 }
4643                 if (ST.alen == 0)
4644                     ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4645             }
4646             DEBUG_EXECUTE_r(
4647                 PerlIO_printf(Perl_debug_log,
4648                           "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4649                           (int)(REPORT_CODE_OFF+(depth*2)), "",
4650                           (IV) ST.count, (IV)ST.alen)
4651             );
4652
4653             locinput = PL_reginput;
4654
4655             if (cur_eval && cur_eval->u.eval.close_paren &&
4656                 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4657                 goto fake_end;
4658
4659             {
4660                 I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
4661                 if ( max == REG_INFTY || ST.count < max )
4662                     goto curlym_do_A; /* try to match another A */
4663             }
4664             goto curlym_do_B; /* try to match B */
4665
4666         case CURLYM_A_fail: /* just failed to match an A */
4667             REGCP_UNWIND(ST.cp);
4668
4669             if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4670                 || (cur_eval && cur_eval->u.eval.close_paren &&
4671                     cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4672                 sayNO;
4673
4674           curlym_do_B: /* execute the B in /A{m,n}B/  */
4675             PL_reginput = locinput;
4676             if (ST.c1 == CHRTEST_UNINIT) {
4677                 /* calculate c1 and c2 for possible match of 1st char
4678                  * following curly */
4679                 ST.c1 = ST.c2 = CHRTEST_VOID;
4680                 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4681                     regnode *text_node = ST.B;
4682                     if (! HAS_TEXT(text_node))
4683                         FIND_NEXT_IMPT(text_node);
4684                     /* this used to be
4685
4686                         (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4687
4688                         But the former is redundant in light of the latter.
4689
4690                         if this changes back then the macro for
4691                         IS_TEXT and friends need to change.
4692                      */
4693                     if (PL_regkind[OP(text_node)] == EXACT)
4694                     {
4695
4696                         ST.c1 = (U8)*STRING(text_node);
4697                         ST.c2 =
4698                             (IS_TEXTF(text_node))
4699                             ? PL_fold[ST.c1]
4700                             : (IS_TEXTFL(text_node))
4701                                 ? PL_fold_locale[ST.c1]
4702                                 : ST.c1;
4703                     }
4704                 }
4705             }
4706
4707             DEBUG_EXECUTE_r(
4708                 PerlIO_printf(Perl_debug_log,
4709                     "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
4710                     (int)(REPORT_CODE_OFF+(depth*2)),
4711                     "", (IV)ST.count)
4712                 );
4713             if (ST.c1 != CHRTEST_VOID
4714                     && UCHARAT(PL_reginput) != ST.c1
4715                     && UCHARAT(PL_reginput) != ST.c2)
4716             {
4717                 /* simulate B failing */
4718                 DEBUG_OPTIMISE_r(
4719                     PerlIO_printf(Perl_debug_log,
4720                         "%*s  CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
4721                         (int)(REPORT_CODE_OFF+(depth*2)),"",
4722                         (IV)ST.c1,(IV)ST.c2
4723                 ));
4724                 state_num = CURLYM_B_fail;
4725                 goto reenter_switch;
4726             }
4727
4728             if (ST.me->flags) {
4729                 /* mark current A as captured */
4730                 I32 paren = ST.me->flags;
4731                 if (ST.count) {
4732                     PL_regoffs[paren].start
4733                         = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4734                     PL_regoffs[paren].end = PL_reginput - PL_bostr;
4735                     /*dmq: *PL_reglastcloseparen = paren; */
4736                 }
4737                 else
4738                     PL_regoffs[paren].end = -1;
4739                 if (cur_eval && cur_eval->u.eval.close_paren &&
4740                     cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4741                 {
4742                     if (ST.count)
4743                         goto fake_end;
4744                     else
4745                         sayNO;
4746                 }
4747             }
4748
4749             PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4750             /* NOTREACHED */
4751
4752         case CURLYM_B_fail: /* just failed to match a B */
4753             REGCP_UNWIND(ST.cp);
4754             if (ST.minmod) {
4755                 I32 max = ARG2(ST.me);
4756                 if (max != REG_INFTY && ST.count == max)
4757                     sayNO;
4758                 goto curlym_do_A; /* try to match a further A */
4759             }
4760             /* backtrack one A */
4761             if (ST.count == ARG1(ST.me) /* min */)
4762                 sayNO;
4763             ST.count--;
4764             locinput = HOPc(locinput, -ST.alen);
4765             goto curlym_do_B; /* try to match B */
4766
4767 #undef ST
4768 #define ST st->u.curly
4769
4770 #define CURLY_SETPAREN(paren, success) \
4771     if (paren) { \
4772         if (success) { \
4773             PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
4774             PL_regoffs[paren].end = locinput - PL_bostr; \
4775             *PL_reglastcloseparen = paren; \
4776         } \
4777         else \
4778             PL_regoffs[paren].end = -1; \
4779     }
4780
4781         case STAR:              /*  /A*B/ where A is width 1 */
4782             ST.paren = 0;
4783             ST.min = 0;
4784             ST.max = REG_INFTY;
4785             scan = NEXTOPER(scan);
4786             goto repeat;
4787         case PLUS:              /*  /A+B/ where A is width 1 */
4788             ST.paren = 0;
4789             ST.min = 1;
4790             ST.max = REG_INFTY;
4791             scan = NEXTOPER(scan);
4792             goto repeat;
4793         case CURLYN:            /*  /(A){m,n}B/ where A is width 1 */
4794             ST.paren = scan->flags;     /* Which paren to set */
4795             if (ST.paren > PL_regsize)
4796                 PL_regsize = ST.paren;
4797             if (ST.paren > *PL_reglastparen)
4798                 *PL_reglastparen = ST.paren;
4799             ST.min = ARG1(scan);  /* min to match */
4800             ST.max = ARG2(scan);  /* max to match */
4801             if (cur_eval && cur_eval->u.eval.close_paren &&
4802                 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4803                 ST.min=1;
4804                 ST.max=1;
4805             }
4806             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4807             goto repeat;
4808         case CURLY:             /*  /A{m,n}B/ where A is width 1 */
4809             ST.paren = 0;
4810             ST.min = ARG1(scan);  /* min to match */
4811             ST.max = ARG2(scan);  /* max to match */
4812             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4813           repeat:
4814             /*
4815             * Lookahead to avoid useless match attempts
4816             * when we know what character comes next.
4817             *
4818             * Used to only do .*x and .*?x, but now it allows
4819             * for )'s, ('s and (?{ ... })'s to be in the way
4820             * of the quantifier and the EXACT-like node.  -- japhy
4821             */
4822
4823             if (ST.min > ST.max) /* XXX make this a compile-time check? */
4824                 sayNO;
4825             if (HAS_TEXT(next) || JUMPABLE(next)) {
4826                 U8 *s;
4827                 regnode *text_node = next;
4828
4829                 if (! HAS_TEXT(text_node))
4830                     FIND_NEXT_IMPT(text_node);
4831
4832                 if (! HAS_TEXT(text_node))
4833                     ST.c1 = ST.c2 = CHRTEST_VOID;
4834                 else {
4835                     if ( PL_regkind[OP(text_node)] != EXACT ) {
4836                         ST.c1 = ST.c2 = CHRTEST_VOID;
4837                         goto assume_ok_easy;
4838                     }
4839                     else
4840                         s = (U8*)STRING(text_node);
4841
4842                     /*  Currently we only get here when
4843
4844                         PL_rekind[OP(text_node)] == EXACT
4845
4846                         if this changes back then the macro for IS_TEXT and
4847                         friends need to change. */
4848                     if (!UTF) {
4849                         ST.c2 = ST.c1 = *s;
4850                         if (IS_TEXTF(text_node))
4851                             ST.c2 = PL_fold[ST.c1];
4852                         else if (IS_TEXTFL(text_node))
4853                             ST.c2 = PL_fold_locale[ST.c1];
4854                     }
4855                     else { /* UTF */
4856                         if (IS_TEXTF(text_node)) {
4857                              STRLEN ulen1, ulen2;
4858                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4859                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4860
4861                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4862                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4863 #ifdef EBCDIC
4864                              ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4865                                                     ckWARN(WARN_UTF8) ?
4866                                                     0 : UTF8_ALLOW_ANY);
4867                              ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4868                                                     ckWARN(WARN_UTF8) ?
4869                                                     0 : UTF8_ALLOW_ANY);
4870 #else
4871                              ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4872                                                     uniflags);
4873                              ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4874                                                     uniflags);
4875 #endif
4876                         }
4877                         else {
4878                             ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4879                                                      uniflags);
4880                         }
4881                     }
4882                 }
4883             }
4884             else
4885                 ST.c1 = ST.c2 = CHRTEST_VOID;
4886         assume_ok_easy:
4887
4888             ST.A = scan;
4889             ST.B = next;
4890             PL_reginput = locinput;
4891             if (minmod) {
4892                 minmod = 0;
4893                 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4894                     sayNO;
4895                 ST.count = ST.min;
4896                 locinput = PL_reginput;
4897                 REGCP_SET(ST.cp);
4898                 if (ST.c1 == CHRTEST_VOID)
4899                     goto curly_try_B_min;
4900
4901                 ST.oldloc = locinput;
4902
4903                 /* set ST.maxpos to the furthest point along the
4904                  * string that could possibly match */
4905                 if  (ST.max == REG_INFTY) {
4906                     ST.maxpos = PL_regeol - 1;
4907                     if (do_utf8)
4908                         while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4909                             ST.maxpos--;
4910                 }
4911                 else if (do_utf8) {
4912                     int m = ST.max - ST.min;
4913                     for (ST.maxpos = locinput;
4914                          m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4915                         ST.maxpos += UTF8SKIP(ST.maxpos);
4916                 }
4917                 else {
4918                     ST.maxpos = locinput + ST.max - ST.min;
4919                     if (ST.maxpos >= PL_regeol)
4920                         ST.maxpos = PL_regeol - 1;
4921                 }
4922                 goto curly_try_B_min_known;
4923
4924             }
4925             else {
4926                 ST.count = regrepeat(rex, ST.A, ST.max, depth);
4927                 locinput = PL_reginput;
4928                 if (ST.count < ST.min)
4929                     sayNO;
4930                 if ((ST.count > ST.min)
4931                     && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4932                 {
4933                     /* A{m,n} must come at the end of the string, there's
4934                      * no point in backing off ... */
4935                     ST.min = ST.count;
4936                     /* ...except that $ and \Z can match before *and* after
4937                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4938                        We may back off by one in this case. */
4939                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4940                         ST.min--;
4941                 }
4942                 REGCP_SET(ST.cp);
4943                 goto curly_try_B_max;
4944             }
4945             /* NOTREACHED */
4946
4947
4948         case CURLY_B_min_known_fail:
4949             /* failed to find B in a non-greedy match where c1,c2 valid */
4950             if (ST.paren && ST.count)
4951                 PL_regoffs[ST.paren].end = -1;
4952
4953             PL_reginput = locinput;     /* Could be reset... */
4954             REGCP_UNWIND(ST.cp);
4955             /* Couldn't or didn't -- move forward. */
4956             ST.oldloc = locinput;
4957             if (do_utf8)
4958                 locinput += UTF8SKIP(locinput);
4959             else
4960                 locinput++;
4961             ST.count++;
4962           curly_try_B_min_known:
4963              /* find the next place where 'B' could work, then call B */
4964             {
4965                 int n;
4966                 if (do_utf8) {
4967                     n = (ST.oldloc == locinput) ? 0 : 1;
4968                     if (ST.c1 == ST.c2) {
4969                         STRLEN len;
4970                         /* set n to utf8_distance(oldloc, locinput) */
4971                         while (locinput <= ST.maxpos &&
4972                                utf8n_to_uvchr((U8*)locinput,
4973                                               UTF8_MAXBYTES, &len,
4974                                               uniflags) != (UV)ST.c1) {
4975                             locinput += len;
4976                             n++;
4977                         }
4978                     }
4979                     else {
4980                         /* set n to utf8_distance(oldloc, locinput) */
4981                         while (locinput <= ST.maxpos) {
4982                             STRLEN len;
4983                             const UV c = utf8n_to_uvchr((U8*)locinput,
4984                                                   UTF8_MAXBYTES, &len,
4985                                                   uniflags);
4986                             if (c == (UV)ST.c1 || c == (UV)ST.c2)
4987                                 break;
4988                             locinput += len;
4989                             n++;
4990                         }
4991                     }
4992                 }
4993                 else {
4994                     if (ST.c1 == ST.c2) {
4995                         while (locinput <= ST.maxpos &&
4996                                UCHARAT(locinput) != ST.c1)
4997                             locinput++;
4998                     }
4999                     else {
5000                         while (locinput <= ST.maxpos
5001                                && UCHARAT(locinput) != ST.c1
5002                                && UCHARAT(locinput) != ST.c2)
5003                             locinput++;
5004                     }
5005                     n = locinput - ST.oldloc;
5006                 }
5007                 if (locinput > ST.maxpos)
5008                     sayNO;
5009                 /* PL_reginput == oldloc now */
5010                 if (n) {
5011                     ST.count += n;
5012                     if (regrepeat(rex, ST.A, n, depth) < n)
5013                         sayNO;
5014                 }
5015                 PL_reginput = locinput;
5016                 CURLY_SETPAREN(ST.paren, ST.count);
5017                 if (cur_eval && cur_eval->u.eval.close_paren &&
5018                     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5019                     goto fake_end;
5020                 }
5021                 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
5022             }
5023             /* NOTREACHED */
5024
5025
5026         case CURLY_B_min_fail:
5027             /* failed to find B in a non-greedy match where c1,c2 invalid */
5028             if (ST.paren && ST.count)
5029                 PL_regoffs[ST.paren].end = -1;
5030
5031             REGCP_UNWIND(ST.cp);
5032             /* failed -- move forward one */
5033             PL_reginput = locinput;
5034             if (regrepeat(rex, ST.A, 1, depth)) {
5035                 ST.count++;
5036                 locinput = PL_reginput;
5037                 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
5038                         ST.count > 0)) /* count overflow ? */
5039                 {
5040                   curly_try_B_min:
5041                     CURLY_SETPAREN(ST.paren, ST.count);
5042                     if (cur_eval && cur_eval->u.eval.close_paren &&
5043                         cur_eval->u.eval.close_paren == (U32)ST.paren) {
5044                         goto fake_end;
5045                     }
5046                     PUSH_STATE_GOTO(CURLY_B_min, ST.B);
5047                 }
5048             }
5049             sayNO;
5050             /* NOTREACHED */
5051
5052
5053         curly_try_B_max:
5054             /* a successful greedy match: now try to match B */
5055             if (cur_eval && cur_eval->u.eval.close_paren &&
5056                 cur_eval->u.eval.close_paren == (U32)ST.paren) {
5057                 goto fake_end;
5058             }
5059             {
5060                 UV c = 0;
5061                 if (ST.c1 != CHRTEST_VOID)
5062                     c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
5063                                            UTF8_MAXBYTES, 0, uniflags)
5064                                 : (UV) UCHARAT(PL_reginput);
5065                 /* If it could work, try it. */
5066                 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
5067                     CURLY_SETPAREN(ST.paren, ST.count);
5068                     PUSH_STATE_GOTO(CURLY_B_max, ST.B);
5069                     /* NOTREACHED */
5070                 }
5071             }
5072             /* FALL THROUGH */
5073         case CURLY_B_max_fail:
5074             /* failed to find B in a greedy match */
5075             if (ST.paren && ST.count)
5076                 PL_regoffs[ST.paren].end = -1;
5077
5078             REGCP_UNWIND(ST.cp);
5079             /*  back up. */
5080             if (--ST.count < ST.min)
5081                 sayNO;
5082             PL_reginput = locinput = HOPc(locinput, -1);
5083             goto curly_try_B_max;
5084
5085 #undef ST
5086
5087         case END:
5088             fake_end:
5089             if (cur_eval) {
5090                 /* we've just finished A in /(??{A})B/; now continue with B */
5091                 I32 tmpix;
5092                 st->u.eval.toggle_reg_flags
5093                             = cur_eval->u.eval.toggle_reg_flags;
5094                 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
5095
5096                 st->u.eval.prev_rex = rex_sv;           /* inner */
5097                 SETREX(rex_sv,cur_eval->u.eval.prev_rex);
5098                 rex = (struct regexp *)SvANY(rex_sv);
5099                 rexi = RXi_GET(rex);
5100                 cur_curlyx = cur_eval->u.eval.prev_curlyx;
5101                 ReREFCNT_inc(rex_sv);
5102                 st->u.eval.cp = regcppush(0);   /* Save *all* the positions. */
5103
5104                 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
5105                 PL_reglastparen = &rex->lastparen;
5106                 PL_reglastcloseparen = &rex->lastcloseparen;
5107
5108                 REGCP_SET(st->u.eval.lastcp);
5109                 PL_reginput = locinput;
5110
5111                 /* Restore parens of the outer rex without popping the
5112                  * savestack */
5113                 tmpix = PL_savestack_ix;
5114                 PL_savestack_ix = cur_eval->u.eval.lastcp;
5115                 regcppop(rex);
5116                 PL_savestack_ix = tmpix;
5117
5118                 st->u.eval.prev_eval = cur_eval;
5119                 cur_eval = cur_eval->u.eval.prev_eval;
5120                 DEBUG_EXECUTE_r(
5121                     PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ... %"UVxf"\n",
5122                                       REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
5123                 if ( nochange_depth )
5124                     nochange_depth--;
5125
5126                 PUSH_YES_STATE_GOTO(EVAL_AB,
5127                         st->u.eval.prev_eval->u.eval.B); /* match B */
5128             }
5129
5130             if (locinput < reginfo->till) {
5131                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5132                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
5133                                       PL_colors[4],
5134                                       (long)(locinput - PL_reg_starttry),
5135                                       (long)(reginfo->till - PL_reg_starttry),
5136                                       PL_colors[5]));
5137
5138                 sayNO_SILENT;           /* Cannot match: too short. */
5139             }
5140             PL_reginput = locinput;     /* put where regtry can find it */
5141             sayYES;                     /* Success! */
5142
5143         case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
5144             DEBUG_EXECUTE_r(
5145             PerlIO_printf(Perl_debug_log,
5146                 "%*s  %ssubpattern success...%s\n",
5147                 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
5148             PL_reginput = locinput;     /* put where regtry can find it */
5149             sayYES;                     /* Success! */
5150
5151 #undef  ST
5152 #define ST st->u.ifmatch
5153
5154         case SUSPEND:   /* (?>A) */
5155             ST.wanted = 1;
5156             PL_reginput = locinput;
5157             goto do_ifmatch;
5158
5159         case UNLESSM:   /* -ve lookaround: (?!A), or with flags, (?<!A) */
5160             ST.wanted = 0;
5161             goto ifmatch_trivial_fail_test;
5162
5163         case IFMATCH:   /* +ve lookaround: (?=A), or with flags, (?<=A) */
5164             ST.wanted = 1;
5165           ifmatch_trivial_fail_test:
5166             if (scan->flags) {
5167                 char * const s = HOPBACKc(locinput, scan->flags);
5168                 if (!s) {
5169                     /* trivial fail */
5170                     if (logical) {
5171                         logical = 0;
5172                         sw = 1 - (bool)ST.wanted;
5173                     }
5174                     else if (ST.wanted)
5175                         sayNO;
5176                     next = scan + ARG(scan);
5177                     if (next == scan)
5178                         next = NULL;
5179                     break;
5180                 }
5181                 PL_reginput = s;
5182             }
5183             else
5184                 PL_reginput = locinput;
5185
5186           do_ifmatch:
5187             ST.me = scan;
5188             ST.logical = logical;
5189             logical = 0; /* XXX: reset state of logical once it has been saved into ST */
5190
5191             /* execute body of (?...A) */
5192             PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
5193             /* NOTREACHED */
5194
5195         case IFMATCH_A_fail: /* body of (?...A) failed */
5196             ST.wanted = !ST.wanted;
5197             /* FALL THROUGH */
5198
5199         case IFMATCH_A: /* body of (?...A) succeeded */
5200             if (ST.logical) {
5201                 sw = (bool)ST.wanted;
5202             }
5203             else if (!ST.wanted)
5204                 sayNO;
5205
5206             if (OP(ST.me) == SUSPEND)
5207                 locinput = PL_reginput;
5208             else {
5209                 locinput = PL_reginput = st->locinput;
5210                 nextchr = UCHARAT(locinput);
5211             }
5212             scan = ST.me + ARG(ST.me);
5213             if (scan == ST.me)
5214                 scan = NULL;
5215             continue; /* execute B */
5216
5217 #undef ST
5218
5219         case LONGJMP:
5220             next = scan + ARG(scan);
5221             if (next == scan)
5222                 next = NULL;
5223             break;
5224         case COMMIT:
5225             reginfo->cutpoint = PL_regeol;
5226             /* FALLTHROUGH */
5227         case PRUNE:
5228             PL_reginput = locinput;
5229             if (!scan->flags)
5230                 sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5231             PUSH_STATE_GOTO(COMMIT_next,next);
5232             /* NOTREACHED */
5233         case COMMIT_next_fail:
5234             no_final = 1;
5235             /* FALLTHROUGH */
5236         case OPFAIL:
5237             sayNO;
5238             /* NOTREACHED */
5239
5240 #define ST st->u.mark
5241         case MARKPOINT:
5242             ST.prev_mark = mark_state;
5243             ST.mark_name = sv_commit = sv_yes_mark
5244                 = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5245             mark_state = st;
5246             ST.mark_loc = PL_reginput = locinput;
5247             PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5248             /* NOTREACHED */
5249         case MARKPOINT_next:
5250             mark_state = ST.prev_mark;
5251             sayYES;
5252             /* NOTREACHED */
5253         case MARKPOINT_next_fail:
5254             if (popmark && sv_eq(ST.mark_name,popmark))
5255             {
5256                 if (ST.mark_loc > startpoint)
5257                     reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5258                 popmark = NULL; /* we found our mark */
5259                 sv_commit = ST.mark_name;
5260
5261                 DEBUG_EXECUTE_r({
5262                         PerlIO_printf(Perl_debug_log,
5263                             "%*s  %ssetting cutpoint to mark:%"SVf"...%s\n",
5264                             REPORT_CODE_OFF+depth*2, "",
5265                             PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
5266                 });
5267             }
5268             mark_state = ST.prev_mark;
5269             sv_yes_mark = mark_state ?
5270                 mark_state->u.mark.mark_name : NULL;
5271             sayNO;
5272             /* NOTREACHED */
5273         case SKIP:
5274             PL_reginput = locinput;
5275             if (scan->flags) {
5276                 /* (*SKIP) : if we fail we cut here*/
5277                 ST.mark_name = NULL;
5278                 ST.mark_loc = locinput;
5279                 PUSH_STATE_GOTO(SKIP_next,next);
5280             } else {
5281                 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5282                    otherwise do nothing.  Meaning we need to scan
5283                  */
5284                 regmatch_state *cur = mark_state;
5285                 SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5286
5287                 while (cur) {
5288                     if ( sv_eq( cur->u.mark.mark_name,
5289                                 find ) )
5290                     {
5291                         ST.mark_name = find;
5292                         PUSH_STATE_GOTO( SKIP_next, next );
5293                     }
5294                     cur = cur->u.mark.prev_mark;
5295                 }
5296             }
5297             /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5298             break;
5299         case SKIP_next_fail:
5300             if (ST.mark_name) {
5301                 /* (*CUT:NAME) - Set up to search for the name as we
5302                    collapse the stack*/
5303                 popmark = ST.mark_name;
5304             } else {
5305                 /* (*CUT) - No name, we cut here.*/
5306                 if (ST.mark_loc > startpoint)
5307                     reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5308                 /* but we set sv_commit to latest mark_name if there
5309                    is one so they can test to see how things lead to this
5310                    cut */
5311                 if (mark_state)
5312                     sv_commit=mark_state->u.mark.mark_name;
5313             }
5314             no_final = 1;
5315             sayNO;
5316             /* NOTREACHED */
5317 #undef ST
5318         case FOLDCHAR:
5319             n = ARG(scan);
5320             if ( n == (U32)what_len_TRICKYFOLD(locinput,do_utf8,ln) ) {
5321                 locinput += ln;
5322             } else if ( 0xDF == n && !do_utf8 && !UTF ) {
5323                 sayNO;
5324             } else  {
5325                 U8 folded[UTF8_MAXBYTES_CASE+1];
5326                 STRLEN foldlen;
5327                 const char * const l = locinput;
5328                 char *e = PL_regeol;
5329                 to_uni_fold(n, folded, &foldlen);
5330
5331                 if (ibcmp_utf8((const char*) folded, 0,  foldlen, 1,
5332                                l, &e, 0,  do_utf8)) {
5333                         sayNO;
5334                 }
5335                 locinput = e;
5336             }
5337             nextchr = UCHARAT(locinput);
5338             break;
5339         case LNBREAK:
5340             if ((n=is_LNBREAK(locinput,do_utf8))) {
5341                 locinput += n;
5342                 nextchr = UCHARAT(locinput);
5343             } else
5344                 sayNO;
5345             break;
5346
5347 #define CASE_CLASS(nAmE)                              \
5348         case nAmE:                                    \
5349             if ((n=is_##nAmE(locinput,do_utf8))) {    \
5350                 locinput += n;                        \
5351                 nextchr = UCHARAT(locinput);          \
5352             } else                                    \
5353                 sayNO;                                \
5354             break;                                    \
5355         case N##nAmE:                                 \
5356             if ((n=is_##nAmE(locinput,do_utf8))) {    \
5357                 sayNO;                                \
5358             } else {                                  \
5359                 locinput += UTF8SKIP(locinput);       \
5360                 nextchr = UCHARAT(locinput);          \
5361             }                                         \
5362             break
5363
5364         CASE_CLASS(VERTWS);
5365         CASE_CLASS(HORIZWS);
5366 #undef CASE_CLASS
5367
5368         default:
5369             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5370                           PTR2UV(scan), OP(scan));
5371             Perl_croak(aTHX_ "regexp memory corruption");
5372
5373         } /* end switch */
5374
5375         /* switch break jumps here */
5376         scan = next; /* prepare to execute the next op and ... */
5377         continue;    /* ... jump back to the top, reusing st */
5378         /* NOTREACHED */
5379
5380       push_yes_state:
5381         /* push a state that backtracks on success */
5382         st->u.yes.prev_yes_state = yes_state;
5383         yes_state = st;
5384         /* FALL THROUGH */
5385       push_state:
5386         /* push a new regex state, then continue at scan  */
5387         {
5388             regmatch_state *newst;
5389
5390             DEBUG_STACK_r({
5391                 regmatch_state *cur = st;
5392                 regmatch_state *curyes = yes_state;
5393                 int curd = depth;
5394                 regmatch_slab *slab = PL_regmatch_slab;
5395                 for (;curd > -1;cur--,curd--) {
5396                     if (cur < SLAB_FIRST(slab)) {
5397                         slab = slab->prev;
5398                         cur = SLAB_LAST(slab);
5399                     }
5400                     PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5401                         REPORT_CODE_OFF + 2 + depth * 2,"",
5402                         curd, PL_reg_name[cur->resume_state],
5403                         (curyes == cur) ? "yes" : ""
5404                     );
5405                     if (curyes == cur)
5406                         curyes = cur->u.yes.prev_yes_state;
5407                 }
5408             } else
5409                 DEBUG_STATE_pp("push")
5410             );
5411             depth++;
5412             st->locinput = locinput;
5413             newst = st+1;
5414             if (newst >  SLAB_LAST(PL_regmatch_slab))
5415                 newst = S_push_slab(aTHX);
5416             PL_regmatch_state = newst;
5417
5418             locinput = PL_reginput;
5419             nextchr = UCHARAT(locinput);
5420             st = newst;
5421             continue;
5422             /* NOTREACHED */
5423         }
5424     }
5425
5426     /*
5427     * We get here only if there's trouble -- normally "case END" is
5428     * the terminating point.
5429     */
5430     Perl_croak(aTHX_ "corrupted regexp pointers");
5431     /*NOTREACHED*/
5432     sayNO;
5433
5434 yes:
5435     if (yes_state) {
5436         /* we have successfully completed a subexpression, but we must now
5437          * pop to the state marked by yes_state and continue from there */
5438         assert(st != yes_state);
5439 #ifdef DEBUGGING
5440         while (st != yes_state) {
5441             st--;
5442             if (st < SLAB_FIRST(PL_regmatch_slab)) {
5443                 PL_regmatch_slab = PL_regmatch_slab->prev;
5444                 st = SLAB_LAST(PL_regmatch_slab);
5445             }
5446             DEBUG_STATE_r({
5447                 if (no_final) {
5448                     DEBUG_STATE_pp("pop (no final)");
5449                 } else {
5450                     DEBUG_STATE_pp("pop (yes)");
5451                 }
5452             });
5453             depth--;
5454         }
5455 #else
5456         while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5457             || yes_state > SLAB_LAST(PL_regmatch_slab))
5458         {
5459             /* not in this slab, pop slab */
5460             depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5461             PL_regmatch_slab = PL_regmatch_slab->prev;
5462             st = SLAB_LAST(PL_regmatch_slab);
5463         }
5464         depth -= (st - yes_state);
5465 #endif
5466         st = yes_state;
5467         yes_state = st->u.yes.prev_yes_state;
5468         PL_regmatch_state = st;
5469
5470         if (no_final) {
5471             locinput= st->locinput;
5472             nextchr = UCHARAT(locinput);
5473         }
5474         state_num = st->resume_state + no_final;
5475         goto reenter_switch;
5476     }
5477
5478     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5479                           PL_colors[4], PL_colors[5]));
5480
5481     if (PL_reg_eval_set) {
5482         /* each successfully executed (?{...}) block does the equivalent of
5483          *   local $^R = do {...}
5484          * When popping the save stack, all these locals would be undone;
5485          * bypass this by setting the outermost saved $^R to the latest
5486          * value */
5487         if (oreplsv != GvSV(PL_replgv))
5488             sv_setsv(oreplsv, GvSV(PL_replgv));
5489     }
5490     result = 1;
5491     goto final_exit;
5492
5493 no:
5494     DEBUG_EXECUTE_r(
5495         PerlIO_printf(Perl_debug_log,
5496             "%*s  %sfailed...%s\n",
5497             REPORT_CODE_OFF+depth*2, "",
5498             PL_colors[4], PL_colors[5])
5499         );
5500
5501 no_silent:
5502     if (no_final) {
5503         if (yes_state) {
5504             goto yes;
5505         } else {
5506             goto final_exit;
5507         }
5508     }
5509     if (depth) {
5510         /* there's a previous state to backtrack to */
5511         st--;
5512         if (st < SLAB_FIRST(PL_regmatch_slab)) {
5513             PL_regmatch_slab = PL_regmatch_slab->prev;
5514             st = SLAB_LAST(PL_regmatch_slab);
5515         }
5516         PL_regmatch_state = st;
5517         locinput= st->locinput;
5518         nextchr = UCHARAT(locinput);
5519
5520         DEBUG_STATE_pp("pop");
5521         depth--;
5522         if (yes_state == st)
5523             yes_state = st->u.yes.prev_yes_state;
5524
5525         state_num = st->resume_state + 1; /* failure = success + 1 */
5526         goto reenter_switch;
5527     }
5528     result = 0;
5529
5530   final_exit:
5531     if (rex->intflags & PREGf_VERBARG_SEEN) {
5532         SV *sv_err = get_sv("REGERROR", 1);
5533         SV *sv_mrk = get_sv("REGMARK", 1);
5534         if (result) {
5535             sv_commit = &PL_sv_no;
5536             if (!sv_yes_mark)
5537                 sv_yes_mark = &PL_sv_yes;
5538         } else {
5539             if (!sv_commit)
5540                 sv_commit = &PL_sv_yes;
5541             sv_yes_mark = &PL_sv_no;
5542         }
5543         sv_setsv(sv_err, sv_commit);
5544         sv_setsv(sv_mrk, sv_yes_mark);
5545     }
5546
5547     /* clean up; in particular, free all slabs above current one */
5548     LEAVE_SCOPE(oldsave);
5549
5550     return result;
5551 }
5552
5553 /*
5554  - regrepeat - repeatedly match something simple, report how many
5555  */
5556 /*
5557  * [This routine now assumes that it will only match on things of length 1.
5558  * That was true before, but now we assume scan - reginput is the count,
5559  * rather than incrementing count on every character.  [Er, except utf8.]]
5560  */
5561 STATIC I32
5562 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5563 {
5564     dVAR;
5565     register char *scan;
5566     register I32 c;
5567     register char *loceol = PL_regeol;
5568     register I32 hardcount = 0;
5569     register bool do_utf8 = PL_reg_match_utf8;
5570 #ifndef DEBUGGING
5571     PERL_UNUSED_ARG(depth);
5572 #endif
5573
5574     PERL_ARGS_ASSERT_REGREPEAT;
5575
5576     scan = PL_reginput;
5577     if (max == REG_INFTY)
5578         max = I32_MAX;
5579     else if (max < loceol - scan)
5580         loceol = scan + max;
5581     switch (OP(p)) {
5582     case REG_ANY:
5583         if (do_utf8) {
5584             loceol = PL_regeol;
5585             while (scan < loceol && hardcount < max && *scan != '\n') {
5586                 scan += UTF8SKIP(scan);
5587                 hardcount++;
5588             }
5589         } else {
5590             while (scan < loceol && *scan != '\n')
5591                 scan++;
5592         }
5593         break;
5594     case SANY:
5595         if (do_utf8) {
5596             loceol = PL_regeol;
5597             while (scan < loceol && hardcount < max) {
5598                 scan += UTF8SKIP(scan);
5599                 hardcount++;
5600             }
5601         }
5602         else
5603             scan = loceol;
5604         break;
5605     case CANY:
5606         scan = loceol;
5607         break;
5608     case EXACT:         /* length of string is 1 */
5609         c = (U8)*STRING(p);
5610         while (scan < loceol && UCHARAT(scan) == c)
5611             scan++;
5612         break;
5613     case EXACTF:        /* length of string is 1 */
5614         c = (U8)*STRING(p);
5615         while (scan < loceol &&
5616                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5617             scan++;
5618         break;
5619     case EXACTFL:       /* length of string is 1 */
5620         PL_reg_flags |= RF_tainted;
5621         c = (U8)*STRING(p);
5622         while (scan < loceol &&
5623                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5624             scan++;
5625         break;
5626     case ANYOF:
5627         if (do_utf8) {
5628             loceol = PL_regeol;
5629             while (hardcount < max && scan < loceol &&
5630                    reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
5631                 scan += UTF8SKIP(scan);
5632                 hardcount++;
5633             }
5634         } else {
5635             while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5636                 scan++;
5637         }
5638         break;
5639     case ALNUM:
5640         if (do_utf8) {
5641             loceol = PL_regeol;
5642             LOAD_UTF8_CHARCLASS_ALNUM();
5643             while (hardcount < max && scan < loceol &&
5644                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5645                 scan += UTF8SKIP(scan);
5646                 hardcount++;
5647             }
5648         } else {
5649             while (scan < loceol && isALNUM(*scan))
5650                 scan++;
5651         }
5652         break;
5653     case ALNUML:
5654         PL_reg_flags |= RF_tainted;
5655         if (do_utf8) {
5656             loceol = PL_regeol;
5657             while (hardcount < max && scan < loceol &&
5658                    isALNUM_LC_utf8((U8*)scan)) {
5659                 scan += UTF8SKIP(scan);
5660                 hardcount++;
5661             }
5662         } else {
5663             while (scan < loceol && isALNUM_LC(*scan))
5664                 scan++;
5665         }
5666         break;
5667     case NALNUM:
5668         if (do_utf8) {
5669             loceol = PL_regeol;
5670             LOAD_UTF8_CHARCLASS_ALNUM();
5671             while (hardcount < max && scan < loceol &&
5672                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5673                 scan += UTF8SKIP(scan);
5674                 hardcount++;
5675             }
5676         } else {
5677             while (scan < loceol && !isALNUM(*scan))
5678                 scan++;
5679         }
5680         break;
5681     case NALNUML:
5682         PL_reg_flags |= RF_tainted;
5683         if (do_utf8) {
5684             loceol = PL_regeol;
5685             while (hardcount < max && scan < loceol &&
5686                    !isALNUM_LC_utf8((U8*)scan)) {
5687                 scan += UTF8SKIP(scan);
5688                 hardcount++;
5689             }
5690         } else {
5691             while (scan < loceol && !isALNUM_LC(*scan))
5692                 scan++;
5693         }
5694         break;
5695     case SPACE:
5696         if (do_utf8) {
5697             loceol = PL_regeol;
5698             LOAD_UTF8_CHARCLASS_SPACE();
5699             while (hardcount < max && scan < loceol &&
5700                    (*scan == ' ' ||
5701                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5702                 scan += UTF8SKIP(scan);
5703                 hardcount++;
5704             }
5705         } else {
5706             while (scan < loceol && isSPACE(*scan))
5707                 scan++;
5708         }
5709         break;
5710     case SPACEL:
5711         PL_reg_flags |= RF_tainted;
5712         if (do_utf8) {
5713             loceol = PL_regeol;
5714             while (hardcount < max && scan < loceol &&
5715                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5716                 scan += UTF8SKIP(scan);
5717                 hardcount++;
5718             }
5719         } else {
5720             while (scan < loceol && isSPACE_LC(*scan))
5721                 scan++;
5722         }
5723         break;
5724     case NSPACE:
5725         if (do_utf8) {
5726             loceol = PL_regeol;
5727             LOAD_UTF8_CHARCLASS_SPACE();
5728             while (hardcount < max && scan < loceol &&
5729                    !(*scan == ' ' ||
5730                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5731                 scan += UTF8SKIP(scan);
5732                 hardcount++;
5733             }
5734         } else {
5735             while (scan < loceol && !isSPACE(*scan))
5736                 scan++;
5737         }
5738         break;
5739     case NSPACEL:
5740         PL_reg_flags |= RF_tainted;
5741         if (do_utf8) {
5742             loceol = PL_regeol;
5743             while (hardcount < max && scan < loceol &&
5744                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5745                 scan += UTF8SKIP(scan);
5746                 hardcount++;
5747             }
5748         } else {
5749             while (scan < loceol && !isSPACE_LC(*scan))
5750                 scan++;
5751         }
5752         break;
5753     case DIGIT:
5754         if (do_utf8) {
5755             loceol = PL_regeol;
5756             LOAD_UTF8_CHARCLASS_DIGIT();
5757             while (hardcount < max && scan < loceol &&
5758                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5759                 scan += UTF8SKIP(scan);
5760                 hardcount++;
5761             }
5762         } else {
5763             while (scan < loceol && isDIGIT(*scan))
5764                 scan++;
5765         }
5766         break;
5767     case NDIGIT:
5768         if (do_utf8) {
5769             loceol = PL_regeol;
5770             LOAD_UTF8_CHARCLASS_DIGIT();
5771             while (hardcount < max && scan < loceol &&
5772                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5773                 scan += UTF8SKIP(scan);
5774                 hardcount++;
5775             }
5776         } else {
5777             while (scan < loceol && !isDIGIT(*scan))
5778                 scan++;
5779         }
5780     case LNBREAK:
5781         if (do_utf8) {
5782             loceol = PL_regeol;
5783             while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
5784                 scan += c;
5785                 hardcount++;
5786             }
5787         } else {
5788             /*
5789               LNBREAK can match two latin chars, which is ok,
5790               because we have a null terminated string, but we
5791               have to use hardcount in this situation
5792             */
5793             while (scan < loceol && (c=is_LNBREAK_latin1(scan)))  {
5794                 scan+=c;
5795                 hardcount++;
5796             }
5797         }
5798         break;
5799     case HORIZWS:
5800         if (do_utf8) {
5801             loceol = PL_regeol;
5802             while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
5803                 scan += c;
5804                 hardcount++;
5805             }
5806         } else {
5807             while (scan < loceol && is_HORIZWS_latin1(scan))
5808                 scan++;
5809         }
5810         break;
5811     case NHORIZWS:
5812         if (do_utf8) {
5813             loceol = PL_regeol;
5814             while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
5815                 scan += UTF8SKIP(scan);
5816                 hardcount++;
5817             }
5818         } else {
5819             while (scan < loceol && !is_HORIZWS_latin1(scan))
5820                 scan++;
5821
5822         }
5823         break;
5824     case VERTWS:
5825         if (do_utf8) {
5826             loceol = PL_regeol;
5827             while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
5828                 scan += c;
5829                 hardcount++;
5830             }
5831         } else {
5832             while (scan < loceol && is_VERTWS_latin1(scan))
5833                 scan++;
5834
5835         }
5836         break;
5837     case NVERTWS:
5838         if (do_utf8) {
5839             loceol = PL_regeol;
5840             while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
5841                 scan += UTF8SKIP(scan);
5842                 hardcount++;
5843             }
5844         } else {
5845             while (scan < loceol && !is_VERTWS_latin1(scan))
5846                 scan++;
5847
5848         }
5849         break;
5850
5851     default:            /* Called on something of 0 width. */
5852         break;          /* So match right here or not at all. */
5853     }
5854
5855     if (hardcount)
5856         c = hardcount;
5857     else
5858         c = scan - PL_reginput;
5859     PL_reginput = scan;
5860
5861     DEBUG_r({
5862         GET_RE_DEBUG_FLAGS_DECL;
5863         DEBUG_EXECUTE_r({
5864             SV * const prop = sv_newmortal();
5865             regprop(prog, prop, p);
5866             PerlIO_printf(Perl_debug_log,
5867                         "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
5868                         REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5869         });
5870     });
5871
5872     return(c);
5873 }
5874
5875
5876 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5877 /*
5878 - regclass_swash - prepare the utf8 swash
5879 */
5880
5881 SV *
5882 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5883 {
5884     dVAR;
5885     SV *sw  = NULL;
5886     SV *si  = NULL;
5887     SV *alt = NULL;
5888     RXi_GET_DECL(prog,progi);
5889     const struct reg_data * const data = prog ? progi->data : NULL;
5890
5891     PERL_ARGS_ASSERT_REGCLASS_SWASH;
5892
5893     if (data && data->count) {
5894         const U32 n = ARG(node);
5895
5896         if (data->what[n] == 's') {
5897             SV * const rv = MUTABLE_SV(data->data[n]);
5898             AV * const av = MUTABLE_AV(SvRV(rv));
5899             SV **const ary = AvARRAY(av);
5900             SV **a, **b;
5901
5902             /* See the end of regcomp.c:S_regclass() for
5903              * documentation of these array elements. */
5904
5905             si = *ary;
5906             a  = SvROK(ary[1]) ? &ary[1] : NULL;
5907             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
5908
5909             if (a)
5910                 sw = *a;
5911             else if (si && doinit) {
5912                 sw = swash_init("utf8", "", si, 1, 0);
5913                 (void)av_store(av, 1, sw);
5914             }
5915             if (b)
5916                 alt = *b;
5917         }
5918     }
5919
5920     if (listsvp)
5921         *listsvp = si;
5922     if (altsvp)
5923         *altsvp  = alt;
5924
5925     return sw;
5926 }
5927 #endif
5928
5929 /*
5930  - reginclass - determine if a character falls into a character class
5931
5932   The n is the ANYOF regnode, the p is the target string, lenp
5933   is pointer to the maximum length of how far to go in the p
5934   (if the lenp is zero, UTF8SKIP(p) is used),
5935   do_utf8 tells whether the target string is in UTF-8.
5936
5937  */
5938
5939 STATIC bool
5940 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5941 {
5942     dVAR;
5943     const char flags = ANYOF_FLAGS(n);
5944     bool match = FALSE;
5945     UV c = *p;
5946     STRLEN len = 0;
5947     STRLEN plen;
5948
5949     PERL_ARGS_ASSERT_REGINCLASS;
5950
5951     if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5952         c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5953                 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
5954                 | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
5955                 /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
5956                  * UTF8_ALLOW_FFFF */
5957         if (len == (STRLEN)-1)
5958             Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5959     }
5960
5961     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5962     if (do_utf8 || (flags & ANYOF_UNICODE)) {
5963         if (lenp)
5964             *lenp = 0;
5965         if (do_utf8 && !ANYOF_RUNTIME(n)) {
5966             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5967                 match = TRUE;
5968         }
5969         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5970             match = TRUE;
5971         if (!match) {
5972             AV *av;
5973             SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5974
5975             if (sw) {
5976                 U8 * utf8_p;
5977                 if (do_utf8) {
5978                     utf8_p = (U8 *) p;
5979                 } else {
5980                     STRLEN len = 1;
5981                     utf8_p = bytes_to_utf8(p, &len);
5982                 }
5983                 if (swash_fetch(sw, utf8_p, 1))
5984                     match = TRUE;
5985                 else if (flags & ANYOF_FOLD) {
5986                     if (!match && lenp && av) {
5987                         I32 i;
5988                         for (i = 0; i <= av_len(av); i++) {
5989                             SV* const sv = *av_fetch(av, i, FALSE);
5990                             STRLEN len;
5991                             const char * const s = SvPV_const(sv, len);
5992                             if (len <= plen && memEQ(s, (char*)utf8_p, len)) {
5993                                 *lenp = len;
5994                                 match = TRUE;
5995                                 break;
5996                             }
5997                         }
5998                     }
5999                     if (!match) {
6000                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
6001
6002                         STRLEN tmplen;
6003                         to_utf8_fold(utf8_p, tmpbuf, &tmplen);
6004                         if (swash_fetch(sw, tmpbuf, 1))
6005                             match = TRUE;
6006                     }
6007                 }
6008
6009                 /* If we allocated a string above, free it */
6010                 if (! do_utf8) Safefree(utf8_p);
6011             }
6012         }
6013         if (match && lenp && *lenp == 0)
6014             *lenp = UNISKIP(NATIVE_TO_UNI(c));
6015     }
6016     if (!match && c < 256) {
6017         if (ANYOF_BITMAP_TEST(n, c))
6018             match = TRUE;
6019         else if (flags & ANYOF_FOLD) {
6020             U8 f;
6021
6022             if (flags & ANYOF_LOCALE) {
6023                 PL_reg_flags |= RF_tainted;
6024                 f = PL_fold_locale[c];
6025             }
6026             else
6027                 f = PL_fold[c];
6028             if (f != c && ANYOF_BITMAP_TEST(n, f))
6029                 match = TRUE;
6030         }
6031
6032         if (!match && (flags & ANYOF_CLASS)) {
6033             PL_reg_flags |= RF_tainted;
6034             if (
6035                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
6036                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
6037                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
6038                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
6039                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
6040                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
6041                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
6042                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
6043                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
6044                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
6045                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
6046                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
6047                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
6048                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
6049                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
6050                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
6051                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
6052                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
6053                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
6054                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
6055                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
6056                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
6057                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
6058                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
6059                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
6060                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
6061                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
6062                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
6063                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
6064                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
6065                 ) /* How's that for a conditional? */
6066             {
6067                 match = TRUE;
6068             }
6069         }
6070     }
6071
6072     return (flags & ANYOF_INVERT) ? !match : match;
6073 }
6074
6075 STATIC U8 *
6076 S_reghop3(U8 *s, I32 off, const U8* lim)
6077 {
6078     dVAR;
6079
6080     PERL_ARGS_ASSERT_REGHOP3;
6081
6082     if (off >= 0) {
6083         while (off-- && s < lim) {
6084             /* XXX could check well-formedness here */
6085             s += UTF8SKIP(s);
6086         }
6087     }
6088     else {
6089         while (off++ && s > lim) {
6090             s--;
6091             if (UTF8_IS_CONTINUED(*s)) {
6092                 while (s > lim && UTF8_IS_CONTINUATION(*s))
6093                     s--;
6094             }
6095             /* XXX could check well-formedness here */
6096         }
6097     }
6098     return s;
6099 }
6100
6101 #ifdef XXX_dmq
6102 /* there are a bunch of places where we use two reghop3's that should
6103    be replaced with this routine. but since thats not done yet
6104    we ifdef it out - dmq
6105 */
6106 STATIC U8 *
6107 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
6108 {
6109     dVAR;
6110
6111     PERL_ARGS_ASSERT_REGHOP4;
6112
6113     if (off >= 0) {
6114         while (off-- && s < rlim) {
6115             /* XXX could check well-formedness here */
6116             s += UTF8SKIP(s);
6117         }
6118     }
6119     else {
6120         while (off++ && s > llim) {
6121             s--;
6122             if (UTF8_IS_CONTINUED(*s)) {
6123                 while (s > llim && UTF8_IS_CONTINUATION(*s))
6124                     s--;
6125             }
6126             /* XXX could check well-formedness here */
6127         }
6128     }
6129     return s;
6130 }
6131 #endif
6132
6133 STATIC U8 *
6134 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
6135 {
6136     dVAR;
6137
6138     PERL_ARGS_ASSERT_REGHOPMAYBE3;
6139
6140     if (off >= 0) {
6141         while (off-- && s < lim) {
6142             /* XXX could check well-formedness here */
6143             s += UTF8SKIP(s);
6144         }
6145         if (off >= 0)
6146             return NULL;
6147     }
6148     else {
6149         while (off++ && s > lim) {
6150             s--;
6151             if (UTF8_IS_CONTINUED(*s)) {
6152                 while (s > lim && UTF8_IS_CONTINUATION(*s))
6153                     s--;
6154             }
6155             /* XXX could check well-formedness here */
6156         }
6157         if (off <= 0)
6158             return NULL;
6159     }
6160     return s;
6161 }
6162
6163 static void
6164 restore_pos(pTHX_ void *arg)
6165 {
6166     dVAR;
6167     regexp * const rex = (regexp *)arg;
6168     if (PL_reg_eval_set) {
6169         if (PL_reg_oldsaved) {
6170             rex->subbeg = PL_reg_oldsaved;
6171             rex->sublen = PL_reg_oldsavedlen;
6172 #ifdef PERL_OLD_COPY_ON_WRITE
6173             rex->saved_copy = PL_nrs;
6174 #endif
6175             RXp_MATCH_COPIED_on(rex);
6176         }
6177         PL_reg_magic->mg_len = PL_reg_oldpos;
6178         PL_reg_eval_set = 0;
6179         PL_curpm = PL_reg_oldcurpm;
6180     }
6181 }
6182
6183 STATIC void
6184 S_to_utf8_substr(pTHX_ register regexp *prog)
6185 {
6186     int i = 1;
6187
6188     PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
6189
6190     do {
6191         if (prog->substrs->data[i].substr
6192             && !prog->substrs->data[i].utf8_substr) {
6193             SV* const sv = newSVsv(prog->substrs->data[i].substr);
6194             prog->substrs->data[i].utf8_substr = sv;
6195             sv_utf8_upgrade(sv);
6196             if (SvVALID(prog->substrs->data[i].substr)) {
6197                 const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
6198                 if (flags & FBMcf_TAIL) {
6199                     /* Trim the trailing \n that fbm_compile added last
6200                        time.  */
6201                     SvCUR_set(sv, SvCUR(sv) - 1);
6202                     /* Whilst this makes the SV technically "invalid" (as its
6203                        buffer is no longer followed by "\0") when fbm_compile()
6204                        adds the "\n" back, a "\0" is restored.  */
6205                 }
6206                 fbm_compile(sv, flags);
6207             }
6208             if (prog->substrs->data[i].substr == prog->check_substr)
6209                 prog->check_utf8 = sv;
6210         }
6211     } while (i--);
6212 }
6213
6214 STATIC void
6215 S_to_byte_substr(pTHX_ register regexp *prog)
6216 {
6217     dVAR;
6218     int i = 1;
6219
6220     PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
6221
6222     do {
6223         if (prog->substrs->data[i].utf8_substr
6224             && !prog->substrs->data[i].substr) {
6225             SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
6226             if (sv_utf8_downgrade(sv, TRUE)) {
6227                 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
6228                     const U8 flags
6229                         = BmFLAGS(prog->substrs->data[i].utf8_substr);
6230                     if (flags & FBMcf_TAIL) {
6231                         /* Trim the trailing \n that fbm_compile added last
6232                            time.  */
6233                         SvCUR_set(sv, SvCUR(sv) - 1);
6234                     }
6235                     fbm_compile(sv, flags);
6236                 }
6237             } else {
6238                 SvREFCNT_dec(sv);
6239                 sv = &PL_sv_undef;
6240             }
6241             prog->substrs->data[i].substr = sv;
6242             if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
6243                 prog->check_substr = sv;
6244         }
6245     } while (i--);
6246 }
6247
6248 /*
6249  * Local variables:
6250  * c-indentation-style: bsd
6251  * c-basic-offset: 4
6252  * indent-tabs-mode: t
6253  * End:
6254  *
6255  * ex: set ts=8 sts=4 sw=4 noet:
6256  */