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