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 = 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 (prog->reganch & ROPT_ANCH_GPOS) {
1777         if (regtry(&reginfo, reginfo.ganch))
1778             goto got_it;
1779         goto phooey;
1780     }
1781
1782     /* Messy cases:  unanchored match. */
1783     if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1784         /* we have /x+whatever/ */
1785         /* it must be a one character string (XXXX Except UTF?) */
1786         char ch;
1787 #ifdef DEBUGGING
1788         int did_match = 0;
1789 #endif
1790         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1791             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1792         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1793
1794         if (do_utf8) {
1795             REXEC_FBC_SCAN(
1796                 if (*s == ch) {
1797                     DEBUG_EXECUTE_r( did_match = 1 );
1798                     if (regtry(&reginfo, s)) goto got_it;
1799                     s += UTF8SKIP(s);
1800                     while (s < strend && *s == ch)
1801                         s += UTF8SKIP(s);
1802                 }
1803             );
1804         }
1805         else {
1806             REXEC_FBC_SCAN(
1807                 if (*s == ch) {
1808                     DEBUG_EXECUTE_r( did_match = 1 );
1809                     if (regtry(&reginfo, s)) goto got_it;
1810                     s++;
1811                     while (s < strend && *s == ch)
1812                         s++;
1813                 }
1814             );
1815         }
1816         DEBUG_EXECUTE_r(if (!did_match)
1817                 PerlIO_printf(Perl_debug_log,
1818                                   "Did not find anchored character...\n")
1819                );
1820     }
1821     else if (prog->anchored_substr != NULL
1822               || prog->anchored_utf8 != NULL
1823               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1824                   && prog->float_max_offset < strend - s)) {
1825         SV *must;
1826         I32 back_max;
1827         I32 back_min;
1828         char *last;
1829         char *last1;            /* Last position checked before */
1830 #ifdef DEBUGGING
1831         int did_match = 0;
1832 #endif
1833         if (prog->anchored_substr || prog->anchored_utf8) {
1834             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1835                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1836             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1837             back_max = back_min = prog->anchored_offset;
1838         } else {
1839             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1840                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1841             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1842             back_max = prog->float_max_offset;
1843             back_min = prog->float_min_offset;
1844         }
1845
1846
1847         if (must == &PL_sv_undef)
1848             /* could not downgrade utf8 check substring, so must fail */
1849             goto phooey;
1850
1851         if (back_min<0) {
1852             last = strend;
1853         } else {
1854             last = HOP3c(strend,        /* Cannot start after this */
1855                   -(I32)(CHR_SVLEN(must)
1856                          - (SvTAIL(must) != 0) + back_min), strbeg);
1857         }
1858         if (s > PL_bostr)
1859             last1 = HOPc(s, -1);
1860         else
1861             last1 = s - 1;      /* bogus */
1862
1863         /* XXXX check_substr already used to find "s", can optimize if
1864            check_substr==must. */
1865         scream_pos = -1;
1866         dontbother = end_shift;
1867         strend = HOPc(strend, -dontbother);
1868         while ( (s <= last) &&
1869                 ((flags & REXEC_SCREAM)
1870                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
1871                                     end_shift, &scream_pos, 0))
1872                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
1873                                   (unsigned char*)strend, must,
1874                                   multiline ? FBMrf_MULTILINE : 0))) ) {
1875             /* we may be pointing at the wrong string */
1876             if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
1877                 s = strbeg + (s - SvPVX_const(sv));
1878             DEBUG_EXECUTE_r( did_match = 1 );
1879             if (HOPc(s, -back_max) > last1) {
1880                 last1 = HOPc(s, -back_min);
1881                 s = HOPc(s, -back_max);
1882             }
1883             else {
1884                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1885
1886                 last1 = HOPc(s, -back_min);
1887                 s = t;
1888             }
1889             if (do_utf8) {
1890                 while (s <= last1) {
1891                     if (regtry(&reginfo, s))
1892                         goto got_it;
1893                     s += UTF8SKIP(s);
1894                 }
1895             }
1896             else {
1897                 while (s <= last1) {
1898                     if (regtry(&reginfo, s))
1899                         goto got_it;
1900                     s++;
1901                 }
1902             }
1903         }
1904         DEBUG_EXECUTE_r(if (!did_match) {
1905             RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
1906                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1907             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
1908                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
1909                                ? "anchored" : "floating"),
1910                 quoted, RE_SV_TAIL(must));
1911         });
1912         goto phooey;
1913     }
1914     else if ( (c = prog->regstclass) ) {
1915         if (minlen) {
1916             const OPCODE op = OP(prog->regstclass);
1917             /* don't bother with what can't match */
1918             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
1919                 strend = HOPc(strend, -(minlen - 1));
1920         }
1921         DEBUG_EXECUTE_r({
1922             SV * const prop = sv_newmortal();
1923             regprop(prog, prop, c);
1924             {
1925                 RE_PV_QUOTED_DECL(quoted,UTF,PERL_DEBUG_PAD_ZERO(1),
1926                     s,strend-s,60);
1927                 PerlIO_printf(Perl_debug_log,
1928                     "Matching stclass %.*s against %s (%d chars)\n",
1929                     (int)SvCUR(prop), SvPVX_const(prop),
1930                      quoted, (int)(strend - s));
1931             }
1932         });
1933         if (find_byclass(prog, c, s, strend, &reginfo))
1934             goto got_it;
1935         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
1936     }
1937     else {
1938         dontbother = 0;
1939         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
1940             /* Trim the end. */
1941             char *last;
1942             SV* float_real;
1943
1944             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1945                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1946             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
1947
1948             if (flags & REXEC_SCREAM) {
1949                 last = screaminstr(sv, float_real, s - strbeg,
1950                                    end_shift, &scream_pos, 1); /* last one */
1951                 if (!last)
1952                     last = scream_olds; /* Only one occurrence. */
1953                 /* we may be pointing at the wrong string */
1954                 else if (RX_MATCH_COPIED(prog))
1955                     s = strbeg + (s - SvPVX_const(sv));
1956             }
1957             else {
1958                 STRLEN len;
1959                 const char * const little = SvPV_const(float_real, len);
1960
1961                 if (SvTAIL(float_real)) {
1962                     if (memEQ(strend - len + 1, little, len - 1))
1963                         last = strend - len + 1;
1964                     else if (!multiline)
1965                         last = memEQ(strend - len, little, len)
1966                             ? strend - len : NULL;
1967                     else
1968                         goto find_last;
1969                 } else {
1970                   find_last:
1971                     if (len)
1972                         last = rninstr(s, strend, little, little + len);
1973                     else
1974                         last = strend;  /* matching "$" */
1975                 }
1976             }
1977             if (last == NULL) {
1978                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1979                                       "%sCan't trim the tail, match fails (should not happen)%s\n",
1980                                       PL_colors[4], PL_colors[5]));
1981                 goto phooey; /* Should not happen! */
1982             }
1983             dontbother = strend - last + prog->float_min_offset;
1984         }
1985         if (minlen && (dontbother < minlen))
1986             dontbother = minlen - 1;
1987         strend -= dontbother;              /* this one's always in bytes! */
1988         /* We don't know much -- general case. */
1989         if (do_utf8) {
1990             for (;;) {
1991                 if (regtry(&reginfo, s))
1992                     goto got_it;
1993                 if (s >= strend)
1994                     break;
1995                 s += UTF8SKIP(s);
1996             };
1997         }
1998         else {
1999             do {
2000                 if (regtry(&reginfo, s))
2001                     goto got_it;
2002             } while (s++ < strend);
2003         }
2004     }
2005
2006     /* Failure. */
2007     goto phooey;
2008
2009 got_it:
2010     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2011
2012     if (PL_reg_eval_set) {
2013         /* Preserve the current value of $^R */
2014         if (oreplsv != GvSV(PL_replgv))
2015             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2016                                                   restored, the value remains
2017                                                   the same. */
2018         restore_pos(aTHX_ prog);
2019     }
2020
2021     /* make sure $`, $&, $', and $digit will work later */
2022     if ( !(flags & REXEC_NOT_FIRST) ) {
2023         RX_MATCH_COPY_FREE(prog);
2024         if (flags & REXEC_COPY_STR) {
2025             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2026 #ifdef PERL_OLD_COPY_ON_WRITE
2027             if ((SvIsCOW(sv)
2028                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2029                 if (DEBUG_C_TEST) {
2030                     PerlIO_printf(Perl_debug_log,
2031                                   "Copy on write: regexp capture, type %d\n",
2032                                   (int) SvTYPE(sv));
2033                 }
2034                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2035                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2036                 assert (SvPOKp(prog->saved_copy));
2037             } else
2038 #endif
2039             {
2040                 RX_MATCH_COPIED_on(prog);
2041                 s = savepvn(strbeg, i);
2042                 prog->subbeg = s;
2043             }
2044             prog->sublen = i;
2045         }
2046         else {
2047             prog->subbeg = strbeg;
2048             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2049         }
2050     }
2051
2052     return 1;
2053
2054 phooey:
2055     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2056                           PL_colors[4], PL_colors[5]));
2057     if (PL_reg_eval_set)
2058         restore_pos(aTHX_ prog);
2059     return 0;
2060 }
2061
2062 /*
2063  - regtry - try match at specific point
2064  */
2065 STATIC I32                      /* 0 failure, 1 success */
2066 S_regtry(pTHX_ const regmatch_info *reginfo, char *startpos)
2067 {
2068     dVAR;
2069     register I32 *sp;
2070     register I32 *ep;
2071     CHECKPOINT lastcp;
2072     regexp *prog = reginfo->prog;
2073     GET_RE_DEBUG_FLAGS_DECL;
2074
2075 #ifdef DEBUGGING
2076     PL_regindent = 0;   /* XXXX Not good when matches are reenterable... */
2077 #endif
2078     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2079         MAGIC *mg;
2080
2081         PL_reg_eval_set = RS_init;
2082         DEBUG_EXECUTE_r(DEBUG_s(
2083             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2084                           (IV)(PL_stack_sp - PL_stack_base));
2085             ));
2086         SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2087         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2088         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2089         SAVETMPS;
2090         /* Apparently this is not needed, judging by wantarray. */
2091         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2092            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2093
2094         if (reginfo->sv) {
2095             /* Make $_ available to executed code. */
2096             if (reginfo->sv != DEFSV) {
2097                 SAVE_DEFSV;
2098                 DEFSV = reginfo->sv;
2099             }
2100
2101             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2102                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2103                 /* prepare for quick setting of pos */
2104 #ifdef PERL_OLD_COPY_ON_WRITE
2105                 if (SvIsCOW(sv))
2106                     sv_force_normal_flags(sv, 0);
2107 #endif
2108                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2109                                  &PL_vtbl_mglob, NULL, 0);
2110                 mg->mg_len = -1;
2111             }
2112             PL_reg_magic    = mg;
2113             PL_reg_oldpos   = mg->mg_len;
2114             SAVEDESTRUCTOR_X(restore_pos, prog);
2115         }
2116         if (!PL_reg_curpm) {
2117             Newxz(PL_reg_curpm, 1, PMOP);
2118 #ifdef USE_ITHREADS
2119             {
2120                 SV* const repointer = newSViv(0);
2121                 /* so we know which PL_regex_padav element is PL_reg_curpm */
2122                 SvFLAGS(repointer) |= SVf_BREAK;
2123                 av_push(PL_regex_padav,repointer);
2124                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2125                 PL_regex_pad = AvARRAY(PL_regex_padav);
2126             }
2127 #endif
2128         }
2129         PM_SETRE(PL_reg_curpm, prog);
2130         PL_reg_oldcurpm = PL_curpm;
2131         PL_curpm = PL_reg_curpm;
2132         if (RX_MATCH_COPIED(prog)) {
2133             /*  Here is a serious problem: we cannot rewrite subbeg,
2134                 since it may be needed if this match fails.  Thus
2135                 $` inside (?{}) could fail... */
2136             PL_reg_oldsaved = prog->subbeg;
2137             PL_reg_oldsavedlen = prog->sublen;
2138 #ifdef PERL_OLD_COPY_ON_WRITE
2139             PL_nrs = prog->saved_copy;
2140 #endif
2141             RX_MATCH_COPIED_off(prog);
2142         }
2143         else
2144             PL_reg_oldsaved = NULL;
2145         prog->subbeg = PL_bostr;
2146         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2147     }
2148     prog->startp[0] = startpos - PL_bostr;
2149     PL_reginput = startpos;
2150     PL_regstartp = prog->startp;
2151     PL_regendp = prog->endp;
2152     PL_reglastparen = &prog->lastparen;
2153     PL_reglastcloseparen = &prog->lastcloseparen;
2154     prog->lastparen = 0;
2155     prog->lastcloseparen = 0;
2156     PL_regsize = 0;
2157     DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
2158     if (PL_reg_start_tmpl <= prog->nparens) {
2159         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2160         if(PL_reg_start_tmp)
2161             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2162         else
2163             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2164     }
2165
2166     /* XXXX What this code is doing here?!!!  There should be no need
2167        to do this again and again, PL_reglastparen should take care of
2168        this!  --ilya*/
2169
2170     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2171      * Actually, the code in regcppop() (which Ilya may be meaning by
2172      * PL_reglastparen), is not needed at all by the test suite
2173      * (op/regexp, op/pat, op/split), but that code is needed, oddly
2174      * enough, for building DynaLoader, or otherwise this
2175      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2176      * will happen.  Meanwhile, this code *is* needed for the
2177      * above-mentioned test suite tests to succeed.  The common theme
2178      * on those tests seems to be returning null fields from matches.
2179      * --jhi */
2180 #if 1
2181     sp = prog->startp;
2182     ep = prog->endp;
2183     if (prog->nparens) {
2184         register I32 i;
2185         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2186             *++sp = -1;
2187             *++ep = -1;
2188         }
2189     }
2190 #endif
2191     REGCP_SET(lastcp);
2192     if (regmatch(reginfo, prog->program + 1)) {
2193         prog->endp[0] = PL_reginput - PL_bostr;
2194         return 1;
2195     }
2196     REGCP_UNWIND(lastcp);
2197     return 0;
2198 }
2199
2200
2201 #define sayYES goto yes
2202 #define sayNO goto no
2203 #define sayNO_ANYOF goto no_anyof
2204 #define sayYES_FINAL goto yes_final
2205 #define sayNO_FINAL  goto no_final
2206 #define sayNO_SILENT goto do_no
2207 #define saySAME(x) if (x) goto yes; else goto no
2208
2209 #define CACHEsayNO STMT_START { \
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 } STMT_END
2215
2216
2217 /* this is used to determine how far from the left messages like
2218    'failed...' are printed. Currently 29 makes these messages line
2219    up with the opcode they refer to. Earlier perls used 25 which
2220    left these messages outdented making reviewing a debug output
2221    quite difficult.
2222 */
2223 #define REPORT_CODE_OFF 29
2224
2225
2226 /* Make sure there is a test for this +1 options in re_tests */
2227 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2228
2229 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2230 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2231
2232 #define SLAB_FIRST(s) (&(s)->states[0])
2233 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2234
2235 /* grab a new slab and return the first slot in it */
2236
2237 STATIC regmatch_state *
2238 S_push_slab(pTHX)
2239 {
2240 #if PERL_VERSION < 9
2241     dMY_CXT;
2242 #endif
2243     regmatch_slab *s = PL_regmatch_slab->next;
2244     if (!s) {
2245         Newx(s, 1, regmatch_slab);
2246         s->prev = PL_regmatch_slab;
2247         s->next = NULL;
2248         PL_regmatch_slab->next = s;
2249     }
2250     PL_regmatch_slab = s;
2251     return SLAB_FIRST(s);
2252 }
2253
2254 /* simulate a recursive call to regmatch */
2255
2256 #define REGMATCH(ns, where) \
2257     st->scan = scan; \
2258     scan = (ns); \
2259     st->resume_state = resume_##where; \
2260     goto start_recurse; \
2261     resume_point_##where:
2262
2263 /* push a new state then goto it */
2264
2265 #define PUSH_STATE_GOTO(state, node) \
2266     scan = node; \
2267     st->resume_state = state; \
2268     goto push_state;
2269
2270 /* push a new state with success backtracking, then goto it */
2271
2272 #define PUSH_YES_STATE_GOTO(state, node) \
2273     scan = node; \
2274     st->resume_state = state; \
2275     goto push_yes_state;
2276
2277
2278
2279 /*
2280  - regmatch - main matching routine
2281  *
2282  * Conceptually the strategy is simple:  check to see whether the current
2283  * node matches, call self recursively to see whether the rest matches,
2284  * and then act accordingly.  In practice we make some effort to avoid
2285  * recursion, in particular by going through "ordinary" nodes (that don't
2286  * need to know whether the rest of the match failed) by a loop instead of
2287  * by recursion.
2288  */
2289 /* [lwall] I've hoisted the register declarations to the outer block in order to
2290  * maybe save a little bit of pushing and popping on the stack.  It also takes
2291  * advantage of machines that use a register save mask on subroutine entry.
2292  *
2293  * This function used to be heavily recursive, but since this had the
2294  * effect of blowing the CPU stack on complex regexes, it has been
2295  * restructured to be iterative, and to save state onto the heap rather
2296  * than the stack. Essentially whereever regmatch() used to be called, it
2297  * pushes the current state, notes where to return, then jumps back into
2298  * the main loop.
2299  *
2300  * Originally the structure of this function used to look something like
2301
2302     S_regmatch() {
2303         int a = 1, b = 2;
2304         ...
2305         while (scan != NULL) {
2306             a++; // do stuff with a and b
2307             ...
2308             switch (OP(scan)) {
2309                 case FOO: {
2310                     int local = 3;
2311                     ...
2312                     if (regmatch(...))  // recurse
2313                         goto yes;
2314                 }
2315                 ...
2316             }
2317         }
2318         yes:
2319         return 1;
2320     }
2321
2322  * Now it looks something like this:
2323
2324     typedef struct {
2325         int a, b, local;
2326         int resume_state;
2327     } regmatch_state;
2328
2329     S_regmatch() {
2330         regmatch_state *st = new();
2331         int depth=0;
2332         st->a++; // do stuff with a and b
2333         ...
2334         while (scan != NULL) {
2335             ...
2336             switch (OP(scan)) {
2337                 case FOO: {
2338                     st->local = 3;
2339                     ...
2340                     st->scan = scan;
2341                     scan = ...;
2342                     st->resume_state = resume_FOO;
2343                     goto start_recurse; // recurse
2344
2345                     resume_point_FOO:
2346                     if (result)
2347                         goto yes;
2348                 }
2349                 ...
2350             }
2351           start_recurse:
2352             st = new(); push a new state
2353             st->a = 1; st->b = 2;
2354             depth++;
2355         }
2356       yes:
2357         result = 1;
2358         if (depth--) {
2359             st = pop();
2360             switch (resume_state) {
2361             case resume_FOO:
2362                 goto resume_point_FOO;
2363             ...
2364             }
2365         }
2366         return result
2367     }
2368
2369  * WARNING: this means that any line in this function that contains a
2370  * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2371  * regmatch() using gotos instead. Thus the values of any local variables
2372  * not saved in the regmatch_state structure will have been lost when
2373  * execution resumes on the next line .
2374  *
2375  * States (ie the st pointer) are allocated in slabs of about 4K in size.
2376  * PL_regmatch_state always points to the currently active state, and
2377  * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2378  * The first time regmatch is called, the first slab is allocated, and is
2379  * never freed until interpreter desctruction. When the slab is full,
2380  * a new one is allocated chained to the end. At exit from regmatch, slabs
2381  * allocated since entry are freed.
2382  */
2383
2384 /* *** every FOO_fail should = FOO+1 */
2385 #define TRIE_next              (REGNODE_MAX+1)
2386 #define TRIE_next_fail         (REGNODE_MAX+2)
2387 #define EVAL_AB                (REGNODE_MAX+3)
2388 #define EVAL_AB_fail           (REGNODE_MAX+4)
2389 #define resume_CURLYX          (REGNODE_MAX+5)
2390 #define resume_WHILEM1         (REGNODE_MAX+6)
2391 #define resume_WHILEM2         (REGNODE_MAX+7)
2392 #define resume_WHILEM3         (REGNODE_MAX+8)
2393 #define resume_WHILEM4         (REGNODE_MAX+9)
2394 #define resume_WHILEM5         (REGNODE_MAX+10)
2395 #define resume_WHILEM6         (REGNODE_MAX+11)
2396 #define BRANCH_next            (REGNODE_MAX+12)
2397 #define BRANCH_next_fail       (REGNODE_MAX+13)
2398 #define CURLYM_A               (REGNODE_MAX+14)
2399 #define CURLYM_A_fail          (REGNODE_MAX+15)
2400 #define CURLYM_B               (REGNODE_MAX+16)
2401 #define CURLYM_B_fail          (REGNODE_MAX+17)
2402 #define IFMATCH_A              (REGNODE_MAX+18)
2403 #define IFMATCH_A_fail         (REGNODE_MAX+19)
2404 #define CURLY_B_min_known      (REGNODE_MAX+20)
2405 #define CURLY_B_min_known_fail (REGNODE_MAX+21)
2406 #define CURLY_B_min            (REGNODE_MAX+22)
2407 #define CURLY_B_min_fail       (REGNODE_MAX+23)
2408 #define CURLY_B_max            (REGNODE_MAX+24)
2409 #define CURLY_B_max_fail       (REGNODE_MAX+25)
2410
2411
2412 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2413
2414 #ifdef DEBUGGING
2415 STATIC void
2416 S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
2417     const char *start, const char *end, const char *blurb)
2418 {
2419     const bool utf8_pat= prog->reganch & ROPT_UTF8 ? 1 : 0;
2420     if (!PL_colorset)
2421             reginitcolors();
2422     {
2423         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2424             prog->precomp, prog->prelen, 60);
2425
2426         RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2427             start, end - start, 60);
2428
2429         PerlIO_printf(Perl_debug_log,
2430             "%s%s REx%s %s against %s\n",
2431                        PL_colors[4], blurb, PL_colors[5], s0, s1);
2432
2433         if (do_utf8||utf8_pat)
2434             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2435                 utf8_pat ? "pattern" : "",
2436                 utf8_pat && do_utf8 ? " and " : "",
2437                 do_utf8 ? "string" : ""
2438             );
2439     }
2440 }
2441
2442 STATIC void
2443 S_dump_exec_pos(pTHX_ const char *locinput,
2444                       const regnode *scan,
2445                       const char *loc_regeol,
2446                       const char *loc_bostr,
2447                       const char *loc_reg_starttry,
2448                       const bool do_utf8)
2449 {
2450     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2451     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2452     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2453     /* The part of the string before starttry has one color
2454        (pref0_len chars), between starttry and current
2455        position another one (pref_len - pref0_len chars),
2456        after the current position the third one.
2457        We assume that pref0_len <= pref_len, otherwise we
2458        decrease pref0_len.  */
2459     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2460         ? (5 + taill) - l : locinput - loc_bostr;
2461     int pref0_len;
2462
2463     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2464         pref_len++;
2465     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2466     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2467         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2468               ? (5 + taill) - pref_len : loc_regeol - locinput);
2469     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2470         l--;
2471     if (pref0_len < 0)
2472         pref0_len = 0;
2473     if (pref0_len > pref_len)
2474         pref0_len = pref_len;
2475     {
2476         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2477
2478         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2479             (locinput - pref_len),pref0_len, 60, 4, 5);
2480
2481         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2482                     (locinput - pref_len + pref0_len),
2483                     pref_len - pref0_len, 60, 2, 3);
2484
2485         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2486                     locinput, loc_regeol - locinput, 10, 0, 1);
2487
2488         const STRLEN tlen=len0+len1+len2;
2489         PerlIO_printf(Perl_debug_log,
2490                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2491                     (IV)(locinput - loc_bostr),
2492                     len0, s0,
2493                     len1, s1,
2494                     (docolor ? "" : "> <"),
2495                     len2, s2,
2496                     tlen > 19 ? 0 :  19 - tlen,
2497                     "");
2498     }
2499 }
2500
2501 #endif
2502
2503 STATIC I32                      /* 0 failure, 1 success */
2504 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2505 {
2506 #if PERL_VERSION < 9
2507     dMY_CXT;
2508 #endif
2509     dVAR;
2510     register const bool do_utf8 = PL_reg_match_utf8;
2511     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2512
2513     regexp *rex = reginfo->prog;
2514
2515     regmatch_slab  *orig_slab;
2516     regmatch_state *orig_state;
2517
2518     /* the current state. This is a cached copy of PL_regmatch_state */
2519     register regmatch_state *st;
2520
2521     /* cache heavy used fields of st in registers */
2522     register regnode *scan;
2523     register regnode *next;
2524     register I32 n = 0; /* initialize to shut up compiler warning */
2525     register char *locinput = PL_reginput;
2526
2527     /* these variables are NOT saved during a recusive RFEGMATCH: */
2528     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2529     bool result = 0;        /* return value of S_regmatch */
2530     int depth = 0;          /* depth of recursion */
2531     regmatch_state *yes_state = NULL; /* state to pop to on success of
2532                                                             subpattern */
2533     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2534     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2535     U32 state_num;
2536
2537     I32 parenfloor = 0;
2538
2539 #ifdef DEBUGGING
2540     GET_RE_DEBUG_FLAGS_DECL;
2541     PL_regindent++;
2542 #endif
2543
2544     /* on first ever call to regmatch, allocate first slab */
2545     if (!PL_regmatch_slab) {
2546         Newx(PL_regmatch_slab, 1, regmatch_slab);
2547         PL_regmatch_slab->prev = NULL;
2548         PL_regmatch_slab->next = NULL;
2549         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2550     }
2551
2552     /* remember current high-water mark for exit */
2553     /* XXX this should be done with SAVE* instead */
2554     orig_slab  = PL_regmatch_slab;
2555     orig_state = PL_regmatch_state;
2556
2557     /* grab next free state slot */
2558     st = ++PL_regmatch_state;
2559     if (st >  SLAB_LAST(PL_regmatch_slab))
2560         st = PL_regmatch_state = S_push_slab(aTHX);
2561
2562     st->minmod = 0;
2563     st->sw = 0;
2564     st->logical = 0;
2565     cur_curlyx = NULL;
2566
2567     /* Note that nextchr is a byte even in UTF */
2568     nextchr = UCHARAT(locinput);
2569     scan = prog;
2570     while (scan != NULL) {
2571
2572         DEBUG_EXECUTE_r( {
2573             SV * const prop = sv_newmortal();
2574             regnode *rnext=regnext(scan);
2575             DUMP_EXEC_POS( locinput, scan, do_utf8 );
2576             regprop(rex, prop, scan);
2577
2578             PerlIO_printf(Perl_debug_log,
2579                     "%3"IVdf":%*s%s(%"IVdf")\n",
2580                     (IV)(scan - rex->program), PL_regindent*2, "",
2581                     SvPVX_const(prop),
2582                     (PL_regkind[OP(scan)] == END || !rnext) ?
2583                         0 : (IV)(rnext - rex->program));
2584         });
2585
2586         next = scan + NEXT_OFF(scan);
2587         if (next == scan)
2588             next = NULL;
2589         state_num = OP(scan);
2590
2591       reenter_switch:
2592         switch (state_num) {
2593         case BOL:
2594             if (locinput == PL_bostr)
2595             {
2596                 /* reginfo->till = reginfo->bol; */
2597                 break;
2598             }
2599             sayNO;
2600         case MBOL:
2601             if (locinput == PL_bostr ||
2602                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2603             {
2604                 break;
2605             }
2606             sayNO;
2607         case SBOL:
2608             if (locinput == PL_bostr)
2609                 break;
2610             sayNO;
2611         case GPOS:
2612             if (locinput == reginfo->ganch)
2613                 break;
2614             sayNO;
2615         case EOL:
2616                 goto seol;
2617         case MEOL:
2618             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2619                 sayNO;
2620             break;
2621         case SEOL:
2622           seol:
2623             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2624                 sayNO;
2625             if (PL_regeol - locinput > 1)
2626                 sayNO;
2627             break;
2628         case EOS:
2629             if (PL_regeol != locinput)
2630                 sayNO;
2631             break;
2632         case SANY:
2633             if (!nextchr && locinput >= PL_regeol)
2634                 sayNO;
2635             if (do_utf8) {
2636                 locinput += PL_utf8skip[nextchr];
2637                 if (locinput > PL_regeol)
2638                     sayNO;
2639                 nextchr = UCHARAT(locinput);
2640             }
2641             else
2642                 nextchr = UCHARAT(++locinput);
2643             break;
2644         case CANY:
2645             if (!nextchr && locinput >= PL_regeol)
2646                 sayNO;
2647             nextchr = UCHARAT(++locinput);
2648             break;
2649         case REG_ANY:
2650             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2651                 sayNO;
2652             if (do_utf8) {
2653                 locinput += PL_utf8skip[nextchr];
2654                 if (locinput > PL_regeol)
2655                     sayNO;
2656                 nextchr = UCHARAT(locinput);
2657             }
2658             else
2659                 nextchr = UCHARAT(++locinput);
2660             break;
2661
2662 #undef  ST
2663 #define ST st->u.trie
2664         case TRIEC:
2665             /* In this case the charclass data is available inline so
2666                we can fail fast without a lot of extra overhead.
2667              */
2668             if (scan->flags == EXACT || !do_utf8) {
2669                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
2670                     DEBUG_EXECUTE_r(
2671                         PerlIO_printf(Perl_debug_log,
2672                                   "%*s  %sfailed to match trie start class...%s\n",
2673                                   REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2674                     );
2675                     sayNO_SILENT;
2676                     /* NOTREACHED */
2677                 }
2678             }
2679             /* FALL THROUGH */
2680         case TRIE:
2681             {
2682                 /* what type of TRIE am I? (utf8 makes this contextual) */
2683                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2684                     trie_type = do_utf8 ?
2685                           (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2686                         : trie_plain;
2687
2688                 /* what trie are we using right now */
2689                 reg_trie_data * const trie
2690                     = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2691                 U32 state = trie->startstate;
2692
2693                 if (trie->bitmap && trie_type != trie_utf8_fold &&
2694                     !TRIE_BITMAP_TEST(trie,*locinput)
2695                 ) {
2696                     if (trie->states[ state ].wordnum) {
2697                          DEBUG_EXECUTE_r(
2698                             PerlIO_printf(Perl_debug_log,
2699                                           "%*s  %smatched empty string...%s\n",
2700                                           REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2701                         );
2702                         break;
2703                     } else {
2704                         DEBUG_EXECUTE_r(
2705                             PerlIO_printf(Perl_debug_log,
2706                                           "%*s  %sfailed to match trie start class...%s\n",
2707                                           REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2708                         );
2709                         sayNO_SILENT;
2710                    }
2711                 }
2712
2713             {
2714                 U8 *uc = ( U8* )locinput;
2715
2716                 STRLEN len = 0;
2717                 STRLEN foldlen = 0;
2718                 U8 *uscan = (U8*)NULL;
2719                 STRLEN bufflen=0;
2720                 SV *sv_accept_buff = NULL;
2721                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2722
2723                 ST.accepted = 0; /* how many accepting states we have seen */
2724                 ST.B = next;
2725                 ST.jump = trie->jump;
2726
2727 #ifdef DEBUGGING
2728                 ST.me = scan;
2729 #endif
2730
2731
2732
2733                 /*
2734                    traverse the TRIE keeping track of all accepting states
2735                    we transition through until we get to a failing node.
2736                 */
2737
2738                 while ( state && uc <= (U8*)PL_regeol ) {
2739                     U32 base = trie->states[ state ].trans.base;
2740                     UV uvc;
2741                     U16 charid;
2742                     /* We use charid to hold the wordnum as we don't use it
2743                        for charid until after we have done the wordnum logic.
2744                        We define an alias just so that the wordnum logic reads
2745                        more naturally. */
2746
2747 #define got_wordnum charid
2748                     got_wordnum = trie->states[ state ].wordnum;
2749
2750                     if ( got_wordnum ) {
2751                         if ( ! ST.accepted ) {
2752                             ENTER;
2753                             SAVETMPS;
2754                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2755                             sv_accept_buff=newSV(bufflen *
2756                                             sizeof(reg_trie_accepted) - 1);
2757                             SvCUR_set(sv_accept_buff, 0);
2758                             SvPOK_on(sv_accept_buff);
2759                             sv_2mortal(sv_accept_buff);
2760                             SAVETMPS;
2761                             ST.accept_buff =
2762                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2763                         }
2764                         do {
2765                             if (ST.accepted >= bufflen) {
2766                                 bufflen *= 2;
2767                                 ST.accept_buff =(reg_trie_accepted*)
2768                                     SvGROW(sv_accept_buff,
2769                                         bufflen * sizeof(reg_trie_accepted));
2770                             }
2771                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2772                                 + sizeof(reg_trie_accepted));
2773
2774
2775                             ST.accept_buff[ST.accepted].wordnum = got_wordnum;
2776                             ST.accept_buff[ST.accepted].endpos = uc;
2777                             ++ST.accepted;
2778                         } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
2779                     }
2780 #undef got_wordnum
2781
2782                     DEBUG_TRIE_EXECUTE_r({
2783                                 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
2784                                 PerlIO_printf( Perl_debug_log,
2785                                     "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
2786                                     2+PL_regindent * 2, "", PL_colors[4],
2787                                     (UV)state, (UV)ST.accepted );
2788                     });
2789
2790                     if ( base ) {
2791                         REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
2792                             uvc, charid, foldlen, foldbuf, uniflags);
2793
2794                         if (charid &&
2795                              (base + charid > trie->uniquecharcount )
2796                              && (base + charid - 1 - trie->uniquecharcount
2797                                     < trie->lasttrans)
2798                              && trie->trans[base + charid - 1 -
2799                                     trie->uniquecharcount].check == state)
2800                         {
2801                             state = trie->trans[base + charid - 1 -
2802                                 trie->uniquecharcount ].next;
2803                         }
2804                         else {
2805                             state = 0;
2806                         }
2807                         uc += len;
2808
2809                     }
2810                     else {
2811                         state = 0;
2812                     }
2813                     DEBUG_TRIE_EXECUTE_r(
2814                         PerlIO_printf( Perl_debug_log,
2815                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
2816                             charid, uvc, (UV)state, PL_colors[5] );
2817                     );
2818                 }
2819                 if (!ST.accepted )
2820                    sayNO;
2821
2822                 DEBUG_EXECUTE_r(
2823                     PerlIO_printf( Perl_debug_log,
2824                         "%*s  %sgot %"IVdf" possible matches%s\n",
2825                         REPORT_CODE_OFF + PL_regindent * 2, "",
2826                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
2827                 );
2828             }}
2829
2830             /* FALL THROUGH */
2831
2832         case TRIE_next_fail: /* we failed - try next alterative */
2833
2834             if ( ST.accepted == 1 ) {
2835                 /* only one choice left - just continue */
2836                 DEBUG_EXECUTE_r({
2837                     reg_trie_data * const trie
2838                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2839                     SV ** const tmp = RX_DEBUG(reginfo->prog)
2840                                     ? av_fetch( trie->words, ST.accept_buff[ 0 ].wordnum-1, 0 )
2841                                     : NULL;
2842                     PerlIO_printf( Perl_debug_log,
2843                         "%*s  %sonly one match left: #%d <%s>%s\n",
2844                         REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2845                         ST.accept_buff[ 0 ].wordnum,
2846                         tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2847                         PL_colors[5] );
2848                 });
2849                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
2850                 /* in this case we free tmps/leave before we call regmatch
2851                    as we wont be using accept_buff again. */
2852                 FREETMPS;
2853                 LEAVE;
2854                 locinput = PL_reginput;
2855                 nextchr = UCHARAT(locinput);
2856
2857                 if ( !ST.jump )
2858                     scan = ST.B;
2859                 else
2860                     scan = ST.B - ST.jump[ST.accept_buff[0].wordnum];
2861
2862                 continue; /* execute rest of RE */
2863             }
2864
2865             if (!ST.accepted-- ) {
2866                 FREETMPS;
2867                 LEAVE;
2868                 sayNO;
2869             }
2870
2871             /*
2872                There are at least two accepting states left.  Presumably
2873                the number of accepting states is going to be low,
2874                typically two. So we simply scan through to find the one
2875                with lowest wordnum.  Once we find it, we swap the last
2876                state into its place and decrement the size. We then try to
2877                match the rest of the pattern at the point where the word
2878                ends. If we succeed, control just continues along the
2879                regex; if we fail we return here to try the next accepting
2880                state
2881              */
2882
2883             {
2884                 U32 best = 0;
2885                 U32 cur;
2886                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
2887                     DEBUG_TRIE_EXECUTE_r(
2888                         PerlIO_printf( Perl_debug_log,
2889                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
2890                             REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2891                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
2892                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
2893                     );
2894
2895                     if (ST.accept_buff[cur].wordnum <
2896                             ST.accept_buff[best].wordnum)
2897                         best = cur;
2898                 }
2899
2900                 DEBUG_EXECUTE_r({
2901                     reg_trie_data * const trie
2902                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2903                     SV ** const tmp = RX_DEBUG(reginfo->prog)
2904                                 ? av_fetch( trie->words, ST.accept_buff[ best ].wordnum - 1, 0 )
2905                                 : NULL;
2906                     PerlIO_printf( Perl_debug_log, "%*s  %strying alternation #%d <%s> at node #%d %s\n",
2907                         REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2908                         ST.accept_buff[best].wordnum,
2909                         tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", REG_NODE_NUM(scan),
2910                         PL_colors[5] );
2911                 });
2912
2913                 if ( best<ST.accepted ) {
2914                     reg_trie_accepted tmp = ST.accept_buff[ best ];
2915                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
2916                     ST.accept_buff[ ST.accepted ] = tmp;
2917                     best = ST.accepted;
2918                 }
2919                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
2920                 if ( !ST.jump ) {
2921                     PUSH_STATE_GOTO(TRIE_next, ST.B);
2922                     /* NOTREACHED */
2923                 } else {
2924                     PUSH_STATE_GOTO(TRIE_next, ST.B - ST.jump[ST.accept_buff[best].wordnum]);
2925                     /* NOTREACHED */
2926                 }
2927                 /* NOTREACHED */
2928             }
2929             /* NOTREACHED */
2930
2931 #undef  ST
2932
2933         case EXACT: {
2934             char *s = STRING(scan);
2935             st->ln = STR_LEN(scan);
2936             if (do_utf8 != UTF) {
2937                 /* The target and the pattern have differing utf8ness. */
2938                 char *l = locinput;
2939                 const char * const e = s + st->ln;
2940
2941                 if (do_utf8) {
2942                     /* The target is utf8, the pattern is not utf8. */
2943                     while (s < e) {
2944                         STRLEN ulen;
2945                         if (l >= PL_regeol)
2946                              sayNO;
2947                         if (NATIVE_TO_UNI(*(U8*)s) !=
2948                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
2949                                             uniflags))
2950                              sayNO;
2951                         l += ulen;
2952                         s ++;
2953                     }
2954                 }
2955                 else {
2956                     /* The target is not utf8, the pattern is utf8. */
2957                     while (s < e) {
2958                         STRLEN ulen;
2959                         if (l >= PL_regeol)
2960                             sayNO;
2961                         if (NATIVE_TO_UNI(*((U8*)l)) !=
2962                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
2963                                            uniflags))
2964                             sayNO;
2965                         s += ulen;
2966                         l ++;
2967                     }
2968                 }
2969                 locinput = l;
2970                 nextchr = UCHARAT(locinput);
2971                 break;
2972             }
2973             /* The target and the pattern have the same utf8ness. */
2974             /* Inline the first character, for speed. */
2975             if (UCHARAT(s) != nextchr)
2976                 sayNO;
2977             if (PL_regeol - locinput < st->ln)
2978                 sayNO;
2979             if (st->ln > 1 && memNE(s, locinput, st->ln))
2980                 sayNO;
2981             locinput += st->ln;
2982             nextchr = UCHARAT(locinput);
2983             break;
2984             }
2985         case EXACTFL:
2986             PL_reg_flags |= RF_tainted;
2987             /* FALL THROUGH */
2988         case EXACTF: {
2989             char * const s = STRING(scan);
2990             st->ln = STR_LEN(scan);
2991
2992             if (do_utf8 || UTF) {
2993               /* Either target or the pattern are utf8. */
2994                 const char * const l = locinput;
2995                 char *e = PL_regeol;
2996
2997                 if (ibcmp_utf8(s, 0,  st->ln, (bool)UTF,
2998                                l, &e, 0,  do_utf8)) {
2999                      /* One more case for the sharp s:
3000                       * pack("U0U*", 0xDF) =~ /ss/i,
3001                       * the 0xC3 0x9F are the UTF-8
3002                       * byte sequence for the U+00DF. */
3003                      if (!(do_utf8 &&
3004                            toLOWER(s[0]) == 's' &&
3005                            st->ln >= 2 &&
3006                            toLOWER(s[1]) == 's' &&
3007                            (U8)l[0] == 0xC3 &&
3008                            e - l >= 2 &&
3009                            (U8)l[1] == 0x9F))
3010                           sayNO;
3011                 }
3012                 locinput = e;
3013                 nextchr = UCHARAT(locinput);
3014                 break;
3015             }
3016
3017             /* Neither the target and the pattern are utf8. */
3018
3019             /* Inline the first character, for speed. */
3020             if (UCHARAT(s) != nextchr &&
3021                 UCHARAT(s) != ((OP(scan) == EXACTF)
3022                                ? PL_fold : PL_fold_locale)[nextchr])
3023                 sayNO;
3024             if (PL_regeol - locinput < st->ln)
3025                 sayNO;
3026             if (st->ln > 1 && (OP(scan) == EXACTF
3027                            ? ibcmp(s, locinput, st->ln)
3028                            : ibcmp_locale(s, locinput, st->ln)))
3029                 sayNO;
3030             locinput += st->ln;
3031             nextchr = UCHARAT(locinput);
3032             break;
3033             }
3034         case ANYOF:
3035             if (do_utf8) {
3036                 STRLEN inclasslen = PL_regeol - locinput;
3037
3038                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3039                     sayNO_ANYOF;
3040                 if (locinput >= PL_regeol)
3041                     sayNO;
3042                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3043                 nextchr = UCHARAT(locinput);
3044                 break;
3045             }
3046             else {
3047                 if (nextchr < 0)
3048                     nextchr = UCHARAT(locinput);
3049                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3050                     sayNO_ANYOF;
3051                 if (!nextchr && locinput >= PL_regeol)
3052                     sayNO;
3053                 nextchr = UCHARAT(++locinput);
3054                 break;
3055             }
3056         no_anyof:
3057             /* If we might have the case of the German sharp s
3058              * in a casefolding Unicode character class. */
3059
3060             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3061                  locinput += SHARP_S_SKIP;
3062                  nextchr = UCHARAT(locinput);
3063             }
3064             else
3065                  sayNO;
3066             break;
3067         case ALNUML:
3068             PL_reg_flags |= RF_tainted;
3069             /* FALL THROUGH */
3070         case ALNUM:
3071             if (!nextchr)
3072                 sayNO;
3073             if (do_utf8) {
3074                 LOAD_UTF8_CHARCLASS_ALNUM();
3075                 if (!(OP(scan) == ALNUM
3076                       ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3077                       : isALNUM_LC_utf8((U8*)locinput)))
3078                 {
3079                     sayNO;
3080                 }
3081                 locinput += PL_utf8skip[nextchr];
3082                 nextchr = UCHARAT(locinput);
3083                 break;
3084             }
3085             if (!(OP(scan) == ALNUM
3086                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3087                 sayNO;
3088             nextchr = UCHARAT(++locinput);
3089             break;
3090         case NALNUML:
3091             PL_reg_flags |= RF_tainted;
3092             /* FALL THROUGH */
3093         case NALNUM:
3094             if (!nextchr && locinput >= PL_regeol)
3095                 sayNO;
3096             if (do_utf8) {
3097                 LOAD_UTF8_CHARCLASS_ALNUM();
3098                 if (OP(scan) == NALNUM
3099                     ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3100                     : isALNUM_LC_utf8((U8*)locinput))
3101                 {
3102                     sayNO;
3103                 }
3104                 locinput += PL_utf8skip[nextchr];
3105                 nextchr = UCHARAT(locinput);
3106                 break;
3107             }
3108             if (OP(scan) == NALNUM
3109                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3110                 sayNO;
3111             nextchr = UCHARAT(++locinput);
3112             break;
3113         case BOUNDL:
3114         case NBOUNDL:
3115             PL_reg_flags |= RF_tainted;
3116             /* FALL THROUGH */
3117         case BOUND:
3118         case NBOUND:
3119             /* was last char in word? */
3120             if (do_utf8) {
3121                 if (locinput == PL_bostr)
3122                     st->ln = '\n';
3123                 else {
3124                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3125
3126                     st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3127                 }
3128                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3129                     st->ln = isALNUM_uni(st->ln);
3130                     LOAD_UTF8_CHARCLASS_ALNUM();
3131                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3132                 }
3133                 else {
3134                     st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3135                     n = isALNUM_LC_utf8((U8*)locinput);
3136                 }
3137             }
3138             else {
3139                 st->ln = (locinput != PL_bostr) ?
3140                     UCHARAT(locinput - 1) : '\n';
3141                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3142                     st->ln = isALNUM(st->ln);
3143                     n = isALNUM(nextchr);
3144                 }
3145                 else {
3146                     st->ln = isALNUM_LC(st->ln);
3147                     n = isALNUM_LC(nextchr);
3148                 }
3149             }
3150             if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3151                                     OP(scan) == BOUNDL))
3152                     sayNO;
3153             break;
3154         case SPACEL:
3155             PL_reg_flags |= RF_tainted;
3156             /* FALL THROUGH */
3157         case SPACE:
3158             if (!nextchr)
3159                 sayNO;
3160             if (do_utf8) {
3161                 if (UTF8_IS_CONTINUED(nextchr)) {
3162                     LOAD_UTF8_CHARCLASS_SPACE();
3163                     if (!(OP(scan) == SPACE
3164                           ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3165                           : isSPACE_LC_utf8((U8*)locinput)))
3166                     {
3167                         sayNO;
3168                     }
3169                     locinput += PL_utf8skip[nextchr];
3170                     nextchr = UCHARAT(locinput);
3171                     break;
3172                 }
3173                 if (!(OP(scan) == SPACE
3174                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3175                     sayNO;
3176                 nextchr = UCHARAT(++locinput);
3177             }
3178             else {
3179                 if (!(OP(scan) == SPACE
3180                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3181                     sayNO;
3182                 nextchr = UCHARAT(++locinput);
3183             }
3184             break;
3185         case NSPACEL:
3186             PL_reg_flags |= RF_tainted;
3187             /* FALL THROUGH */
3188         case NSPACE:
3189             if (!nextchr && locinput >= PL_regeol)
3190                 sayNO;
3191             if (do_utf8) {
3192                 LOAD_UTF8_CHARCLASS_SPACE();
3193                 if (OP(scan) == NSPACE
3194                     ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3195                     : isSPACE_LC_utf8((U8*)locinput))
3196                 {
3197                     sayNO;
3198                 }
3199                 locinput += PL_utf8skip[nextchr];
3200                 nextchr = UCHARAT(locinput);
3201                 break;
3202             }
3203             if (OP(scan) == NSPACE
3204                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3205                 sayNO;
3206             nextchr = UCHARAT(++locinput);
3207             break;
3208         case DIGITL:
3209             PL_reg_flags |= RF_tainted;
3210             /* FALL THROUGH */
3211         case DIGIT:
3212             if (!nextchr)
3213                 sayNO;
3214             if (do_utf8) {
3215                 LOAD_UTF8_CHARCLASS_DIGIT();
3216                 if (!(OP(scan) == DIGIT
3217                       ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3218                       : isDIGIT_LC_utf8((U8*)locinput)))
3219                 {
3220                     sayNO;
3221                 }
3222                 locinput += PL_utf8skip[nextchr];
3223                 nextchr = UCHARAT(locinput);
3224                 break;
3225             }
3226             if (!(OP(scan) == DIGIT
3227                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3228                 sayNO;
3229             nextchr = UCHARAT(++locinput);
3230             break;
3231         case NDIGITL:
3232             PL_reg_flags |= RF_tainted;
3233             /* FALL THROUGH */
3234         case NDIGIT:
3235             if (!nextchr && locinput >= PL_regeol)
3236                 sayNO;
3237             if (do_utf8) {
3238                 LOAD_UTF8_CHARCLASS_DIGIT();
3239                 if (OP(scan) == NDIGIT
3240                     ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3241                     : isDIGIT_LC_utf8((U8*)locinput))
3242                 {
3243                     sayNO;
3244                 }
3245                 locinput += PL_utf8skip[nextchr];
3246                 nextchr = UCHARAT(locinput);
3247                 break;
3248             }
3249             if (OP(scan) == NDIGIT
3250                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3251                 sayNO;
3252             nextchr = UCHARAT(++locinput);
3253             break;
3254         case CLUMP:
3255             if (locinput >= PL_regeol)
3256                 sayNO;
3257             if  (do_utf8) {
3258                 LOAD_UTF8_CHARCLASS_MARK();
3259                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3260                     sayNO;
3261                 locinput += PL_utf8skip[nextchr];
3262                 while (locinput < PL_regeol &&
3263                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3264                     locinput += UTF8SKIP(locinput);
3265                 if (locinput > PL_regeol)
3266                     sayNO;
3267             }
3268             else
3269                locinput++;
3270             nextchr = UCHARAT(locinput);
3271             break;
3272         case REFFL:
3273             PL_reg_flags |= RF_tainted;
3274             /* FALL THROUGH */
3275         case REF:
3276         case REFF: {
3277             char *s;
3278             n = ARG(scan);  /* which paren pair */
3279             st->ln = PL_regstartp[n];
3280             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3281             if ((I32)*PL_reglastparen < n || st->ln == -1)
3282                 sayNO;                  /* Do not match unless seen CLOSEn. */
3283             if (st->ln == PL_regendp[n])
3284                 break;
3285
3286             s = PL_bostr + st->ln;
3287             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
3288                 char *l = locinput;
3289                 const char *e = PL_bostr + PL_regendp[n];
3290                 /*
3291                  * Note that we can't do the "other character" lookup trick as
3292                  * in the 8-bit case (no pun intended) because in Unicode we
3293                  * have to map both upper and title case to lower case.
3294                  */
3295                 if (OP(scan) == REFF) {
3296                     while (s < e) {
3297                         STRLEN ulen1, ulen2;
3298                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3299                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3300
3301                         if (l >= PL_regeol)
3302                             sayNO;
3303                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3304                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3305                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3306                             sayNO;
3307                         s += ulen1;
3308                         l += ulen2;
3309                     }
3310                 }
3311                 locinput = l;
3312                 nextchr = UCHARAT(locinput);
3313                 break;
3314             }
3315
3316             /* Inline the first character, for speed. */
3317             if (UCHARAT(s) != nextchr &&
3318                 (OP(scan) == REF ||
3319                  (UCHARAT(s) != ((OP(scan) == REFF
3320                                   ? PL_fold : PL_fold_locale)[nextchr]))))
3321                 sayNO;
3322             st->ln = PL_regendp[n] - st->ln;
3323             if (locinput + st->ln > PL_regeol)
3324                 sayNO;
3325             if (st->ln > 1 && (OP(scan) == REF
3326                            ? memNE(s, locinput, st->ln)
3327                            : (OP(scan) == REFF
3328                               ? ibcmp(s, locinput, st->ln)
3329                               : ibcmp_locale(s, locinput, st->ln))))
3330                 sayNO;
3331             locinput += st->ln;
3332             nextchr = UCHARAT(locinput);
3333             break;
3334             }
3335
3336         case NOTHING:
3337         case TAIL:
3338             break;
3339         case BACK:
3340             break;
3341
3342 #undef  ST
3343 #define ST st->u.eval
3344
3345         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3346         {
3347             SV *ret;
3348             {
3349                 /* execute the code in the {...} */
3350                 dSP;
3351                 SV ** const before = SP;
3352                 OP_4tree * const oop = PL_op;
3353                 COP * const ocurcop = PL_curcop;
3354                 PAD *old_comppad;
3355
3356                 n = ARG(scan);
3357                 PL_op = (OP_4tree*)rex->data->data[n];
3358                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3359                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3360                 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3361
3362                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3363                 SPAGAIN;
3364                 if (SP == before)
3365                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3366                 else {
3367                     ret = POPs;
3368                     PUTBACK;
3369                 }
3370
3371                 PL_op = oop;
3372                 PAD_RESTORE_LOCAL(old_comppad);
3373                 PL_curcop = ocurcop;
3374                 if (!st->logical) {
3375                     /* /(?{...})/ */
3376                     sv_setsv(save_scalar(PL_replgv), ret);
3377                     break;
3378                 }
3379             }
3380             if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3381                 regexp *re;
3382                 {
3383                     /* extract RE object from returned value; compiling if
3384                      * necessary */
3385
3386                     MAGIC *mg = NULL;
3387                     const SV *sv;
3388                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3389                         mg = mg_find(sv, PERL_MAGIC_qr);
3390                     else if (SvSMAGICAL(ret)) {
3391                         if (SvGMAGICAL(ret))
3392                             sv_unmagic(ret, PERL_MAGIC_qr);
3393                         else
3394                             mg = mg_find(ret, PERL_MAGIC_qr);
3395                     }
3396
3397                     if (mg) {
3398                         re = (regexp *)mg->mg_obj;
3399                         (void)ReREFCNT_inc(re);
3400                     }
3401                     else {
3402                         STRLEN len;
3403                         const char * const t = SvPV_const(ret, len);
3404                         PMOP pm;
3405                         const I32 osize = PL_regsize;
3406
3407                         Zero(&pm, 1, PMOP);
3408                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3409                         re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3410                         if (!(SvFLAGS(ret)
3411                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3412                                 | SVs_GMG)))
3413                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3414                                         PERL_MAGIC_qr,0,0);
3415                         PL_regsize = osize;
3416                     }
3417                 }
3418
3419                 /* run the pattern returned from (??{...}) */
3420                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3421                 REGCP_SET(ST.lastcp);
3422                 *PL_reglastparen = 0;
3423                 *PL_reglastcloseparen = 0;
3424                 PL_reginput = locinput;
3425
3426                 /* XXXX This is too dramatic a measure... */
3427                 PL_reg_maxiter = 0;
3428
3429                 st->logical = 0;
3430                 ST.toggle_reg_flags = PL_reg_flags;
3431                 if (re->reganch & ROPT_UTF8)
3432                     PL_reg_flags |= RF_utf8;
3433                 else
3434                     PL_reg_flags &= ~RF_utf8;
3435                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3436
3437                 ST.prev_rex = rex;
3438                 ST.prev_curlyx = cur_curlyx;
3439                 rex = re;
3440                 cur_curlyx = NULL;
3441                 ST.B = next;
3442                 ST.prev_eval = cur_eval;
3443                 cur_eval = st;
3444
3445                 DEBUG_EXECUTE_r(
3446                     debug_start_match(re, do_utf8, locinput, PL_regeol,
3447                         "Matching embedded");
3448                     );
3449                 /* now continue from first node in postoned RE */
3450                 PUSH_YES_STATE_GOTO(EVAL_AB, re->program + 1);
3451                 /* NOTREACHED */
3452             }
3453             /* /(?(?{...})X|Y)/ */
3454             st->sw = SvTRUE(ret);
3455             st->logical = 0;
3456             break;
3457         }
3458
3459         case EVAL_AB: /* cleanup after a successful (??{A})B */
3460             /* note: this is called twice; first after popping B, then A */
3461             PL_reg_flags ^= ST.toggle_reg_flags;
3462             ReREFCNT_dec(rex);
3463             rex = ST.prev_rex;
3464             regcpblow(ST.cp);
3465             cur_eval = ST.prev_eval;
3466             cur_curlyx = ST.prev_curlyx;
3467             /* XXXX This is too dramatic a measure... */
3468             PL_reg_maxiter = 0;
3469             sayYES_FINAL;
3470
3471
3472         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3473             /* note: this is called twice; first after popping B, then A */
3474             PL_reg_flags ^= ST.toggle_reg_flags;
3475             ReREFCNT_dec(rex);
3476             rex = ST.prev_rex;
3477             PL_reginput = locinput;
3478             REGCP_UNWIND(ST.lastcp);
3479             regcppop(rex);
3480             cur_eval = ST.prev_eval;
3481             cur_curlyx = ST.prev_curlyx;
3482             /* XXXX This is too dramatic a measure... */
3483             PL_reg_maxiter = 0;
3484             sayNO_SILENT;
3485
3486 #undef ST
3487
3488         case OPEN:
3489             n = ARG(scan);  /* which paren pair */
3490             PL_reg_start_tmp[n] = locinput;
3491             if (n > PL_regsize)
3492                 PL_regsize = n;
3493             break;
3494         case CLOSE:
3495             n = ARG(scan);  /* which paren pair */
3496             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3497             PL_regendp[n] = locinput - PL_bostr;
3498             if (n > (I32)*PL_reglastparen)
3499                 *PL_reglastparen = n;
3500             *PL_reglastcloseparen = n;
3501             break;
3502         case GROUPP:
3503             n = ARG(scan);  /* which paren pair */
3504             st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3505             break;
3506         case IFTHEN:
3507             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3508             if (st->sw)
3509                 next = NEXTOPER(NEXTOPER(scan));
3510             else {
3511                 next = scan + ARG(scan);
3512                 if (OP(next) == IFTHEN) /* Fake one. */
3513                     next = NEXTOPER(NEXTOPER(next));
3514             }
3515             break;
3516         case LOGICAL:
3517             st->logical = scan->flags;
3518             break;
3519 /*******************************************************************
3520  cur_curlyx points to the regmatch_state associated with the most recent CURLYX.
3521  This struct contains info about the innermost (...)* loop (an
3522  "infoblock"), and a pointer to the next outer cur_curlyx.
3523
3524  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3525
3526    1) After matching Y, regnode for CURLYX is processed;
3527
3528    2) This regnode populates cur_curlyx, and calls regmatch() recursively
3529       with the starting point at WHILEM node;
3530
3531    3) Each hit of WHILEM node tries to match A and Z (in the order
3532       depending on the current iteration, min/max of {min,max} and
3533       greediness).  The information about where are nodes for "A"
3534       and "Z" is read from cur_curlyx, as is info on how many times "A"
3535       was already matched, and greediness.
3536
3537    4) After A matches, the same WHILEM node is hit again.
3538
3539    5) Each time WHILEM is hit, cur_curlyx is the infoblock created by CURLYX
3540       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
3541       resets cur_curlyx, since this Y(A)*Z can be a part of some other loop:
3542       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
3543       of the external loop.
3544
3545  Currently present infoblocks form a tree with a stem formed by cur_curlyx
3546  and whatever it mentions via ->next, and additional attached trees
3547  corresponding to temporarily unset infoblocks as in "5" above.
3548
3549  In the following picture, infoblocks for outer loop of
3550  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
3551  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
3552  infoblocks are drawn below the "reset" infoblock.
3553
3554  In fact in the picture below we do not show failed matches for Z and T
3555  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
3556  more obvious *why* one needs to *temporary* unset infoblocks.]
3557
3558   Matched       REx position    InfoBlocks      Comment
3559                 (Y(A)*?Z)*?T    x
3560                 Y(A)*?Z)*?T     x <- O
3561   Y             (A)*?Z)*?T      x <- O
3562   Y             A)*?Z)*?T       x <- O <- I
3563   YA            )*?Z)*?T        x <- O <- I
3564   YA            A)*?Z)*?T       x <- O <- I
3565   YAA           )*?Z)*?T        x <- O <- I
3566   YAA           Z)*?T           x <- O          # Temporary unset I
3567                                      I
3568
3569   YAAZ          Y(A)*?Z)*?T     x <- O
3570                                      I
3571
3572   YAAZY         (A)*?Z)*?T      x <- O
3573                                      I
3574
3575   YAAZY         A)*?Z)*?T       x <- O <- I
3576                                      I
3577
3578   YAAZYA        )*?Z)*?T        x <- O <- I
3579                                      I
3580
3581   YAAZYA        Z)*?T           x <- O          # Temporary unset I
3582                                      I,I
3583
3584   YAAZYAZ       )*?T            x <- O
3585                                      I,I
3586
3587   YAAZYAZ       T               x               # Temporary unset O
3588                                 O
3589                                 I,I
3590
3591   YAAZYAZT                      x
3592                                 O
3593                                 I,I
3594  *******************************************************************/
3595
3596         case CURLYX: {
3597                 /* No need to save/restore up to this paren */
3598                 parenfloor = scan->flags;
3599
3600                 /* Dave says:
3601
3602                    CURLYX and WHILEM are always paired: they're the moral
3603                    equivalent of pp_enteriter anbd pp_iter.
3604
3605                    The only time next could be null is if the node tree is
3606                    corrupt. This was mentioned on p5p a few days ago.
3607
3608                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3609                    So we'll assert that this is true:
3610                 */
3611                 assert(next);
3612                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3613                     next += ARG(next);
3614                 /* XXXX Probably it is better to teach regpush to support
3615                    parenfloor > PL_regsize... */
3616                 if (parenfloor > (I32)*PL_reglastparen)
3617                     parenfloor = *PL_reglastparen; /* Pessimization... */
3618
3619                 st->u.curlyx.cp = PL_savestack_ix;
3620                 st->u.curlyx.outercc = cur_curlyx;
3621                 cur_curlyx = st;
3622                 /* these fields contain the state of the current curly.
3623                  * they are accessed by subsequent WHILEMs;
3624                  * cur and lastloc are also updated by WHILEM */
3625                 st->u.curlyx.parenfloor = parenfloor;
3626                 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3627                 st->u.curlyx.min = ARG1(scan);
3628                 st->u.curlyx.max  = ARG2(scan);
3629                 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3630                 st->u.curlyx.lastloc = 0;
3631                 /* st->next and st->minmod are also read by WHILEM */
3632
3633                 PL_reginput = locinput;
3634                 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3635                 /*** all unsaved local vars undefined at this point */
3636                 regcpblow(st->u.curlyx.cp);
3637                 cur_curlyx = st->u.curlyx.outercc;
3638                 saySAME(result);
3639             }
3640             /* NOTREACHED */
3641         case WHILEM: {
3642                 /*
3643                  * This is really hard to understand, because after we match
3644                  * what we're trying to match, we must make sure the rest of
3645                  * the REx is going to match for sure, and to do that we have
3646                  * to go back UP the parse tree by recursing ever deeper.  And
3647                  * if it fails, we have to reset our parent's current state
3648                  * that we can try again after backing off.
3649                  */
3650
3651                 /* Dave says:
3652
3653                    cur_curlyx gets initialised by CURLYX ready for use by WHILEM.
3654                    So again, unless somethings been corrupted, cur_curlyx cannot
3655                    be null at that point in WHILEM.
3656
3657                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3658                    So we'll assert that this is true:
3659                 */
3660                 assert(cur_curlyx);
3661                 st->u.whilem.lastloc = cur_curlyx->u.curlyx.lastloc; /* Detection of 0-len. */
3662                 st->u.whilem.cache_offset = 0;
3663                 st->u.whilem.cache_bit = 0;
3664
3665                 n = cur_curlyx->u.curlyx.cur + 1; /* how many we know we matched */
3666                 PL_reginput = locinput;
3667
3668                 DEBUG_EXECUTE_r(
3669                     PerlIO_printf(Perl_debug_log,
3670                                   "%*s  %ld out of %ld..%ld  cc=%"UVxf"\n",
3671                                   REPORT_CODE_OFF+PL_regindent*2, "",
3672                                   (long)n, (long)cur_curlyx->u.curlyx.min,
3673                                   (long)cur_curlyx->u.curlyx.max,
3674                                   PTR2UV(cur_curlyx))
3675                     );
3676
3677                 /* If degenerate scan matches "", assume scan done. */
3678
3679                 if (locinput == cur_curlyx->u.curlyx.lastloc && n >=
3680                     cur_curlyx->u.curlyx.min)
3681                 {
3682                     st->u.whilem.savecc = cur_curlyx;
3683                     cur_curlyx = cur_curlyx->u.curlyx.outercc;
3684                     if (cur_curlyx)
3685                         st->ln = cur_curlyx->u.curlyx.cur;
3686                     DEBUG_EXECUTE_r(
3687                         PerlIO_printf(Perl_debug_log,
3688                            "%*s  empty match detected, try continuation...\n",
3689                            REPORT_CODE_OFF+PL_regindent*2, "")
3690                         );
3691                     REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3692                     /*** all unsaved local vars undefined at this point */
3693                     cur_curlyx = st->u.whilem.savecc;
3694                     if (result)
3695                         sayYES;
3696                     if (cur_curlyx->u.curlyx.outercc)
3697                         cur_curlyx->u.curlyx.outercc->u.curlyx.cur = st->ln;
3698                     sayNO;
3699                 }
3700
3701                 /* First just match a string of min scans. */
3702
3703                 if (n < cur_curlyx->u.curlyx.min) {
3704                     cur_curlyx->u.curlyx.cur = n;
3705                     cur_curlyx->u.curlyx.lastloc = locinput;
3706                     REGMATCH(cur_curlyx->u.curlyx.scan, WHILEM2);
3707                     /*** all unsaved local vars undefined at this point */
3708                     if (result)
3709                         sayYES;
3710                     cur_curlyx->u.curlyx.cur = n - 1;
3711                     cur_curlyx->u.curlyx.lastloc = st->u.whilem.lastloc;
3712                     sayNO;
3713                 }
3714
3715                 if (scan->flags) {
3716                     /* Check whether we already were at this position.
3717                         Postpone detection until we know the match is not
3718                         *that* much linear. */
3719                 if (!PL_reg_maxiter) {
3720                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3721                     /* possible overflow for long strings and many CURLYX's */
3722                     if (PL_reg_maxiter < 0)
3723                         PL_reg_maxiter = I32_MAX;
3724                     PL_reg_leftiter = PL_reg_maxiter;
3725                 }
3726                 if (PL_reg_leftiter-- == 0) {
3727                     const I32 size = (PL_reg_maxiter + 7)/8;
3728                     if (PL_reg_poscache) {
3729                         if ((I32)PL_reg_poscache_size < size) {
3730                             Renew(PL_reg_poscache, size, char);
3731                             PL_reg_poscache_size = size;
3732                         }
3733                         Zero(PL_reg_poscache, size, char);
3734                     }
3735                     else {
3736                         PL_reg_poscache_size = size;
3737                         Newxz(PL_reg_poscache, size, char);
3738                     }
3739                     DEBUG_EXECUTE_r(
3740                         PerlIO_printf(Perl_debug_log,
3741               "%sDetected a super-linear match, switching on caching%s...\n",
3742                                       PL_colors[4], PL_colors[5])
3743                         );
3744                 }
3745                 if (PL_reg_leftiter < 0) {
3746                     st->u.whilem.cache_offset = locinput - PL_bostr;
3747
3748                     st->u.whilem.cache_offset = (scan->flags & 0xf) - 1
3749                             + st->u.whilem.cache_offset * (scan->flags>>4);
3750                     st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
3751                     st->u.whilem.cache_offset /= 8;
3752                     if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
3753                     DEBUG_EXECUTE_r(
3754                         PerlIO_printf(Perl_debug_log,
3755                                       "%*s  already tried at this position...\n",
3756                                       REPORT_CODE_OFF+PL_regindent*2, "")
3757                         );
3758                         sayNO; /* cache records failure */
3759                     }
3760                 }
3761                 }
3762
3763                 /* Prefer next over scan for minimal matching. */
3764
3765                 if (cur_curlyx->minmod) {
3766                     st->u.whilem.savecc = cur_curlyx;
3767                     cur_curlyx = cur_curlyx->u.curlyx.outercc;
3768                     if (cur_curlyx)
3769                         st->ln = cur_curlyx->u.curlyx.cur;
3770                     st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
3771                     REGCP_SET(st->u.whilem.lastcp);
3772                     REGMATCH(st->u.whilem.savecc->next, WHILEM3);
3773                     /*** all unsaved local vars undefined at this point */
3774                     cur_curlyx = st->u.whilem.savecc;
3775                     if (result) {
3776                         regcpblow(st->u.whilem.cp);
3777                         sayYES; /* All done. */
3778                     }
3779                     REGCP_UNWIND(st->u.whilem.lastcp);
3780                     regcppop(rex);
3781                     if (cur_curlyx->u.curlyx.outercc)
3782                         cur_curlyx->u.curlyx.outercc->u.curlyx.cur = st->ln;
3783
3784                     if (n >= cur_curlyx->u.curlyx.max) { /* Maximum greed exceeded? */
3785                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3786                             && !(PL_reg_flags & RF_warned)) {
3787                             PL_reg_flags |= RF_warned;
3788                             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3789                                  "Complex regular subexpression recursion",
3790                                  REG_INFTY - 1);
3791                         }
3792                         CACHEsayNO;
3793                     }
3794
3795                     DEBUG_EXECUTE_r(
3796                         PerlIO_printf(Perl_debug_log,
3797                                       "%*s  trying longer...\n",
3798                                       REPORT_CODE_OFF+PL_regindent*2, "")
3799                         );
3800                     /* Try scanning more and see if it helps. */
3801                     PL_reginput = locinput;
3802                     cur_curlyx->u.curlyx.cur = n;
3803                     cur_curlyx->u.curlyx.lastloc = locinput;
3804                     st->u.whilem.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
3805                     REGCP_SET(st->u.whilem.lastcp);
3806                     REGMATCH(cur_curlyx->u.curlyx.scan, WHILEM4);
3807                     /*** all unsaved local vars undefined at this point */
3808                     if (result) {
3809                         regcpblow(st->u.whilem.cp);
3810                         sayYES;
3811                     }
3812                     REGCP_UNWIND(st->u.whilem.lastcp);
3813                     regcppop(rex);
3814                     cur_curlyx->u.curlyx.cur = n - 1;
3815                     cur_curlyx->u.curlyx.lastloc = st->u.whilem.lastloc;
3816                     CACHEsayNO;
3817                 }
3818
3819                 /* Prefer scan over next for maximal matching. */
3820
3821                 if (n < cur_curlyx->u.curlyx.max) {     /* More greed allowed? */
3822                     st->u.whilem.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
3823                     cur_curlyx->u.curlyx.cur = n;
3824                     cur_curlyx->u.curlyx.lastloc = locinput;
3825                     REGCP_SET(st->u.whilem.lastcp);
3826                     REGMATCH(cur_curlyx->u.curlyx.scan, WHILEM5);
3827                     /*** all unsaved local vars undefined at this point */
3828                     if (result) {
3829                         regcpblow(st->u.whilem.cp);
3830                         sayYES;
3831                     }
3832                     REGCP_UNWIND(st->u.whilem.lastcp);
3833                     regcppop(rex);      /* Restore some previous $<digit>s? */
3834                     PL_reginput = locinput;
3835                     DEBUG_EXECUTE_r(
3836                         PerlIO_printf(Perl_debug_log,
3837                                       "%*s  failed, try continuation...\n",
3838                                       REPORT_CODE_OFF+PL_regindent*2, "")
3839                         );
3840                 }
3841                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3842                         && !(PL_reg_flags & RF_warned)) {
3843                     PL_reg_flags |= RF_warned;
3844                     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3845                          "Complex regular subexpression recursion",
3846                          REG_INFTY - 1);
3847                 }
3848
3849                 /* Failed deeper matches of scan, so see if this one works. */
3850                 st->u.whilem.savecc = cur_curlyx;
3851                 cur_curlyx = cur_curlyx->u.curlyx.outercc;
3852                 if (cur_curlyx)
3853                     st->ln = cur_curlyx->u.curlyx.cur;
3854                 REGMATCH(st->u.whilem.savecc->next, WHILEM6);
3855                 /*** all unsaved local vars undefined at this point */
3856                 cur_curlyx = st->u.whilem.savecc;
3857                 if (result)
3858                     sayYES;
3859                 if (cur_curlyx->u.curlyx.outercc)
3860                     cur_curlyx->u.curlyx.outercc->u.curlyx.cur = st->ln;
3861                 cur_curlyx->u.curlyx.cur = n - 1;
3862                 cur_curlyx->u.curlyx.lastloc = st->u.whilem.lastloc;
3863                 CACHEsayNO;
3864             }
3865             /* NOTREACHED */
3866
3867 #undef  ST
3868 #define ST st->u.branch
3869
3870         case BRANCHJ:       /*  /(...|A|...)/ with long next pointer */
3871             next = scan + ARG(scan);
3872             if (next == scan)
3873                 next = NULL;
3874             scan = NEXTOPER(scan);
3875             /* FALL THROUGH */
3876
3877         case BRANCH:        /*  /(...|A|...)/ */
3878             scan = NEXTOPER(scan); /* scan now points to inner node */
3879             if (!next || (OP(next) != BRANCH && OP(next) != BRANCHJ))
3880                 /* last branch; skip state push and jump direct to node */
3881                 continue;
3882             ST.lastparen = *PL_reglastparen;
3883             ST.next_branch = next;
3884             REGCP_SET(ST.cp);
3885             PL_reginput = locinput;
3886
3887             /* Now go into the branch */
3888             PUSH_STATE_GOTO(BRANCH_next, scan);
3889             /* NOTREACHED */
3890
3891         case BRANCH_next_fail: /* that branch failed; try the next, if any */
3892             REGCP_UNWIND(ST.cp);
3893             for (n = *PL_reglastparen; n > ST.lastparen; n--)
3894                 PL_regendp[n] = -1;
3895             *PL_reglastparen = n;
3896             scan = ST.next_branch;
3897             /* no more branches? */
3898             if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ))
3899                 sayNO;
3900             continue; /* execute next BRANCH[J] op */
3901             /* NOTREACHED */
3902
3903         case MINMOD:
3904             st->minmod = 1;
3905             break;
3906
3907 #undef  ST
3908 #define ST st->u.curlym
3909
3910         case CURLYM:    /* /A{m,n}B/ where A is fixed-length */
3911
3912             /* This is an optimisation of CURLYX that enables us to push
3913