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