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                 if (sv_yes_mark) {
3565                     SV *sv_mrk = get_sv("REGMARK", 1);
3566                     sv_setsv(sv_mrk, sv_yes_mark);
3567                 }
3568
3569                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3570                 SPAGAIN;
3571                 if (SP == before)
3572                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3573                 else {
3574                     ret = POPs;
3575                     PUTBACK;
3576                 }
3577
3578                 PL_op = oop;
3579                 PAD_RESTORE_LOCAL(old_comppad);
3580                 PL_curcop = ocurcop;
3581                 if (!logical) {
3582                     /* /(?{...})/ */
3583                     sv_setsv(save_scalar(PL_replgv), ret);
3584                     break;
3585                 }
3586             }
3587             if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3588                 logical = 0;
3589                 {
3590                     /* extract RE object from returned value; compiling if
3591                      * necessary */
3592
3593                     MAGIC *mg = NULL;
3594                     const SV *sv;
3595                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3596                         mg = mg_find(sv, PERL_MAGIC_qr);
3597                     else if (SvSMAGICAL(ret)) {
3598                         if (SvGMAGICAL(ret))
3599                             sv_unmagic(ret, PERL_MAGIC_qr);
3600                         else
3601                             mg = mg_find(ret, PERL_MAGIC_qr);
3602                     }
3603
3604                     if (mg) {
3605                         re = (regexp *)mg->mg_obj;
3606                         (void)ReREFCNT_inc(re);
3607                     }
3608                     else {
3609                         STRLEN len;
3610                         const char * const t = SvPV_const(ret, len);
3611                         PMOP pm;
3612                         const I32 osize = PL_regsize;
3613
3614                         Zero(&pm, 1, PMOP);
3615                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3616                         re = CALLREGCOMP((char*)t, (char*)t + len, &pm);
3617                         if (!(SvFLAGS(ret)
3618                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3619                                 | SVs_GMG)))
3620                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3621                                         PERL_MAGIC_qr,0,0);
3622                         PL_regsize = osize;
3623                     }
3624                 }
3625                 rei = RXi_GET(re);
3626                 DEBUG_EXECUTE_r(
3627                     debug_start_match(re, do_utf8, locinput, PL_regeol,
3628                         "Matching embedded");
3629                 );
3630                 startpoint = rei->program + 1;
3631                 ST.close_paren = 0; /* only used for GOSUB */
3632                 /* borrowed from regtry */
3633                 if (PL_reg_start_tmpl <= re->nparens) {
3634                     PL_reg_start_tmpl = re->nparens*3/2 + 3;
3635                     if(PL_reg_start_tmp)
3636                         Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3637                     else
3638                         Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3639                 }
3640
3641         eval_recurse_doit: /* Share code with GOSUB below this line */
3642                 /* run the pattern returned from (??{...}) */
3643                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3644                 REGCP_SET(ST.lastcp);
3645
3646                 PL_regstartp = re->startp; /* essentially NOOP on GOSUB */
3647                 PL_regendp = re->endp;     /* essentially NOOP on GOSUB */
3648
3649                 *PL_reglastparen = 0;
3650                 *PL_reglastcloseparen = 0;
3651                 PL_reginput = locinput;
3652                 PL_regsize = 0;
3653
3654                 /* XXXX This is too dramatic a measure... */
3655                 PL_reg_maxiter = 0;
3656
3657                 ST.toggle_reg_flags = PL_reg_flags;
3658                 if (re->extflags & RXf_UTF8)
3659                     PL_reg_flags |= RF_utf8;
3660                 else
3661                     PL_reg_flags &= ~RF_utf8;
3662                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3663
3664                 ST.prev_rex = rex;
3665                 ST.prev_curlyx = cur_curlyx;
3666                 rex = re;
3667                 rexi = rei;
3668                 cur_curlyx = NULL;
3669                 ST.B = next;
3670                 ST.prev_eval = cur_eval;
3671                 cur_eval = st;
3672                 /* now continue from first node in postoned RE */
3673                 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
3674                 /* NOTREACHED */
3675             }
3676             /* logical is 1,   /(?(?{...})X|Y)/ */
3677             sw = (bool)SvTRUE(ret);
3678             logical = 0;
3679             break;
3680         }
3681
3682         case EVAL_AB: /* cleanup after a successful (??{A})B */
3683             /* note: this is called twice; first after popping B, then A */
3684             PL_reg_flags ^= ST.toggle_reg_flags;
3685             ReREFCNT_dec(rex);
3686             rex = ST.prev_rex;
3687             rexi = RXi_GET(rex);
3688             regcpblow(ST.cp);
3689             cur_eval = ST.prev_eval;
3690             cur_curlyx = ST.prev_curlyx;
3691             /* XXXX This is too dramatic a measure... */
3692             PL_reg_maxiter = 0;
3693             sayYES;
3694
3695
3696         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3697             /* note: this is called twice; first after popping B, then A */
3698             PL_reg_flags ^= ST.toggle_reg_flags;
3699             ReREFCNT_dec(rex);
3700             rex = ST.prev_rex;
3701             rexi = RXi_GET(rex);
3702             PL_reginput = locinput;
3703             REGCP_UNWIND(ST.lastcp);
3704             regcppop(rex);
3705             cur_eval = ST.prev_eval;
3706             cur_curlyx = ST.prev_curlyx;
3707             /* XXXX This is too dramatic a measure... */
3708             PL_reg_maxiter = 0;
3709             sayNO_SILENT;
3710 #undef ST
3711
3712         case OPEN:
3713             n = ARG(scan);  /* which paren pair */
3714             PL_reg_start_tmp[n] = locinput;
3715             if (n > PL_regsize)
3716                 PL_regsize = n;
3717             lastopen = n;
3718             break;
3719         case CLOSE:
3720             n = ARG(scan);  /* which paren pair */
3721             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3722             PL_regendp[n] = locinput - PL_bostr;
3723             /*if (n > PL_regsize)
3724                 PL_regsize = n;*/
3725             if (n > *PL_reglastparen)
3726                 *PL_reglastparen = n;
3727             *PL_reglastcloseparen = n;
3728             if (cur_eval && cur_eval->u.eval.close_paren == n) {
3729                 goto fake_end;
3730             }
3731             break;
3732         case ACCEPT:
3733             if (ARG(scan)){
3734                 regnode *cursor;
3735                 for (cursor=scan;
3736                      cursor && OP(cursor)!=END;
3737                      cursor=regnext(cursor))
3738                 {
3739                     if ( OP(cursor)==CLOSE ){
3740                         n = ARG(cursor);
3741                         if ( n <= lastopen ) {
3742                             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3743                             PL_regendp[n] = locinput - PL_bostr;
3744                             /*if (n > PL_regsize)
3745                             PL_regsize = n;*/
3746                             if (n > *PL_reglastparen)
3747                                 *PL_reglastparen = n;
3748                             *PL_reglastcloseparen = n;
3749                             if ( n == ARG(scan) || (cur_eval &&
3750                                 cur_eval->u.eval.close_paren == n))
3751                                 break;
3752                         }
3753                     }
3754                 }
3755             }
3756             goto fake_end;
3757             /*NOTREACHED*/
3758         case GROUPP:
3759             n = ARG(scan);  /* which paren pair */
3760             sw = (bool)(*PL_reglastparen >= n && PL_regendp[n] != -1);
3761             break;
3762         case NGROUPP:
3763             /* reg_check_named_buff_matched returns 0 for no match */
3764             sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
3765             break;
3766         case INSUBP:
3767             n = ARG(scan);
3768             sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
3769             break;
3770         case DEFINEP:
3771             sw = 0;
3772             break;
3773         case IFTHEN:
3774             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3775             if (sw)
3776                 next = NEXTOPER(NEXTOPER(scan));
3777             else {
3778                 next = scan + ARG(scan);
3779                 if (OP(next) == IFTHEN) /* Fake one. */
3780                     next = NEXTOPER(NEXTOPER(next));
3781             }
3782             break;
3783         case LOGICAL:
3784             logical = scan->flags;
3785             break;
3786
3787 /*******************************************************************
3788
3789 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
3790 pattern, where A and B are subpatterns. (For simple A, CURLYM or
3791 STAR/PLUS/CURLY/CURLYN are used instead.)
3792
3793 A*B is compiled as <CURLYX><A><WHILEM><B>
3794
3795 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
3796 state, which contains the current count, initialised to -1. It also sets
3797 cur_curlyx to point to this state, with any previous value saved in the
3798 state block.
3799
3800 CURLYX then jumps straight to the WHILEM op, rather than executing A,
3801 since the pattern may possibly match zero times (i.e. it's a while {} loop
3802 rather than a do {} while loop).
3803
3804 Each entry to WHILEM represents a successful match of A. The count in the
3805 CURLYX block is incremented, another WHILEM state is pushed, and execution
3806 passes to A or B depending on greediness and the current count.
3807
3808 For example, if matching against the string a1a2a3b (where the aN are
3809 substrings that match /A/), then the match progresses as follows: (the
3810 pushed states are interspersed with the bits of strings matched so far):
3811
3812     <CURLYX cnt=-1>
3813     <CURLYX cnt=0><WHILEM>
3814     <CURLYX cnt=1><WHILEM> a1 <WHILEM>
3815     <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
3816     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
3817     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
3818
3819 (Contrast this with something like CURLYM, which maintains only a single
3820 backtrack state:
3821
3822     <CURLYM cnt=0> a1
3823     a1 <CURLYM cnt=1> a2
3824     a1 a2 <CURLYM cnt=2> a3
3825     a1 a2 a3 <CURLYM cnt=3> b
3826 )
3827
3828 Each WHILEM state block marks a point to backtrack to upon partial failure
3829 of A or B, and also contains some minor state data related to that
3830 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
3831 overall state, such as the count, and pointers to the A and B ops.
3832
3833 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
3834 must always point to the *current* CURLYX block, the rules are:
3835
3836 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
3837 and set cur_curlyx to point the new block.
3838
3839 When popping the CURLYX block after a successful or unsuccessful match,
3840 restore the previous cur_curlyx.
3841
3842 When WHILEM is about to execute B, save the current cur_curlyx, and set it
3843 to the outer one saved in the CURLYX block.
3844
3845 When popping the WHILEM block after a successful or unsuccessful B match,
3846 restore the previous cur_curlyx.
3847
3848 Here's an example for the pattern (AI* BI)*BO
3849 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
3850
3851 cur_
3852 curlyx backtrack stack
3853 ------ ---------------
3854 NULL
3855 CO     <CO prev=NULL> <WO>
3856 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
3857 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
3858 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
3859
3860 At this point the pattern succeeds, and we work back down the stack to
3861 clean up, restoring as we go:
3862
3863 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
3864 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
3865 CO     <CO prev=NULL> <WO>
3866 NULL
3867
3868 *******************************************************************/
3869
3870 #define ST st->u.curlyx
3871
3872         case CURLYX:    /* start of /A*B/  (for complex A) */
3873         {
3874             /* No need to save/restore up to this paren */
3875             I32 parenfloor = scan->flags;
3876
3877             assert(next); /* keep Coverity happy */
3878             if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3879                 next += ARG(next);
3880
3881             /* XXXX Probably it is better to teach regpush to support
3882                parenfloor > PL_regsize... */
3883             if (parenfloor > (I32)*PL_reglastparen)
3884                 parenfloor = *PL_reglastparen; /* Pessimization... */
3885
3886             ST.prev_curlyx= cur_curlyx;
3887             cur_curlyx = st;
3888             ST.cp = PL_savestack_ix;
3889
3890             /* these fields contain the state of the current curly.
3891              * they are accessed by subsequent WHILEMs */
3892             ST.parenfloor = parenfloor;
3893             ST.min = ARG1(scan);
3894             ST.max = ARG2(scan);
3895             ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3896             ST.B = next;
3897             ST.minmod = minmod;
3898             minmod = 0;
3899             ST.count = -1;      /* this will be updated by WHILEM */
3900             ST.lastloc = NULL;  /* this will be updated by WHILEM */
3901
3902             PL_reginput = locinput;
3903             PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
3904             /* NOTREACHED */
3905         }
3906
3907         case CURLYX_end: /* just finished matching all of A*B */
3908             if (PL_reg_eval_set){
3909                 SV *pres= GvSV(PL_replgv);
3910                 SvREFCNT_inc(pres);
3911                 regcpblow(ST.cp);
3912                 sv_setsv(GvSV(PL_replgv), pres);
3913                 SvREFCNT_dec(pres);
3914             } else {
3915                 regcpblow(ST.cp);
3916             }
3917             cur_curlyx = ST.prev_curlyx;
3918             sayYES;
3919             /* NOTREACHED */
3920
3921         case CURLYX_end_fail: /* just failed to match all of A*B */
3922             regcpblow(ST.cp);
3923             cur_curlyx = ST.prev_curlyx;
3924             sayNO;
3925             /* NOTREACHED */
3926
3927
3928 #undef ST
3929 #define ST st->u.whilem
3930
3931         case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
3932         {
3933             /* see the discussion above about CURLYX/WHILEM */
3934             I32 n;
3935             assert(cur_curlyx); /* keep Coverity happy */
3936             n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
3937             ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
3938             ST.cache_offset = 0;
3939             ST.cache_mask = 0;
3940
3941             PL_reginput = locinput;
3942
3943             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3944                   "%*s  whilem: matched %ld out of %ld..%ld\n",
3945                   REPORT_CODE_OFF+depth*2, "", (long)n,
3946                   (long)cur_curlyx->u.curlyx.min,
3947                   (long)cur_curlyx->u.curlyx.max)
3948             );
3949
3950             /* First just match a string of min A's. */
3951
3952             if (n < cur_curlyx->u.curlyx.min) {
3953                 cur_curlyx->u.curlyx.lastloc = locinput;
3954            &nbs