regexec.c

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