regexec.c

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