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     if (PL_curpm && (PM_GETRE(PL_curpm) == prog)) {
1730         I32 *t;
1731         if (!prog->swap) {
1732         /* We have to be careful. If the previous successful match
1733            was from this regex we don't want a subsequent paritally
1734            successful match to clobber the old results.
1735            So when we detect this possibility we add a swap buffer
1736            to the re, and switch the buffer each match. If we fail
1737            we switch it back, otherwise we leave it swapped.
1738         */
1739             Newxz(prog->swap, 1, regexp_paren_ofs);
1740             /* no need to copy these */
1741             Newxz(prog->swap->startp, prog->nparens + 1, I32);
1742             Newxz(prog->swap->endp, prog->nparens + 1, I32);
1743         }
1744         t = prog->swap->startp;
1745         prog->swap->startp = prog->startp;
1746         prog->startp = t;
1747         t = prog->swap->endp;
1748         prog->swap->endp = prog->endp;
1749         prog->endp = t;
1750     }
1751     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1752         re_scream_pos_data d;
1753
1754         d.scream_olds = &scream_olds;
1755         d.scream_pos = &scream_pos;
1756         s = re_intuit_start(prog, sv, s, strend, flags, &d);
1757         if (!s) {
1758             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1759             goto phooey;        /* not present */
1760         }
1761     }
1762
1763
1764
1765     /* Simplest case:  anchored match need be tried only once. */
1766     /*  [unless only anchor is BOL and multiline is set] */
1767     if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1768         if (s == startpos && regtry(&reginfo, &startpos))
1769             goto got_it;
1770         else if (multiline || (prog->reganch & ROPT_IMPLICIT)
1771                  || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1772         {
1773             char *end;
1774
1775             if (minlen)
1776                 dontbother = minlen - 1;
1777             end = HOP3c(strend, -dontbother, strbeg) - 1;
1778             /* for multiline we only have to try after newlines */
1779             if (prog->check_substr || prog->check_utf8) {
1780                 if (s == startpos)
1781                     goto after_try;
1782                 while (1) {
1783                     if (regtry(&reginfo, &s))
1784                         goto got_it;
1785                   after_try:
1786                     if (s >= end)
1787                         goto phooey;
1788                     if (prog->reganch & RE_USE_INTUIT) {
1789                         s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1790                         if (!s)
1791                             goto phooey;
1792                     }
1793                     else
1794                         s++;
1795                 }
1796             } else {
1797                 if (s > startpos)
1798                     s--;
1799                 while (s < end) {
1800                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1801                         if (regtry(&reginfo, &s))
1802                             goto got_it;
1803                     }
1804                 }
1805             }
1806         }
1807         goto phooey;
1808     } else if (ROPT_GPOS_CHECK == (prog->reganch & ROPT_GPOS_CHECK))
1809     {
1810         /* the warning about reginfo.ganch being used without intialization
1811            is bogus -- we set it above, when prog->reganch & ROPT_GPOS_SEEN
1812            and we only enter this block when the same bit is set. */
1813         if (regtry(&reginfo, &reginfo.ganch))
1814             goto got_it;
1815         goto phooey;
1816     }
1817
1818     /* Messy cases:  unanchored match. */
1819     if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1820         /* we have /x+whatever/ */
1821         /* it must be a one character string (XXXX Except UTF?) */
1822         char ch;
1823 #ifdef DEBUGGING
1824         int did_match = 0;
1825 #endif
1826         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1827             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1828         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1829
1830         if (do_utf8) {
1831             REXEC_FBC_SCAN(
1832                 if (*s == ch) {
1833                     DEBUG_EXECUTE_r( did_match = 1 );
1834                     if (regtry(&reginfo, &s)) goto got_it;
1835                     s += UTF8SKIP(s);
1836                     while (s < strend && *s == ch)
1837                         s += UTF8SKIP(s);
1838                 }
1839             );
1840         }
1841         else {
1842             REXEC_FBC_SCAN(
1843                 if (*s == ch) {
1844                     DEBUG_EXECUTE_r( did_match = 1 );
1845                     if (regtry(&reginfo, &s)) goto got_it;
1846                     s++;
1847                     while (s < strend && *s == ch)
1848                         s++;
1849                 }
1850             );
1851         }
1852         DEBUG_EXECUTE_r(if (!did_match)
1853                 PerlIO_printf(Perl_debug_log,
1854                                   "Did not find anchored character...\n")
1855                );
1856     }
1857     else if (prog->anchored_substr != NULL
1858               || prog->anchored_utf8 != NULL
1859               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1860                   && prog->float_max_offset < strend - s)) {
1861         SV *must;
1862         I32 back_max;
1863         I32 back_min;
1864         char *last;
1865         char *last1;            /* Last position checked before */
1866 #ifdef DEBUGGING
1867         int did_match = 0;
1868 #endif
1869         if (prog->anchored_substr || prog->anchored_utf8) {
1870             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1871                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1872             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1873             back_max = back_min = prog->anchored_offset;
1874         } else {
1875             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1876                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1877             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1878             back_max = prog->float_max_offset;
1879             back_min = prog->float_min_offset;
1880         }
1881
1882
1883         if (must == &PL_sv_undef)
1884             /* could not downgrade utf8 check substring, so must fail */
1885             goto phooey;
1886
1887         if (back_min<0) {
1888             last = strend;
1889         } else {
1890             last = HOP3c(strend,        /* Cannot start after this */
1891                   -(I32)(CHR_SVLEN(must)
1892                          - (SvTAIL(must) != 0) + back_min), strbeg);
1893         }
1894         if (s > PL_bostr)
1895             last1 = HOPc(s, -1);
1896         else
1897             last1 = s - 1;      /* bogus */
1898
1899         /* XXXX check_substr already used to find "s", can optimize if
1900            check_substr==must. */
1901         scream_pos = -1;
1902         dontbother = end_shift;
1903         strend = HOPc(strend, -dontbother);
1904         while ( (s <= last) &&
1905                 ((flags & REXEC_SCREAM)
1906                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
1907                                     end_shift, &scream_pos, 0))
1908                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
1909                                   (unsigned char*)strend, must,
1910                                   multiline ? FBMrf_MULTILINE : 0))) ) {
1911             /* we may be pointing at the wrong string */
1912             if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
1913                 s = strbeg + (s - SvPVX_const(sv));
1914             DEBUG_EXECUTE_r( did_match = 1 );
1915             if (HOPc(s, -back_max) > last1) {
1916                 last1 = HOPc(s, -back_min);
1917                 s = HOPc(s, -back_max);
1918             }
1919             else {
1920                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1921
1922                 last1 = HOPc(s, -back_min);
1923                 s = t;
1924             }
1925             if (do_utf8) {
1926                 while (s <= last1) {
1927                     if (regtry(&reginfo, &s))
1928                         goto got_it;
1929                     s += UTF8SKIP(s);
1930                 }
1931             }
1932             else {
1933                 while (s <= last1) {
1934                     if (regtry(&reginfo, &s))
1935                         goto got_it;
1936                     s++;
1937                 }
1938             }
1939         }
1940         DEBUG_EXECUTE_r(if (!did_match) {
1941             RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
1942                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1943             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
1944                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
1945                                ? "anchored" : "floating"),
1946                 quoted, RE_SV_TAIL(must));
1947         });
1948         goto phooey;
1949     }
1950     else if ( (c = prog->regstclass) ) {
1951         if (minlen) {
1952             const OPCODE op = OP(prog->regstclass);
1953             /* don't bother with what can't match */
1954             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
1955                 strend = HOPc(strend, -(minlen - 1));
1956         }
1957         DEBUG_EXECUTE_r({
1958             SV * const prop = sv_newmortal();
1959             regprop(prog, prop, c);
1960             {
1961                 RE_PV_QUOTED_DECL(quoted,UTF,PERL_DEBUG_PAD_ZERO(1),
1962                     s,strend-s,60);
1963                 PerlIO_printf(Perl_debug_log,
1964                     "Matching stclass %.*s against %s (%d chars)\n",
1965                     (int)SvCUR(prop), SvPVX_const(prop),
1966                      quoted, (int)(strend - s));
1967             }
1968         });
1969         if (find_byclass(prog, c, s, strend, &reginfo))
1970             goto got_it;
1971         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
1972     }
1973     else {
1974         dontbother = 0;
1975         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
1976             /* Trim the end. */
1977             char *last;
1978             SV* float_real;
1979
1980             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1981                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1982             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
1983
1984             if (flags & REXEC_SCREAM) {
1985                 last = screaminstr(sv, float_real, s - strbeg,
1986                                    end_shift, &scream_pos, 1); /* last one */
1987                 if (!last)
1988                     last = scream_olds; /* Only one occurrence. */
1989                 /* we may be pointing at the wrong string */
1990                 else if (RX_MATCH_COPIED(prog))
1991                     s = strbeg + (s - SvPVX_const(sv));
1992             }
1993             else {
1994                 STRLEN len;
1995                 const char * const little = SvPV_const(float_real, len);
1996
1997                 if (SvTAIL(float_real)) {
1998                     if (memEQ(strend - len + 1, little, len - 1))
1999                         last = strend - len + 1;
2000                     else if (!multiline)
2001                         last = memEQ(strend - len, little, len)
2002                             ? strend - len : NULL;
2003                     else
2004                         goto find_last;
2005                 } else {
2006                   find_last:
2007                     if (len)
2008                         last = rninstr(s, strend, little, little + len);
2009                     else
2010                         last = strend;  /* matching "$" */
2011                 }
2012             }
2013             if (last == NULL) {
2014                 DEBUG_EXECUTE_r(
2015                     PerlIO_printf(Perl_debug_log,
2016                         "%sCan't trim the tail, match fails (should not happen)%s\n",
2017                         PL_colors[4], PL_colors[5]));
2018                 goto phooey; /* Should not happen! */
2019             }
2020             dontbother = strend - last + prog->float_min_offset;
2021         }
2022         if (minlen && (dontbother < minlen))
2023             dontbother = minlen - 1;
2024         strend -= dontbother;              /* this one's always in bytes! */
2025         /* We don't know much -- general case. */
2026         if (do_utf8) {
2027             for (;;) {
2028                 if (regtry(&reginfo, &s))
2029                     goto got_it;
2030                 if (s >= strend)
2031                     break;
2032                 s += UTF8SKIP(s);
2033             };
2034         }
2035         else {
2036             do {
2037                 if (regtry(&reginfo, &s))
2038                     goto got_it;
2039             } while (s++ < strend);
2040         }
2041     }
2042
2043     /* Failure. */
2044     goto phooey;
2045
2046 got_it:
2047     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2048
2049     if (PL_reg_eval_set) {
2050         /* Preserve the current value of $^R */
2051         if (oreplsv != GvSV(PL_replgv))
2052             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2053                                                   restored, the value remains
2054                                                   the same. */
2055         restore_pos(aTHX_ prog);
2056     }
2057     if (prog->paren_names)
2058         (void)hv_iterinit(prog->paren_names);
2059
2060     /* make sure $`, $&, $', and $digit will work later */
2061     if ( !(flags & REXEC_NOT_FIRST) ) {
2062         RX_MATCH_COPY_FREE(prog);
2063         if (flags & REXEC_COPY_STR) {
2064             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2065 #ifdef PERL_OLD_COPY_ON_WRITE
2066             if ((SvIsCOW(sv)
2067                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2068                 if (DEBUG_C_TEST) {
2069                     PerlIO_printf(Perl_debug_log,
2070                                   "Copy on write: regexp capture, type %d\n",
2071                                   (int) SvTYPE(sv));
2072                 }
2073                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2074                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2075                 assert (SvPOKp(prog->saved_copy));
2076             } else
2077 #endif
2078             {
2079                 RX_MATCH_COPIED_on(prog);
2080                 s = savepvn(strbeg, i);
2081                 prog->subbeg = s;
2082             }
2083             prog->sublen = i;
2084         }
2085         else {
2086             prog->subbeg = strbeg;
2087             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2088         }
2089     }
2090
2091     return 1;
2092
2093 phooey:
2094     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2095                           PL_colors[4], PL_colors[5]));
2096     if (PL_reg_eval_set)
2097         restore_pos(aTHX_ prog);
2098     if (prog->swap) {
2099         /* we failed :-( roll it back */
2100         I32 *t;
2101         t = prog->swap->startp;
2102         prog->swap->startp = prog->startp;
2103         prog->startp = t;
2104         t = prog->swap->endp;
2105         prog->swap->endp = prog->endp;
2106         prog->endp = t;
2107     }
2108     return 0;
2109 }
2110
2111
2112 /*
2113  - regtry - try match at specific point
2114  */
2115 STATIC I32                      /* 0 failure, 1 success */
2116 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2117 {
2118     dVAR;
2119     register I32 *sp;
2120     register I32 *ep;
2121     CHECKPOINT lastcp;
2122     regexp *prog = reginfo->prog;
2123     GET_RE_DEBUG_FLAGS_DECL;
2124     reginfo->cutpoint=NULL;
2125
2126     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2127         MAGIC *mg;
2128
2129         PL_reg_eval_set = RS_init;
2130         DEBUG_EXECUTE_r(DEBUG_s(
2131             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2132                           (IV)(PL_stack_sp - PL_stack_base));
2133             ));
2134         SAVESTACK_CXPOS();
2135         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2136         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2137         SAVETMPS;
2138         /* Apparently this is not needed, judging by wantarray. */
2139         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2140            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2141
2142         if (reginfo->sv) {
2143             /* Make $_ available to executed code. */
2144             if (reginfo->sv != DEFSV) {
2145                 SAVE_DEFSV;
2146                 DEFSV = reginfo->sv;
2147             }
2148
2149             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2150                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2151                 /* prepare for quick setting of pos */
2152 #ifdef PERL_OLD_COPY_ON_WRITE
2153                 if (SvIsCOW(reginfo->sv))
2154                     sv_force_normal_flags(reginfo->sv, 0);
2155 #endif
2156                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2157                                  &PL_vtbl_mglob, NULL, 0);
2158                 mg->mg_len = -1;
2159             }
2160             PL_reg_magic    = mg;
2161             PL_reg_oldpos   = mg->mg_len;
2162             SAVEDESTRUCTOR_X(restore_pos, prog);
2163         }
2164         if (!PL_reg_curpm) {
2165             Newxz(PL_reg_curpm, 1, PMOP);
2166 #ifdef USE_ITHREADS
2167             {
2168                 SV* const repointer = newSViv(0);
2169                 /* so we know which PL_regex_padav element is PL_reg_curpm */
2170                 SvFLAGS(repointer) |= SVf_BREAK;
2171                 av_push(PL_regex_padav,repointer);
2172                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2173                 PL_regex_pad = AvARRAY(PL_regex_padav);
2174             }
2175 #endif
2176         }
2177         PM_SETRE(PL_reg_curpm, prog);
2178         PL_reg_oldcurpm = PL_curpm;
2179         PL_curpm = PL_reg_curpm;
2180         if (RX_MATCH_COPIED(prog)) {
2181             /*  Here is a serious problem: we cannot rewrite subbeg,
2182                 since it may be needed if this match fails.  Thus
2183                 $` inside (?{}) could fail... */
2184             PL_reg_oldsaved = prog->subbeg;
2185             PL_reg_oldsavedlen = prog->sublen;
2186 #ifdef PERL_OLD_COPY_ON_WRITE
2187             PL_nrs = prog->saved_copy;
2188 #endif
2189             RX_MATCH_COPIED_off(prog);
2190         }
2191         else
2192             PL_reg_oldsaved = NULL;
2193         prog->subbeg = PL_bostr;
2194         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2195     }
2196     DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2197     prog->startp[0] = *startpos - PL_bostr;
2198     PL_reginput = *startpos;
2199     PL_reglastparen = &prog->lastparen;
2200     PL_reglastcloseparen = &prog->lastcloseparen;
2201     prog->lastparen = 0;
2202     prog->lastcloseparen = 0;
2203     PL_regsize = 0;
2204     PL_regstartp = prog->startp;
2205     PL_regendp = prog->endp;
2206     if (PL_reg_start_tmpl <= prog->nparens) {
2207         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2208         if(PL_reg_start_tmp)
2209             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2210         else
2211             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2212     }
2213
2214     /* XXXX What this code is doing here?!!!  There should be no need
2215        to do this again and again, PL_reglastparen should take care of
2216        this!  --ilya*/
2217
2218     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2219      * Actually, the code in regcppop() (which Ilya may be meaning by
2220      * PL_reglastparen), is not needed at all by the test suite
2221      * (op/regexp, op/pat, op/split), but that code is needed, oddly
2222      * enough, for building DynaLoader, or otherwise this
2223      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2224      * will happen.  Meanwhile, this code *is* needed for the
2225      * above-mentioned test suite tests to succeed.  The common theme
2226      * on those tests seems to be returning null fields from matches.
2227      * --jhi */
2228 #if 1
2229     sp = PL_regstartp;
2230     ep = PL_regendp;
2231     if (prog->nparens) {
2232         register I32 i;
2233         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2234             *++sp = -1;
2235             *++ep = -1;
2236         }
2237     }
2238 #endif
2239     REGCP_SET(lastcp);
2240     if (regmatch(reginfo, prog->program + 1)) {
2241         PL_regendp[0] = PL_reginput - PL_bostr;
2242         return 1;
2243     }
2244     if (reginfo->cutpoint)
2245         *startpos= reginfo->cutpoint;
2246     REGCP_UNWIND(lastcp);
2247     return 0;
2248 }
2249
2250
2251 #define sayYES goto yes
2252 #define sayNO goto no
2253 #define sayNO_SILENT goto no_silent
2254
2255 /* we dont use STMT_START/END here because it leads to
2256    "unreachable code" warnings, which are bogus, but distracting. */
2257 #define CACHEsayNO \
2258     if (ST.cache_mask) \
2259        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2260     sayNO
2261
2262 /* this is used to determine how far from the left messages like
2263    'failed...' are printed. It should be set such that messages
2264    are inline with the regop output that created them.
2265 */
2266 #define REPORT_CODE_OFF 32
2267
2268
2269 /* Make sure there is a test for this +1 options in re_tests */
2270 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2271
2272 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2273 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2274
2275 #define SLAB_FIRST(s) (&(s)->states[0])
2276 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2277
2278 /* grab a new slab and return the first slot in it */
2279
2280 STATIC regmatch_state *
2281 S_push_slab(pTHX)
2282 {
2283 #if PERL_VERSION < 9
2284     dMY_CXT;
2285 #endif
2286     regmatch_slab *s = PL_regmatch_slab->next;
2287     if (!s) {
2288         Newx(s, 1, regmatch_slab);
2289         s->prev = PL_regmatch_slab;
2290         s->next = NULL;
2291         PL_regmatch_slab->next = s;
2292     }
2293     PL_regmatch_slab = s;
2294     return SLAB_FIRST(s);
2295 }
2296
2297
2298 /* push a new state then goto it */
2299
2300 #define PUSH_STATE_GOTO(state, node) \
2301     scan = node; \
2302     st->resume_state = state; \
2303     goto push_state;
2304
2305 /* push a new state with success backtracking, then goto it */
2306
2307 #define PUSH_YES_STATE_GOTO(state, node) \
2308     scan = node; \
2309     st->resume_state = state; \
2310     goto push_yes_state;
2311
2312
2313
2314 /*
2315
2316 regmatch() - main matching routine
2317
2318 This is basically one big switch statement in a loop. We execute an op,
2319 set 'next' to point the next op, and continue. If we come to a point which
2320 we may need to backtrack to on failure such as (A|B|C), we push a
2321 backtrack state onto the backtrack stack. On failure, we pop the top
2322 state, and re-enter the loop at the state indicated. If there are no more
2323 states to pop, we return failure.
2324
2325 Sometimes we also need to backtrack on success; for example /A+/, where
2326 after successfully matching one A, we need to go back and try to
2327 match another one; similarly for lookahead assertions: if the assertion
2328 completes successfully, we backtrack to the state just before the assertion
2329 and then carry on.  In these cases, the pushed state is marked as
2330 'backtrack on success too'. This marking is in fact done by a chain of
2331 pointers, each pointing to the previous 'yes' state. On success, we pop to
2332 the nearest yes state, discarding any intermediate failure-only states.
2333 Sometimes a yes state is pushed just to force some cleanup code to be
2334 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2335 it to free the inner regex.
2336
2337 Note that failure backtracking rewinds the cursor position, while
2338 success backtracking leaves it alone.
2339
2340 A pattern is complete when the END op is executed, while a subpattern
2341 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2342 ops trigger the "pop to last yes state if any, otherwise return true"
2343 behaviour.
2344
2345 A common convention in this function is to use A and B to refer to the two
2346 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2347 the subpattern to be matched possibly multiple times, while B is the entire
2348 rest of the pattern. Variable and state names reflect this convention.
2349
2350 The states in the main switch are the union of ops and failure/success of
2351 substates associated with with that op.  For example, IFMATCH is the op
2352 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2353 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2354 successfully matched A and IFMATCH_A_fail is a state saying that we have
2355 just failed to match A. Resume states always come in pairs. The backtrack
2356 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2357 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2358 on success or failure.
2359
2360 The struct that holds a backtracking state is actually a big union, with
2361 one variant for each major type of op. The variable st points to the
2362 top-most backtrack struct. To make the code clearer, within each
2363 block of code we #define ST to alias the relevant union.
2364
2365 Here's a concrete example of a (vastly oversimplified) IFMATCH
2366 implementation:
2367
2368     switch (state) {
2369     ....
2370
2371 #define ST st->u.ifmatch
2372
2373     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2374         ST.foo = ...; // some state we wish to save
2375         ...
2376         // push a yes backtrack state with a resume value of
2377         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2378         // first node of A:
2379         PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2380         // NOTREACHED
2381
2382     case IFMATCH_A: // we have successfully executed A; now continue with B
2383         next = B;
2384         bar = ST.foo; // do something with the preserved value
2385         break;
2386
2387     case IFMATCH_A_fail: // A failed, so the assertion failed
2388         ...;   // do some housekeeping, then ...
2389         sayNO; // propagate the failure
2390
2391 #undef ST
2392
2393     ...
2394     }
2395
2396 For any old-timers reading this who are familiar with the old recursive
2397 approach, the code above is equivalent to:
2398
2399     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2400     {
2401         int foo = ...
2402         ...
2403         if (regmatch(A)) {
2404             next = B;
2405             bar = foo;
2406             break;
2407         }
2408         ...;   // do some housekeeping, then ...
2409         sayNO; // propagate the failure
2410     }
2411
2412 The topmost backtrack state, pointed to by st, is usually free. If you
2413 want to claim it, populate any ST.foo fields in it with values you wish to
2414 save, then do one of
2415
2416         PUSH_STATE_GOTO(resume_state, node);
2417         PUSH_YES_STATE_GOTO(resume_state, node);
2418
2419 which sets that backtrack state's resume value to 'resume_state', pushes a
2420 new free entry to the top of the backtrack stack, then goes to 'node'.
2421 On backtracking, the free slot is popped, and the saved state becomes the
2422 new free state. An ST.foo field in this new top state can be temporarily
2423 accessed to retrieve values, but once the main loop is re-entered, it
2424 becomes available for reuse.
2425
2426 Note that the depth of the backtrack stack constantly increases during the
2427 left-to-right execution of the pattern, rather than going up and down with
2428 the pattern nesting. For example the stack is at its maximum at Z at the
2429 end of the pattern, rather than at X in the following:
2430
2431     /(((X)+)+)+....(Y)+....Z/
2432
2433 The only exceptions to this are lookahead/behind assertions and the cut,
2434 (?>A), which pop all the backtrack states associated with A before
2435 continuing.
2436
2437 Bascktrack state structs are allocated in slabs of about 4K in size.
2438 PL_regmatch_state and st always point to the currently active state,
2439 and PL_regmatch_slab points to the slab currently containing
2440 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2441 allocated, and is never freed until interpreter destruction. When the slab
2442 is full, a new one is allocated and chained to the end. At exit from
2443 regmatch(), slabs allocated since entry are freed.
2444
2445 */
2446
2447
2448 #define DEBUG_STATE_pp(pp)                                  \
2449     DEBUG_STATE_r({                                         \
2450         DUMP_EXEC_POS(locinput, scan, do_utf8);             \
2451         PerlIO_printf(Perl_debug_log,                       \
2452             "    %*s"pp" %s%s%s%s%s\n",                     \
2453             depth*2, "",                                    \
2454             reg_name[st->resume_state],                     \
2455             ((st==yes_state||st==mark_state) ? "[" : ""),   \
2456             ((st==yes_state) ? "Y" : ""),                   \
2457             ((st==mark_state) ? "M" : ""),                  \
2458             ((st==yes_state||st==mark_state) ? "]" : "")    \
2459         );                                                  \
2460     });
2461
2462
2463 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2464
2465 #ifdef DEBUGGING
2466
2467 STATIC void
2468 S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
2469     const char *start, const char *end, const char *blurb)
2470 {
2471     const bool utf8_pat= prog->reganch & ROPT_UTF8 ? 1 : 0;
2472     if (!PL_colorset)
2473             reginitcolors();
2474     {
2475         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2476             prog->precomp, prog->prelen, 60);
2477
2478         RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2479             start, end - start, 60);
2480
2481         PerlIO_printf(Perl_debug_log,
2482             "%s%s REx%s %s against %s\n",
2483                        PL_colors[4], blurb, PL_colors[5], s0, s1);
2484
2485         if (do_utf8||utf8_pat)
2486             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2487                 utf8_pat ? "pattern" : "",
2488                 utf8_pat && do_utf8 ? " and " : "",
2489                 do_utf8 ? "string" : ""
2490             );
2491     }
2492 }
2493
2494 STATIC void
2495 S_dump_exec_pos(pTHX_ const char *locinput,
2496                       const regnode *scan,
2497                       const char *loc_regeol,
2498                       const char *loc_bostr,
2499                       const char *loc_reg_starttry,
2500                       const bool do_utf8)
2501 {
2502     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2503     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2504     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2505     /* The part of the string before starttry has one color
2506        (pref0_len chars), between starttry and current
2507        position another one (pref_len - pref0_len chars),
2508        after the current position the third one.
2509        We assume that pref0_len <= pref_len, otherwise we
2510        decrease pref0_len.  */
2511     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2512         ? (5 + taill) - l : locinput - loc_bostr;
2513     int pref0_len;
2514
2515     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2516         pref_len++;
2517     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2518     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2519         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2520               ? (5 + taill) - pref_len : loc_regeol - locinput);
2521     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2522         l--;
2523     if (pref0_len < 0)
2524         pref0_len = 0;
2525     if (pref0_len > pref_len)
2526         pref0_len = pref_len;
2527     {
2528         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2529
2530         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2531             (locinput - pref_len),pref0_len, 60, 4, 5);
2532
2533         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2534                     (locinput - pref_len + pref0_len),
2535                     pref_len - pref0_len, 60, 2, 3);
2536
2537         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2538                     locinput, loc_regeol - locinput, 10, 0, 1);
2539
2540         const STRLEN tlen=len0+len1+len2;
2541         PerlIO_printf(Perl_debug_log,
2542                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2543                     (IV)(locinput - loc_bostr),
2544                     len0, s0,
2545                     len1, s1,
2546                     (docolor ? "" : "> <"),
2547                     len2, s2,
2548                     (int)(tlen > 19 ? 0 :  19 - tlen),
2549                     "");
2550     }
2551 }
2552
2553 #endif
2554
2555 /* reg_check_named_buff_matched()
2556  * Checks to see if a named buffer has matched. The data array of
2557  * buffer numbers corresponding to the buffer is expected to reside
2558  * in the regexp->data->data array in the slot stored in the ARG() of
2559  * node involved. Note that this routine doesn't actually care about the
2560  * name, that information is not preserved from compilation to execution.
2561  * Returns the index of the leftmost defined buffer with the given name
2562  * or 0 if non of the buffers matched.
2563  */
2564 STATIC I32
2565 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) {
2566     I32 n;
2567     SV *sv_dat=(SV*)rex->data->data[ ARG( scan ) ];
2568     I32 *nums=(I32*)SvPVX(sv_dat);
2569     for ( n=0; n<SvIVX(sv_dat); n++ ) {
2570         if ((I32)*PL_reglastparen >= nums[n] &&
2571             PL_regendp[nums[n]] != -1)
2572         {
2573             return nums[n];
2574         }
2575     }
2576     return 0;
2577 }
2578
2579 STATIC I32                      /* 0 failure, 1 success */
2580 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2581 {
2582 #if PERL_VERSION < 9
2583     dMY_CXT;
2584 #endif
2585     dVAR;
2586     register const bool do_utf8 = PL_reg_match_utf8;
2587     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2588
2589     regexp *rex = reginfo->prog;
2590
2591     regmatch_slab  *orig_slab;
2592     regmatch_state *orig_state;
2593
2594     /* the current state. This is a cached copy of PL_regmatch_state */
2595     register regmatch_state *st;
2596
2597     /* cache heavy used fields of st in registers */
2598     register regnode *scan;
2599     register regnode *next;
2600     register U32 n = 0; /* general value; init to avoid compiler warning */
2601     register I32 ln = 0; /* len or last;  init to avoid compiler warning */
2602     register char *locinput = PL_reginput;
2603     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2604
2605     bool result = 0;        /* return value of S_regmatch */
2606     int depth = 0;          /* depth of backtrack stack */
2607     int nochange_depth = 0; /* depth of GOSUB recursion with nochange*/
2608     regmatch_state *yes_state = NULL; /* state to pop to on success of
2609                                                             subpattern */
2610     /* mark_state piggy backs on the yes_state logic so that when we unwind
2611        the stack on success we can update the mark_state as we go */
2612     regmatch_state *mark_state = NULL; /* last mark state we have seen */
2613
2614     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2615     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2616     U32 state_num;
2617     bool no_final = 0;      /* prevent failure from backtracking? */
2618     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
2619     char *startpoint = PL_reginput;
2620     SV *popmark = NULL;     /* are we looking for a mark? */
2621     SV *sv_commit = NULL;   /* last mark name seen in failure */
2622     SV *sv_yes_mark = NULL; /* last mark name we have seen
2623                                during a successfull match */
2624     U32 lastopen = 0;       /* last open we saw */
2625     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2626
2627     /* these three flags are set by various ops to signal information to
2628      * the very next op. They have a useful lifetime of exactly one loop
2629      * iteration, and are not preserved or restored by state pushes/pops
2630      */
2631     bool sw = 0;            /* the condition value in (?(cond)a|b) */
2632     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
2633     int logical = 0;        /* the following EVAL is:
2634                                 0: (?{...})
2635                                 1: (?(?{...})X|Y)
2636                                 2: (??{...})
2637                                or the following IFMATCH/UNLESSM is:
2638                                 false: plain (?=foo)
2639                                 true:  used as a condition: (?(?=foo))
2640                             */
2641
2642 #ifdef DEBUGGING
2643     GET_RE_DEBUG_FLAGS_DECL;
2644 #endif
2645
2646     DEBUG_STACK_r( {
2647             PerlIO_printf(Perl_debug_log,"regmatch start\n");
2648     });
2649     /* on first ever call to regmatch, allocate first slab */
2650     if (!PL_regmatch_slab) {
2651         Newx(PL_regmatch_slab, 1, regmatch_slab);
2652         PL_regmatch_slab->prev = NULL;
2653         PL_regmatch_slab->next = NULL;
2654         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2655     }
2656
2657     /* remember current high-water mark for exit */
2658     /* XXX this should be done with SAVE* instead */
2659     orig_slab  = PL_regmatch_slab;
2660     orig_state = PL_regmatch_state;
2661
2662     /* grab next free state slot */
2663     st = ++PL_regmatch_state;
2664     if (st >  SLAB_LAST(PL_regmatch_slab))
2665         st = PL_regmatch_state = S_push_slab(aTHX);
2666
2667     /* Note that nextchr is a byte even in UTF */
2668     nextchr = UCHARAT(locinput);
2669     scan = prog;
2670     while (scan != NULL) {
2671
2672         DEBUG_EXECUTE_r( {
2673             SV * const prop = sv_newmortal();
2674             regnode *rnext=regnext(scan);
2675             DUMP_EXEC_POS( locinput, scan, do_utf8 );
2676             regprop(rex, prop, scan);
2677
2678             PerlIO_printf(Perl_debug_log,
2679                     "%3"IVdf":%*s%s(%"IVdf")\n",
2680                     (IV)(scan - rex->program), depth*2, "",
2681                     SvPVX_const(prop),
2682                     (PL_regkind[OP(scan)] == END || !rnext) ?
2683                         0 : (IV)(rnext - rex->program));
2684         });
2685
2686         next = scan + NEXT_OFF(scan);
2687         if (next == scan)
2688             next = NULL;
2689         state_num = OP(scan);
2690
2691       reenter_switch:
2692         switch (state_num) {
2693         case BOL:
2694             if (locinput == PL_bostr)
2695             {
2696                 /* reginfo->till = reginfo->bol; */
2697                 break;
2698             }
2699             sayNO;
2700         case MBOL:
2701             if (locinput == PL_bostr ||
2702                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2703             {
2704                 break;
2705             }
2706             sayNO;
2707         case SBOL:
2708             if (locinput == PL_bostr)
2709                 break;
2710             sayNO;
2711         case GPOS:
2712             if (locinput == reginfo->ganch)
2713                 break;
2714             sayNO;
2715         case EOL:
2716                 goto seol;
2717         case MEOL:
2718             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2719                 sayNO;
2720             break;
2721         case SEOL:
2722           seol:
2723             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2724                 sayNO;
2725             if (PL_regeol - locinput > 1)
2726                 sayNO;
2727             break;
2728         case EOS:
2729             if (PL_regeol != locinput)
2730                 sayNO;
2731             break;
2732         case SANY:
2733             if (!nextchr && locinput >= PL_regeol)
2734                 sayNO;
2735             if (do_utf8) {
2736                 locinput += PL_utf8skip[nextchr];
2737                 if (locinput > PL_regeol)
2738                     sayNO;
2739                 nextchr = UCHARAT(locinput);
2740             }
2741             else
2742                 nextchr = UCHARAT(++locinput);
2743             break;
2744         case CANY:
2745             if (!nextchr && locinput >= PL_regeol)
2746                 sayNO;
2747             nextchr = UCHARAT(++locinput);
2748             break;
2749         case REG_ANY:
2750             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2751                 sayNO;
2752             if (do_utf8) {
2753                 locinput += PL_utf8skip[nextchr];
2754                 if (locinput > PL_regeol)
2755                     sayNO;
2756                 nextchr = UCHARAT(locinput);
2757             }
2758             else
2759                 nextchr = UCHARAT(++locinput);
2760             break;
2761
2762 #undef  ST
2763 #define ST st->u.trie
2764         case TRIEC:
2765             /* In this case the charclass data is available inline so
2766                we can fail fast without a lot of extra overhead.
2767              */
2768             if (scan->flags == EXACT || !do_utf8) {
2769                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
2770                     DEBUG_EXECUTE_r(
2771                         PerlIO_printf(Perl_debug_log,
2772                                   "%*s  %sfailed to match trie start class...%s\n",
2773                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2774                     );
2775                     sayNO_SILENT;
2776                     /* NOTREACHED */
2777                 }
2778             }
2779             /* FALL THROUGH */
2780         case TRIE:
2781             {
2782                 /* what type of TRIE am I? (utf8 makes this contextual) */
2783                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2784                     trie_type = do_utf8 ?
2785                           (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2786                         : trie_plain;
2787
2788                 /* what trie are we using right now */
2789                 reg_trie_data * const trie
2790                     = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2791                 U32 state = trie->startstate;
2792
2793                 if (trie->bitmap && trie_type != trie_utf8_fold &&
2794                     !TRIE_BITMAP_TEST(trie,*locinput)
2795                 ) {
2796                     if (trie->states[ state ].wordnum) {
2797                          DEBUG_EXECUTE_r(
2798                             PerlIO_printf(Perl_debug_log,
2799                                           "%*s  %smatched empty string...%s\n",
2800                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2801                         );
2802                         break;
2803                     } else {
2804                         DEBUG_EXECUTE_r(
2805                             PerlIO_printf(Perl_debug_log,
2806                                           "%*s  %sfailed to match trie start class...%s\n",
2807                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2808                         );
2809                         sayNO_SILENT;
2810                    }
2811                 }
2812
2813             {
2814                 U8 *uc = ( U8* )locinput;
2815
2816                 STRLEN len = 0;
2817                 STRLEN foldlen = 0;
2818                 U8 *uscan = (U8*)NULL;
2819                 STRLEN bufflen=0;
2820                 SV *sv_accept_buff = NULL;
2821                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2822
2823                 ST.accepted = 0; /* how many accepting states we have seen */
2824                 ST.B = next;
2825                 ST.jump = trie->jump;
2826                 ST.me = scan;
2827
2828                 /*
2829                    traverse the TRIE keeping track of all accepting states
2830                    we transition through until we get to a failing node.
2831                 */
2832
2833                 while ( state && uc <= (U8*)PL_regeol ) {
2834                     U32 base = trie->states[ state ].trans.base;
2835                     UV uvc = 0;
2836                     U16 charid;
2837                     /* We use charid to hold the wordnum as we don't use it
2838                        for charid until after we have done the wordnum logic.
2839                        We define an alias just so that the wordnum logic reads
2840                        more naturally. */
2841
2842 #define got_wordnum charid
2843                     got_wordnum = trie->states[ state ].wordnum;
2844
2845                     if ( got_wordnum ) {
2846                         if ( ! ST.accepted ) {
2847                             ENTER;
2848                             SAVETMPS;
2849                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2850                             sv_accept_buff=newSV(bufflen *
2851                                             sizeof(reg_trie_accepted) - 1);
2852                             SvCUR_set(sv_accept_buff, 0);
2853                             SvPOK_on(sv_accept_buff);
2854                             sv_2mortal(sv_accept_buff);
2855                             SAVETMPS;
2856                             ST.accept_buff =
2857                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2858                         }
2859                         do {
2860                             if (ST.accepted >= bufflen) {
2861                                 bufflen *= 2;
2862                                 ST.accept_buff =(reg_trie_accepted*)
2863                                     SvGROW(sv_accept_buff,
2864                                         bufflen * sizeof(reg_trie_accepted));
2865                             }
2866                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2867                                 + sizeof(reg_trie_accepted));
2868
2869
2870                             ST.accept_buff[ST.accepted].wordnum = got_wordnum;
2871                             ST.accept_buff[ST.accepted].endpos = uc;
2872                             ++ST.accepted;
2873                         } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
2874                     }
2875 #undef got_wordnum
2876
2877                     DEBUG_TRIE_EXECUTE_r({
2878                                 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
2879                                 PerlIO_printf( Perl_debug_log,
2880                                     "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
2881                                     2+depth * 2, "", PL_colors[4],
2882                                     (UV)state, (UV)ST.accepted );
2883                     });
2884
2885                     if ( base ) {
2886                         REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
2887                             uvc, charid, foldlen, foldbuf, uniflags);
2888
2889                         if (charid &&
2890                              (base + charid > trie->uniquecharcount )
2891                              && (base + charid - 1 - trie->uniquecharcount
2892                                     < trie->lasttrans)
2893                              && trie->trans[base + charid - 1 -
2894                                     trie->uniquecharcount].check == state)
2895                         {
2896                             state = trie->trans[base + charid - 1 -
2897                                 trie->uniquecharcount ].next;
2898                         }
2899                         else {
2900                             state = 0;
2901                         }
2902                         uc += len;
2903
2904                     }
2905                     else {
2906                         state = 0;
2907                     }
2908                     DEBUG_TRIE_EXECUTE_r(
2909                         PerlIO_printf( Perl_debug_log,
2910                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
2911                             charid, uvc, (UV)state, PL_colors[5] );
2912                     );
2913                 }
2914                 if (!ST.accepted )
2915                    sayNO;
2916
2917                 DEBUG_EXECUTE_r(
2918                     PerlIO_printf( Perl_debug_log,
2919                         "%*s  %sgot %"IVdf" possible matches%s\n",
2920                         REPORT_CODE_OFF + depth * 2, "",
2921                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
2922                 );
2923             }}
2924
2925             /* FALL THROUGH */
2926         case TRIE_next_fail: /* we failed - try next alterative */
2927             if (do_cutgroup) {
2928                 do_cutgroup = 0;
2929                 no_final = 0;
2930             }
2931             if ( ST.accepted == 1 ) {
2932                 /* only one choice left - just continue */
2933                 DEBUG_EXECUTE_r({
2934                     reg_trie_data * const trie
2935                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2936                     SV ** const tmp = av_fetch( trie->words,
2937                         ST.accept_buff[ 0 ].wordnum-1, 0 );
2938                     SV *sv= tmp ? sv_newmortal() : NULL;
2939
2940                     PerlIO_printf( Perl_debug_log,
2941                         "%*s  %sonly one match left: #%d <%s>%s\n",
2942                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
2943                         ST.accept_buff[ 0 ].wordnum,
2944                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
2945                                 PL_colors[0], PL_colors[1],
2946                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
2947                             )
2948                         : "not compiled under -Dr",
2949                         PL_colors[5] );
2950                 });
2951                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
2952                 /* in this case we free tmps/leave before we call regmatch
2953                    as we wont be using accept_buff again. */
2954
2955                 locinput = PL_reginput;
2956                 nextchr = UCHARAT(locinput);
2957                 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
2958                     scan = ST.B;
2959                 else
2960                     scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
2961                 if (!has_cutgroup) {
2962                     FREETMPS;
2963                     LEAVE;
2964                 } else {
2965                     ST.accepted--;
2966                     PUSH_YES_STATE_GOTO(TRIE_next, scan);
2967                 }
2968
2969                 continue; /* execute rest of RE */
2970             }
2971
2972             if (!ST.accepted-- ) {
2973                 DEBUG_EXECUTE_r({
2974                     PerlIO_printf( Perl_debug_log,
2975                         "%*s  %sTRIE failed...%s\n",
2976                         REPORT_CODE_OFF+depth*2, "",
2977                         PL_colors[4],
2978                         PL_colors[5] );
2979                 });
2980                 FREETMPS;
2981                 LEAVE;
2982                 sayNO_SILENT;
2983             }
2984
2985             /*
2986                There are at least two accepting states left.  Presumably
2987                the number of accepting states is going to be low,
2988                typically two. So we simply scan through to find the one
2989                with lowest wordnum.  Once we find it, we swap the last
2990                state into its place and decrement the size. We then try to
2991                match the rest of the pattern at the point where the word
2992                ends. If we succeed, control just continues along the
2993                regex; if we fail we return here to try the next accepting
2994                state
2995              */
2996
2997             {
2998                 U32 best = 0;
2999                 U32 cur;
3000                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3001                     DEBUG_TRIE_EXECUTE_r(
3002                         PerlIO_printf( Perl_debug_log,
3003                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3004                             REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3005                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3006                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3007                     );
3008
3009                     if (ST.accept_buff[cur].wordnum <
3010                             ST.accept_buff[best].wordnum)
3011                         best = cur;
3012                 }
3013
3014                 DEBUG_EXECUTE_r({
3015                     reg_trie_data * const trie
3016                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
3017                     SV ** const tmp = av_fetch( trie->words,
3018                         ST.accept_buff[ best ].wordnum - 1, 0 );
3019                     regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
3020                                     ST.B :
3021                                     ST.me + ST.jump[ST.accept_buff[best].wordnum];
3022                     SV *sv= tmp ? sv_newmortal() : NULL;
3023
3024                     PerlIO_printf( Perl_debug_log,
3025                         "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3026                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3027                         ST.accept_buff[best].wordnum,
3028                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3029                                 PL_colors[0], PL_colors[1],
3030                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3031                             ) : "not compiled under -Dr",
3032                             REG_NODE_NUM(nextop),
3033                         PL_colors[5] );
3034                 });
3035
3036                 if ( best<ST.accepted ) {
3037                     reg_trie_accepted tmp = ST.accept_buff[ best ];
3038                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3039                     ST.accept_buff[ ST.accepted ] = tmp;
3040                     best = ST.accepted;
3041                 }
3042                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3043                 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3044                     scan = ST.B;
3045                     /* NOTREACHED */
3046                 } else {
3047                     scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3048                     /* NOTREACHED */
3049                 }
3050                 if (has_cutgroup) {
3051                     PUSH_YES_STATE_GOTO(TRIE_next, scan);
3052                     /* NOTREACHED */
3053                 } else {
3054                     PUSH_STATE_GOTO(TRIE_next, scan);
3055                     /* NOTREACHED */
3056                 }
3057                 /* NOTREACHED */
3058             }
3059             /* NOTREACHED */
3060         case TRIE_next:
3061             FREETMPS;
3062             LEAVE;
3063             sayYES;
3064 #undef  ST
3065
3066         case EXACT: {
3067             char *s = STRING(scan);
3068             ln = STR_LEN(scan);
3069             if (do_utf8 != UTF) {
3070                 /* The target and the pattern have differing utf8ness. */
3071                 char *l = locinput;
3072                 const char * const e = s + ln;
3073
3074                 if (do_utf8) {
3075                     /* The target is utf8, the pattern is not utf8. */
3076                     while (s < e) {
3077                         STRLEN ulen;
3078                         if (l >= PL_regeol)
3079                              sayNO;
3080                         if (NATIVE_TO_UNI(*(U8*)s) !=
3081                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3082                                             uniflags))
3083                              sayNO;
3084                         l += ulen;
3085                         s ++;
3086                     }
3087                 }
3088                 else {
3089                     /* The target is not utf8, the pattern is utf8. */
3090                     while (s < e) {
3091                         STRLEN ulen;
3092                         if (l >= PL_regeol)
3093                             sayNO;
3094                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3095                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3096                                            uniflags))
3097                             sayNO;
3098                         s += ulen;
3099                         l ++;
3100                     }
3101                 }
3102                 locinput = l;
3103                 nextchr = UCHARAT(locinput);
3104                 break;
3105             }
3106             /* The target and the pattern have the same utf8ness. */
3107             /* Inline the first character, for speed. */
3108             if (UCHARAT(s) != nextchr)
3109                 sayNO;
3110             if (PL_regeol - locinput < ln)
3111                 sayNO;
3112             if (ln > 1 && memNE(s, locinput, ln))
3113                 sayNO;
3114             locinput += ln;
3115             nextchr = UCHARAT(locinput);
3116             break;
3117             }
3118         case EXACTFL:
3119             PL_reg_flags |= RF_tainted;
3120             /* FALL THROUGH */
3121         case EXACTF: {
3122             char * const s = STRING(scan);
3123             ln = STR_LEN(scan);
3124
3125             if (do_utf8 || UTF) {
3126               /* Either target or the pattern are utf8. */
3127                 const char * const l = locinput;
3128                 char *e = PL_regeol;
3129
3130                 if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
3131                                l, &e, 0,  do_utf8)) {
3132                      /* One more case for the sharp s:
3133                       * pack("U0U*", 0xDF) =~ /ss/i,
3134                       * the 0xC3 0x9F are the UTF-8
3135                       * byte sequence for the U+00DF. */
3136                      if (!(do_utf8 &&
3137                            toLOWER(s[0]) == 's' &&
3138                            ln >= 2 &&
3139                            toLOWER(s[1]) == 's' &&
3140                            (U8)l[0] == 0xC3 &&
3141                            e - l >= 2 &&
3142                            (U8)l[1] == 0x9F))
3143                           sayNO;
3144                 }
3145                 locinput = e;
3146                 nextchr = UCHARAT(locinput);
3147                 break;
3148             }
3149
3150             /* Neither the target and the pattern are utf8. */
3151
3152             /* Inline the first character, for speed. */
3153             if (UCHARAT(s) != nextchr &&
3154                 UCHARAT(s) != ((OP(scan) == EXACTF)
3155                                ? PL_fold : PL_fold_locale)[nextchr])
3156                 sayNO;
3157             if (PL_regeol - locinput < ln)
3158                 sayNO;
3159             if (ln > 1 && (OP(scan) == EXACTF
3160                            ? ibcmp(s, locinput, ln)
3161                            : ibcmp_locale(s, locinput, ln)))
3162                 sayNO;
3163             locinput += ln;
3164             nextchr = UCHARAT(locinput);
3165             break;
3166             }
3167         case ANYOF:
3168             if (do_utf8) {
3169                 STRLEN inclasslen = PL_regeol - locinput;
3170
3171                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3172                     goto anyof_fail;
3173                 if (locinput >= PL_regeol)
3174                     sayNO;
3175                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3176                 nextchr = UCHARAT(locinput);
3177                 break;
3178             }
3179             else {
3180                 if (nextchr < 0)
3181                     nextchr = UCHARAT(locinput);
3182                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3183                     goto anyof_fail;
3184                 if (!nextchr && locinput >= PL_regeol)
3185                     sayNO;
3186                 nextchr = UCHARAT(++locinput);
3187                 break;
3188             }
3189         anyof_fail:
3190             /* If we might have the case of the German sharp s
3191              * in a casefolding Unicode character class. */
3192
3193             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3194                  locinput += SHARP_S_SKIP;
3195                  nextchr = UCHARAT(locinput);
3196             }
3197             else
3198                  sayNO;
3199             break;
3200         case ALNUML:
3201             PL_reg_flags |= RF_tainted;
3202             /* FALL THROUGH */
3203         case ALNUM:
3204             if (!nextchr)
3205                 sayNO;
3206             if (do_utf8) {
3207                 LOAD_UTF8_CHARCLASS_ALNUM();
3208                 if (!(OP(scan) == ALNUM
3209                       ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3210                       : isALNUM_LC_utf8((U8*)locinput)))
3211                 {
3212                     sayNO;
3213                 }
3214                 locinput += PL_utf8skip[nextchr];
3215                 nextchr = UCHARAT(locinput);
3216                 break;
3217             }
3218             if (!(OP(scan) == ALNUM
3219                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3220                 sayNO;
3221             nextchr = UCHARAT(++locinput);
3222             break;
3223         case NALNUML:
3224             PL_reg_flags |= RF_tainted;
3225             /* FALL THROUGH */
3226         case NALNUM:
3227             if (!nextchr && locinput >= PL_regeol)
3228                 sayNO;
3229             if (do_utf8) {
3230                 LOAD_UTF8_CHARCLASS_ALNUM();
3231                 if (OP(scan) == NALNUM
3232                     ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3233                     : isALNUM_LC_utf8((U8*)locinput))
3234                 {
3235                     sayNO;
3236                 }
3237                 locinput += PL_utf8skip[nextchr];
3238                 nextchr = UCHARAT(locinput);
3239                 break;
3240             }
3241             if (OP(scan) == NALNUM
3242                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3243                 sayNO;
3244             nextchr = UCHARAT(++locinput);
3245             break;
3246         case BOUNDL:
3247         case NBOUNDL:
3248             PL_reg_flags |= RF_tainted;
3249             /* FALL THROUGH */
3250         case BOUND:
3251         case NBOUND:
3252             /* was last char in word? */
3253             if (do_utf8) {
3254                 if (locinput == PL_bostr)
3255                     ln = '\n';
3256                 else {
3257                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3258
3259                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3260                 }
3261                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3262                     ln = isALNUM_uni(ln);
3263                     LOAD_UTF8_CHARCLASS_ALNUM();
3264                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3265                 }
3266                 else {
3267                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3268                     n = isALNUM_LC_utf8((U8*)locinput);
3269                 }
3270             }
3271             else {
3272                 ln = (locinput != PL_bostr) ?
3273                     UCHARAT(locinput - 1) : '\n';
3274                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3275                     ln = isALNUM(ln);
3276                     n = isALNUM(nextchr);
3277                 }
3278                 else {
3279                     ln = isALNUM_LC(ln);
3280                     n = isALNUM_LC(nextchr);
3281                 }
3282             }
3283             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3284                                     OP(scan) == BOUNDL))
3285                     sayNO;
3286             break;
3287         case SPACEL:
3288             PL_reg_flags |= RF_tainted;
3289             /* FALL THROUGH */
3290         case SPACE:
3291             if (!nextchr)
3292                 sayNO;
3293             if (do_utf8) {
3294                 if (UTF8_IS_CONTINUED(nextchr)) {
3295                     LOAD_UTF8_CHARCLASS_SPACE();
3296                     if (!(OP(scan) == SPACE
3297                           ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3298                           : isSPACE_LC_utf8((U8*)locinput)))
3299                     {
3300                         sayNO;
3301                     }
3302                     locinput += PL_utf8skip[nextchr];
3303                     nextchr = UCHARAT(locinput);
3304                     break;
3305                 }
3306                 if (!(OP(scan) == SPACE
3307                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3308                     sayNO;
3309                 nextchr = UCHARAT(++locinput);
3310             }
3311             else {
3312                 if (!(OP(scan) == SPACE
3313                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3314                     sayNO;
3315                 nextchr = UCHARAT(++locinput);
3316             }
3317             break;
3318         case NSPACEL:
3319             PL_reg_flags |= RF_tainted;
3320             /* FALL THROUGH */
3321         case NSPACE:
3322             if (!nextchr && locinput >= PL_regeol)
3323                 sayNO;
3324             if (do_utf8) {
3325                 LOAD_UTF8_CHARCLASS_SPACE();
3326                 if (OP(scan) == NSPACE
3327                     ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3328                     : isSPACE_LC_utf8((U8*)locinput))
3329                 {
3330                     sayNO;
3331                 }
3332                 locinput += PL_utf8skip[nextchr];
3333                 nextchr = UCHARAT(locinput);
3334                 break;
3335             }
3336             if (OP(scan) == NSPACE
3337                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3338                 sayNO;
3339             nextchr = UCHARAT(++locinput);
3340             break;
3341         case DIGITL:
3342             PL_reg_flags |= RF_tainted;
3343             /* FALL THROUGH */
3344         case DIGIT:
3345             if (!nextchr)
3346                 sayNO;
3347             if (do_utf8) {
3348                 LOAD_UTF8_CHARCLASS_DIGIT();
3349                 if (!(OP(scan) == DIGIT
3350                       ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3351                       : isDIGIT_LC_utf8((U8*)locinput)))
3352                 {
3353                     sayNO;
3354                 }
3355                 locinput += PL_utf8skip[nextchr];
3356                 nextchr = UCHARAT(locinput);
3357                 break;
3358             }
3359             if (!(OP(scan) == DIGIT
3360                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3361                 sayNO;
3362             nextchr = UCHARAT(++locinput);
3363             break;
3364         case NDIGITL:
3365             PL_reg_flags |= RF_tainted;
3366             /* FALL THROUGH */
3367         case NDIGIT:
3368             if (!nextchr && locinput >= PL_regeol)
3369                 sayNO;
3370             if (do_utf8) {
3371                 LOAD_UTF8_CHARCLASS_DIGIT();
3372                 if (OP(scan) == NDIGIT
3373                     ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3374                     : isDIGIT_LC_utf8((U8*)locinput))
3375                 {
3376                     sayNO;
3377                 }
3378                 locinput += PL_utf8skip[nextchr];
3379                 nextchr = UCHARAT(locinput);
3380                 break;
3381             }
3382             if (OP(scan) == NDIGIT
3383                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3384                 sayNO;
3385             nextchr = UCHARAT(++locinput);
3386             break;
3387         case CLUMP:
3388             if (locinput >= PL_regeol)
3389                 sayNO;
3390             if  (do_utf8) {
3391                 LOAD_UTF8_CHARCLASS_MARK();
3392                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3393                     sayNO;
3394                 locinput += PL_utf8skip[nextchr];
3395                 while (locinput < PL_regeol &&
3396                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3397                     locinput += UTF8SKIP(locinput);
3398                 if (locinput > PL_regeol)
3399                     sayNO;
3400             }
3401             else
3402                locinput++;
3403             nextchr = UCHARAT(locinput);
3404             break;
3405
3406         case NREFFL:
3407         {
3408             char *s;
3409             char type;
3410             PL_reg_flags |= RF_tainted;
3411             /* FALL THROUGH */
3412         case NREF:
3413         case NREFF:
3414             type = OP(scan);
3415             n = reg_check_named_buff_matched(rex,scan);
3416
3417             if ( n ) {
3418                 type = REF + ( type - NREF );
3419                 goto do_ref;
3420             } else {
3421                 sayNO;
3422             }
3423             /* unreached */
3424         case REFFL:
3425             PL_reg_flags |= RF_tainted;
3426             /* FALL THROUGH */
3427         case REF:
3428         case REFF:
3429             n = ARG(scan);  /* which paren pair */
3430             type = OP(scan);
3431           do_ref:
3432             ln = PL_regstartp[n];
3433             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3434             if (*PL_reglastparen < n || ln == -1)
3435                 sayNO;                  /* Do not match unless seen CLOSEn. */
3436             if (ln == PL_regendp[n])
3437                 break;
3438
3439             s = PL_bostr + ln;
3440             if (do_utf8 && type != REF) {       /* REF can do byte comparison */
3441                 char *l = locinput;
3442                 const char *e = PL_bostr + PL_regendp[n];
3443                 /*
3444                  * Note that we can't do the "other character" lookup trick as
3445                  * in the 8-bit case (no pun intended) because in Unicode we
3446                  * have to map both upper and title case to lower case.
3447                  */
3448                 if (type == REFF) {
3449                     while (s < e) {
3450                         STRLEN ulen1, ulen2;
3451                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3452                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3453
3454                         if (l >= PL_regeol)
3455                             sayNO;
3456                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3457                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3458                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3459                             sayNO;
3460                         s += ulen1;
3461                         l += ulen2;
3462                     }
3463                 }
3464                 locinput = l;
3465                 nextchr = UCHARAT(locinput);
3466                 break;
3467             }
3468
3469             /* Inline the first character, for speed. */
3470             if (UCHARAT(s) != nextchr &&
3471                 (type == REF ||
3472                  (UCHARAT(s) != (type == REFF
3473                                   ? PL_fold : PL_fold_locale)[nextchr])))
3474                 sayNO;
3475             ln = PL_regendp[n] - ln;
3476             if (locinput + ln > PL_regeol)
3477                 sayNO;
3478             if (ln > 1 && (type == REF
3479                            ? memNE(s, locinput, ln)
3480                            : (type == REFF
3481                               ? ibcmp(s, locinput, ln)
3482                               : ibcmp_locale(s, locinput, ln))))
3483                 sayNO;
3484             locinput += ln;
3485             nextchr = UCHARAT(locinput);
3486             break;
3487         }
3488         case NOTHING:
3489         case TAIL:
3490             break;
3491         case BACK:
3492             break;
3493
3494 #undef  ST
3495 #define ST st->u.eval
3496         {
3497             SV *ret;
3498             regexp *re;
3499             regnode *startpoint;
3500
3501         case GOSTART:
3502         case GOSUB: /*    /(...(?1))/      */
3503             if (cur_eval && cur_eval->locinput==locinput) {
3504                 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3505                     Perl_croak(aTHX_ "Infinite recursion in regex");
3506                 if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH )
3507                     Perl_croak(aTHX_
3508                         "Pattern subroutine nesting without pos change"
3509                         " exceeded limit in regex");
3510             } else {
3511                 nochange_depth = 0;
3512             }
3513             re = rex;
3514             (void)ReREFCNT_inc(rex);
3515             if (OP(scan)==GOSUB) {
3516                 startpoint = scan + ARG2L(scan);
3517                 ST.close_paren = ARG(scan);
3518             } else {
3519                 startpoint = re->program+1;
3520                 ST.close_paren = 0;
3521             }
3522             goto eval_recurse_doit;
3523             /* NOTREACHED */
3524         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3525             if (cur_eval && cur_eval->locinput==locinput) {
3526                 if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH )
3527                     Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3528             } else {
3529                 nochange_depth = 0;
3530             }
3531             {
3532                 /* execute the code in the {...} */
3533                 dSP;
3534                 SV ** const before = SP;
3535                 OP_4tree * const oop = PL_op;
3536                 COP * const ocurcop = PL_curcop;
3537                 PAD *old_comppad;
3538
3539                 n = ARG(scan);
3540                 PL_op = (OP_4tree*)rex->data->data[n];
3541                 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3542                     "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3543                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3544                 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3545
3546                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3547                 SPAGAIN;
3548                 if (SP == before)
3549                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3550                 else {
3551                     ret = POPs;
3552                     PUTBACK;
3553                 }
3554
3555                 PL_op = oop;
3556                 PAD_RESTORE_LOCAL(old_comppad);
3557                 PL_curcop = ocurcop;
3558                 if (!logical) {
3559                     /* /(?{...})/ */
3560                     sv_setsv(save_scalar(PL_replgv), ret);
3561                     break;
3562                 }
3563             }
3564             if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3565                 logical = 0;
3566                 {
3567                     /* extract RE object from returned value; compiling if
3568                      * necessary */
3569
3570                     MAGIC *mg = NULL;
3571                     const SV *sv;
3572                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3573                         mg = mg_find(sv, PERL_MAGIC_qr);
3574                     else if (SvSMAGICAL(ret)) {
3575                         if (SvGMAGICAL(ret))
3576                             sv_unmagic(ret, PERL_MAGIC_qr);
3577                         else
3578                             mg = mg_find(ret, PERL_MAGIC_qr);
3579                     }
3580
3581                     if (mg) {
3582                         re = (regexp *)mg->mg_obj;
3583                         (void)ReREFCNT_inc(re);
3584                     }
3585                     else {
3586                         STRLEN len;
3587                         const char * const t = SvPV_const(ret, len);
3588                         PMOP pm;
3589                         const I32 osize = PL_regsize;
3590
3591                         Zero(&pm, 1, PMOP);
3592                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3593                         re = CALLREGCOMP((char*)t, (char*)t + len, &pm);
3594                         if (!(SvFLAGS(ret)
3595                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3596                                 | SVs_GMG)))
3597                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3598                                         PERL_MAGIC_qr,0,0);
3599                         PL_regsize = osize;
3600                     }
3601                 }
3602                 DEBUG_EXECUTE_r(
3603                     debug_start_match(re, do_utf8, locinput, PL_regeol,
3604                         "Matching embedded");
3605                 );
3606                 startpoint = re->program + 1;
3607                 ST.close_paren = 0; /* only used for GOSUB */
3608                 /* borrowed from regtry */
3609                 if (PL_reg_start_tmpl <= re->nparens) {
3610                     PL_reg_start_tmpl = re->nparens*3/2 + 3;
3611                     if(PL_reg_start_tmp)
3612                         Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3613                     else
3614                         Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3615                 }
3616
3617         eval_recurse_doit: /* Share code with GOSUB below this line */
3618                 /* run the pattern returned from (??{...}) */
3619                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3620                 REGCP_SET(ST.lastcp);
3621
3622                 PL_regstartp = re->startp; /* essentially NOOP on GOSUB */
3623                 PL_regendp = re->endp;     /* essentially NOOP on GOSUB */
3624
3625                 *PL_reglastparen = 0;
3626                 *PL_reglastcloseparen = 0;
3627                 PL_reginput = locinput;
3628                 PL_regsize = 0;
3629
3630                 /* XXXX This is too dramatic a measure... */
3631                 PL_reg_maxiter = 0;
3632
3633                 ST.toggle_reg_flags = PL_reg_flags;
3634                 if (re->reganch & ROPT_UTF8)
3635                     PL_reg_flags |= RF_utf8;
3636                 else
3637                     PL_reg_flags &= ~RF_utf8;
3638                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3639
3640                 ST.prev_rex = rex;
3641                 ST.prev_curlyx = cur_curlyx;
3642                 rex = re;
3643                 cur_curlyx = NULL;
3644                 ST.B = next;
3645                 ST.prev_eval = cur_eval;
3646                 cur_eval = st;
3647                 /* now continue from first node in postoned RE */
3648                 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
3649                 /* NOTREACHED */
3650             }
3651             /* logical is 1,   /(?(?{...})X|Y)/ */
3652             sw = (bool)SvTRUE(ret);
3653             logical = 0;
3654             break;
3655         }
3656
3657         case EVAL_AB: /* cleanup after a successful (??{A})B */
3658             /* note: this is called twice; first after popping B, then A */
3659             PL_reg_flags ^= ST.toggle_reg_flags;
3660             ReREFCNT_dec(rex);
3661             rex = ST.prev_rex;
3662             regcpblow(ST.cp);
3663             cur_eval = ST.prev_eval;
3664             cur_curlyx = ST.prev_curlyx;
3665             /* XXXX This is too dramatic a measure... */
3666             PL_reg_maxiter = 0;
3667             sayYES;
3668
3669
3670         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3671             /* note: this is called twice; first after popping B, then A */
3672             PL_reg_flags ^= ST.toggle_reg_flags;
3673             ReREFCNT_dec(rex);
3674             rex = ST.prev_rex;
3675             PL_reginput = locinput;
3676             REGCP_UNWIND(ST.lastcp);
3677             regcppop(rex);
3678             cur_eval = ST.prev_eval;
3679             cur_curlyx = ST.prev_curlyx;
3680             /* XXXX This is too dramatic a measure... */
3681             PL_reg_maxiter = 0;
3682             sayNO_SILENT;
3683 #undef ST
3684
3685         case OPEN:
3686             n = ARG(scan);  /* which paren pair */
3687             PL_reg_start_tmp[n] = locinput;
3688             if (n > PL_regsize)
3689                 PL_regsize = n;
3690             lastopen = n;
3691             break;
3692         case CLOSE:
3693             n = ARG(scan);  /* which paren pair */
3694             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3695             PL_regendp[n] = locinput - PL_bostr;
3696             /*if (n > PL_regsize)
3697                 PL_regsize = n;*/
3698             if (n > *PL_reglastparen)
3699                 *PL_reglastparen = n;
3700             *PL_reglastcloseparen = n;
3701             if (cur_eval && cur_eval->u.eval.close_paren == n) {
3702                 goto fake_end;
3703             }
3704             break;
3705         case ACCEPT:
3706             if (ARG(scan)){
3707                 regnode *cursor;
3708                 for (cursor=scan;
3709                      cursor && OP(cursor)!=END;
3710                      cursor=regnext(cursor))
3711                 {
3712                     if ( OP(cursor)==CLOSE ){
3713                         n = ARG(cursor);
3714                         if ( n <= lastopen ) {
3715                             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3716                             PL_regendp[n] = locinput - PL_bostr;
3717                             /*if (n > PL_regsize)
3718                             PL_regsize = n;*/
3719                             if (n > *PL_reglastparen)
3720                                 *PL_reglastparen = n;
3721                             *PL_reglastcloseparen = n;
3722                             if ( n == ARG(scan) || (cur_eval &&
3723                                 cur_eval->u.eval.close_paren == n))
3724                                 break;
3725                         }
3726                     }
3727                 }
3728             }
3729             goto fake_end;
3730             /*NOTREACHED*/
3731         case GROUPP:
3732             n = ARG(scan);  /* which paren pair */
3733             sw = (bool)(*PL_reglastparen >= n && PL_regendp[n] != -1);
3734             break;
3735         case NGROUPP:
3736             /* reg_check_named_buff_matched returns 0 for no match */
3737             sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
3738             break;
3739         case INSUBP:
3740             n = ARG(scan);
3741             sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
3742             break;
3743         case DEFINEP:
3744             sw = 0;
3745             break;
3746         case IFTHEN:
3747             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3748             if (sw)
3749                 next = NEXTOPER(NEXTOPER(scan));
3750             else {
3751                 next = scan + ARG(scan);
3752                 if (OP(next) == IFTHEN) /* Fake one. */
3753                     next = NEXTOPER(NEXTOPER(next));
3754             }
3755             break;
3756         case LOGICAL:
3757             logical = scan->flags;
3758             break;
3759
3760 /*******************************************************************
3761
3762 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
3763 pattern, where A and B are subpatterns. (For simple A, CURLYM or
3764 STAR/PLUS/CURLY/CURLYN are used instead.)
3765
3766 A*B is compiled as <CURLYX><A><WHILEM><B>
3767
3768 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
3769 state, which contains the current count, initialised to -1. It also sets
3770 cur_curlyx to point to this state, with any previous value saved in the
3771 state block.
3772
3773 CURLYX then jumps straight to the WHILEM op, rather than executing A,
3774 since the pattern may possibly match zero times (i.e. it's a while {} loop
3775 rather than a do {} while loop).
3776
3777 Each entry to WHILEM represents a successful match of A. The count in the
3778 CURLYX block is incremented, another WHILEM state is pushed, and execution
3779 passes to A or B depending on greediness and the current count.
3780
3781 For example, if matching against the string a1a2a3b (where the aN are
3782 substrings that match /A/), then the match progresses as follows: (the
3783 pushed states are interspersed with the bits of strings matched so far):
3784
3785     <CURLYX cnt=-1>
3786     <CURLYX cnt=0><WHILEM>
3787     <CURLYX cnt=1><WHILEM> a1 <WHILEM>
3788     <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
3789     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
3790     <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
3791
3792 (Contrast this with something like CURLYM, which maintains only a single
3793 backtrack state:
3794
3795     <CURLYM cnt=0> a1
3796     a1 <CURLYM cnt=1> a2
3797     a1 a2 <CURLYM cnt=2> a3
3798     a1 a2 a3 <CURLYM cnt=3> b
3799 )
3800
3801 Each WHILEM state block marks a point to backtrack to upon partial failure
3802 of A or B, and also contains some minor state data related to that
3803 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
3804 overall state, such as the count, and pointers to the A and B ops.
3805
3806 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
3807 must always point to the *current* CURLYX block, the rules are:
3808
3809 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
3810 and set cur_curlyx to point the new block.
3811
3812 When popping the CURLYX block after a successful or unsuccessful match,
3813 restore the previous cur_curlyx.
3814
3815 When WHILEM is about to execute B, save the current cur_curlyx, and set it
3816 to the outer one saved in the CURLYX block.
3817
3818 When popping the WHILEM block after a successful or unsuccessful B match,
3819 restore the previous cur_curlyx.
3820
3821 Here's an example for the pattern (AI* BI)*BO
3822 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
3823
3824 cur_
3825 curlyx backtrack stack
3826 ------ ---------------
3827 NULL
3828 CO     <CO prev=NULL> <WO>
3829 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
3830 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
3831 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
3832
3833 At this point the pattern succeeds, and we work back down the stack to
3834 clean up, restoring as we go:
3835
3836 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
3837 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
3838 CO     <CO prev=NULL> <WO>
3839 NULL
3840
3841 *******************************************************************/
3842
3843 #define ST st->u.curlyx
3844
3845         case CURLYX:    /* start of /A*B/  (for complex A) */
3846         {
3847             /* No need to save/restore up to this paren */
3848             I32 parenfloor = scan->flags;
3849
3850             assert(next); /* keep Coverity happy */
3851             if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3852                 next += ARG(next);
3853
3854             /* XXXX Probably it is better to teach regpush to support
3855                parenfloor > PL_regsize... */
3856             if (parenfloor > (I32)*PL_reglastparen)
3857                 parenfloor = *PL_reglastparen; /* Pessimization... */
3858
3859             ST.prev_curlyx= cur_curlyx;
3860             cur_curlyx = st;
3861             ST.cp = PL_savestack_ix;
3862
3863             /* these fields contain the state of the current curly.
3864              * they are accessed by subsequent WHILEMs */
3865             ST.parenfloor = parenfloor;
3866             ST.min = ARG1(scan);
3867             ST.max = ARG2(scan);
3868             ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3869             ST.B = next;
3870             ST.minmod = minmod;
3871             minmod = 0;
3872             ST.count = -1;      /* this will be updated by WHILEM */
3873             ST.lastloc = NULL;  /* this will be updated by WHILEM */
3874
3875             PL_reginput = locinput;
3876             PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
3877             /* NOTREACHED */
3878         }
3879
3880         case CURLYX_end: /* just finished matching all of A*B */
3881             if (PL_reg_eval_set){
3882                 SV *pres= GvSV(PL_replgv);
3883                 SvREFCNT_inc(pres);
3884                 regcpblow(ST.cp);
3885                 sv_setsv(GvSV(PL_replgv), pres);
3886                 SvREFCNT_dec(pres);
3887             } else {
3888                 regcpblow(ST.cp);
3889             }
3890             cur_curlyx = ST.prev_curlyx;
3891             sayYES;
3892             /* NOTREACHED */
3893
3894         case CURLYX_end_fail: /* just failed to match all of A*B */
3895             regcpblow(ST.cp);
3896             cur_curlyx = ST.prev_curlyx;
3897             sayNO;
3898             /* NOTREACHED */
3899
3900
3901 #undef ST
3902 #define ST st->u.whilem
3903
3904         case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
3905         {
3906             /* see the discussion above about CURLYX/WHILEM */
3907             I32 n;
3908             assert(cur_curlyx); /* keep Coverity happy */
3909             n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
3910             ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
3911             ST.cache_offset = 0;
3912             ST.cache_mask = 0;
3913
3914             PL_reginput = locinput;
3915
3916             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3917                   "%*s  whilem: matched %ld out of %ld..%ld\n",
3918                   REPORT_CODE_OFF+depth*2, "", (long)n,
3919                   (long)cur_curlyx->u.curlyx.min,
3920                   (long)cur_curlyx->u.curlyx.max)
3921             );
3922
3923             /* First just match a string of min A's. */
3924
3925             if (n < cur_curlyx->u.curlyx.min) {
3926                 cur_curlyx->u.curlyx.lastloc = locinput;
3927                 PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
3928                 /* NOTREACHED */
3929             }
3930
3931             /* If degenerate A matches "", assume A done. */
3932
3933             if (locinput == cur_curlyx->u.curlyx.lastloc) {
3934                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3935                    "%*s  whilem: empty match detected, trying continuation...\n",
3936                    REPORT_CODE_OFF+depth*2, "")
3937                 );
3938                 goto do_whilem_B_max;
3939             }
3940
3941             /* super-linear cache processing */
3942
3943             if (scan->flags) {
3944
3945                 if (!PL_reg_maxiter) {
3946                     /* start the countdown: Postpone detection until we
3947                      * know the match is not *that* much linear. */
3948                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3949                     /* possible overflow for long strings and many CURLYX's */
3950                     if (PL_reg_maxiter < 0)
3951                         PL_reg_maxiter = I32_MAX;
3952                     PL_reg_leftiter = PL_reg_maxiter;
3953                 }
3954
3955                 if (PL_reg_leftiter-- == 0) {
3956                     /* initialise cache */
3957                     const I32 size = (PL_reg_maxiter + 7)/8;
3958                     if (PL_reg_poscache) {
3959                         if ((I32)PL_reg_poscache_size < size) {
3960                             Renew(PL_reg_poscache, size, char);
3961                             PL_reg_poscache_size = size;
3962                         }
3963                         Zero(PL_reg_poscache, size, char);
3964                     }
3965                     else {
3966                         PL_reg_poscache_size = size;
3967                         Newxz(PL_reg_poscache, size, char);
3968                     }
3969                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3970       "%swhilem: Detected a super-linear match, switching on caching%s...\n",
3971                               PL_colors[4], PL_colors[5])
3972                     );
3973                 }
3974
3975                 if (PL_reg_leftiter < 0) {
3976                     /* have we already failed at this position? */
3977                     I32 offset, mask;
3978                     offset  = (scan->flags & 0xf) - 1
3979                                 + (locinput - PL_bostr)  * (scan->flags>>4);
3980                     mask    = 1 << (offset % 8);
3981                     offset /= 8;
3982                     if (PL_reg_poscache[offset] & mask) {
3983                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3984                             "%*s  whilem: (cache) already tried at this position...\n",
3985                             REPORT_CODE_OFF+depth*2, "")
3986                         );
3987                         sayNO; /* cache records failure */
3988                     }
3989                     ST.cache_offset = offset;
3990                     ST.cache_mask   = mask;
3991                 }
3992             }
3993
3994             /* Prefer B over A for minimal matching. */
3995
3996             if (cur_curlyx->u.curlyx.minmod) {
3997                 ST.save_curlyx = cur_curlyx;
3998                 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
3999                 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4000                 REGCP_SET(ST.lastcp);
4001                 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4002                 /* NOTREACHED */
4003             }
4004
4005             /* Prefer A over B for maximal matching. */
4006
4007             if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
4008                 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4009                 cur_curlyx->u.curlyx.lastloc = locinput;
4010                 REGCP_SET(ST.lastcp);
4011                 PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
4012                 /* NOTREACHED */
4013             }
4014             goto do_whilem_B_max;
4015         }
4016         /* NOTREACHED */
4017
4018         case WHILEM_B_min: /* just matched B in a minimal match */
4019         case WHILEM_B_max: /* just matched B in a maximal match */
4020             cur_curlyx = ST.save_curlyx;
4021             sayYES;
4022             /* NOTREACHED */
4023
4024         case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4025             cur_curlyx = ST.save_curlyx;
4026             cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4027             cur_curlyx->u.curlyx.count--;
4028             CACHEsayNO;
4029             /* NOTREACHED */
4030
4031         case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4032             REGCP_UNWIND(ST.lastcp);
4033             regcppop(rex);
4034             /* FALL THROUGH */
4035         case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4036             cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4037             cur_curlyx->u.curlyx.count--;
4038             CACHEsayNO;
4039             /* NOTREACHED */
4040
4041         case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4042             REGCP_UNWIND(ST.lastcp);
4043             regcppop(rex);      /* Restore some previous $<digit>s? */
4044             PL_reginput = locinput;
4045             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4046                 "%*s  whilem: failed, trying continuation...\n",
4047                 REPORT_CODE_OFF+depth*2, "")
4048             );
4049           do_whilem_B_max:
4050             if (cur_curlyx->u.curlyx.count >= REG_INFTY
4051                 && ckWARN(WARN_REGEXP)
4052                 && !(PL_reg_flags & RF_warned))
4053             {
4054                 PL_reg_flags |= RF_warned;
4055                 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4056                      "Complex regular subexpression recursion",
4057                      REG_INFTY - 1);
4058             }
4059
4060             /* now try B */
4061             ST.save_curlyx = cur_curlyx;
4062             cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4063             PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4064             /* NOTREACHED */
4065
4066         case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4067             cur_curlyx = ST.save_curlyx;
4068             REGCP_UNWIND(ST.lastcp);
4069             regcppop(rex);
4070
4071             if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
4072                 /* Maximum greed exceeded */
4073                 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4074                     && ckWARN(WARN_REGEXP)
4075                     && !(PL_reg_flags & RF_warned))
4076                 {
4077                     PL_reg_flags |= RF_warned;
4078                     Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4079                         "%s limit (%d) exceeded",
4080                         "Complex regular subexpression recursion",
4081                         REG_INFTY - 1);
4082                 }
4083                 cur_curlyx->u.curlyx.count--;
4084                 CACHEsayNO;
4085             }
4086
4087             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4088                 "%*s  trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4089             );
4090             /* Try grabbing another A and see if it helps. */
4091             PL_reginput = locinput;
4092             cur_curlyx->u.curlyx.lastloc = locinput;
4093             ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4094             REGCP_SET(ST.lastcp);
4095             PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
4096             /* NOTREACHED */
4097
4098 #undef  ST
4099 #define ST st->u.branch
4100
4101         case BRANCHJ:       /*  /(...|A|...)/ with long next pointer */
4102             next = scan + ARG(scan);
4103             if (next == scan)
4104                 next = NULL;
4105             scan = NEXTOPER(scan);
4106             /* FALL THROUGH */
4107
4108         case BRANCH:        /*  /(...|A|...)/ */
4109             scan = NEXTOPER(scan); /* scan now points to inner node */
4110             if ((!next || (OP(next) != BRANCH && OP(next) != BRANCHJ))
4111                 && !has_cutgroup)
4112             {
4113                 /* last branch; skip state push and jump direct to node */
4114                 continue;
4115             }
4116             ST.lastparen = *PL_reglastparen;
4117             ST.next_branch = next;
4118             REGCP_SET(ST.cp);
4119             PL_reginput = locinput;
4120
4121             /* Now go into the branch */
4122             if (has_cutgroup) {
4123                 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4124             } else {
4125                 PUSH_STATE_GOTO(BRANCH_next, scan);
4126             }
4127             /* NOTREACHED */
4128         case CUTGROUP:
4129             PL_reginput = locinput;
4130             sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4131                 (SV*)rex->data->data[ ARG( scan ) ];
4132             PUSH_STATE_GOTO(CUTGROUP_next,next);
4133             /* NOTREACHED */
4134         case CUTGROUP_next_fail:
4135             do_cutgroup = 1;
4136             no_final = 1;
4137             if (st->u.mark.mark_name)
4138                 sv_commit = st->u.mark.mark_name;
4139             sayNO;
4140             /* NOTREACHED */
4141         case BRANCH_next:
4142             sayYES;
4143             /* NOTREACHED */
4144         case BRANCH_next_fail: /* that branch failed; try the next, if any */
4145             if (do_cutgroup) {
4146                 do_cutgroup = 0;
4147                 no_final = 0;
4148             }
4149             REGCP_UNWIND(ST.cp);
4150             for (n = *PL_reglastparen; n > ST.lastparen; n--)
4151                 PL_regendp[n] = -1;
4152             *PL_reglastparen = n;
4153             /*dmq: *PL_reglastcloseparen = n; */
4154             scan = ST.next_branch;
4155             /* no more branches? */
4156             if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4157                 DEBUG_EXECUTE_r({
4158                     PerlIO_printf( Perl_debug_log,
4159                         "%*s  %sBRANCH failed...%s\n",
4160                         REPORT_CODE_OFF+depth*2, "",
4161                         PL_colors[4],
4162                         PL_colors[5] );
4163                 });
4164                 sayNO_SILENT;
4165             }
4166             continue; /* execute next BRANCH[J] op */
4167             /* NOTREACHED */
4168
4169         case MINMOD:
4170             minmod = 1;
4171             break;
4172
4173 #undef  ST
4174 #define ST st->u.curlym
4175
4176         case CURLYM:    /* /A{m,n}B/ where A is fixed-length */
4177
4178             /* This is an optimisation of CURLYX that enables us to push
4179              * only a single backtracking state, no matter now many matches
4180              * there are in {m,n}. It relies on the pattern being constant
4181              * length, with no parens to influence future backrefs
4182              */
4183
4184             ST.me = scan;
4185             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4186
4187             /* if paren positive, emulate an OPEN/CLOSE around A */
4188             if (ST.me->flags) {
4189                 U32 paren = ST.me->flags;
4190                 if (paren > PL_regsize)
4191                     PL_regsize = paren;
4192                 if (paren > *PL_reglastparen)
4193                     *PL_reglastparen = paren;
4194                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4195             }
4196             ST.A = scan;
4197             ST.B = next;
4198             ST.alen = 0;
4199             ST.count = 0;
4200             ST.minmod = minmod;
4201             minmod = 0;
4202             ST.c1 = CHRTEST_UNINIT;
4203             REGCP_SET(ST.cp);
4204
4205             if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4206                 goto curlym_do_B;
4207
4208           curlym_do_A: /* execute the A in /A{m,n}B/  */
4209             PL_reginput = locinput;
4210             PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4211             /* NOTREACHED */
4212
4213         case CURLYM_A: /* we've just matched an A */
4214             locinput = st->locinput;
4215             nextchr = UCHARAT(locinput);
4216
4217             ST.count++;
4218             /* after first match, determine A's length: u.curlym.alen */
4219             if (ST.count == 1) {
4220                 if (PL_reg_match_utf8) {
4221                     char *s = locinput;
4222                     while (s < PL_reginput) {
4223                         ST.alen++;
4224                         s += UTF8SKIP(s);
4225                     }
4226                 }
4227                 else {
4228                     ST.alen = PL_reginput - locinput;
4229                 }
4230                 if (ST.alen == 0)
4231                     ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4232             }
4233             DEBUG_EXECUTE_r(
4234                 PerlIO_printf(Perl_debug_log,
4235                           "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4236                           (int)(REPORT_CODE_OFF+(depth*2)), "",
4237                           (IV) ST.count, (IV)ST.alen)
4238             );
4239
4240             locinput = PL_reginput;
4241
4242             if (cur_eval && cur_eval->u.eval.close_paren &&
4243                 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4244                 goto fake_end;
4245
4246             if ( ST.count < (ST.minmod ? ARG1(ST.me) : ARG2(ST.me)) )
4247                 goto curlym_do_A; /* try to match another A */
4248             goto curlym_do_B; /* try to match B */
4249
4250         case CURLYM_A_fail: /* just failed to match an A */
4251             REGCP_UNWIND(ST.cp);
4252
4253             if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4254                 || (cur_eval && cur_eval->u.eval.close_paren &&
4255                     cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4256                 sayNO;
4257
4258           curlym_do_B: /* execute the B in /A{m,n}B/  */
4259             PL_reginput = locinput;
4260             if (ST.c1 == CHRTEST_UNINIT) {
4261                 /* calculate c1 and c2 for possible match of 1st char
4262                  * following curly */
4263                 ST.c1 = ST.c2 = CHRTEST_VOID;
4264                 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4265                     regnode *text_node = ST.B;
4266                     if (! HAS_TEXT(text_node))
4267                         FIND_NEXT_IMPT(text_node);
4268                     if (HAS_TEXT(text_node)
4269                         && PL_regkind[OP(text_node)] != REF)
4270                     {
4271                         ST.c1 = (U8)*STRING(text_node);
4272                         ST.c2 =
4273                             (OP(text_node) == EXACTF || OP(text_node) == REFF)
4274                             ? PL_fold[ST.c1]
4275                             : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4276                                 ? PL_fold_locale[ST.c1]
4277                                 : ST.c1;
4278                     }
4279                 }
4280             }
4281
4282             DEBUG_EXECUTE_r(
4283                 PerlIO_printf(Perl_debug_log,
4284                     "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
4285                     (int)(REPORT_CODE_OFF+(depth*2)),
4286                     "", (IV)ST.count)
4287                 );
4288             if (ST.c1 != CHRTEST_VOID
4289                     && UCHARAT(PL_reginput) != ST.c1
4290                     && UCHARAT(PL_reginput) != ST.c2)
4291             {
4292                 /* simulate B failing */
4293                 state_num = CURLYM_B_fail;
4294                 goto reenter_switch;
4295             }
4296
4297             if (ST.me->flags) {
4298                 /* mark current A as captured */
4299                 I32 paren = ST.me->flags;
4300                 if (ST.count) {
4301                     PL_regstartp[paren]
4302                         = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4303                     PL_regendp[paren] = PL_reginput - PL_bostr;
4304                     /*dmq: *PL_reglastcloseparen = paren; */
4305                 }
4306                 else
4307                     PL_regendp[paren] = -1;
4308                 if (cur_eval && cur_eval->u.eval.close_paren &&
4309                     cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4310                 {
4311                     if (ST.count)
4312                         goto fake_end;
4313                     else
4314                         sayNO;
4315                 }
4316             }
4317
4318             PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4319             /* NOTREACHED */
4320
4321         case CURLYM_B_fail: /* just failed to match a B */
4322             REGCP_UNWIND(ST.cp);
4323             if (ST.minmod) {
4324                 if (ST.count == ARG2(ST.me) /* max */)
4325                     sayNO;
4326                 goto curlym_do_A; /* try to match a further A */
4327             }
4328             /* backtrack one A */
4329             if (ST.count == ARG1(ST.me) /* min */)
4330                 sayNO;
4331             ST.count--;
4332             locinput = HOPc(locinput, -ST.alen);
4333             goto curlym_do_B; /* try to match B */
4334
4335 #undef ST
4336 #define ST st->u.curly
4337
4338 #define CURLY_SETPAREN(paren, success) \
4339     if (paren) { \
4340         if (success) { \
4341             PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr; \
4342             PL_regendp[paren] = locinput - PL_bostr; \
4343             *PL_reglastcloseparen = paren; \
4344         } \
4345         else \
4346             PL_regendp[paren] = -1; \
4347     }
4348
4349         case STAR:              /*  /A*B/ where A is width 1 */
4350             ST.paren = 0;
4351             ST.min = 0;
4352             ST.max = REG_INFTY;
4353             scan = NEXTOPER(scan);
4354             goto repeat;
4355         case PLUS:              /*  /A+B/ where A is width 1 */
4356             ST.paren = 0;
4357             ST.min = 1;
4358             ST.max = REG_INFTY;
4359             scan = NEXTOPER(scan);
4360             goto repeat;
4361         case CURLYN:            /*  /(A){m,n}B/ where A is width 1 */
4362             ST.paren = scan->flags;     /* Which paren to set */
4363             if (ST.paren > PL_regsize)
4364                 PL_regsize = ST.paren;
4365             if (ST.paren > *PL_reglastparen)
4366                 *PL_reglastparen = ST.paren;
4367             ST.min = ARG1(scan);  /* min to match */
4368             ST.max = ARG2(scan);  /* max to match */
4369             if (cur_eval && cur_eval->u.eval.close_paren &&
4370                 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4371                 ST.min=1;
4372                 ST.max=1;
4373             }
4374             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4375             goto repeat;
4376         case CURLY:             /*  /A{m,n}B/ where A is width 1 */
4377             ST.paren = 0;
4378             ST.min = ARG1(scan);  /* min to match */
4379             ST.max = ARG2(scan);  /* max to match */
4380             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4381           repeat:
4382             /*
4383             * Lookahead to avoid useless match attempts
4384             * when we know what character comes next.
4385             *
4386             * Used to only do .*x and .*?x, but now it allows
4387             * for )'s, ('s and (?{ ... })'s to be in the way
4388             * of the quantifier and the EXACT-like node.  -- japhy
4389             */
4390
4391             if (ST.min > ST.max) /* XXX make this a compile-time check? */
4392                 sayNO;
4393             if (HAS_TEXT(next) || JUMPABLE(next)) {
4394                 U8 *s;
4395                 regnode *text_node = next;
4396
4397                 if (! HAS_TEXT(text_node))
4398                     FIND_NEXT_IMPT(text_node);
4399
4400                 if (! HAS_TEXT(text_node))
4401                     ST.c1 = ST.c2 = CHRTEST_VOID;
4402                 else {
4403                     if (PL_regkind[OP(text_node)] == REF) {
4404                         ST.c1 = ST.c2 = CHRTEST_VOID;
4405                         goto assume_ok_easy;
4406                     }
4407                     else
4408                         s = (U8*)STRING(text_node);
4409
4410                     if (!UTF) {
4411                         ST.c2 = ST.c1 = *s;
4412                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4413                             ST.c2 = PL_fold[ST.c1];
4414                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4415                             ST.c2 = PL_fold_locale[ST.c1];
4416                     }
4417                     else { /* UTF */
4418                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4419                              STRLEN ulen1, ulen2;
4420                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4421                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4422
4423                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4424                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4425 #ifdef EBCDIC
4426                              ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4427                                                     ckWARN(WARN_UTF8) ?
4428                                                     0 : UTF8_ALLOW_ANY);
4429                              ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4430                                                     ckWARN(WARN_UTF8) ?
4431                                                     0 : UTF8_ALLOW_ANY);
4432 #else
4433                              ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4434                                                     uniflags);
4435                              ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4436                                                     uniflags);
4437 #endif
4438                         }
4439                         else {
4440                             ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4441                                                      uniflags);
4442                         }
4443                     }
4444                 }
4445             }
4446             else
4447                 ST.c1 = ST.c2 = CHRTEST_VOID;
4448         assume_ok_easy:
4449
4450             ST.A = scan;
4451             ST.B = next;
4452             PL_reginput = locinput;
4453             if (minmod) {
4454                 minmod = 0;
4455                 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4456                     sayNO;
4457                 ST.count = ST.min;
4458                 locinput = PL_reginput;
4459                 REGCP_SET(ST.cp);
4460                 if (ST.c1 == CHRTEST_VOID)
4461                     goto curly_try_B_min;
4462
4463                 ST.oldloc = locinput;
4464
4465                 /* set ST.maxpos to the furthest point along the
4466                  * string that could possibly match */
4467                 if  (ST.max == REG_INFTY) {
4468                     ST.maxpos = PL_regeol - 1;
4469                     if (do_utf8)
4470                         while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4471                             ST.maxpos--;
4472                 }
4473                 else if (do_utf8) {
4474                     int m = ST.max - ST.min;
4475                     for (ST.maxpos = locinput;
4476                          m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4477                         ST.maxpos += UTF8SKIP(ST.maxpos);
4478                 }
4479                 else {
4480                     ST.maxpos = locinput + ST.max - ST.min;
4481                     if (ST.maxpos >= PL_regeol)
4482                         ST.maxpos = PL_regeol - 1;
4483                 }
4484                 goto curly_try_B_min_known;
4485
4486             }
4487             else {
4488                 ST.count = regrepeat(rex, ST.A, ST.max, depth);
4489                 locinput = PL_reginput;
4490                 if (ST.count < ST.min)
4491                     sayNO;
4492                 if ((ST.count > ST.min)
4493                     && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4494                 {
4495                     /* A{m,n} must come at the end of the string, there's
4496                      * no point in backing off ... */
4497                     ST.min = ST.count;
4498                     /* ...except that $ and \Z can match before *and* after
4499                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4500                        We may back off by one in this case. */
4501                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4502                         ST.min--;
4503                 }
4504                 REGCP_SET(ST.cp);
4505                 goto curly_try_B_max;
4506             }
4507             /* NOTREACHED */
4508
4509
4510         case CURLY_B_min_known_fail:
4511             /* failed to find B in a non-greedy match where c1,c2 valid */
4512             if (ST.paren && ST.count)
4513                 PL_regendp[ST.paren] = -1;
4514
4515             PL_reginput = locinput;     /* Could be reset... */
4516             REGCP_UNWIND(ST.cp);
4517             /* Couldn't or didn't -- move forward. */
4518             ST.oldloc = locinput;
4519             if (do_utf8)
4520                 locinput += UTF8SKIP(locinput);
4521             else
4522                 locinput++;
4523             ST.count++;
4524           curly_try_B_min_known:
4525              /* find the next place where 'B' could work, then call B */
4526             {
4527                 int n;
4528                 if (do_utf8) {
4529                     n = (ST.oldloc == locinput) ? 0 : 1;
4530                     if (ST.c1 == ST.c2) {
4531                         STRLEN len;
4532                         /* set n to utf8_distance(oldloc, locinput) */
4533                         while (locinput <= ST.maxpos &&
4534                                utf8n_to_uvchr((U8*)locinput,
4535                                               UTF8_MAXBYTES, &len,
4536                                               uniflags) != (UV)ST.c1) {
4537                             locinput += len;
4538                             n++;
4539                         }
4540                     }
4541                     else {
4542                         /* set n to utf8_distance(oldloc, locinput) */
4543                         while (locinput <= ST.maxpos) {
4544                             STRLEN len;
4545                             const UV c = utf8n_to_uvchr((U8*)locinput,
4546                                                   UTF8_MAXBYTES, &len,
4547                                                   uniflags);
4548                             if (c == (UV)ST.c1 || c == (UV)ST.c2)
4549                                 break;
4550                             locinput += len;
4551                             n++;
4552                         }
4553                     }
4554                 }
4555                 else {
4556                     if (ST.c1 == ST.c2) {
4557                         while (locinput <= ST.maxpos &&
4558                                UCHARAT(locinput) != ST.c1)
4559                             locinput++;
4560                     }
4561                     else {
4562                         while (locinput <= ST.maxpos
4563                                && UCHARAT(locinput) != ST.c1
4564                                && UCHARAT(locinput) != ST.c2)
4565                             locinput++;
4566                     }
4567                     n = locinput - ST.oldloc;
4568                 }
4569                 if (locinput > ST.maxpos)
4570                     sayNO;
4571                 /* PL_reginput == oldloc now */
4572                 if (n) {
4573                     ST.count += n;
4574                     if (regrepeat(rex, ST.A, n, depth) < n)
4575                         sayNO;
4576                 }
4577                 PL_reginput = locinput;
4578                 CURLY_SETPAREN(ST.paren, ST.count);
4579                 if (cur_eval && cur_eval->u.eval.close_paren &&
4580                     cur_eval->u.eval.close_paren == (U32)ST.paren) {
4581                     goto fake_end;
4582                 }
4583                 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
4584             }
4585             /* NOTREACHED */
4586
4587
4588         case CURLY_B_min_fail:
4589             /* failed to find B in a non-greedy match where c1,c2 invalid */
4590             if (ST.paren && ST.count)
4591                 PL_regendp[ST.paren] = -1;
4592
4593             REGCP_UNWIND(ST.cp);
4594             /* failed -- move forward one */
4595             PL_reginput = locinput;
4596             if (regrepeat(rex, ST.A, 1, depth)) {
4597                 ST.count++;
4598                 locinput = PL_reginput;
4599                 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
4600                         ST.count > 0)) /* count overflow ? */
4601                 {
4602                   curly_try_B_min:
4603                     CURLY_SETPAREN(ST.paren, ST.count);
4604                     if (cur_eval && cur_eval->u.eval.close_paren &&
4605                         cur_eval->u.eval.close_paren == (U32)ST.paren) {
4606                         goto fake_end;
4607                     }
4608                     PUSH_STATE_GOTO(CURLY_B_min, ST.B);
4609                 }
4610             }
4611             sayNO;
4612             /* NOTREACHED */
4613
4614
4615         curly_try_B_max:
4616             /* a successful greedy match: now try to match B */
4617             if (cur_eval && cur_eval->u.eval.close_paren &&
4618                 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4619                 goto fake_end;
4620             }
4621             {
4622                 UV c = 0;
4623                 if (ST.c1 != CHRTEST_VOID)
4624                     c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
4625                                            UTF8_MAXBYTES, 0, uniflags)
4626                                 : (UV) UCHARAT(PL_reginput);
4627                 /* If it could work, try it. */
4628                 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
4629                     CURLY_SETPAREN(ST.paren, ST.count);
4630                     PUSH_STATE_GOTO(CURLY_B_max, ST.B);
4631                     /* NOTREACHED */
4632                 }
4633             }
4634             /* FALL THROUGH */
4635         case CURLY_B_max_fail:
4636             /* failed to find B in a greedy match */
4637             if (ST.paren && ST.count)
4638                 PL_regendp[ST.paren] = -1;
4639
4640             REGCP_UNWIND(ST.cp);
4641             /*  back up. */
4642             if (--ST.count < ST.min)
4643                 sayNO;
4644             PL_reginput = locinput = HOPc(locinput, -1);
4645             goto curly_try_B_max;
4646
4647 #undef ST
4648
4649         case END:
4650             fake_end:
4651             if (cur_eval) {
4652                 /* we've just finished A in /(??{A})B/; now continue with B */
4653                 I32 tmpix;
4654
4655
4656                 st->u.eval.toggle_reg_flags
4657                             = cur_eval->u.eval.toggle_reg_flags;
4658                 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
4659
4660                 st->u.eval.prev_rex = rex;              /* inner */
4661                 rex    = cur_eval->u.eval.prev_rex;     /* outer */
4662                 cur_curlyx = cur_eval->u.eval.prev_curlyx;
4663                 ReREFCNT_inc(rex);
4664                 st->u.eval.cp = regcppush(0);   /* Save *all* the positions. */
4665                 REGCP_SET(st->u.eval.lastcp);
4666                 PL_reginput = locinput;
4667
4668                 /* Restore parens of the outer rex without popping the
4669                  * savestack */
4670                 tmpix = PL_savestack_ix;
4671                 PL_savestack_ix = cur_eval->u.eval.lastcp;
4672                 regcppop(rex);
4673                 PL_savestack_ix = tmpix;
4674
4675                 st->u.eval.prev_eval = cur_eval;
4676                 cur_eval = cur_eval->u.eval.prev_eval;
4677                 DEBUG_EXECUTE_r(
4678                     PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ... %"UVxf"\n",
4679                                       REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
4680                 PUSH_YES_STATE_GOTO(EVAL_AB,
4681                         st->u.eval.prev_eval->u.eval.B); /* match B */
4682             }
4683
4684             if (locinput < reginfo->till) {
4685                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4686                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4687                                       PL_colors[4],
4688                                       (long)(locinput - PL_reg_starttry),
4689                                       (long)(reginfo->till - PL_reg_starttry),
4690                                       PL_colors[5]));
4691                 sayNO_SILENT;           /* Cannot match: too short. */
4692             }
4693             PL_reginput = locinput;     /* put where regtry can find it */
4694             sayYES;                     /* Success! */
4695
4696         case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4697             DEBUG_EXECUTE_r(
4698             PerlIO_printf(Perl_debug_log,
4699                 "%*s  %ssubpattern success...%s\n",
4700                 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
4701             PL_reginput = locinput;     /* put where regtry can find it */
4702             sayYES;                     /* Success! */
4703
4704 #undef  ST
4705 #define ST st->u.ifmatch
4706
4707         case SUSPEND:   /* (?>A) */
4708             ST.wanted = 1;
4709             PL_reginput = locinput;
4710             goto do_ifmatch;
4711
4712         case UNLESSM:   /* -ve lookaround: (?!A), or with flags, (?<!A) */
4713             ST.wanted = 0;
4714             goto ifmatch_trivial_fail_test;
4715
4716         case IFMATCH:   /* +ve lookaround: (?=A), or with flags, (?<=A) */
4717             ST.wanted = 1;
4718           ifmatch_trivial_fail_test:
4719             if (scan->flags) {
4720                 char * const s = HOPBACKc(locinput, scan->flags);
4721                 if (!s) {
4722                     /* trivial fail */
4723                     if (logical) {
4724                         logical = 0;
4725                         sw = 1 - (bool)ST.wanted;
4726                     }
4727                     else if (ST.wanted)
4728                         sayNO;
4729                     next = scan + ARG(scan);
4730                     if (next == scan)
4731                         next = NULL;
4732                     break;
4733                 }
4734                 PL_reginput = s;
4735             }
4736             else
4737                 PL_reginput = locinput;
4738
4739           do_ifmatch:
4740             ST.me = scan;
4741             ST.logical = logical;
4742             /* execute body of (?...A) */
4743             PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
4744             /* NOTREACHED */
4745
4746         case IFMATCH_A_fail: /* body of (?...A) failed */
4747             ST.wanted = !ST.wanted;
4748             /* FALL THROUGH */
4749
4750         case IFMATCH_A: /* body of (?...A) succeeded */
4751             if (ST.logical) {
4752                 sw = (bool)ST.wanted;
4753             }
4754             else if (!ST.wanted)
4755                 sayNO;
4756
4757             if (OP(ST.me) == SUSPEND)
4758                 locinput = PL_reginput;
4759             else {
4760                 locinput = PL_reginput = st->locinput;
4761                 nextchr = UCHARAT(locinput);
4762             }
4763             scan = ST.me + ARG(ST.me);
4764             if (scan == ST.me)
4765                 scan = NULL;
4766             continue; /* execute B */
4767
4768 #undef ST
4769
4770         case LONGJMP:
4771             next = scan + ARG(scan);
4772             if (next == scan)
4773                 next = NULL;
4774             break;
4775         case COMMIT:
4776             reginfo->cutpoint = PL_regeol;
4777             /* FALLTHROUGH */
4778         case PRUNE:
4779             PL_reginput = locinput;
4780             if (!scan->flags)
4781                 sv_yes_mark = sv_commit = (SV*)rex->data->data[ ARG( scan ) ];
4782             PUSH_STATE_GOTO(COMMIT_next,next);
4783             /* NOTREACHED */
4784         case COMMIT_next_fail:
4785             no_final = 1;
4786             /* FALLTHROUGH */
4787         case OPFAIL:
4788             sayNO;
4789             /* NOTREACHED */
4790
4791 #define ST st->u.mark
4792         case MARKPOINT:
4793             ST.prev_mark = mark_state;
4794             ST.mark_name = sv_commit = sv_yes_mark
4795                 = (SV*)rex->data->data[ ARG( scan ) ];
4796             mark_state = st;
4797             ST.mark_loc = PL_reginput = locinput;
4798             PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
4799             /* NOTREACHED */
4800         case MARKPOINT_next:
4801             mark_state = ST.prev_mark;
4802             sayYES;
4803             /* NOTREACHED */
4804         case MARKPOINT_next_fail:
4805             if (popmark && sv_eq(ST.mark_name,popmark))
4806             {
4807                 if (ST.mark_loc > startpoint)
4808                     reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
4809                 popmark = NULL; /* we found our mark */
4810                 sv_commit = ST.mark_name;
4811
4812                 DEBUG_EXECUTE_r({
4813                         PerlIO_printf(Perl_debug_log,
4814                             "%*s  %ssetting cutpoint to mark:%"SVf"...%s\n",
4815                             REPORT_CODE_OFF+depth*2, "",
4816                             PL_colors[4], sv_commit, PL_colors[5]);
4817                 });
4818             }
4819             mark_state = ST.prev_mark;
4820             sv_yes_mark = mark_state ?
4821                 mark_state->u.mark.mark_name : NULL;
4822             sayNO;
4823             /* NOTREACHED */
4824         case SKIP:
4825             PL_reginput = locinput;
4826             if (scan->flags) {
4827                 /* (*CUT) : if we fail we cut here*/
4828                 ST.mark_name = NULL;
4829                 ST.mark_loc = locinput;
4830                 PUSH_STATE_GOTO(SKIP_next,next);
4831             } else {
4832                 /* (*CUT:NAME) : if there is a (*MARK:NAME) fail where it was,
4833                    otherwise do nothing.  Meaning we need to scan
4834                  */
4835                 regmatch_state *cur = mark_state;
4836                 SV *find = (SV*)rex->data->data[ ARG( scan ) ];
4837
4838                 while (cur) {
4839                     if ( sv_eq( cur->u.mark.mark_name,
4840                                 find ) )
4841                     {
4842                         ST.mark_name = find;
4843                         PUSH_STATE_GOTO( SKIP_next, next );
4844                     }
4845                     cur = cur->u.mark.prev_mark;
4846                 }
4847             }
4848             /* Didn't find our (*MARK:NAME) so ignore this (*CUT:NAME) */
4849             break;
4850         case SKIP_next_fail:
4851             if (ST.mark_name) {
4852                 /* (*CUT:NAME) - Set up to search for the name as we
4853                    collapse the stack*/
4854                 popmark = ST.mark_name;
4855             } else {
4856                 /* (*CUT) - No name, we cut here.*/
4857                 if (ST.mark_loc > startpoint)
4858                     reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
4859                 /* but we set sv_commit to latest mark_name if there
4860                    is one so they can test to see how things lead to this
4861                    cut */
4862                 if (mark_state)
4863                     sv_commit=mark_state->u.mark.mark_name;
4864             }
4865             no_final = 1;
4866             sayNO;
4867             /* NOTREACHED */
4868 #undef ST
4869
4870         default:
4871             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4872                           PTR2UV(scan), OP(scan));
4873             Perl_croak(aTHX_ "regexp memory corruption");
4874
4875         } /* end switch */
4876
4877         /* switch break jumps here */
4878         scan = next; /* prepare to execute the next op and ... */
4879         continue;    /* ... jump back to the top, reusing st */
4880         /* NOTREACHED */
4881
4882       push_yes_state:
4883         /* push a state that backtracks on success */
4884         st->u.yes.prev_yes_state = yes_state;
4885         yes_state = st;
4886         /* FALL THROUGH */
4887       push_state:
4888         /* push a new regex state, then continue at scan  */
4889         {
4890             regmatch_state *newst;
4891
4892             DEBUG_STACK_r({
4893                 regmatch_state *cur = st;
4894                 regmatch_state *curyes = yes_state;
4895                 int curd = depth;
4896                 regmatch_slab *slab = PL_regmatch_slab;
4897                 for (;curd > -1;cur--,curd--) {
4898                     if (cur < SLAB_FIRST(slab)) {
4899                         slab = slab->prev;
4900                         cur = SLAB_LAST(slab);
4901                     }
4902                     PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
4903                         REPORT_CODE_OFF + 2 + depth * 2,"",
4904                         curd, reg_name[cur->resume_state],
4905                         (curyes == cur) ? "yes" : ""
4906                     );
4907                     if (curyes == cur)
4908                         curyes = cur->u.yes.prev_yes_state;
4909                 }
4910             } else
4911                 DEBUG_STATE_pp("push")
4912             );
4913             depth++;
4914             st->locinput = locinput;
4915             newst = st+1;
4916             if (newst >  SLAB_LAST(PL_regmatch_slab))
4917                 newst = S_push_slab(aTHX);
4918             PL_regmatch_state = newst;
4919
4920             locinput = PL_reginput;
4921             nextchr = UCHARAT(locinput);
4922             st = newst;
4923             continue;
4924             /* NOTREACHED */
4925         }
4926     }
4927
4928     /*
4929     * We get here only if there's trouble -- normally "case END" is
4930     * the terminating point.
4931     */
4932     Perl_croak(aTHX_ "corrupted regexp pointers");
4933     /*NOTREACHED*/
4934     sayNO;
4935
4936 yes:
4937     if (yes_state) {
4938         /* we have successfully completed a subexpression, but we must now
4939          * pop to the state marked by yes_state and continue from there */
4940         assert(st != yes_state);
4941 #ifdef DEBUGGING
4942         while (st != yes_state) {
4943             st--;
4944             if (st < SLAB_FIRST(PL_regmatch_slab)) {
4945                 PL_regmatch_slab = PL_regmatch_slab->prev;
4946                 st = SLAB_LAST(PL_regmatch_slab);
4947             }
4948             DEBUG_STATE_r({
4949                 if (no_final) {
4950                     DEBUG_STATE_pp("pop (no final)");
4951                 } else {
4952                     DEBUG_STATE_pp("pop (yes)");
4953                 }
4954             });
4955             depth--;
4956         }
4957 #else
4958         while (yes_state < SLAB_FIRST(PL_regmatch_slab)
4959             || yes_state > SLAB_LAST(PL_regmatch_slab))
4960         {
4961             /* not in this slab, pop slab */
4962             depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
4963             PL_regmatch_slab = PL_regmatch_slab->prev;
4964             st = SLAB_LAST(PL_regmatch_slab);
4965         }
4966         depth -= (st - yes_state);
4967 #endif
4968         st = yes_state;
4969         yes_state = st->u.yes.prev_yes_state;
4970         PL_regmatch_state = st;
4971
4972         if (no_final) {
4973             locinput= st->locinput;
4974             nextchr = UCHARAT(locinput);
4975         }
4976         state_num = st->resume_state + no_final;
4977         goto reenter_switch;
4978     }
4979
4980     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4981                           PL_colors[4], PL_colors[5]));
4982
4983     result = 1;
4984     goto final_exit;
4985
4986 no:
4987     DEBUG_EXECUTE_r(
4988         PerlIO_printf(Perl_debug_log,
4989             "%*s  %sfailed...%s\n",
4990             REPORT_CODE_OFF+depth*2, "",
4991             PL_colors[4], PL_colors[5])
4992         );
4993
4994 no_silent:
4995     if (no_final) {
4996         if (yes_state) {
4997             goto yes;
4998         } else {
4999             goto final_exit;
5000         }
5001     }
5002     if (depth) {
5003         /* there's a previous state to backtrack to */
5004         st--;
5005         if (st < SLAB_FIRST(PL_regmatch_slab)) {
5006             PL_regmatch_slab = PL_regmatch_slab->prev;
5007             st = SLAB_LAST(PL_regmatch_slab);
5008         }
5009         PL_regmatch_state = st;
5010         locinput= st->locinput;
5011         nextchr = UCHARAT(locinput);
5012
5013         DEBUG_STATE_pp("pop");
5014         depth--;
5015         if (yes_state == st)
5016             yes_state = st->u.yes.prev_yes_state;
5017
5018         state_num = st->resume_state + 1; /* failure = success + 1 */
5019         goto reenter_switch;
5020     }
5021     result = 0;
5022
5023   final_exit:
5024     if (rex->reganch & ROPT_VERBARG_SEEN) {
5025         SV *sv_err = get_sv("REGERROR", 1);
5026         SV *sv_mrk = get_sv("REGMARK", 1);
5027         if (result) {
5028             sv_commit = &PL_sv_no;
5029             if (!sv_yes_mark)
5030                 sv_yes_mark = &PL_sv_yes;
5031         } else {
5032             if (!sv_commit)
5033                 sv_commit = &PL_sv_yes;
5034             sv_yes_mark = &PL_sv_no;
5035         }
5036         sv_setsv(sv_err, sv_commit);
5037         sv_setsv(sv_mrk, sv_yes_mark);
5038     }
5039     /* restore original high-water mark */
5040     PL_regmatch_slab  = orig_slab;
5041     PL_regmatch_state = orig_state;
5042
5043     /* free all slabs above current one */
5044     if (orig_slab->next) {
5045         regmatch_slab *sl = orig_slab->next;
5046         orig_slab->next = NULL;
5047         while (sl) {
5048             regmatch_slab * const osl = sl;
5049             sl = sl->next;
5050             Safefree(osl);
5051         }
5052     }
5053
5054     return result;
5055 }
5056
5057 /*
5058  - regrepeat - repeatedly match something simple, report how many
5059  */
5060 /*
5061  * [This routine now assumes that it will only match on things of length 1.
5062  * That was true before, but now we assume scan - reginput is the count,
5063  * rather than incrementing count on every character.  [Er, except utf8.]]
5064  */
5065 STATIC I32
5066 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5067 {
5068     dVAR;
5069     register char *scan;
5070     register I32 c;
5071     register char *loceol = PL_regeol;
5072     register I32 hardcount = 0;
5073     register bool do_utf8 = PL_reg_match_utf8;
5074
5075     scan = PL_reginput;
5076     if (max == REG_INFTY)
5077         max = I32_MAX;
5078     else if (max < loceol - scan)
5079         loceol = scan + max;
5080     switch (OP(p)) {
5081     case REG_ANY:
5082         if (do_utf8) {
5083             loceol = PL_regeol;
5084             while (scan < loceol && hardcount < max && *scan != '\n') {
5085                 scan += UTF8SKIP(scan);
5086                 hardcount++;
5087             }
5088         } else {
5089             while (scan < loceol && *scan != '\n')
5090                 scan++;
5091         }
5092         break;
5093     case SANY:
5094         if (do_utf8) {
5095             loceol = PL_regeol;
5096             while (scan < loceol && hardcount < max) {
5097                 scan += UTF8SKIP(scan);
5098                 hardcount++;
5099             }
5100         }
5101         else
5102             scan = loceol;
5103         break;
5104     case CANY:
5105         scan = loceol;
5106         break;
5107     case EXACT:         /* length of string is 1 */
5108         c = (U8)*STRING(p);
5109         while (scan < loceol && UCHARAT(scan) == c)
5110             scan++;
5111         break;
5112     case EXACTF:        /* length of string is 1 */
5113         c = (U8)*STRING(p);
5114         while (scan < loceol &&
5115                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5116             scan++;
5117         break;
5118     case EXACTFL:       /* length of string is 1 */
5119         PL_reg_flags |= RF_tainted;
5120         c = (U8)*STRING(p);
5121         while (scan < loceol &&
5122                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5123             scan++;
5124         break;
5125     case ANYOF:
5126         if (do_utf8) {
5127             loceol = PL_regeol;
5128             while (hardcount < max && scan < loceol &&
5129                    reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
5130                 scan += UTF8SKIP(scan);
5131                 hardcount++;
5132             }
5133         } else {
5134             while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5135                 scan++;
5136         }
5137         break;
5138     case ALNUM:
5139         if (do_utf8) {
5140             loceol = PL_regeol;
5141             LOAD_UTF8_CHARCLASS_ALNUM();
5142             while (hardcount < max && scan < loceol &&
5143                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5144                 scan += UTF8SKIP(scan);
5145                 hardcount++;
5146             }
5147         } else {
5148             while (scan < loceol && isALNUM(*scan))
5149                 scan++;
5150         }
5151         break;
5152     case ALNUML:
5153         PL_reg_flags |= RF_tainted;
5154         if (do_utf8) {
5155             loceol = PL_regeol;
5156             while (hardcount < max && scan < loceol &&
5157                    isALNUM_LC_utf8((U8*)scan)) {
5158                 scan += UTF8SKIP(scan);
5159                 hardcount++;
5160             }
5161         } else {
5162             while (scan < loceol && isALNUM_LC(*scan))
5163                 scan++;
5164         }
5165         break;
5166     case NALNUM:
5167         if (do_utf8) {
5168             loceol = PL_regeol;
5169             LOAD_UTF8_CHARCLASS_ALNUM();
5170             while (hardcount < max && scan < loceol &&
5171                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5172                 scan += UTF8SKIP(scan);
5173                 hardcount++;
5174             }
5175         } else {
5176             while (scan < loceol && !isALNUM(*scan))
5177                 scan++;
5178         }
5179         break;
5180     case NALNUML:
5181         PL_reg_flags |= RF_tainted;
5182         if (do_utf8) {
5183             loceol = PL_regeol;
5184             while (hardcount < max && scan < loceol &&
5185                    !isALNUM_LC_utf8((U8*)scan)) {
5186                 scan += UTF8SKIP(scan);
5187                 hardcount++;
5188             }
5189         } else {
5190             while (scan < loceol && !isALNUM_LC(*scan))
5191                 scan++;
5192         }
5193         break;
5194     case SPACE:
5195         if (do_utf8) {
5196             loceol = PL_regeol;
5197             LOAD_UTF8_CHARCLASS_SPACE();
5198             while (hardcount < max && scan < loceol &&
5199                    (*scan == ' ' ||
5200                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5201                 scan += UTF8SKIP(scan);
5202                 hardcount++;
5203             }
5204         } else {
5205             while (scan < loceol && isSPACE(*scan))
5206                 scan++;
5207         }
5208         break;
5209     case SPACEL:
5210         PL_reg_flags |= RF_tainted;
5211         if (do_utf8) {
5212             loceol = PL_regeol;
5213             while (hardcount < max && scan < loceol &&
5214                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5215                 scan += UTF8SKIP(scan);
5216                 hardcount++;
5217             }
5218         } else {
5219             while (scan < loceol && isSPACE_LC(*scan))
5220                 scan++;
5221         }
5222         break;
5223     case NSPACE:
5224         if (do_utf8) {
5225             loceol = PL_regeol;
5226             LOAD_UTF8_CHARCLASS_SPACE();
5227             while (hardcount < max && scan < loceol &&
5228                    !(*scan == ' ' ||
5229                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5230                 scan += UTF8SKIP(scan);
5231                 hardcount++;
5232             }
5233         } else {
5234             while (scan < loceol && !isSPACE(*scan))
5235                 scan++;
5236             break;
5237         }
5238     case NSPACEL:
5239         PL_reg_flags |= RF_tainted;
5240         if (do_utf8) {
5241             loceol = PL_regeol;
5242             while (hardcount < max && scan < loceol &&
5243                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5244                 scan += UTF8SKIP(scan);
5245                 hardcount++;
5246             }
5247         } else {
5248             while (scan < loceol && !isSPACE_LC(*scan))
5249                 scan++;
5250         }
5251         break;
5252     case DIGIT:
5253         if (do_utf8) {
5254             loceol = PL_regeol;
5255             LOAD_UTF8_CHARCLASS_DIGIT();
5256             while (hardcount < max && scan < loceol &&
5257                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5258                 scan += UTF8SKIP(scan);
5259                 hardcount++;
5260             }
5261         } else {
5262             while (scan < loceol && isDIGIT(*scan))
5263                 scan++;
5264         }
5265         break;
5266     case NDIGIT:
5267         if (do_utf8) {
5268             loceol = PL_regeol;
5269             LOAD_UTF8_CHARCLASS_DIGIT();
5270             while (hardcount < max && scan < loceol &&
5271                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5272                 scan += UTF8SKIP(scan);
5273                 hardcount++;
5274             }
5275         } else {
5276             while (scan < loceol && !isDIGIT(*scan))
5277                 scan++;
5278         }
5279         break;
5280     default:            /* Called on something of 0 width. */
5281         break;          /* So match right here or not at all. */
5282     }
5283
5284     if (hardcount)
5285         c = hardcount;
5286     else
5287         c = scan - PL_reginput;
5288     PL_reginput = scan;
5289
5290     DEBUG_r({
5291         GET_RE_DEBUG_FLAGS_DECL;
5292         DEBUG_EXECUTE_r({
5293             SV * const prop = sv_newmortal();
5294             regprop(prog, prop, p);
5295             PerlIO_printf(Perl_debug_log,
5296                         "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
5297                         REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5298         });
5299     });
5300
5301     return(c);
5302 }
5303
5304
5305 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5306 /*
5307 - regclass_swash - prepare the utf8 swash
5308 */
5309
5310 SV *
5311 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5312 {
5313     dVAR;
5314     SV *sw  = NULL;
5315     SV *si  = NULL;
5316     SV *alt = NULL;
5317     const struct reg_data * const data = prog ? prog->data : NULL;
5318
5319     if (data && data->count) {
5320         const U32 n = ARG(node);
5321
5322         if (data->what[n] == 's') {
5323             SV * const rv = (SV*)data->data[n];
5324             AV * const av = (AV*)SvRV((SV*)rv);
5325             SV **const ary = AvARRAY(av);
5326             SV **a, **b;
5327
5328             /* See the end of regcomp.c:S_regclass() for
5329              * documentation of these array elements. */
5330
5331             si = *ary;
5332             a  = SvROK(ary[1]) ? &ary[1] : 0;
5333             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
5334
5335             if (a)
5336                 sw = *a;
5337             else if (si && doinit) {
5338                 sw = swash_init("utf8", "", si, 1, 0);
5339                 (void)av_store(av, 1, sw);
5340             }
5341             if (b)
5342                 alt = *b;
5343         }
5344     }
5345
5346     if (listsvp)
5347         *listsvp = si;
5348     if (altsvp)
5349         *altsvp  = alt;
5350
5351     return sw;
5352 }
5353 #endif
5354
5355 /*
5356  - reginclass - determine if a character falls into a character class
5357
5358   The n is the ANYOF regnode, the p is the target string, lenp
5359   is pointer to the maximum length of how far to go in the p
5360   (if the lenp is zero, UTF8SKIP(p) is used),
5361   do_utf8 tells whether the target string is in UTF-8.
5362
5363  */
5364
5365 STATIC bool
5366 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5367 {
5368     dVAR;
5369     const char flags = ANYOF_FLAGS(n);
5370     bool match = FALSE;
5371     UV c = *p;
5372     STRLEN len = 0;
5373     STRLEN plen;
5374
5375     if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5376         c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5377                 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5378                 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5379         if (len == (STRLEN)-1)
5380             Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5381     }
5382
5383     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5384     if (do_utf8 || (flags & ANYOF_UNICODE)) {
5385         if (lenp)
5386             *lenp = 0;
5387         if (do_utf8 && !ANYOF_RUNTIME(n)) {
5388             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5389                 match = TRUE;
5390         }
5391         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5392             match = TRUE;
5393         if (!match) {
5394             AV *av;
5395             SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5396
5397             if (sw) {
5398                 if (swash_fetch(sw, p, do_utf8))
5399                     match = TRUE;
5400                 else if (flags & ANYOF_FOLD) {
5401                     if (!match && lenp && av) {
5402                         I32 i;
5403                         for (i = 0; i <= av_len(av); i++) {
5404                             SV* const sv = *av_fetch(av, i, FALSE);
5405                             STRLEN len;
5406                             const char * const s = SvPV_const(sv, len);
5407
5408                             if (len <= plen && memEQ(s, (char*)p, len)) {
5409                                 *lenp = len;
5410                                 match = TRUE;
5411                                 break;
5412                             }
5413                         }
5414                     }
5415                     if (!match) {
5416                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5417                         STRLEN tmplen;
5418
5419                         to_utf8_fold(p, tmpbuf, &tmplen);
5420                         if (swash_fetch(sw, tmpbuf, do_utf8))
5421                             match = TRUE;
5422                     }
5423                 }
5424             }
5425         }
5426         if (match && lenp && *lenp == 0)
5427             *lenp = UNISKIP(NATIVE_TO_UNI(c));
5428     }
5429     if (!match && c < 256) {
5430         if (ANYOF_BITMAP_TEST(n, c))
5431             match = TRUE;
5432         else if (flags & ANYOF_FOLD) {
5433             U8 f;
5434
5435             if (flags & ANYOF_LOCALE) {
5436                 PL_reg_flags |= RF_tainted;
5437                 f = PL_fold_locale[c];
5438             }
5439             else
5440                 f = PL_fold[c];
5441             if (f != c && ANYOF_BITMAP_TEST(n, f))
5442                 match = TRUE;
5443         }
5444
5445         if (!match && (flags & ANYOF_CLASS)) {
5446             PL_reg_flags |= RF_tainted;
5447             if (
5448                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
5449                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
5450                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
5451                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
5452                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
5453                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
5454                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
5455                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5456                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
5457                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
5458                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
5459                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
5460                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
5461                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
5462                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
5463                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
5464                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
5465                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
5466                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
5467                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
5468                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
5469                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
5470                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
5471                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
5472                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
5473                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
5474                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
5475                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
5476                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
5477                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
5478                 ) /* How's that for a conditional? */
5479             {
5480                 match = TRUE;
5481             }
5482         }
5483     }
5484
5485     return (flags & ANYOF_INVERT) ? !match : match;
5486 }
5487
5488 STATIC U8 *
5489 S_reghop3(U8 *s, I32 off, const U8* lim)
5490 {
5491     dVAR;
5492     if (off >= 0) {
5493         while (off-- && s < lim) {
5494             /* XXX could check well-formedness here */
5495             s += UTF8SKIP(s);
5496         }
5497     }
5498     else {
5499         while (off++ && s > lim) {
5500             s--;
5501             if (UTF8_IS_CONTINUED(*s)) {
5502                 while (s > lim && UTF8_IS_CONTINUATION(*s))
5503                     s--;
5504             }
5505             /* XXX could check well-formedness here */
5506         }
5507     }
5508     return s;
5509 }
5510
5511 #ifdef XXX_dmq
5512 /* there are a bunch of places where we use two reghop3's that should
5513    be replaced with this routine. but since thats not done yet
5514    we ifdef it out - dmq
5515 */
5516 STATIC U8 *
5517 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
5518 {
5519     dVAR;
5520     if (off >= 0) {
5521         while (off-- && s < rlim) {
5522             /* XXX could check well-formedness here */
5523             s += UTF8SKIP(s);
5524         }
5525     }
5526     else {
5527         while (off++ && s > llim) {
5528             s--;
5529             if (UTF8_IS_CONTINUED(*s)) {
5530                 while (s > llim && UTF8_IS_CONTINUATION(*s))
5531                     s--;
5532             }
5533             /* XXX could check well-formedness here */
5534         }
5535     }
5536     return s;
5537 }
5538 #endif
5539
5540 STATIC U8 *
5541 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5542 {
5543     dVAR;
5544     if (off >= 0) {
5545         while (off-- && s < lim) {
5546             /* XXX could check well-formedness here */
5547             s += UTF8SKIP(s);
5548         }
5549         if (off >= 0)
5550             return NULL;
5551     }
5552     else {
5553         while (off++ && s > lim) {
5554             s--;
5555             if (UTF8_IS_CONTINUED(*s)) {
5556                 while (s > lim && UTF8_IS_CONTINUATION(*s))
5557                     s--;
5558             }
5559             /* XXX could check well-formedness here */
5560         }
5561         if (off <= 0)
5562             return NULL;
5563     }
5564     return s;
5565 }
5566
5567 static void
5568 restore_pos(pTHX_ void *arg)
5569 {
5570     dVAR;
5571     regexp * const rex = (regexp *)arg;
5572     if (PL_reg_eval_set) {
5573         if (PL_reg_oldsaved) {
5574             rex->subbeg = PL_reg_oldsaved;
5575             rex->sublen = PL_reg_oldsavedlen;
5576 #ifdef PERL_OLD_COPY_ON_WRITE
5577             rex->saved_copy = PL_nrs;
5578 #endif
5579             RX_MATCH_COPIED_on(rex);
5580         }
5581         PL_reg_magic->mg_len = PL_reg_oldpos;
5582         PL_reg_eval_set = 0;
5583         PL_curpm = PL_reg_oldcurpm;
5584     }
5585 }
5586
5587 STATIC void
5588 S_to_utf8_substr(pTHX_ register regexp *prog)
5589 {
5590     if (prog->float_substr && !prog->float_utf8) {
5591         SV* const sv = newSVsv(prog->float_substr);
5592         prog->float_utf8 = sv;
5593         sv_utf8_upgrade(sv);
5594         if (SvTAIL(prog->float_substr))
5595             SvTAIL_on(sv);
5596         if (prog->float_substr == prog->check_substr)
5597             prog->check_utf8 = sv;
5598     }
5599     if (prog->anchored_substr && !prog->anchored_utf8) {
5600         SV* const sv = newSVsv(prog->anchored_substr);
5601         prog->anchored_utf8 = sv;
5602         sv_utf8_upgrade(sv);
5603         if (SvTAIL(prog->anchored_substr))
5604             SvTAIL_on(sv);
5605         if (prog->anchored_substr == prog->check_substr)
5606             prog->check_utf8 = sv;
5607     }
5608 }
5609
5610 STATIC void
5611 S_to_byte_substr(pTHX_ register regexp *prog)
5612 {
5613     dVAR;
5614     if (prog->float_utf8 && !prog->float_substr) {
5615         SV* sv = newSVsv(prog->float_utf8);
5616         prog->float_substr = sv;
5617         if (sv_utf8_downgrade(sv, TRUE)) {
5618             if (SvTAIL(prog->float_utf8))
5619                 SvTAIL_on(sv);
5620         } else {
5621             SvREFCNT_dec(sv);
5622             prog->float_substr = sv = &PL_sv_undef;
5623         }
5624         if (prog->float_utf8 == prog->check_utf8)
5625             prog->check_substr = sv;
5626     }
5627     if (prog->anchored_utf8 && !prog->anchored_substr) {
5628         SV* sv = newSVsv(prog->anchored_utf8);
5629         prog->anchored_substr = sv;
5630         if (sv_utf8_downgrade(sv, TRUE)) {
5631             if (SvTAIL(prog->anchored_utf8))
5632                 SvTAIL_on(sv);
5633         } else {
5634             SvREFCNT_dec(sv);
5635             prog->anchored_substr = sv = &PL_sv_undef;
5636         }
5637         if (prog->anchored_utf8 == prog->check_utf8)
5638             prog->check_substr = sv;
5639     }
5640 }
5641
5642 /*
5643  * Local variables:
5644  * c-indentation-style: bsd
5645  * c-basic-offset: 4
5646  * indent-tabs-mode: t
5647  * End:
5648  *
5649  * ex: set ts=8 sts=4 sw=4 noet:
5650  */