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