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