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