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
  19 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
  20  * confused with the original package (see point 3 below).  Thanks, Henry!
  21  */
  22
  23 /* Additional note: this code is very heavily munged from Henry's version
  24  * in places.  In some spots I've traded clarity for efficiency, so don't
  25  * blame Henry for some of the lack of readability.
  26  */
  27
  28 /* The names of the functions have been changed from regcomp and
  29  * regexec to  pregcomp and pregexec in order to avoid conflicts
  30  * with the POSIX routines of the same names.
  31 */
  32
  33 #ifdef PERL_EXT_RE_BUILD
  34 #include "re_top.h"
  35 #endif
  36
  37 /*
  38  * pregcomp and pregexec -- regsub and regerror are not used in perl
  39  *
  40  *      Copyright (c) 1986 by University of Toronto.
  41  *      Written by Henry Spencer.  Not derived from licensed software.
  42  *
  43  *      Permission is granted to anyone to use this software for any
  44  *      purpose on any computer system, and to redistribute it freely,
  45  *      subject to the following restrictions:
  46  *
  47  *      1. The author is not responsible for the consequences of use of
  48  *              this software, no matter how awful, even if they arise
  49  *              from defects in it.
  50  *
  51  *      2. The origin of this software must not be misrepresented, either
  52  *              by explicit claim or by omission.
  53  *
  54  *      3. Altered versions must be plainly marked as such, and must not
  55  *              be misrepresented as being the original software.
  56  *
  57  ****    Alterations to Henry's code are...
  58  ****
  59  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
  60  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
  61  ****
  62  ****    You may distribute under the terms of either the GNU General Public
  63  ****    License or the Artistic License, as specified in the README file.
  64  *
  65  * Beware that some of this code is subtly aware of the way operator
  66  * precedence is structured in regular expressions.  Serious changes in
  67  * regular-expression syntax might require a total rethink.
  68  */
  69 #include "EXTERN.h"
  70 #define PERL_IN_REGEXEC_C
  71 #include "perl.h"
  72
  73 #ifdef PERL_IN_XSUB_RE
  74 #  include "re_comp.h"
  75 #else
  76 #  include "regcomp.h"
  77 #endif
  78
  79 #define RF_tainted      1               /* tainted information used? */
  80 #define RF_warned       2               /* warned about big count? */
  81 #define RF_evaled       4               /* Did an EVAL with setting? */
  82 #define RF_utf8         8               /* String contains multibyte chars? */
  83
  84 #define UTF ((PL_reg_flags & RF_utf8) != 0)
  85
  86 #define RS_init         1               /* eval environment created */
  87 #define RS_set          2               /* replsv value is set */
  88
  89 #ifndef STATIC
  90 #define STATIC  static
  91 #endif
  92
  93 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
  94
  95 /*
  96  * Forwards.
  97  */
  98
  99 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
 100 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
 101
 102 #define HOPc(pos,off) \
 103         (char *)(PL_reg_match_utf8 \
 104             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
 105             : (U8*)(pos + off))
 106 #define HOPBACKc(pos, off) \
 107         (char*)(PL_reg_match_utf8\
 108             ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
 109             : (pos - off >= PL_bostr)           \
 110                 ? (U8*)pos - off                \
 111                 : NULL)
 112
 113 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
 114 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
 115
 116 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
 117     if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
 118 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
 119 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
 120 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
 121 #define LOAD_UTF8_CHARCLASS_MARK()  LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
 122
 123 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
 124
 125 /* for use after a quantifier and before an EXACT-like node -- japhy */
 126 #define JUMPABLE(rn) ( \
 127     OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
 128     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 129     OP(rn) == PLUS || OP(rn) == MINMOD || \
 130     (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
 131 )
 132
 133 #define HAS_TEXT(rn) ( \
 134     PL_regkind[OP(rn)] == EXACT || PL_regkind[OP(rn)] == REF \
 135 )
 136
 137 /*
 138   Search for mandatory following text node; for lookahead, the text must
 139   follow but for lookbehind (rn->flags != 0) we skip to the next step.
 140 */
 141 #define FIND_NEXT_IMPT(rn) STMT_START { \
 142     while (JUMPABLE(rn)) { \
 143         const OPCODE type = OP(rn); \
 144         if (type == SUSPEND || PL_regkind[type] == CURLY) \
 145             rn = NEXTOPER(NEXTOPER(rn)); \
 146         else if (type == PLUS) \
 147             rn = NEXTOPER(rn); \
 148         else if (type == IFMATCH) \
 149             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
 150         else rn += NEXT_OFF(rn); \
 151     } \
 152 } STMT_END
 153
 154 static void restore_pos(pTHX_ void *arg);
 155
 156 STATIC CHECKPOINT
 157 S_regcppush(pTHX_ I32 parenfloor)
 158 {
 159     dVAR;
 160     const int retval = PL_savestack_ix;
 161 #define REGCP_PAREN_ELEMS 4
 162     const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
 163     int p;
 164     GET_RE_DEBUG_FLAGS_DECL;
 165
 166     if (paren_elems_to_push < 0)
 167         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
 168
 169 #define REGCP_OTHER_ELEMS 6
 170     SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
 171     for (p = PL_regsize; p > parenfloor; p--) {
 172 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 173         SSPUSHINT(PL_regendp[p]);
 174         SSPUSHINT(PL_regstartp[p]);
 175         SSPUSHPTR(PL_reg_start_tmp[p]);
 176         SSPUSHINT(p);
 177         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 178           "     saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
 179                       (UV)p, (IV)PL_regstartp[p],
 180                       (IV)(PL_reg_start_tmp[p] - PL_bostr),
 181                       (IV)PL_regendp[p]
 182         ));
 183     }
 184 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 185     SSPUSHINT(PL_regsize);
 186     SSPUSHINT(*PL_reglastparen);
 187     SSPUSHINT(*PL_reglastcloseparen);
 188     SSPUSHPTR(PL_reginput);
 189 #define REGCP_FRAME_ELEMS 2
 190 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
 191  * are needed for the regexp context stack bookkeeping. */
 192     SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 193     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
 194
 195     return retval;
 196 }
 197
 198 /* These are needed since we do not localize EVAL nodes: */
 199 #  define REGCP_SET(cp)  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,          \
 200                              "  Setting an EVAL scope, savestack=%"IVdf"\n",    \
 201                              (IV)PL_savestack_ix)); cp = PL_savestack_ix
 202
 203 #  define REGCP_UNWIND(cp)  DEBUG_EXECUTE_r(cp != PL_savestack_ix ?             \
 204                                 PerlIO_printf(Perl_debug_log,           \
 205                                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 206                                 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
 207
 208 STATIC char *
 209 S_regcppop(pTHX_ const regexp *rex)
 210 {
 211     dVAR;
 212     I32 i;
 213     char *input;
 214
 215     GET_RE_DEBUG_FLAGS_DECL;
 216
 217     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 218     i = SSPOPINT;
 219     assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 220     i = SSPOPINT; /* Parentheses elements to pop. */
 221     input = (char *) SSPOPPTR;
 222     *PL_reglastcloseparen = SSPOPINT;
 223     *PL_reglastparen = SSPOPINT;
 224     PL_regsize = SSPOPINT;
 225
 226     /* Now restore the parentheses context. */
 227     for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 228          i > 0; i -= REGCP_PAREN_ELEMS) {
 229         I32 tmps;
 230         U32 paren = (U32)SSPOPINT;
 231         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
 232         PL_regstartp[paren] = SSPOPINT;
 233         tmps = SSPOPINT;
 234         if (paren <= *PL_reglastparen)
 235             PL_regendp[paren] = tmps;
 236         DEBUG_EXECUTE_r(
 237             PerlIO_printf(Perl_debug_log,
 238                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 239                           (UV)paren, (IV)PL_regstartp[paren],
 240                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
 241                           (IV)PL_regendp[paren],
 242                           (paren > *PL_reglastparen ? "(no)" : ""));
 243         );
 244     }
 245     DEBUG_EXECUTE_r(
 246         if (*PL_reglastparen + 1 <= rex->nparens) {
 247             PerlIO_printf(Perl_debug_log,
 248                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
 249                           (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
 250         }
 251     );
 252 #if 1
 253     /* It would seem that the similar code in regtry()
 254      * already takes care of this, and in fact it is in
 255      * a better location to since this code can #if 0-ed out
 256      * but the code in regtry() is needed or otherwise tests
 257      * requiring null fields (pat.t#187 and split.t#{13,14}
 258      * (as of patchlevel 7877)  will fail.  Then again,
 259      * this code seems to be necessary or otherwise
 260      * building DynaLoader will fail:
 261      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
 262      * --jhi */
 263     for (i = *PL_reglastparen + 1; (U32)i <= rex->nparens; i++) {
 264         if (i > PL_regsize)
 265             PL_regstartp[i] = -1;
 266         PL_regendp[i] = -1;
 267     }
 268 #endif
 269     return input;
 270 }
 271
 272 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
 273
 274 /*
 275  * pregexec and friends
 276  */
 277
 278 #ifndef PERL_IN_XSUB_RE
 279 /*
 280  - pregexec - match a regexp against a string
 281  */
 282 I32
 283 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
 284          char *strbeg, I32 minend, SV *screamer, U32 nosave)
 285 /* strend: pointer to null at end of string */
 286 /* strbeg: real beginning of string */
 287 /* minend: end of match must be >=minend after stringarg. */
 288 /* nosave: For optimizations. */
 289 {
 290     return
 291         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 292                       nosave ? 0 : REXEC_COPY_STR);
 293 }
 294 #endif
 295
 296 /*
 297  * Need to implement the following flags for reg_anch:
 298  *
 299  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
 300  * USE_INTUIT_ML
 301  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
 302  * INTUIT_AUTORITATIVE_ML
 303  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
 304  * INTUIT_ONCE_ML
 305  *
 306  * Another flag for this function: SECOND_TIME (so that float substrs
 307  * with giant delta may be not rechecked).
 308  */
 309
 310 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 311
 312 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
 313    Otherwise, only SvCUR(sv) is used to get strbeg. */
 314
 315 /* XXXX We assume that strpos is strbeg unless sv. */
 316
 317 /* XXXX Some places assume that there is a fixed substring.
 318         An update may be needed if optimizer marks as "INTUITable"
 319         RExen without fixed substrings.  Similarly, it is assumed that
 320         lengths of all the strings are no more than minlen, thus they
 321         cannot come from lookahead.
 322         (Or minlen should take into account lookahead.) */
 323
 324 /* A failure to find a constant substring means that there is no need to make
 325    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 326    finding a substring too deep into the string means that less calls to
 327    regtry() should be needed.
 328
 329    REx compiler's optimizer found 4 possible hints:
 330         a) Anchored substring;
 331         b) Fixed substring;
 332         c) Whether we are anchored (beginning-of-line or \G);
 333         d) First node (of those at offset 0) which may distingush positions;
 334    We use a)b)d) and multiline-part of c), and try to find a position in the
 335    string which does not contradict any of them.
 336  */
 337
 338 /* Most of decisions we do here should have been done at compile time.
 339    The nodes of the REx which we used for the search should have been
 340    deleted from the finite automaton. */
 341
 342 char *
 343 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
 344                      char *strend, U32 flags, re_scream_pos_data *data)
 345 {
 346     dVAR;
 347     register I32 start_shift = 0;
 348     /* Should be nonnegative! */
 349     register I32 end_shift   = 0;
 350     register char *s;
 351     register SV *check;
 352     char *strbeg;
 353     char *t;
 354     const int do_utf8 = sv ? SvUTF8(sv) : 0;    /* if no sv we have to assume bytes */
 355     I32 ml_anch;
 356     register char *other_last = NULL;   /* other substr checked before this */
 357     char *check_at = NULL;              /* check substr found at this pos */
 358     const I32 multiline = prog->reganch & PMf_MULTILINE;
 359 #ifdef DEBUGGING
 360     const char * const i_strpos = strpos;
 361     SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
 362 #endif
 363
 364     GET_RE_DEBUG_FLAGS_DECL;
 365
 366     RX_MATCH_UTF8_set(prog,do_utf8);
 367
 368     if (prog->reganch & ROPT_UTF8) {
 369         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 370                               "UTF-8 regex...\n"));
 371         PL_reg_flags |= RF_utf8;
 372     }
 373
 374     DEBUG_EXECUTE_r({
 375          const char *s   = PL_reg_match_utf8 ?
 376                          sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
 377                          strpos;
 378          const int   len = PL_reg_match_utf8 ?
 379                          (int)strlen(s) : strend - strpos;
 380          if (!PL_colorset)
 381               reginitcolors();
 382          if (PL_reg_match_utf8)
 383              DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 384                                    "UTF-8 target...\n"));
 385          PerlIO_printf(Perl_debug_log,
 386                        "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n",
 387                        PL_colors[4], PL_colors[5], PL_colors[0],
 388                        prog->precomp,
 389                        PL_colors[1],
 390                        (strlen(prog->precomp) > 60 ? "..." : ""),
 391                        PL_colors[0],
 392                        (int)(len > 60 ? 60 : len),
 393                        s, PL_colors[1],
 394                        (len > 60 ? "..." : "")
 395               );
 396     });
 397
 398     /* CHR_DIST() would be more correct here but it makes things slow. */
 399     if (prog->minlen > strend - strpos) {
 400         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 401                               "String too short... [re_intuit_start]\n"));
 402         goto fail;
 403     }
 404     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
 405     PL_regeol = strend;
 406     if (do_utf8) {
 407         if (!prog->check_utf8 && prog->check_substr)
 408             to_utf8_substr(prog);
 409         check = prog->check_utf8;
 410     } else {
 411         if (!prog->check_substr && prog->check_utf8)
 412             to_byte_substr(prog);
 413         check = prog->check_substr;
 414     }
 415    if (check == &PL_sv_undef) {
 416         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 417                 "Non-utf string cannot match utf check string\n"));
 418         goto fail;
 419     }
 420     if (prog->reganch & ROPT_ANCH) {    /* Match at beg-of-str or after \n */
 421         ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
 422                      || ( (prog->reganch & ROPT_ANCH_BOL)
 423                           && !multiline ) );    /* Check after \n? */
 424
 425         if (!ml_anch) {
 426           if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
 427                                   | ROPT_IMPLICIT)) /* not a real BOL */
 428                /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
 429                && sv && !SvROK(sv)
 430                && (strpos != strbeg)) {
 431               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 432               goto fail;
 433           }
 434           if (prog->check_offset_min == prog->check_offset_max &&
 435               !(prog->reganch & ROPT_CANY_SEEN)) {
 436             /* Substring at constant offset from beg-of-str... */
 437             I32 slen;
 438
 439             s = HOP3c(strpos, prog->check_offset_min, strend);
 440             if (SvTAIL(check)) {
 441                 slen = SvCUR(check);    /* >= 1 */
 442
 443                 if ( strend - s > slen || strend - s < slen - 1
 444                      || (strend - s == slen && strend[-1] != '\n')) {
 445                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 446                     goto fail_finish;
 447                 }
 448                 /* Now should match s[0..slen-2] */
 449                 slen--;
 450                 if (slen && (*SvPVX_const(check) != *s
 451                              || (slen > 1
 452                                  && memNE(SvPVX_const(check), s, slen)))) {
 453                   report_neq:
 454                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 455                     goto fail_finish;
 456                 }
 457             }
 458             else if (*SvPVX_const(check) != *s
 459                      || ((slen = SvCUR(check)) > 1
 460                          && memNE(SvPVX_const(check), s, slen)))
 461                 goto report_neq;
 462             check_at = s;
 463             goto success_at_start;
 464           }
 465         }
 466         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 467         s = strpos;
 468         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 469         end_shift = prog->minlen - start_shift -
 470             CHR_SVLEN(check) + (SvTAIL(check) != 0);
 471         if (!ml_anch) {
 472             const I32 end = prog->check_offset_max + CHR_SVLEN(check)
 473                                          - (SvTAIL(check) != 0);
 474             const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 475
 476             if (end_shift < eshift)
 477                 end_shift = eshift;
 478         }
 479     }
 480     else {                              /* Can match at random position */
 481         ml_anch = 0;
 482         s = strpos;
 483         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 484         /* Should be nonnegative! */
 485         end_shift = prog->minlen - start_shift -
 486             CHR_SVLEN(check) + (SvTAIL(check) != 0);
 487     }
 488
 489 #ifdef DEBUGGING        /* 7/99: reports of failure (with the older version) */
 490     if (end_shift < 0)
 491         Perl_croak(aTHX_ "panic: end_shift");
 492 #endif
 493
 494   restart:
 495     /* Find a possible match in the region s..strend by looking for
 496        the "check" substring in the region corrected by start/end_shift. */
 497     if (flags & REXEC_SCREAM) {
 498         I32 p = -1;                     /* Internal iterator of scream. */
 499         I32 * const pp = data ? data->scream_pos : &p;
 500
 501         if (PL_screamfirst[BmRARE(check)] >= 0
 502             || ( BmRARE(check) == '\n'
 503                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
 504                  && SvTAIL(check) ))
 505             s = screaminstr(sv, check,
 506                             start_shift + (s - strbeg), end_shift, pp, 0);
 507         else
 508             goto fail_finish;
 509         /* we may be pointing at the wrong string */
 510         if (s && RX_MATCH_COPIED(prog))
 511             s = strbeg + (s - SvPVX_const(sv));
 512         if (data)
 513             *data->scream_olds = s;
 514     }
 515     else if (prog->reganch & ROPT_CANY_SEEN)
 516         s = fbm_instr((U8*)(s + start_shift),
 517                       (U8*)(strend - end_shift),
 518                       check, multiline ? FBMrf_MULTILINE : 0);
 519     else
 520         s = fbm_instr(HOP3(s, start_shift, strend),
 521                       HOP3(strend, -end_shift, strbeg),
 522                       check, multiline ? FBMrf_MULTILINE : 0);
 523
 524     /* Update the count-of-usability, remove useless subpatterns,
 525         unshift s.  */
 526
 527     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s",
 528                           (s ? "Found" : "Did not find"),
 529                           (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
 530                           PL_colors[0],
 531                           (int)(SvCUR(check) - (SvTAIL(check)!=0)),
 532                           SvPVX_const(check),
 533                           PL_colors[1], (SvTAIL(check) ? "$" : ""),
 534                           (s ? " at offset " : "...\n") ) );
 535
 536     if (!s)
 537         goto fail_finish;
 538
 539     check_at = s;
 540
 541     /* Finish the diagnostic message */
 542     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 543
 544     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 545        Start with the other substr.
 546        XXXX no SCREAM optimization yet - and a very coarse implementation
 547        XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
 548                 *always* match.  Probably should be marked during compile...
 549        Probably it is right to do no SCREAM here...
 550      */
 551
 552     if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
 553         /* Take into account the "other" substring. */
 554         /* XXXX May be hopelessly wrong for UTF... */
 555         if (!other_last)
 556             other_last = strpos;
 557         if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
 558           do_other_anchored:
 559             {
 560                 char * const last = HOP3c(s, -start_shift, strbeg);
 561                 char *last1, *last2;
 562                 char * const saved_s = s;
 563                 SV* must;
 564
 565                 t = s - prog->check_offset_max;
 566                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 567                     && (!do_utf8
 568                         || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
 569                             && t > strpos)))
 570                     NOOP;
 571                 else
 572                     t = strpos;
 573                 t = HOP3c(t, prog->anchored_offset, strend);
 574                 if (t < other_last)     /* These positions already checked */
 575                     t = other_last;
 576                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 577                 if (last < last1)
 578                     last1 = last;
 579  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 580                 /* On end-of-str: see comment below. */
 581                 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
 582                 if (must == &PL_sv_undef) {
 583                     s = (char*)NULL;
 584                     DEBUG_EXECUTE_r(must = prog->anchored_utf8);        /* for debug */
 585                 }
 586                 else
 587                     s = fbm_instr(
 588                         (unsigned char*)t,
 589                         HOP3(HOP3(last1, prog->anchored_offset, strend)
 590                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
 591                         must,
 592                         multiline ? FBMrf_MULTILINE : 0
 593                     );
 594                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 595                         "%s anchored substr \"%s%.*s%s\"%s",
 596                         (s ? "Found" : "Contradicts"),
 597                         PL_colors[0],
 598                           (int)(SvCUR(must)
 599                           - (SvTAIL(must)!=0)),
 600                           SvPVX_const(must),
 601                           PL_colors[1], (SvTAIL(must) ? "$" : "")));
 602                 if (!s) {
 603                     if (last1 >= last2) {
 604                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 605                                                 ", giving up...\n"));
 606                         goto fail_finish;
 607                     }
 608                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 609                         ", trying floating at offset %ld...\n",
 610                         (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
 611                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 612                     s = HOP3c(last, 1, strend);
 613                     goto restart;
 614                 }
 615                 else {
 616                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 617                           (long)(s - i_strpos)));
 618                     t = HOP3c(s, -prog->anchored_offset, strbeg);
 619                     other_last = HOP3c(s, 1, strend);
 620                     s = saved_s;
 621                     if (t == strpos)
 622                         goto try_at_start;
 623                     goto try_at_offset;
 624                 }
 625             }
 626         }
 627         else {          /* Take into account the floating substring. */
 628             char *last, *last1;
 629             char * const saved_s = s;
 630             SV* must;
 631
 632             t = HOP3c(s, -start_shift, strbeg);
 633             last1 = last =
 634                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 635             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 636                 last = HOP3c(t, prog->float_max_offset, strend);
 637             s = HOP3c(t, prog->float_min_offset, strend);
 638             if (s < other_last)
 639                 s = other_last;
 640  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 641             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
 642             /* fbm_instr() takes into account exact value of end-of-str
 643                if the check is SvTAIL(ed).  Since false positives are OK,
 644                and end-of-str is not later than strend we are OK. */
 645             if (must == &PL_sv_undef) {
 646                 s = (char*)NULL;
 647                 DEBUG_EXECUTE_r(must = prog->float_utf8);       /* for debug message */
 648             }
 649             else
 650                 s = fbm_instr((unsigned char*)s,
 651                               (unsigned char*)last + SvCUR(must)
 652                                   - (SvTAIL(must)!=0),
 653                               must, multiline ? FBMrf_MULTILINE : 0);
 654             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
 655                     (s ? "Found" : "Contradicts"),
 656                     PL_colors[0],
 657                       (int)(SvCUR(must) - (SvTAIL(must)!=0)),
 658                       SvPVX_const(must),
 659                       PL_colors[1], (SvTAIL(must) ? "$" : "")));
 660             if (!s) {
 661                 if (last1 == last) {
 662                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 663                                             ", giving up...\n"));
 664                     goto fail_finish;
 665                 }
 666                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 667                     ", trying anchored starting at offset %ld...\n",
 668                     (long)(saved_s + 1 - i_strpos)));
 669                 other_last = last;
 670                 s = HOP3c(t, 1, strend);
 671                 goto restart;
 672             }
 673             else {
 674                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 675                       (long)(s - i_strpos)));
 676                 other_last = s; /* Fix this later. --Hugo */
 677                 s = saved_s;
 678                 if (t == strpos)
 679                     goto try_at_start;
 680                 goto try_at_offset;
 681             }
 682         }
 683     }
 684
 685     t = s - prog->check_offset_max;
 686     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 687         && (!do_utf8
 688             || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*)strpos))
 689                  && t > strpos))) {
 690         /* Fixed substring is found far enough so that the match
 691            cannot start at strpos. */
 692       try_at_offset:
 693         if (ml_anch && t[-1] != '\n') {
 694             /* Eventually fbm_*() should handle this, but often
 695                anchored_offset is not 0, so this check will not be wasted. */
 696             /* XXXX In the code below we prefer to look for "^" even in
 697                presence of anchored substrings.  And we search even
 698                beyond the found float position.  These pessimizations
 699                are historical artefacts only.  */
 700           find_anchor:
 701             while (t < strend - prog->minlen) {
 702                 if (*t == '\n') {
 703                     if (t < check_at - prog->check_offset_min) {
 704                         if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
 705                             /* Since we moved from the found position,
 706                                we definitely contradict the found anchored
 707                                substr.  Due to the above check we do not
 708                                contradict "check" substr.
 709                                Thus we can arrive here only if check substr
 710                                is float.  Redo checking for "other"=="fixed".
 711                              */
 712                             strpos = t + 1;
 713                             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
 714                                 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
 715                             goto do_other_anchored;
 716                         }
 717                         /* We don't contradict the found floating substring. */
 718                         /* XXXX Why not check for STCLASS? */
 719                         s = t + 1;
 720                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
 721                             PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
 722                         goto set_useful;
 723                     }
 724                     /* Position contradicts check-string */
 725                     /* XXXX probably better to look for check-string
 726                        than for "\n", so one should lower the limit for t? */
 727                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
 728                         PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
 729                     other_last = strpos = s = t + 1;
 730                     goto restart;
 731                 }
 732                 t++;
 733             }
 734             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
 735                         PL_colors[0], PL_colors[1]));
 736             goto fail_finish;
 737         }
 738         else {
 739             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
 740                         PL_colors[0], PL_colors[1]));
 741         }
 742         s = t;
 743       set_useful:
 744         ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr);    /* hooray/5 */
 745     }
 746     else {
 747         /* The found string does not prohibit matching at strpos,
 748            - no optimization of calling REx engine can be performed,
 749            unless it was an MBOL and we are not after MBOL,
 750            or a future STCLASS check will fail this. */
 751       try_at_start:
 752         /* Even in this situation we may use MBOL flag if strpos is offset
 753            wrt the start of the string. */
 754         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
 755             && (strpos != strbeg) && strpos[-1] != '\n'
 756             /* May be due to an implicit anchor of m{.*foo}  */
 757             && !(prog->reganch & ROPT_IMPLICIT))
 758         {
 759             t = strpos;
 760             goto find_anchor;
 761         }
 762         DEBUG_EXECUTE_r( if (ml_anch)
 763             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
 764                         (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
 765         );
 766       success_at_start:
 767         if (!(prog->reganch & ROPT_NAUGHTY)     /* XXXX If strpos moved? */
 768             && (do_utf8 ? (
 769                 prog->check_utf8                /* Could be deleted already */
 770                 && --BmUSEFUL(prog->check_utf8) < 0
 771                 && (prog->check_utf8 == prog->float_utf8)
 772             ) : (
 773                 prog->check_substr              /* Could be deleted already */
 774                 && --BmUSEFUL(prog->check_substr) < 0
 775                 && (prog->check_substr == prog->float_substr)
 776             )))
 777         {
 778             /* If flags & SOMETHING - do not do it many times on the same match */
 779             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
 780             SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
 781             if (do_utf8 ? prog->check_substr : prog->check_utf8)
 782                 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
 783             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
 784             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
 785             check = NULL;                       /* abort */
 786             s = strpos;
 787             /* XXXX This is a remnant of the old implementation.  It
 788                     looks wasteful, since now INTUIT can use many
 789                     other heuristics. */
 790             prog->reganch &= ~RE_USE_INTUIT;
 791         }
 792         else
 793             s = strpos;
 794     }
 795
 796     /* Last resort... */
 797     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
 798     if (prog->regstclass && OP(prog->regstclass)!=TRIE) {
 799         /* minlen == 0 is possible if regstclass is \b or \B,
 800            and the fixed substr is ''$.
 801            Since minlen is already taken into account, s+1 is before strend;
 802            accidentally, minlen >= 1 guaranties no false positives at s + 1
 803            even for \b or \B.  But (minlen? 1 : 0) below assumes that
 804            regstclass does not come from lookahead...  */
 805         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
 806            This leaves EXACTF only, which is dealt with in find_byclass().  */
 807         const U8* const str = (U8*)STRING(prog->regstclass);
 808         const int cl_l = (PL_regkind[OP(prog->regstclass)] == EXACT
 809                     ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
 810                     : 1);
 811         const char * endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
 812                 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
 813                 : (prog->float_substr || prog->float_utf8
 814                    ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
 815                            cl_l, strend)
 816                    : strend);
 817         /*if (OP(prog->regstclass) == TRIE)
 818             endpos++;*/
 819         t = s;
 820         s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
 821         if (!s) {
 822 #ifdef DEBUGGING
 823             const char *what = NULL;
 824 #endif
 825             if (endpos == strend) {
 826                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 827                                 "Could not match STCLASS...\n") );
 828                 goto fail;
 829             }
 830             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 831                                    "This position contradicts STCLASS...\n") );
 832             if ((prog->reganch & ROPT_ANCH) && !ml_anch)
 833                 goto fail;
 834             /* Contradict one of substrings */
 835             if (prog->anchored_substr || prog->anchored_utf8) {
 836                 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
 837                     DEBUG_EXECUTE_r( what = "anchored" );
 838                   hop_and_restart:
 839                     s = HOP3c(t, 1, strend);
 840                     if (s + start_shift + end_shift > strend) {
 841                         /* XXXX Should be taken into account earlier? */
 842                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 843                                                "Could not match STCLASS...\n") );
 844                         goto fail;
 845                     }
 846                     if (!check)
 847                         goto giveup;
 848                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 849                                 "Looking for %s substr starting at offset %ld...\n",
 850                                  what, (long)(s + start_shift - i_strpos)) );
 851                     goto restart;
 852                 }
 853                 /* Have both, check_string is floating */
 854                 if (t + start_shift >= check_at) /* Contradicts floating=check */
 855                     goto retry_floating_check;
 856                 /* Recheck anchored substring, but not floating... */
 857                 s = check_at;
 858                 if (!check)
 859                     goto giveup;
 860                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 861                           "Looking for anchored substr starting at offset %ld...\n",
 862                           (long)(other_last - i_strpos)) );
 863                 goto do_other_anchored;
 864             }
 865             /* Another way we could have checked stclass at the
 866                current position only: */
 867             if (ml_anch) {
 868                 s = t = t + 1;
 869                 if (!check)
 870                     goto giveup;
 871                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 872                           "Looking for /%s^%s/m starting at offset %ld...\n",
 873                           PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
 874                 goto try_at_offset;
 875             }
 876             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))     /* Could have been deleted */
 877                 goto fail;
 878             /* Check is floating subtring. */
 879           retry_floating_check:
 880             t = check_at - start_shift;
 881             DEBUG_EXECUTE_r( what = "floating" );
 882             goto hop_and_restart;
 883         }
 884         if (t != s) {
 885             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 886                         "By STCLASS: moving %ld --> %ld\n",
 887                                   (long)(t - i_strpos), (long)(s - i_strpos))
 888                    );
 889         }
 890         else {
 891             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 892                                   "Does not contradict STCLASS...\n");
 893                    );
 894         }
 895     }
 896   giveup:
 897     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
 898                           PL_colors[4], (check ? "Guessed" : "Giving up"),
 899                           PL_colors[5], (long)(s - i_strpos)) );
 900     return s;
 901
 902   fail_finish:                          /* Substring not found */
 903     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
 904         BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
 905   fail:
 906     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
 907                           PL_colors[4], PL_colors[5]));
 908     return NULL;
 909 }
 910
 911 /* We know what class REx starts with.  Try to find this position... */
 912 /* if reginfo is NULL, its a dryrun */
 913 /* annoyingly all the vars in this routine have different names from their counterparts
 914    in regmatch. /grrr */
 915
 916 STATIC char *
 917 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
 918     const char *strend, const regmatch_info *reginfo)
 919 {
 920         dVAR;
 921         const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
 922         char *m;
 923         STRLEN ln;
 924         STRLEN lnc;
 925         register STRLEN uskip;
 926         unsigned int c1;
 927         unsigned int c2;
 928         char *e;
 929         register I32 tmp = 1;   /* Scratch variable? */
 930         register const bool do_utf8 = PL_reg_match_utf8;
 931
 932         /* We know what class it must start with. */
 933         switch (OP(c)) {
 934         case ANYOF:
 935             if (do_utf8) {
 936                  while (s + (uskip = UTF8SKIP(s)) <= strend) {
 937                       if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
 938                           !UTF8_IS_INVARIANT((U8)s[0]) ?
 939                           reginclass(prog, c, (U8*)s, 0, do_utf8) :
 940                           REGINCLASS(prog, c, (U8*)s)) {
 941                            if (tmp && (!reginfo || regtry(reginfo, s)))
 942                                 goto got_it;
 943                            else
 944                                 tmp = doevery;
 945                       }
 946                       else
 947                            tmp = 1;
 948                       s += uskip;
 949                  }
 950             }
 951             else {
 952                  while (s < strend) {
 953                       STRLEN skip = 1;
 954
 955                       if (REGINCLASS(prog, c, (U8*)s) ||
 956                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
 957                            /* The assignment of 2 is intentional:
 958                             * for the folded sharp s, the skip is 2. */
 959                            (skip = SHARP_S_SKIP))) {
 960                            if (tmp && (!reginfo || regtry(reginfo, s)))
 961                                 goto got_it;
 962                            else
 963                                 tmp = doevery;
 964                       }
 965                       else
 966                            tmp = 1;
 967                       s += skip;
 968                  }
 969             }
 970             break;
 971         case CANY:
 972             while (s < strend) {
 973                 if (tmp && (!reginfo || regtry(reginfo, s)))
 974                     goto got_it;
 975                 else
 976                     tmp = doevery;
 977                 s++;
 978             }
 979             break;
 980         case EXACTF:
 981             m   = STRING(c);
 982             ln  = STR_LEN(c);   /* length to match in octets/bytes */
 983             lnc = (I32) ln;     /* length to match in characters */
 984             if (UTF) {
 985                 STRLEN ulen1, ulen2;
 986                 U8 *sm = (U8 *) m;
 987                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
 988                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
 989                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
 990
 991                 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
 992                 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
 993
 994                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
 995                                     0, uniflags);
 996                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
 997                                     0, uniflags);
 998                 lnc = 0;
 999                 while (sm < ((U8 *) m + ln)) {
1000                     lnc++;
1001                     sm += UTF8SKIP(sm);
1002                 }
1003             }
1004             else {
1005                 c1 = *(U8*)m;
1006                 c2 = PL_fold[c1];
1007             }
1008             goto do_exactf;
1009         case EXACTFL:
1010             m   = STRING(c);
1011             ln  = STR_LEN(c);
1012             lnc = (I32) ln;
1013             c1 = *(U8*)m;
1014             c2 = PL_fold_locale[c1];
1015           do_exactf:
1016             e = HOP3c(strend, -((I32)lnc), s);
1017
1018             if (!reginfo && e < s)
1019                 e = s;                  /* Due to minlen logic of intuit() */
1020
1021             /* The idea in the EXACTF* cases is to first find the
1022              * first character of the EXACTF* node and then, if
1023              * necessary, case-insensitively compare the full
1024              * text of the node.  The c1 and c2 are the first
1025              * characters (though in Unicode it gets a bit
1026              * more complicated because there are more cases
1027              * than just upper and lower: one needs to use
1028              * the so-called folding case for case-insensitive
1029              * matching (called "loose matching" in Unicode).
1030              * ibcmp_utf8() will do just that. */
1031
1032             if (do_utf8) {
1033                 UV c, f;
1034                 U8 tmpbuf [UTF8_MAXBYTES+1];
1035                 STRLEN len, foldlen;
1036                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1037                 if (c1 == c2) {
1038                     /* Upper and lower of 1st char are equal -
1039                      * probably not a "letter". */
1040                     while (s <= e) {
1041                         c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1042                                            uniflags);
1043                         if ( c == c1
1044                              && (ln == len ||
1045                                  ibcmp_utf8(s, NULL, 0,  do_utf8,
1046                                             m, NULL, ln, (bool)UTF))
1047                              && (!reginfo || regtry(reginfo, s)) )
1048                             goto got_it;
1049                         else {
1050                              U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1051                              uvchr_to_utf8(tmpbuf, c);
1052                              f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1053                              if ( f != c
1054                                   && (f == c1 || f == c2)
1055                                   && (ln == foldlen ||
1056                                       !ibcmp_utf8((char *) foldbuf,
1057                                                   NULL, foldlen, do_utf8,
1058                                                   m,
1059                                                   NULL, ln, (bool)UTF))
1060                                   && (!reginfo || regtry(reginfo, s)) )
1061                                   goto got_it;
1062                         }
1063                         s += len;
1064                     }
1065                 }
1066                 else {
1067                     while (s <= e) {
1068                       c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1069                                            uniflags);
1070
1071                         /* Handle some of the three Greek sigmas cases.
1072                          * Note that not all the possible combinations
1073                          * are handled here: some of them are handled
1074                          * by the standard folding rules, and some of
1075                          * them (the character class or ANYOF cases)
1076                          * are handled during compiletime in
1077                          * regexec.c:S_regclass(). */
1078                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1079                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1080                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1081
1082                         if ( (c == c1 || c == c2)
1083                              && (ln == len ||
1084                                  ibcmp_utf8(s, NULL, 0,  do_utf8,
1085                                             m, NULL, ln, (bool)UTF))
1086                              && (!reginfo || regtry(reginfo, s)) )
1087                             goto got_it;
1088                         else {
1089                              U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1090                              uvchr_to_utf8(tmpbuf, c);
1091                              f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1092                              if ( f != c
1093                                   && (f == c1 || f == c2)
1094                                   && (ln == foldlen ||
1095                                       !ibcmp_utf8((char *) foldbuf,
1096                                                   NULL, foldlen, do_utf8,
1097                                                   m,
1098                                                   NULL, ln, (bool)UTF))
1099                                   && (!reginfo || regtry(reginfo, s)) )
1100                                   goto got_it;
1101                         }
1102                         s += len;
1103                     }
1104                 }
1105             }
1106             else {
1107                 if (c1 == c2)
1108                     while (s <= e) {
1109                         if ( *(U8*)s == c1
1110                              && (ln == 1 || !(OP(c) == EXACTF
1111                                               ? ibcmp(s, m, ln)
1112                                               : ibcmp_locale(s, m, ln)))
1113                              && (!reginfo || regtry(reginfo, s)) )
1114                             goto got_it;
1115                         s++;
1116                     }
1117                 else
1118                     while (s <= e) {
1119                         if ( (*(U8*)s == c1 || *(U8*)s == c2)
1120                              && (ln == 1 || !(OP(c) == EXACTF
1121                                               ? ibcmp(s, m, ln)
1122                                               : ibcmp_locale(s, m, ln)))
1123                              && (!reginfo || regtry(reginfo, s)) )
1124                             goto got_it;
1125                         s++;
1126                     }
1127             }
1128             break;
1129         case BOUNDL:
1130             PL_reg_flags |= RF_tainted;
1131             /* FALL THROUGH */
1132         case BOUND:
1133             if (do_utf8) {
1134                 if (s == PL_bostr)
1135                     tmp = '\n';
1136                 else {
1137                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1138                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1139                 }
1140                 tmp = ((OP(c) == BOUND ?
1141                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1142                 LOAD_UTF8_CHARCLASS_ALNUM();
1143                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1144                     if (tmp == !(OP(c) == BOUND ?
1145                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1146                                  isALNUM_LC_utf8((U8*)s)))
1147                     {
1148                         tmp = !tmp;
1149                         if ((!reginfo || regtry(reginfo, s)))
1150                             goto got_it;
1151                     }
1152                     s += uskip;
1153                 }
1154             }
1155             else {
1156                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1157                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1158                 while (s < strend) {
1159                     if (tmp ==
1160                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1161                         tmp = !tmp;
1162                         if ((!reginfo || regtry(reginfo, s)))
1163                             goto got_it;
1164                     }
1165                     s++;
1166                 }
1167             }
1168             if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, s)))
1169                 goto got_it;
1170             break;
1171         case NBOUNDL:
1172             PL_reg_flags |= RF_tainted;
1173             /* FALL THROUGH */
1174         case NBOUND:
1175             if (do_utf8) {
1176                 if (s == PL_bostr)
1177                     tmp = '\n';
1178                 else {
1179                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1180                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1181                 }
1182                 tmp = ((OP(c) == NBOUND ?
1183                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1184                 LOAD_UTF8_CHARCLASS_ALNUM();
1185                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1186                     if (tmp == !(OP(c) == NBOUND ?
1187                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1188                                  isALNUM_LC_utf8((U8*)s)))
1189                         tmp = !tmp;
1190                     else if ((!reginfo || regtry(reginfo, s)))
1191                         goto got_it;
1192                     s += uskip;
1193                 }
1194             }
1195             else {
1196                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1197                 tmp = ((OP(c) == NBOUND ?
1198                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1199                 while (s < strend) {
1200                     if (tmp ==
1201                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1202                         tmp = !tmp;
1203                     else if ((!reginfo || regtry(reginfo, s)))
1204                         goto got_it;
1205                     s++;
1206                 }
1207             }
1208             if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, s)))
1209                 goto got_it;
1210             break;
1211         case ALNUM:
1212             if (do_utf8) {
1213                 LOAD_UTF8_CHARCLASS_ALNUM();
1214                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1215                     if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1216                         if (tmp && (!reginfo || regtry(reginfo, s)))
1217                             goto got_it;
1218                         else
1219                             tmp = doevery;
1220                     }
1221                     else
1222                         tmp = 1;
1223                     s += uskip;
1224                 }
1225             }
1226             else {
1227                 while (s < strend) {
1228                     if (isALNUM(*s)) {
1229                         if (tmp && (!reginfo || regtry(reginfo, s)))
1230                             goto got_it;
1231                         else
1232                             tmp = doevery;
1233                     }
1234                     else
1235                         tmp = 1;
1236                     s++;
1237                 }
1238             }
1239             break;
1240         case ALNUML:
1241             PL_reg_flags |= RF_tainted;
1242             if (do_utf8) {
1243                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1244                     if (isALNUM_LC_utf8((U8*)s)) {
1245                         if (tmp && (!reginfo || regtry(reginfo, s)))
1246                             goto got_it;
1247                         else
1248                             tmp = doevery;
1249                     }
1250                     else
1251                         tmp = 1;
1252                     s += uskip;
1253                 }
1254             }
1255             else {
1256                 while (s < strend) {
1257                     if (isALNUM_LC(*s)) {
1258                         if (tmp && (!reginfo || regtry(reginfo, s)))
1259                             goto got_it;
1260                         else
1261                             tmp = doevery;
1262                     }
1263                     else
1264                         tmp = 1;
1265                     s++;
1266                 }
1267             }
1268             break;
1269         case NALNUM:
1270             if (do_utf8) {
1271                 LOAD_UTF8_CHARCLASS_ALNUM();
1272                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1273                     if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1274                         if (tmp && (!reginfo || regtry(reginfo, s)))
1275                             goto got_it;
1276                         else
1277                             tmp = doevery;
1278                     }
1279                     else
1280                         tmp = 1;
1281                     s += uskip;
1282                 }
1283             }
1284             else {
1285                 while (s < strend) {
1286                     if (!isALNUM(*s)) {
1287                         if (tmp && (!reginfo || regtry(reginfo, s)))
1288                             goto got_it;
1289                         else
1290                             tmp = doevery;
1291                     }
1292                     else
1293                         tmp = 1;
1294                     s++;
1295                 }
1296             }
1297             break;
1298         case NALNUML:
1299             PL_reg_flags |= RF_tainted;
1300             if (do_utf8) {
1301                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1302                     if (!isALNUM_LC_utf8((U8*)s)) {
1303                         if (tmp && (!reginfo || regtry(reginfo, s)))
1304                             goto got_it;
1305                         else
1306                             tmp = doevery;
1307                     }
1308                     else
1309                         tmp = 1;
1310                     s += uskip;
1311                 }
1312             }
1313             else {
1314                 while (s < strend) {
1315                     if (!isALNUM_LC(*s)) {
1316                         if (tmp && (!reginfo || regtry(reginfo, s)))
1317                             goto got_it;
1318                         else
1319                             tmp = doevery;
1320                     }
1321                     else
1322                         tmp = 1;
1323                     s++;
1324                 }
1325             }
1326             break;
1327         case SPACE:
1328             if (do_utf8) {
1329                 LOAD_UTF8_CHARCLASS_SPACE();
1330                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1331                     if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1332                         if (tmp && (!reginfo || regtry(reginfo, s)))
1333                             goto got_it;
1334                         else
1335                             tmp = doevery;
1336                     }
1337                     else
1338                         tmp = 1;
1339                     s += uskip;
1340                 }
1341             }
1342             else {
1343                 while (s < strend) {
1344                     if (isSPACE(*s)) {
1345                         if (tmp && (!reginfo || regtry(reginfo, s)))
1346                             goto got_it;
1347                         else
1348                             tmp = doevery;
1349                     }
1350                     else
1351                         tmp = 1;
1352                     s++;
1353                 }
1354             }
1355             break;
1356         case SPACEL:
1357             PL_reg_flags |= RF_tainted;
1358             if (do_utf8) {
1359                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1360                     if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1361                         if (tmp && (!reginfo || regtry(reginfo, s)))
1362                             goto got_it;
1363                         else
1364                             tmp = doevery;
1365                     }
1366                     else
1367                         tmp = 1;
1368                     s += uskip;
1369                 }
1370             }
1371             else {
1372                 while (s < strend) {
1373                     if (isSPACE_LC(*s)) {
1374                         if (tmp && (!reginfo || regtry(reginfo, s)))
1375                             goto got_it;
1376                         else
1377                             tmp = doevery;
1378                     }
1379                     else
1380                         tmp = 1;
1381                     s++;
1382                 }
1383             }
1384             break;
1385         case NSPACE:
1386             if (do_utf8) {
1387                 LOAD_UTF8_CHARCLASS_SPACE();
1388                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1389                     if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1390                         if (tmp && (!reginfo || regtry(reginfo, s)))
1391                             goto got_it;
1392                         else
1393                             tmp = doevery;
1394                     }
1395                     else
1396                         tmp = 1;
1397                     s += uskip;
1398                 }
1399             }
1400             else {
1401                 while (s < strend) {
1402                     if (!isSPACE(*s)) {
1403                         if (tmp && (!reginfo || regtry(reginfo, s)))
1404                             goto got_it;
1405                         else
1406                             tmp = doevery;
1407                     }
1408                     else
1409                         tmp = 1;
1410                     s++;
1411                 }
1412             }
1413             break;
1414         case NSPACEL:
1415             PL_reg_flags |= RF_tainted;
1416             if (do_utf8) {
1417                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1418                     if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1419                         if (tmp && (!reginfo || regtry(reginfo, s)))
1420                             goto got_it;
1421                         else
1422                             tmp = doevery;
1423                     }
1424                     else
1425                         tmp = 1;
1426                     s += uskip;
1427                 }
1428             }
1429             else {
1430                 while (s < strend) {
1431                     if (!isSPACE_LC(*s)) {
1432                         if (tmp && (!reginfo || regtry(reginfo, s)))
1433                             goto got_it;
1434                         else
1435                             tmp = doevery;
1436                     }
1437                     else
1438                         tmp = 1;
1439                     s++;
1440                 }
1441             }
1442             break;
1443         case DIGIT:
1444             if (do_utf8) {
1445                 LOAD_UTF8_CHARCLASS_DIGIT();
1446                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1447                     if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1448                         if (tmp && (!reginfo || regtry(reginfo, s)))
1449                             goto got_it;
1450                         else
1451                             tmp = doevery;
1452                     }
1453                     else
1454                         tmp = 1;
1455                     s += uskip;
1456                 }
1457             }
1458             else {
1459                 while (s < strend) {
1460                     if (isDIGIT(*s)) {
1461                         if (tmp && (!reginfo || regtry(reginfo, s)))
1462                             goto got_it;
1463                         else
1464                             tmp = doevery;
1465                     }
1466                     else
1467                         tmp = 1;
1468                     s++;
1469                 }
1470             }
1471             break;
1472         case DIGITL:
1473             PL_reg_flags |= RF_tainted;
1474             if (do_utf8) {
1475                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1476                     if (isDIGIT_LC_utf8((U8*)s)) {
1477                         if (tmp && (!reginfo || regtry(reginfo, s)))
1478                             goto got_it;
1479                         else
1480                             tmp = doevery;
1481                     }
1482                     else
1483                         tmp = 1;
1484                     s += uskip;
1485                 }
1486             }
1487             else {
1488                 while (s < strend) {
1489                     if (isDIGIT_LC(*s)) {
1490                         if (tmp && (!reginfo || regtry(reginfo, s)))
1491                             goto got_it;
1492                         else
1493                             tmp = doevery;
1494                     }
1495                     else
1496                         tmp = 1;
1497                     s++;
1498                 }
1499             }
1500             break;
1501         case NDIGIT:
1502             if (do_utf8) {
1503                 LOAD_UTF8_CHARCLASS_DIGIT();
1504                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1505                     if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1506                         if (tmp && (!reginfo || regtry(reginfo, s)))
1507                             goto got_it;
1508                         else
1509                             tmp = doevery;
1510                     }
1511                     else
1512                         tmp = 1;
1513                     s += uskip;
1514                 }
1515             }
1516             else {
1517                 while (s < strend) {
1518                     if (!isDIGIT(*s)) {
1519                         if (tmp && (!reginfo || regtry(reginfo, s)))
1520                             goto got_it;
1521                         else
1522                             tmp = doevery;
1523                     }
1524                     else
1525                         tmp = 1;
1526                     s++;
1527                 }
1528             }
1529             break;
1530         case NDIGITL:
1531             PL_reg_flags |= RF_tainted;
1532             if (do_utf8) {
1533                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1534                     if (!isDIGIT_LC_utf8((U8*)s)) {
1535                         if (tmp && (!reginfo || regtry(reginfo, s)))
1536                             goto got_it;
1537                         else
1538                             tmp = doevery;
1539                     }
1540                     else
1541                         tmp = 1;
1542                     s += uskip;
1543                 }
1544             }
1545             else {
1546                 while (s < strend) {
1547                     if (!isDIGIT_LC(*s)) {
1548                         if (tmp && (!reginfo || regtry(reginfo, s)))
1549                             goto got_it;
1550                         else
1551                             tmp = doevery;
1552                     }
1553                     else
1554                         tmp = 1;
1555                     s++;
1556                 }
1557             }
1558             break;
1559         case TRIE:
1560             /*Perl_croak(aTHX_ "panic: unknown regstclass TRIE");*/
1561             {
1562                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
1563                     trie_type = do_utf8 ?
1564                           (c->flags == EXACT ? trie_utf8 : trie_utf8_fold)
1565                         : trie_plain;
1566                 /* what trie are we using right now */
1567                 reg_ac_data *aho
1568                     = (reg_ac_data*)prog->data->data[ ARG( c ) ];
1569                 reg_trie_data *trie=aho->trie;
1570
1571                 const char *last_start = strend - trie->minlen;
1572                 const char *real_start = s;
1573                 STRLEN maxlen = trie->maxlen;
1574                 SV *sv_points;
1575                 U8 **points; /* map of where we were in the input string
1576                                 when reading a given string. For ASCII this
1577                                 is unnecessary overhead as the relationship
1578                                 is always 1:1, but for unicode, especially
1579                                 case folded unicode this is not true. */
1580                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1581
1582                 GET_RE_DEBUG_FLAGS_DECL;
1583
1584                 /* We can't just allocate points here. We need to wrap it in
1585                  * an SV so it gets freed properly if there is a croak while
1586                  * running the match */
1587                 ENTER;
1588                 SAVETMPS;
1589                 sv_points=newSV(maxlen * sizeof(U8 *));
1590                 SvCUR_set(sv_points,
1591                     maxlen * sizeof(U8 *));
1592                 SvPOK_on(sv_points);
1593                 sv_2mortal(sv_points);
1594                 points=(U8**)SvPV_nolen(sv_points );
1595
1596                 if (trie->bitmap && trie_type != trie_utf8_fold) {
1597                     while (s <= last_start && !TRIE_BITMAP_TEST(trie,*s) ) {
1598                         s++;
1599                     }
1600                 }
1601
1602                 while (s <= last_start) {
1603                     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1604                     U8 *uc = (U8*)s;
1605                     U16 charid = 0;
1606                     U32 base = 1;
1607                     U32 state = 1;
1608                     UV uvc = 0;
1609                     STRLEN len = 0;
1610                     STRLEN foldlen = 0;
1611                     U8 *uscan = (U8*)NULL;
1612                     U8 *leftmost = NULL;
1613
1614                     U32 pointpos = 0;
1615
1616                     while ( state && uc <= (U8*)strend ) {
1617                         int failed=0;
1618                         if (aho->states[ state ].wordnum) {
1619                             U8 *lpos= points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1] ) % maxlen ];
1620                             if (!leftmost || lpos < leftmost)
1621                                 leftmost= lpos;
1622                             if (base==0) break;
1623                         }
1624                         points[pointpos++ % maxlen]= uc;
1625                         switch (trie_type) {
1626                         case trie_utf8_fold:
1627                             if ( foldlen>0 ) {
1628                                 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
1629                                 foldlen -= len;
1630                                 uscan += len;
1631                                 len=0;
1632                             } else {
1633                                 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
1634                                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
1635                                 foldlen -= UNISKIP( uvc );
1636                                 uscan = foldbuf + UNISKIP( uvc );
1637                             }
1638                             break;
1639                         case trie_utf8:
1640                             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
1641                                                         &len, uniflags );
1642                             break;
1643                         case trie_plain:
1644                             uvc = (UV)*uc;
1645                             len = 1;
1646                         }
1647
1648                         if (uvc < 256) {
1649                             charid = trie->charmap[ uvc ];
1650                         }
1651                         else {
1652                             charid = 0;
1653                             if (trie->widecharmap) {
1654                                 SV** const svpp = hv_fetch(trie->widecharmap,
1655                                     (char*)&uvc, sizeof(UV), 0);
1656                                 if (svpp)
1657                                     charid = (U16)SvIV(*svpp);
1658                             }
1659                         }
1660                         DEBUG_TRIE_EXECUTE_r(
1661                             PerlIO_printf(Perl_debug_log,
1662                                 "Pos: %d Charid:%3x CV:%4"UVxf" ",
1663                                 (int)((const char*)uc - real_start), charid, uvc)
1664                         );
1665                         uc += len;
1666
1667                         do {
1668                             U32 word = aho->states[ state ].wordnum;
1669                             base = aho->states[ state ].trans.base;
1670
1671                             DEBUG_TRIE_EXECUTE_r(
1672                                 PerlIO_printf( Perl_debug_log,
1673                                     "%sState: %4"UVxf", Base: 0x%-4"UVxf" uvc=%"UVxf" word=%"UVxf"\n",
1674                                     failed ? "Fail transition to " : "",
1675                                     state, base, uvc, word)
1676                             );
1677                             if ( base ) {
1678                                 U32 tmp;
1679                                 if (charid &&
1680                                      (base + charid > trie->uniquecharcount )
1681                                      && (base + charid - 1 - trie->uniquecharcount
1682                                             < trie->lasttrans)
1683                                      && trie->trans[base + charid - 1 -
1684                                             trie->uniquecharcount].check == state
1685                                      && (tmp=trie->trans[base + charid - 1 -
1686                                         trie->uniquecharcount ].next))
1687                                 {
1688                                     state = tmp;
1689                                     break;
1690                                 }
1691                                 else {
1692                                     failed++;
1693                                     if ( state == 1 )
1694                                         break;
1695                                     else
1696                                         state = aho->fail[state];
1697                                 }
1698                             }
1699                             else {
1700                                 /* we must be accepting here */
1701                                 failed++;
1702                                 break;
1703                             }
1704                         } while(state);
1705                         if (failed) {
1706                             if (leftmost)
1707                                 break;
1708                             else if (!charid && trie->bitmap && trie_type != trie_utf8_fold) {
1709                                 while ( uc <= (U8*)last_start  && !TRIE_BITMAP_TEST(trie,*uc) ) {
1710                                     uc++;
1711                                 }
1712                             }
1713                         }
1714                     }
1715                     if ( aho->states[ state ].wordnum ) {
1716                         U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1717                         if (!leftmost || lpos < leftmost)
1718                             leftmost = lpos;
1719                     }
1720                     DEBUG_TRIE_EXECUTE_r(
1721                         PerlIO_printf( Perl_debug_log,
1722                             "%sState: %4"UVxf", Base: 0x%-4"UVxf" uvc=%"UVxf"\n",
1723                             "All done: ",
1724                             state, base, uvc)
1725                     );
1726                     if (leftmost) {
1727                         s = (char*)leftmost;
1728                         if (!reginfo || regtry(reginfo, s)) {
1729                             FREETMPS;
1730                             LEAVE;
1731                             goto got_it;
1732                         }
1733                         s = HOPc(s,1);
1734                     } else {
1735                         break;
1736                     }
1737                 }
1738                 FREETMPS;
1739                 LEAVE;
1740             }
1741             break;
1742         default:
1743             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1744             break;
1745         }
1746         return 0;
1747       got_it:
1748         return s;
1749 }
1750
1751 /*
1752  - regexec_flags - match a regexp against a string
1753  */
1754 I32
1755 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1756               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1757 /* strend: pointer to null at end of string */
1758 /* strbeg: real beginning of string */
1759 /* minend: end of match must be >=minend after stringarg. */
1760 /* data: May be used for some additional optimizations. */
1761 /* nosave: For optimizations. */
1762 {
1763     dVAR;
1764     register char *s;
1765     register regnode *c;
1766     register char *startpos = stringarg;
1767     I32 minlen;         /* must match at least this many chars */
1768     I32 dontbother = 0; /* how many characters not to try at end */
1769     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1770     I32 scream_pos = -1;                /* Internal iterator of scream. */
1771     char *scream_olds = NULL;
1772     SV* const oreplsv = GvSV(PL_replgv);
1773     const bool do_utf8 = DO_UTF8(sv);
1774     I32 multiline;
1775 #ifdef DEBUGGING
1776     SV* dsv0;
1777     SV* dsv1;
1778 #endif
1779     regmatch_info reginfo;  /* create some info to pass to regtry etc */
1780
1781     GET_RE_DEBUG_FLAGS_DECL;
1782
1783     PERL_UNUSED_ARG(data);
1784
1785     /* Be paranoid... */
1786     if (prog == NULL || startpos == NULL) {
1787         Perl_croak(aTHX_ "NULL regexp parameter");
1788         return 0;
1789     }
1790
1791     multiline = prog->reganch & PMf_MULTILINE;
1792     reginfo.prog = prog;
1793
1794 #ifdef DEBUGGING
1795     dsv0 = PERL_DEBUG_PAD_ZERO(0);
1796     dsv1 = PERL_DEBUG_PAD_ZERO(1);
1797 #endif
1798
1799     RX_MATCH_UTF8_set(prog, do_utf8);
1800
1801     minlen = prog->minlen;
1802     if (strend - startpos < minlen) {
1803         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1804                               "String too short [regexec_flags]...\n"));
1805         goto phooey;
1806     }
1807
1808     /* Check validity of program. */
1809     if (UCHARAT(prog->program) != REG_MAGIC) {
1810         Perl_croak(aTHX_ "corrupted regexp program");
1811     }
1812
1813     PL_reg_flags = 0;
1814     PL_reg_eval_set = 0;
1815     PL_reg_maxiter = 0;
1816
1817     if (prog->reganch & ROPT_UTF8)
1818         PL_reg_flags |= RF_utf8;
1819
1820     /* Mark beginning of line for ^ and lookbehind. */
1821     reginfo.bol = startpos; /* XXX not used ??? */
1822     PL_bostr  = strbeg;
1823     reginfo.sv = sv;
1824
1825     /* Mark end of line for $ (and such) */
1826     PL_regeol = strend;
1827
1828     /* see how far we have to get to not match where we matched before */
1829     reginfo.till = startpos+minend;
1830
1831     /* If there is a "must appear" string, look for it. */
1832     s = startpos;
1833
1834     if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to set reginfo->ganch */
1835         MAGIC *mg;
1836
1837         if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
1838             reginfo.ganch = startpos;
1839         else if (sv && SvTYPE(sv) >= SVt_PVMG
1840                   && SvMAGIC(sv)
1841                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1842                   && mg->mg_len >= 0) {
1843             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
1844             if (prog->reganch & ROPT_ANCH_GPOS) {
1845                 if (s > reginfo.ganch)
1846                     goto phooey;
1847                 s = reginfo.ganch;
1848             }
1849         }
1850         else                            /* pos() not defined */
1851             reginfo.ganch = strbeg;
1852     }
1853
1854     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1855         re_scream_pos_data d;
1856
1857         d.scream_olds = &scream_olds;
1858         d.scream_pos = &scream_pos;
1859         s = re_intuit_start(prog, sv, s, strend, flags, &d);
1860         if (!s) {
1861             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1862             goto phooey;        /* not present */
1863         }
1864     }
1865
1866     DEBUG_EXECUTE_r({
1867         const char * const s0   = UTF
1868             ? pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
1869                           UNI_DISPLAY_REGEX)
1870             : prog->precomp;
1871         const int len0 = UTF ? (int)SvCUR(dsv0) : prog->prelen;
1872         const char * const s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60,
1873                                                UNI_DISPLAY_REGEX) : startpos;
1874         const int len1 = do_utf8 ? (int)SvCUR(dsv1) : strend - startpos;
1875          if (!PL_colorset)
1876              reginitcolors();
1877          PerlIO_printf(Perl_debug_log,
1878                        "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n",
1879                        PL_colors[4], PL_colors[5], PL_colors[0],
1880                        len0, len0, s0,
1881                        PL_colors[1],
1882                        len0 > 60 ? "..." : "",
1883                        PL_colors[0],
1884                        (int)(len1 > 60 ? 60 : len1),
1885                        s1, PL_colors[1],
1886                        (len1 > 60 ? "..." : "")
1887               );
1888     });
1889
1890     /* Simplest case:  anchored match need be tried only once. */
1891     /*  [unless only anchor is BOL and multiline is set] */
1892     if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1893         if (s == startpos && regtry(&reginfo, startpos))
1894             goto got_it;
1895         else if (multiline || (prog->reganch & ROPT_IMPLICIT)
1896                  || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1897         {
1898             char *end;
1899
1900             if (minlen)
1901                 dontbother = minlen - 1;
1902             end = HOP3c(strend, -dontbother, strbeg) - 1;
1903             /* for multiline we only have to try after newlines */
1904             if (prog->check_substr || prog->check_utf8) {
1905                 if (s == startpos)
1906                     goto after_try;
1907                 while (1) {
1908                     if (regtry(&reginfo, s))
1909                         goto got_it;
1910                   after_try:
1911                     if (s >= end)
1912                         goto phooey;
1913                     if (prog->reganch & RE_USE_INTUIT) {
1914                         s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1915                         if (!s)
1916                             goto phooey;
1917                     }
1918                     else
1919                         s++;
1920                 }
1921             } else {
1922                 if (s > startpos)
1923                     s--;
1924                 while (s < end) {
1925                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1926                         if (regtry(&reginfo, s))
1927                             goto got_it;
1928                     }
1929                 }
1930             }
1931         }
1932         goto phooey;
1933     } else if (prog->reganch & ROPT_ANCH_GPOS) {
1934         if (regtry(&reginfo, reginfo.ganch))
1935             goto got_it;
1936         goto phooey;
1937     }
1938
1939     /* Messy cases:  unanchored match. */
1940     if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1941         /* we have /x+whatever/ */
1942         /* it must be a one character string (XXXX Except UTF?) */
1943         char ch;
1944 #ifdef DEBUGGING
1945         int did_match = 0;
1946 #endif
1947         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1948             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1949         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1950
1951         if (do_utf8) {
1952             while (s < strend) {
1953                 if (*s == ch) {
1954                     DEBUG_EXECUTE_r( did_match = 1 );
1955                     if (regtry(&reginfo, s)) goto got_it;
1956                     s += UTF8SKIP(s);
1957                     while (s < strend && *s == ch)
1958                         s += UTF8SKIP(s);
1959                 }
1960                 s += UTF8SKIP(s);
1961             }
1962         }
1963         else {
1964             while (s < strend) {
1965                 if (*s == ch) {
1966                     DEBUG_EXECUTE_r( did_match = 1 );
1967                     if (regtry(&reginfo, s)) goto got_it;
1968                     s++;
1969                     while (s < strend && *s == ch)
1970                         s++;
1971                 }
1972                 s++;
1973             }
1974         }
1975         DEBUG_EXECUTE_r(if (!did_match)
1976                 PerlIO_printf(Perl_debug_log,
1977                                   "Did not find anchored character...\n")
1978                );
1979     }
1980     else if (prog->anchored_substr != NULL
1981               || prog->anchored_utf8 != NULL
1982               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1983                   && prog->float_max_offset < strend - s)) {
1984         SV *must;
1985         I32 back_max;
1986         I32 back_min;
1987         char *last;
1988         char *last1;            /* Last position checked before */
1989 #ifdef DEBUGGING
1990         int did_match = 0;
1991 #endif
1992         if (prog->anchored_substr || prog->anchored_utf8) {
1993             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1994                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1995             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1996             back_max = back_min = prog->anchored_offset;
1997         } else {
1998             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1999                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2000             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2001             back_max = prog->float_max_offset;
2002             back_min = prog->float_min_offset;
2003         }
2004         if (must == &PL_sv_undef)
2005             /* could not downgrade utf8 check substring, so must fail */
2006             goto phooey;
2007
2008         last = HOP3c(strend,    /* Cannot start after this */
2009                           -(I32)(CHR_SVLEN(must)
2010                                  - (SvTAIL(must) != 0) + back_min), strbeg);
2011
2012         if (s > PL_bostr)
2013             last1 = HOPc(s, -1);
2014         else
2015             last1 = s - 1;      /* bogus */
2016
2017         /* XXXX check_substr already used to find "s", can optimize if
2018            check_substr==must. */
2019         scream_pos = -1;
2020         dontbother = end_shift;
2021         strend = HOPc(strend, -dontbother);
2022         while ( (s <= last) &&
2023                 ((flags & REXEC_SCREAM)
2024                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
2025                                     end_shift, &scream_pos, 0))
2026                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
2027                                   (unsigned char*)strend, must,
2028                                   multiline ? FBMrf_MULTILINE : 0))) ) {
2029             /* we may be pointing at the wrong string */
2030             if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
2031                 s = strbeg + (s - SvPVX_const(sv));
2032             DEBUG_EXECUTE_r( did_match = 1 );
2033             if (HOPc(s, -back_max) > last1) {
2034                 last1 = HOPc(s, -back_min);
2035                 s = HOPc(s, -back_max);
2036             }
2037             else {
2038                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2039
2040                 last1 = HOPc(s, -back_min);
2041                 s = t;
2042             }
2043             if (do_utf8) {
2044                 while (s <= last1) {
2045                     if (regtry(&reginfo, s))
2046                         goto got_it;
2047                     s += UTF8SKIP(s);
2048                 }
2049             }
2050             else {
2051                 while (s <= last1) {
2052                     if (regtry(&reginfo, s))
2053                         goto got_it;
2054                     s++;
2055                 }
2056             }
2057         }
2058         DEBUG_EXECUTE_r(if (!did_match)
2059                     PerlIO_printf(Perl_debug_log,
2060                                   "Did not find %s substr \"%s%.*s%s\"%s...\n",
2061                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2062                                ? "anchored" : "floating"),
2063                               PL_colors[0],
2064                               (int)(SvCUR(must) - (SvTAIL(must)!=0)),
2065                               SvPVX_const(must),
2066                                   PL_colors[1], (SvTAIL(must) ? "$" : ""))
2067                );
2068         goto phooey;
2069     }
2070     else if ((c = prog->regstclass)) {
2071         if (minlen) {
2072             const OPCODE op = OP(prog->regstclass);
2073             /* don't bother with what can't match */
2074             if (PL_regkind[op] != EXACT && op != CANY && op != TRIE)
2075                 strend = HOPc(strend, -(minlen - 1));
2076         }
2077         DEBUG_EXECUTE_r({
2078             SV * const prop = sv_newmortal();
2079             const char *s0;
2080             const char *s1;
2081             int len0;
2082             int len1;
2083
2084             regprop(prog, prop, c);
2085             s0 = UTF ?
2086               pv_uni_display(dsv0, (U8*)SvPVX_const(prop), SvCUR(prop), 60,
2087                              UNI_DISPLAY_REGEX) :
2088               SvPVX_const(prop);
2089             len0 = UTF ? SvCUR(dsv0) : SvCUR(prop);
2090             s1 = UTF ?
2091               sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
2092             len1 = UTF ? (int)SvCUR(dsv1) : strend - s;
2093             PerlIO_printf(Perl_debug_log,
2094                           "Matching stclass \"%*.*s\" against \"%*.*s\" (%d chars)\n",
2095                           len0, len0, s0,
2096                           len1, len1, s1, (int)(strend - s));
2097         });
2098         if (find_byclass(prog, c, s, strend, &reginfo))
2099             goto got_it;
2100         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2101     }
2102     else {
2103         dontbother = 0;
2104         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2105             /* Trim the end. */
2106             char *last;
2107             SV* float_real;
2108
2109             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2110                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2111             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2112
2113             if (flags & REXEC_SCREAM) {
2114                 last = screaminstr(sv, float_real, s - strbeg,
2115                                    end_shift, &scream_pos, 1); /* last one */
2116                 if (!last)
2117                     last = scream_olds; /* Only one occurrence. */
2118                 /* we may be pointing at the wrong string */
2119                 else if (RX_MATCH_COPIED(prog))
2120                     s = strbeg + (s - SvPVX_const(sv));
2121             }
2122             else {
2123                 STRLEN len;
2124                 const char * const little = SvPV_const(float_real, len);
2125
2126                 if (SvTAIL(float_real)) {
2127                     if (memEQ(strend - len + 1, little, len - 1))
2128                         last = strend - len + 1;
2129                     else if (!multiline)
2130                         last = memEQ(strend - len, little, len)
2131                             ? strend - len : NULL;
2132                     else
2133                         goto find_last;
2134                 } else {
2135                   find_last:
2136                     if (len)
2137                         last = rninstr(s, strend, little, little + len);
2138                     else
2139                         last = strend;  /* matching "$" */
2140                 }
2141             }
2142             if (last == NULL) {
2143                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2144                                       "%sCan't trim the tail, match fails (should not happen)%s\n",
2145                                       PL_colors[4], PL_colors[5]));
2146                 goto phooey; /* Should not happen! */
2147             }
2148             dontbother = strend - last + prog->float_min_offset;
2149         }
2150         if (minlen && (dontbother < minlen))
2151             dontbother = minlen - 1;
2152         strend -= dontbother;              /* this one's always in bytes! */
2153         /* We don't know much -- general case. */
2154         if (do_utf8) {
2155             for (;;) {
2156                 if (regtry(&reginfo, s))
2157                     goto got_it;
2158                 if (s >= strend)
2159                     break;
2160                 s += UTF8SKIP(s);
2161             };
2162         }
2163         else {
2164             do {
2165                 if (regtry(&reginfo, s))
2166                     goto got_it;
2167             } while (s++ < strend);
2168         }
2169     }
2170
2171     /* Failure. */
2172     goto phooey;
2173
2174 got_it:
2175     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2176
2177     if (PL_reg_eval_set) {
2178         /* Preserve the current value of $^R */
2179         if (oreplsv != GvSV(PL_replgv))
2180             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2181                                                   restored, the value remains
2182                                                   the same. */
2183         restore_pos(aTHX_ prog);
2184     }
2185
2186     /* make sure $`, $&, $', and $digit will work later */
2187     if ( !(flags & REXEC_NOT_FIRST) ) {
2188         RX_MATCH_COPY_FREE(prog);
2189         if (flags & REXEC_COPY_STR) {
2190             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2191 #ifdef PERL_OLD_COPY_ON_WRITE
2192             if ((SvIsCOW(sv)
2193                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2194                 if (DEBUG_C_TEST) {
2195                     PerlIO_printf(Perl_debug_log,
2196                                   "Copy on write: regexp capture, type %d\n",
2197                                   (int) SvTYPE(sv));
2198                 }
2199                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2200                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2201                 assert (SvPOKp(prog->saved_copy));
2202             } else
2203 #endif
2204             {
2205                 RX_MATCH_COPIED_on(prog);
2206                 s = savepvn(strbeg, i);
2207                 prog->subbeg = s;
2208             }
2209             prog->sublen = i;
2210         }
2211         else {
2212             prog->subbeg = strbeg;
2213             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2214         }
2215     }
2216
2217     return 1;
2218
2219 phooey:
2220     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2221                           PL_colors[4], PL_colors[5]));
2222     if (PL_reg_eval_set)
2223         restore_pos(aTHX_ prog);
2224     return 0;
2225 }
2226
2227 /*
2228  - regtry - try match at specific point
2229  */
2230 STATIC I32                      /* 0 failure, 1 success */
2231 S_regtry(pTHX_ const regmatch_info *reginfo, char *startpos)
2232 {
2233     dVAR;
2234     register I32 *sp;
2235     register I32 *ep;
2236     CHECKPOINT lastcp;
2237     regexp *prog = reginfo->prog;
2238     GET_RE_DEBUG_FLAGS_DECL;
2239
2240 #ifdef DEBUGGING
2241     PL_regindent = 0;   /* XXXX Not good when matches are reenterable... */
2242 #endif
2243     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2244         MAGIC *mg;
2245
2246         PL_reg_eval_set = RS_init;
2247         DEBUG_EXECUTE_r(DEBUG_s(
2248             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2249                           (IV)(PL_stack_sp - PL_stack_base));
2250             ));
2251         SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2252         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2253         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2254         SAVETMPS;
2255         /* Apparently this is not needed, judging by wantarray. */
2256         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2257            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2258
2259         if (reginfo->sv) {
2260             /* Make $_ available to executed code. */
2261             if (reginfo->sv != DEFSV) {
2262                 SAVE_DEFSV;
2263                 DEFSV = reginfo->sv;
2264             }
2265
2266             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2267                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2268                 /* prepare for quick setting of pos */
2269 #ifdef PERL_OLD_COPY_ON_WRITE
2270                 if (SvIsCOW(sv))
2271                     sv_force_normal_flags(sv, 0);
2272 #endif
2273                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2274                                  &PL_vtbl_mglob, NULL, 0);
2275                 mg->mg_len = -1;
2276             }
2277             PL_reg_magic    = mg;
2278             PL_reg_oldpos   = mg->mg_len;
2279             SAVEDESTRUCTOR_X(restore_pos, prog);
2280         }
2281         if (!PL_reg_curpm) {
2282             Newxz(PL_reg_curpm, 1, PMOP);
2283 #ifdef USE_ITHREADS
2284             {
2285                 SV* const repointer = newSViv(0);
2286                 /* so we know which PL_regex_padav element is PL_reg_curpm */
2287                 SvFLAGS(repointer) |= SVf_BREAK;
2288                 av_push(PL_regex_padav,repointer);
2289                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2290                 PL_regex_pad = AvARRAY(PL_regex_padav);
2291             }
2292 #endif
2293         }
2294         PM_SETRE(PL_reg_curpm, prog);
2295         PL_reg_oldcurpm = PL_curpm;
2296         PL_curpm = PL_reg_curpm;
2297         if (RX_MATCH_COPIED(prog)) {
2298             /*  Here is a serious problem: we cannot rewrite subbeg,
2299                 since it may be needed if this match fails.  Thus
2300                 $` inside (?{}) could fail... */
2301             PL_reg_oldsaved = prog->subbeg;
2302             PL_reg_oldsavedlen = prog->sublen;
2303 #ifdef PERL_OLD_COPY_ON_WRITE
2304             PL_nrs = prog->saved_copy;
2305 #endif
2306             RX_MATCH_COPIED_off(prog);
2307         }
2308         else
2309             PL_reg_oldsaved = NULL;
2310         prog->subbeg = PL_bostr;
2311         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2312     }
2313     prog->startp[0] = startpos - PL_bostr;
2314     PL_reginput = startpos;
2315     PL_regstartp = prog->startp;
2316     PL_regendp = prog->endp;
2317     PL_reglastparen = &prog->lastparen;
2318     PL_reglastcloseparen = &prog->lastcloseparen;
2319     prog->lastparen = 0;
2320     prog->lastcloseparen = 0;
2321     PL_regsize = 0;
2322     DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
2323     if (PL_reg_start_tmpl <= prog->nparens) {
2324         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2325         if(PL_reg_start_tmp)
2326             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2327         else
2328             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2329     }
2330
2331     /* XXXX What this code is doing here?!!!  There should be no need
2332        to do this again and again, PL_reglastparen should take care of
2333        this!  --ilya*/
2334
2335     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2336      * Actually, the code in regcppop() (which Ilya may be meaning by
2337      * PL_reglastparen), is not needed at all by the test suite
2338      * (op/regexp, op/pat, op/split), but that code is needed, oddly
2339      * enough, for building DynaLoader, or otherwise this
2340      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2341      * will happen.  Meanwhile, this code *is* needed for the
2342      * above-mentioned test suite tests to succeed.  The common theme
2343      * on those tests seems to be returning null fields from matches.
2344      * --jhi */
2345 #if 1
2346     sp = prog->startp;
2347     ep = prog->endp;
2348     if (prog->nparens) {
2349         register I32 i;
2350         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2351             *++sp = -1;
2352             *++ep = -1;
2353         }
2354     }
2355 #endif
2356     REGCP_SET(lastcp);
2357     if (regmatch(reginfo, prog->program + 1)) {
2358         prog->endp[0] = PL_reginput - PL_bostr;
2359         return 1;
2360     }
2361     REGCP_UNWIND(lastcp);
2362     return 0;
2363 }
2364
2365
2366 #define sayYES goto yes
2367 #define sayNO goto no
2368 #define sayNO_ANYOF goto no_anyof
2369 #define sayYES_FINAL goto yes_final
2370 #define sayNO_FINAL  goto no_final
2371 #define sayNO_SILENT goto do_no
2372 #define saySAME(x) if (x) goto yes; else goto no
2373
2374 #define POSCACHE_SUCCESS 0      /* caching success rather than failure */
2375 #define POSCACHE_SEEN 1         /* we know what we're caching */
2376 #define POSCACHE_START 2        /* the real cache: this bit maps to pos 0 */
2377
2378 #define CACHEsayYES STMT_START { \
2379     if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2380         if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2381             PL_reg_poscache[0] |= (1<<POSCACHE_SUCCESS) | (1<<POSCACHE_SEEN); \
2382             PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2383         } \
2384         else if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS)) { \
2385             PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2386         } \
2387         else { \
2388             /* cache records failure, but this is success */ \
2389             DEBUG_r( \
2390                 PerlIO_printf(Perl_debug_log, \
2391                     "%*s  (remove success from failure cache)\n", \
2392                     REPORT_CODE_OFF+PL_regindent*2, "") \
2393             ); \
2394             PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2395         } \
2396     } \
2397     sayYES; \
2398 } STMT_END
2399
2400 #define CACHEsayNO STMT_START { \
2401     if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2402         if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2403             PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2404             PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2405         } \
2406         else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2407             PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2408         } \
2409         else { \
2410             /* cache records success, but this is failure */ \
2411             DEBUG_r( \
2412                 PerlIO_printf(Perl_debug_log, \
2413                     "%*s  (remove failure from success cache)\n", \
2414                     REPORT_CODE_OFF+PL_regindent*2, "") \
2415             ); \
2416             PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2417         } \
2418     } \
2419     sayNO; \
2420 } STMT_END
2421
2422 /* this is used to determine how far from the left messages like
2423    'failed...' are printed. Currently 29 makes these messages line
2424    up with the opcode they refer to. Earlier perls used 25 which
2425    left these messages outdented making reviewing a debug output
2426    quite difficult.
2427 */
2428 #define REPORT_CODE_OFF 29
2429
2430
2431 /* Make sure there is a test for this +1 options in re_tests */
2432 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2433
2434 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2435 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2436
2437 #define SLAB_FIRST(s) (&(s)->states[0])
2438 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2439
2440 /* grab a new slab and return the first slot in it */
2441
2442 STATIC regmatch_state *
2443 S_push_slab(pTHX)
2444 {
2445 #if PERL_VERSION < 9
2446     dMY_CXT;
2447 #endif
2448     regmatch_slab *s = PL_regmatch_slab->next;
2449     if (!s) {
2450         Newx(s, 1, regmatch_slab);
2451         s->prev = PL_regmatch_slab;
2452         s->next = NULL;
2453         PL_regmatch_slab->next = s;
2454     }
2455     PL_regmatch_slab = s;
2456     return SLAB_FIRST(s);
2457 }
2458
2459 /* simulate a recursive call to regmatch */
2460
2461 #define REGMATCH(ns, where) \
2462     st->scan = scan; \
2463     scan = (ns); \
2464     st->resume_state = resume_##where; \
2465     goto start_recurse; \
2466     resume_point_##where:
2467
2468 /* push a new state then goto it */
2469
2470 #define PUSH_STATE_GOTO(state, node) \
2471     scan = node; \
2472     st->resume_state = state; \
2473     goto push_state;
2474
2475 /* push a new state with success backtracking, then goto it */
2476
2477 #define PUSH_YES_STATE_GOTO(state, node) \
2478     scan = node; \
2479     st->resume_state = state; \
2480     goto push_yes_state;
2481
2482
2483
2484 /*
2485  - regmatch - main matching routine
2486  *
2487  * Conceptually the strategy is simple:  check to see whether the current
2488  * node matches, call self recursively to see whether the rest matches,
2489  * and then act accordingly.  In practice we make some effort to avoid
2490  * recursion, in particular by going through "ordinary" nodes (that don't
2491  * need to know whether the rest of the match failed) by a loop instead of
2492  * by recursion.
2493  */
2494 /* [lwall] I've hoisted the register declarations to the outer block in order to
2495  * maybe save a little bit of pushing and popping on the stack.  It also takes
2496  * advantage of machines that use a register save mask on subroutine entry.
2497  *
2498  * This function used to be heavily recursive, but since this had the
2499  * effect of blowing the CPU stack on complex regexes, it has been
2500  * restructured to be iterative, and to save state onto the heap rather
2501  * than the stack. Essentially whereever regmatch() used to be called, it
2502  * pushes the current state, notes where to return, then jumps back into
2503  * the main loop.
2504  *
2505  * Originally the structure of this function used to look something like
2506
2507     S_regmatch() {
2508         int a = 1, b = 2;
2509         ...
2510         while (scan != NULL) {
2511             a++; // do stuff with a and b
2512             ...
2513             switch (OP(scan)) {
2514                 case FOO: {
2515                     int local = 3;
2516                     ...
2517                     if (regmatch(...))  // recurse
2518                         goto yes;
2519                 }
2520                 ...
2521             }
2522         }
2523         yes:
2524         return 1;
2525     }
2526
2527  * Now it looks something like this:
2528
2529     typedef struct {
2530         int a, b, local;
2531         int resume_state;
2532     } regmatch_state;
2533
2534     S_regmatch() {
2535         regmatch_state *st = new();
2536         int depth=0;
2537         st->a++; // do stuff with a and b
2538         ...
2539         while (scan != NULL) {
2540             ...
2541             switch (OP(scan)) {
2542                 case FOO: {
2543                     st->local = 3;
2544                     ...
2545                     st->scan = scan;
2546                     scan = ...;
2547                     st->resume_state = resume_FOO;
2548                     goto start_recurse; // recurse
2549
2550                     resume_point_FOO:
2551                     if (result)
2552                         goto yes;
2553                 }
2554                 ...
2555             }
2556           start_recurse:
2557             st = new(); push a new state
2558             st->a = 1; st->b = 2;
2559             depth++;
2560         }
2561       yes:
2562         result = 1;
2563         if (depth--) {
2564             st = pop();
2565             switch (resume_state) {
2566             case resume_FOO:
2567                 goto resume_point_FOO;
2568             ...
2569             }
2570         }
2571         return result
2572     }
2573
2574  * WARNING: this means that any line in this function that contains a
2575  * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2576  * regmatch() using gotos instead. Thus the values of any local variables
2577  * not saved in the regmatch_state structure will have been lost when
2578  * execution resumes on the next line .
2579  *
2580  * States (ie the st pointer) are allocated in slabs of about 4K in size.
2581  * PL_regmatch_state always points to the currently active state, and
2582  * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2583  * The first time regmatch is called, the first slab is allocated, and is
2584  * never freed until interpreter desctruction. When the slab is full,
2585  * a new one is allocated chained to the end. At exit from regmatch, slabs
2586  * allocated since entry are freed.
2587  */
2588
2589 /* *** every FOO_fail should = FOO+1 */
2590 #define TRIE_next              (REGNODE_MAX+1)
2591 #define TRIE_next_fail         (REGNODE_MAX+2)
2592 #define EVAL_A                 (REGNODE_MAX+3)
2593 #define EVAL_A_fail            (REGNODE_MAX+4)
2594 #define resume_CURLYX          (REGNODE_MAX+5)
2595 #define resume_WHILEM1         (REGNODE_MAX+6)
2596 #define resume_WHILEM2         (REGNODE_MAX+7)
2597 #define resume_WHILEM3         (REGNODE_MAX+8)
2598 #define resume_WHILEM4         (REGNODE_MAX+9)
2599 #define resume_WHILEM5         (REGNODE_MAX+10)
2600 #define resume_WHILEM6         (REGNODE_MAX+11)
2601 #define BRANCH_next            (REGNODE_MAX+12)
2602 #define BRANCH_next_fail       (REGNODE_MAX+13)
2603 #define CURLYM_A               (REGNODE_MAX+14)
2604 #define CURLYM_A_fail          (REGNODE_MAX+15)
2605 #define CURLYM_B               (REGNODE_MAX+16)
2606 #define CURLYM_B_fail          (REGNODE_MAX+17)
2607 #define IFMATCH_A              (REGNODE_MAX+18)
2608 #define IFMATCH_A_fail         (REGNODE_MAX+19)
2609 #define CURLY_B_min_known      (REGNODE_MAX+20)
2610 #define CURLY_B_min_known_fail (REGNODE_MAX+21)
2611 #define CURLY_B_min            (REGNODE_MAX+22)
2612 #define CURLY_B_min_fail       (REGNODE_MAX+23)
2613 #define CURLY_B_max            (REGNODE_MAX+24)
2614 #define CURLY_B_max_fail       (REGNODE_MAX+25)
2615
2616
2617 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2618
2619 #ifdef DEBUGGING
2620 STATIC void
2621 S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const bool do_utf8)
2622 {
2623     const int docolor = *PL_colors[0];
2624     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2625     int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2626     /* The part of the string before starttry has one color
2627        (pref0_len chars), between starttry and current
2628        position another one (pref_len - pref0_len chars),
2629        after the current position the third one.
2630        We assume that pref0_len <= pref_len, otherwise we
2631        decrease pref0_len.  */
2632     int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2633         ? (5 + taill) - l : locinput - PL_bostr;
2634     int pref0_len;
2635
2636     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2637         pref_len++;
2638     pref0_len = pref_len  - (locinput - PL_reg_starttry);
2639     if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2640         l = ( PL_regeol - locinput > (5 + taill) - pref_len
2641               ? (5 + taill) - pref_len : PL_regeol - locinput);
2642     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2643         l--;
2644     if (pref0_len < 0)
2645         pref0_len = 0;
2646     if (pref0_len > pref_len)
2647         pref0_len = pref_len;
2648     {
2649       const char * const s0 =
2650         do_utf8 && OP(scan) != CANY ?
2651         pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
2652                        pref0_len, 60, UNI_DISPLAY_REGEX) :
2653         locinput - pref_len;
2654       const int len0 = do_utf8 ? (int)strlen(s0) : pref0_len;
2655       const char * const s1 = do_utf8 && OP(scan) != CANY ?
2656         pv_uni_display(PERL_DEBUG_PAD(1),
2657                        (U8*)(locinput - pref_len + pref0_len),
2658                        pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2659         locinput - pref_len + pref0_len;
2660       const int len1 = do_utf8 ? (int)strlen(s1) : pref_len - pref0_len;
2661       const char * const s2 = do_utf8 && OP(scan) != CANY ?
2662         pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
2663                        PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2664         locinput;
2665       const int len2 = do_utf8 ? (int)strlen(s2) : l;
2666       PerlIO_printf(Perl_debug_log,
2667                     "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|",
2668                     (IV)(locinput - PL_bostr),
2669                     PL_colors[4],
2670                     len0, s0,
2671                     PL_colors[5],
2672                     PL_colors[2],
2673                     len1, s1,
2674                     PL_colors[3],
2675                     (docolor ? "" : "> <"),
2676                     PL_colors[0],
2677                     len2, s2,
2678                     PL_colors[1],
2679                     15 - l - pref_len + 1,
2680                     "");
2681     }
2682 }
2683 #endif
2684
2685 STATIC I32                      /* 0 failure, 1 success */
2686 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2687 {
2688 #if PERL_VERSION < 9
2689     dMY_CXT;
2690 #endif
2691     dVAR;
2692     register const bool do_utf8 = PL_reg_match_utf8;
2693     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2694
2695     regexp *rex = reginfo->prog;
2696
2697     regmatch_slab  *orig_slab;
2698     regmatch_state *orig_state;
2699
2700     /* the current state. This is a cached copy of PL_regmatch_state */
2701     register regmatch_state *st;
2702
2703     /* cache heavy used fields of st in registers */
2704     register regnode *scan;
2705     register regnode *next;
2706     register I32 n = 0; /* initialize to shut up compiler warning */
2707     register char *locinput = PL_reginput;
2708
2709     /* these variables are NOT saved during a recusive RFEGMATCH: */
2710     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2711     bool result;            /* return value of S_regmatch */
2712     int depth = 0;          /* depth of recursion */
2713     regmatch_state *yes_state = NULL; /* state to pop to on success of
2714                                                             subpattern */
2715     U32 state_num;
2716
2717 #ifdef DEBUGGING
2718     GET_RE_DEBUG_FLAGS_DECL;
2719     PL_regindent++;
2720 #endif
2721
2722     /* on first ever call to regmatch, allocate first slab */
2723     if (!PL_regmatch_slab) {
2724         Newx(PL_regmatch_slab, 1, regmatch_slab);
2725         PL_regmatch_slab->prev = NULL;
2726         PL_regmatch_slab->next = NULL;
2727         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2728     }
2729
2730     /* remember current high-water mark for exit */
2731     /* XXX this should be done with SAVE* instead */
2732     orig_slab  = PL_regmatch_slab;
2733     orig_state = PL_regmatch_state;
2734
2735     /* grab next free state slot */
2736     st = ++PL_regmatch_state;
2737     if (st >  SLAB_LAST(PL_regmatch_slab))
2738         st = PL_regmatch_state = S_push_slab(aTHX);
2739
2740     st->minmod = 0;
2741     st->sw = 0;
2742     st->logical = 0;
2743     st->cc = NULL;
2744     /* Note that nextchr is a byte even in UTF */
2745     nextchr = UCHARAT(locinput);
2746     scan = prog;
2747     while (scan != NULL) {
2748
2749         DEBUG_EXECUTE_r( {
2750             SV * const prop = sv_newmortal();
2751             dump_exec_pos( locinput, scan, do_utf8 );
2752             regprop(rex, prop, scan);
2753
2754             PerlIO_printf(Perl_debug_log,
2755                     "%3"IVdf":%*s%s(%"IVdf")\n",
2756                     (IV)(scan - rex->program), PL_regindent*2, "",
2757                     SvPVX_const(prop),
2758                     PL_regkind[OP(scan)] == END ? 0 : (IV)(regnext(scan) - rex->program));
2759         });
2760
2761         next = scan + NEXT_OFF(scan);
2762         if (next == scan)
2763             next = NULL;
2764         state_num = OP(scan);
2765
2766       reenter_switch:
2767         switch (state_num) {
2768         case BOL:
2769             if (locinput == PL_bostr)
2770             {
2771                 /* reginfo->till = reginfo->bol; */
2772                 break;
2773             }
2774             sayNO;
2775         case MBOL:
2776             if (locinput == PL_bostr ||
2777                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2778             {
2779                 break;
2780             }
2781             sayNO;
2782         case SBOL:
2783             if (locinput == PL_bostr)
2784                 break;
2785             sayNO;
2786         case GPOS:
2787             if (locinput == reginfo->ganch)
2788                 break;
2789             sayNO;
2790         case EOL:
2791                 goto seol;
2792         case MEOL:
2793             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2794                 sayNO;
2795             break;
2796         case SEOL:
2797           seol:
2798             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2799                 sayNO;
2800             if (PL_regeol - locinput > 1)
2801                 sayNO;
2802             break;
2803         case EOS:
2804             if (PL_regeol != locinput)
2805                 sayNO;
2806             break;
2807         case SANY:
2808             if (!nextchr && locinput >= PL_regeol)
2809                 sayNO;
2810             if (do_utf8) {
2811                 locinput += PL_utf8skip[nextchr];
2812                 if (locinput > PL_regeol)
2813                     sayNO;
2814                 nextchr = UCHARAT(locinput);
2815             }
2816             else
2817                 nextchr = UCHARAT(++locinput);
2818             break;
2819         case CANY:
2820             if (!nextchr && locinput >= PL_regeol)
2821                 sayNO;
2822             nextchr = UCHARAT(++locinput);
2823             break;
2824         case REG_ANY:
2825             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2826                 sayNO;
2827             if (do_utf8) {
2828                 locinput += PL_utf8skip[nextchr];
2829                 if (locinput > PL_regeol)
2830                     sayNO;
2831                 nextchr = UCHARAT(locinput);
2832             }
2833             else
2834                 nextchr = UCHARAT(++locinput);
2835             break;
2836
2837 #undef  ST
2838 #define ST st->u.trie
2839
2840         case TRIE:
2841             {
2842                 /* what type of TRIE am I? (utf8 makes this contextual) */
2843                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2844                     trie_type = do_utf8 ?
2845                           (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2846                         : trie_plain;
2847
2848                 /* what trie are we using right now */
2849                 reg_trie_data * const trie
2850                     = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2851                 U32 state = trie->startstate;
2852
2853                 U8 *uc = ( U8* )locinput;
2854                 U16 charid = 0;
2855                 U32 base = 0;
2856                 UV uvc = 0;
2857                 STRLEN len = 0;
2858                 STRLEN foldlen = 0;
2859                 U8 *uscan = (U8*)NULL;
2860                 STRLEN bufflen=0;
2861                 SV *sv_accept_buff = NULL;
2862                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2863
2864                 ST.accepted = 0; /* how many accepting states we have seen */
2865                 ST.B = next;
2866 #ifdef DEBUGGING
2867                 ST.me = scan;
2868 #endif
2869
2870                 if (trie->bitmap && trie_type != trie_utf8_fold &&
2871                     !TRIE_BITMAP_TEST(trie,*locinput)
2872                 ) {
2873                     if (trie->states[ state ].wordnum) {
2874                          DEBUG_EXECUTE_r(
2875                             PerlIO_printf(Perl_debug_log,
2876                                           "%*s  %smatched empty string...%s\n",
2877                                           REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2878                         );
2879                         break;
2880                     } else {
2881                         DEBUG_EXECUTE_r(
2882                             PerlIO_printf(Perl_debug_log,
2883                                           "%*s  %sfailed to match start class...%s\n",
2884                                           REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2885                         );
2886                         sayNO_SILENT;
2887                    }
2888                 }
2889
2890                 /*
2891                    traverse the TRIE keeping track of all accepting states
2892                    we transition through until we get to a failing node.
2893                 */
2894
2895                 while ( state && uc <= (U8*)PL_regeol ) {
2896
2897                     if (trie->states[ state ].wordnum) {
2898                         if (!ST.accepted ) {
2899                             ENTER;
2900                             SAVETMPS;
2901                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2902                             sv_accept_buff=newSV(bufflen *
2903                                             sizeof(reg_trie_accepted) - 1);
2904                             SvCUR_set(sv_accept_buff,
2905                                                 sizeof(reg_trie_accepted));
2906                             SvPOK_on(sv_accept_buff);
2907                             sv_2mortal(sv_accept_buff);
2908                             SAVETMPS;
2909                             ST.accept_buff =
2910                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2911                         }
2912                         else {
2913                             if (ST.accepted >= bufflen) {
2914                                 bufflen *= 2;
2915                                 ST.accept_buff =(reg_trie_accepted*)
2916                                     SvGROW(sv_accept_buff,
2917                                         bufflen * sizeof(reg_trie_accepted));
2918                             }
2919                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2920                                 + sizeof(reg_trie_accepted));
2921                         }
2922                         ST.accept_buff[ST.accepted].wordnum = trie->states[state].wordnum;
2923                         ST.accept_buff[ST.accepted].endpos = uc;
2924                         ++ST.accepted;
2925                     }
2926
2927                     base = trie->states[ state ].trans.base;
2928
2929                     DEBUG_TRIE_EXECUTE_r({
2930                                 dump_exec_pos( (char *)uc, scan, do_utf8 );
2931                                 PerlIO_printf( Perl_debug_log,
2932                                     "%*s  %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2933                                     2+PL_regindent * 2, "", PL_colors[4],
2934                                     (UV)state, (UV)base, (UV)ST.accepted );
2935                     });
2936
2937                     if ( base ) {
2938                         switch (trie_type) {
2939                         case trie_utf8_fold:
2940                             if ( foldlen>0 ) {
2941                                 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2942                                 foldlen -= len;
2943                                 uscan += len;
2944                                 len=0;
2945                             } else {
2946                                 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2947                                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2948                                 foldlen -= UNISKIP( uvc );
2949                                 uscan = foldbuf + UNISKIP( uvc );
2950                             }
2951                             break;
2952                         case trie_utf8:
2953                             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
2954                                                             &len, uniflags );
2955                             break;
2956                         case trie_plain:
2957                             uvc = (UV)*uc;
2958                             len = 1;
2959                         }
2960
2961                         if (uvc < 256) {
2962                             charid = trie->charmap[ uvc ];
2963                         }
2964                         else {
2965                             charid = 0;
2966                             if (trie->widecharmap) {
2967                                 SV** const svpp = hv_fetch(trie->widecharmap,
2968                                             (char*)&uvc, sizeof(UV), 0);
2969                                 if (svpp)
2970                                     charid = (U16)SvIV(*svpp);
2971                             }
2972                         }
2973
2974                         if (charid &&
2975                              (base + charid > trie->uniquecharcount )
2976                              && (base + charid - 1 - trie->uniquecharcount
2977                                     < trie->lasttrans)
2978                              && trie->trans[base + charid - 1 -
2979                                     trie->uniquecharcount].check == state)
2980                         {
2981                             state = trie->trans[base + charid - 1 -
2982                                 trie->uniquecharcount ].next;
2983                         }
2984                         else {
2985                             state = 0;
2986                         }
2987                         uc += len;
2988
2989                     }
2990                     else {
2991                         state = 0;
2992                     }
2993                     DEBUG_TRIE_EXECUTE_r(
2994                         PerlIO_printf( Perl_debug_log,
2995                             "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
2996                             charid, uvc, (UV)state, PL_colors[5] );
2997                     );
2998                 }
2999                 if (!ST.accepted )
3000                    sayNO;
3001
3002                 DEBUG_EXECUTE_r(
3003                     PerlIO_printf( Perl_debug_log,
3004                         "%*s  %sgot %"IVdf" possible matches%s\n",
3005                         REPORT_CODE_OFF + PL_regindent * 2, "",
3006                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3007                 );
3008             }
3009
3010             /* FALL THROUGH */
3011
3012         case TRIE_next_fail: /* we failed - try next alterative */
3013
3014             if ( ST.accepted == 1 ) {
3015                 /* only one choice left - just continue */
3016                 DEBUG_EXECUTE_r({
3017                     reg_trie_data * const trie
3018                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
3019                     SV ** const tmp = RX_DEBUG(reginfo->prog)
3020                                     ? av_fetch( trie->words, ST.accept_buff[ 0 ].wordnum-1, 0 )
3021                                     : NULL;
3022                     PerlIO_printf( Perl_debug_log,
3023                         "%*s  %sonly one match left: #%d <%s>%s\n",
3024                         REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
3025                         ST.accept_buff[ 0 ].wordnum,
3026                         tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
3027                         PL_colors[5] );
3028                 });
3029                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3030                 /* in this case we free tmps/leave before we call regmatch
3031                    as we wont be using accept_buff again. */
3032                 FREETMPS;
3033                 LEAVE;
3034                 locinput = PL_reginput;
3035                 nextchr = UCHARAT(locinput);
3036                 scan = ST.B;
3037                 continue; /* execute rest of RE */
3038             }
3039
3040             if (!ST.accepted-- ) {
3041                 FREETMPS;
3042                 LEAVE;
3043                 sayNO;
3044             }
3045
3046             /*
3047                There are at least two accepting states left.  Presumably
3048                the number of accepting states is going to be low,
3049                typically two. So we simply scan through to find the one
3050                with lowest wordnum.  Once we find it, we swap the last
3051                state into its place and decrement the size. We then try to
3052                match the rest of the pattern at the point where the word
3053                ends. If we succeed, control just continues along the
3054                regex; if we fail we return here to try the next accepting
3055                state
3056              */
3057
3058             {
3059                 U32 best = 0;
3060                 U32 cur;
3061                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3062                     DEBUG_TRIE_EXECUTE_r(
3063                         PerlIO_printf( Perl_debug_log,
3064                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3065                             REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
3066                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3067                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3068                     );
3069
3070                     if (ST.accept_buff[cur].wordnum <
3071                             ST.accept_buff[best].wordnum)
3072                         best = cur;
3073                 }
3074
3075                 DEBUG_EXECUTE_r({
3076                     reg_trie_data * const trie
3077                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
3078                     SV ** const tmp = RX_DEBUG(reginfo->prog)
3079                                 ? av_fetch( trie->words, ST.accept_buff[ best ].wordnum - 1, 0 )
3080                                 : NULL;
3081                     PerlIO_printf( Perl_debug_log, "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3082                         REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
3083                         ST.accept_buff[best].wordnum,
3084                         tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", REG_NODE_NUM(scan),
3085                         PL_colors[5] );
3086                 });
3087
3088                 if ( best<ST.accepted ) {
3089                     reg_trie_accepted tmp = ST.accept_buff[ best ];
3090                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3091                     ST.accept_buff[ ST.accepted ] = tmp;
3092                     best = ST.accepted;
3093                 }
3094                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3095             }
3096             PUSH_STATE_GOTO(TRIE_next, ST.B);
3097             /* NOTREACHED */
3098
3099 #undef  ST
3100
3101         case EXACT: {
3102             char *s = STRING(scan);
3103             st->ln = STR_LEN(scan);
3104             if (do_utf8 != UTF) {
3105                 /* The target and the pattern have differing utf8ness. */
3106                 char *l = locinput;
3107                 const char * const e = s + st->ln;
3108
3109                 if (do_utf8) {
3110                     /* The target is utf8, the pattern is not utf8. */
3111                     while (s < e) {
3112                         STRLEN ulen;
3113                         if (l >= PL_regeol)
3114                              sayNO;
3115                         if (NATIVE_TO_UNI(*(U8*)s) !=
3116                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3117                                             uniflags))
3118                              sayNO;
3119                         l += ulen;
3120                         s ++;
3121                     }
3122                 }
3123                 else {
3124                     /* The target is not utf8, the pattern is utf8. */
3125                     while (s < e) {
3126                         STRLEN ulen;
3127                         if (l >= PL_regeol)
3128                             sayNO;
3129                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3130                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3131                                            uniflags))
3132                             sayNO;
3133                         s += ulen;
3134                         l ++;
3135                     }
3136                 }
3137                 locinput = l;
3138                 nextchr = UCHARAT(locinput);
3139                 break;
3140             }
3141             /* The target and the pattern have the same utf8ness. */
3142             /* Inline the first character, for speed. */
3143             if (UCHARAT(s) != nextchr)
3144                 sayNO;
3145             if (PL_regeol - locinput < st->ln)
3146                 sayNO;
3147             if (st->ln > 1 && memNE(s, locinput, st->ln))
3148                 sayNO;
3149             locinput += st->ln;
3150             nextchr = UCHARAT(locinput);
3151             break;
3152             }
3153         case EXACTFL:
3154             PL_reg_flags |= RF_tainted;
3155             /* FALL THROUGH */
3156         case EXACTF: {
3157             char * const s = STRING(scan);
3158             st->ln = STR_LEN(scan);
3159
3160             if (do_utf8 || UTF) {
3161               /* Either target or the pattern are utf8. */
3162                 const char * const l = locinput;
3163                 char *e = PL_regeol;
3164
3165                 if (ibcmp_utf8(s, 0,  st->ln, (bool)UTF,
3166                                l, &e, 0,  do_utf8)) {
3167                      /* One more case for the sharp s:
3168                       * pack("U0U*", 0xDF) =~ /ss/i,
3169                       * the 0xC3 0x9F are the UTF-8
3170                       * byte sequence for the U+00DF. */
3171                      if (!(do_utf8 &&
3172                            toLOWER(s[0]) == 's' &&
3173                            st->ln >= 2 &&
3174                            toLOWER(s[1]) == 's' &&
3175                            (U8)l[0] == 0xC3 &&
3176                            e - l >= 2 &&
3177                            (U8)l[1] == 0x9F))
3178                           sayNO;
3179                 }
3180                 locinput = e;
3181                 nextchr = UCHARAT(locinput);
3182                 break;
3183             }
3184
3185             /* Neither the target and the pattern are utf8. */
3186
3187             /* Inline the first character, for speed. */
3188             if (UCHARAT(s) != nextchr &&
3189                 UCHARAT(s) != ((OP(scan) == EXACTF)
3190                                ? PL_fold : PL_fold_locale)[nextchr])
3191                 sayNO;
3192             if (PL_regeol - locinput < st->ln)
3193                 sayNO;
3194             if (st->ln > 1 && (OP(scan) == EXACTF
3195                            ? ibcmp(s, locinput, st->ln)
3196                            : ibcmp_locale(s, locinput, st->ln)))
3197                 sayNO;
3198             locinput += st->ln;
3199             nextchr = UCHARAT(locinput);
3200             break;
3201             }
3202         case ANYOF:
3203             if (do_utf8) {
3204                 STRLEN inclasslen = PL_regeol - locinput;
3205
3206                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3207                     sayNO_ANYOF;
3208                 if (locinput >= PL_regeol)
3209                     sayNO;
3210                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3211                 nextchr = UCHARAT(locinput);
3212                 break;
3213             }
3214             else {
3215                 if (nextchr < 0)
3216                     nextchr = UCHARAT(locinput);
3217                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3218                     sayNO_ANYOF;
3219                 if (!nextchr && locinput >= PL_regeol)
3220                     sayNO;
3221                 nextchr = UCHARAT(++locinput);
3222                 break;
3223             }
3224         no_anyof:
3225             /* If we might have the case of the German sharp s
3226              * in a casefolding Unicode character class. */
3227
3228             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3229                  locinput += SHARP_S_SKIP;
3230                  nextchr = UCHARAT(locinput);
3231             }
3232             else
3233                  sayNO;
3234             break;
3235         case ALNUML:
3236             PL_reg_flags |= RF_tainted;
3237             /* FALL THROUGH */
3238         case ALNUM:
3239             if (!nextchr)
3240                 sayNO;
3241             if (do_utf8) {
3242                 LOAD_UTF8_CHARCLASS_ALNUM();
3243                 if (!(OP(scan) == ALNUM
3244                       ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3245                       : isALNUM_LC_utf8((U8*)locinput)))
3246                 {
3247                     sayNO;
3248                 }
3249                 locinput += PL_utf8skip[nextchr];
3250                 nextchr = UCHARAT(locinput);
3251                 break;
3252             }
3253             if (!(OP(scan) == ALNUM
3254                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3255                 sayNO;
3256             nextchr = UCHARAT(++locinput);
3257             break;
3258         case NALNUML:
3259             PL_reg_flags |= RF_tainted;
3260             /* FALL THROUGH */
3261         case NALNUM:
3262             if (!nextchr && locinput >= PL_regeol)
3263                 sayNO;
3264             if (do_utf8) {
3265                 LOAD_UTF8_CHARCLASS_ALNUM();
3266                 if (OP(scan) == NALNUM
3267                     ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3268                     : isALNUM_LC_utf8((U8*)locinput))
3269                 {
3270                     sayNO;
3271                 }
3272                 locinput += PL_utf8skip[nextchr];
3273                 nextchr = UCHARAT(locinput);
3274                 break;
3275             }
3276             if (OP(scan) == NALNUM
3277                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3278                 sayNO;
3279             nextchr = UCHARAT(++locinput);
3280             break;
3281         case BOUNDL:
3282         case NBOUNDL:
3283             PL_reg_flags |= RF_tainted;
3284             /* FALL THROUGH */
3285         case BOUND:
3286         case NBOUND:
3287             /* was last char in word? */
3288             if (do_utf8) {
3289                 if (locinput == PL_bostr)
3290                     st->ln = '\n';
3291                 else {
3292                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3293
3294                     st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3295                 }
3296                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3297                     st->ln = isALNUM_uni(st->ln);
3298                     LOAD_UTF8_CHARCLASS_ALNUM();
3299                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3300                 }
3301                 else {
3302                     st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3303                     n = isALNUM_LC_utf8((U8*)locinput);
3304                 }
3305             }
3306             else {
3307                 st->ln = (locinput != PL_bostr) ?
3308                     UCHARAT(locinput - 1) : '\n';
3309                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3310                     st->ln = isALNUM(st->ln);
3311                     n = isALNUM(nextchr);
3312                 }
3313                 else {
3314                     st->ln = isALNUM_LC(st->ln);
3315                     n = isALNUM_LC(nextchr);
3316                 }
3317             }
3318             if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3319                                     OP(scan) == BOUNDL))
3320                     sayNO;
3321             break;
3322         case SPACEL:
3323             PL_reg_flags |= RF_tainted;
3324             /* FALL THROUGH */
3325         case SPACE:
3326             if (!nextchr)
3327                 sayNO;
3328             if (do_utf8) {
3329                 if (UTF8_IS_CONTINUED(nextchr)) {
3330                     LOAD_UTF8_CHARCLASS_SPACE();
3331                     if (!(OP(scan) == SPACE
3332                           ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3333                           : isSPACE_LC_utf8((U8*)locinput)))
3334                     {
3335                         sayNO;
3336                     }
3337                     locinput += PL_utf8skip[nextchr];
3338                     nextchr = UCHARAT(locinput);
3339                     break;
3340                 }
3341                 if (!(OP(scan) == SPACE
3342                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3343                     sayNO;
3344                 nextchr = UCHARAT(++locinput);
3345             }
3346             else {
3347                 if (!(OP(scan) == SPACE
3348                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3349                     sayNO;
3350                 nextchr = UCHARAT(++locinput);
3351             }
3352             break;
3353         case NSPACEL:
3354             PL_reg_flags |= RF_tainted;
3355             /* FALL THROUGH */
3356         case NSPACE:
3357             if (!nextchr && locinput >= PL_regeol)
3358                 sayNO;
3359             if (do_utf8) {
3360                 LOAD_UTF8_CHARCLASS_SPACE();
3361                 if (OP(scan) == NSPACE
3362                     ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3363                     : isSPACE_LC_utf8((U8*)locinput))
3364                 {
3365                     sayNO;
3366                 }
3367                 locinput += PL_utf8skip[nextchr];
3368                 nextchr = UCHARAT(locinput);
3369                 break;
3370             }
3371             if (OP(scan) == NSPACE
3372                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3373                 sayNO;
3374             nextchr = UCHARAT(++locinput);
3375             break;
3376         case DIGITL:
3377             PL_reg_flags |= RF_tainted;
3378             /* FALL THROUGH */
3379         case DIGIT:
3380             if (!nextchr)
3381                 sayNO;
3382             if (do_utf8) {
3383                 LOAD_UTF8_CHARCLASS_DIGIT();
3384                 if (!(OP(scan) == DIGIT
3385                       ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3386                       : isDIGIT_LC_utf8((U8*)locinput)))
3387                 {
3388                     sayNO;
3389                 }
3390                 locinput += PL_utf8skip[nextchr];
3391                 nextchr = UCHARAT(locinput);
3392                 break;
3393             }
3394             if (!(OP(scan) == DIGIT
3395                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3396                 sayNO;
3397             nextchr = UCHARAT(++locinput);
3398             break;
3399         case NDIGITL:
3400             PL_reg_flags |= RF_tainted;
3401             /* FALL THROUGH */
3402         case NDIGIT:
3403             if (!nextchr && locinput >= PL_regeol)
3404                 sayNO;
3405             if (do_utf8) {
3406                 LOAD_UTF8_CHARCLASS_DIGIT();
3407                 if (OP(scan) == NDIGIT
3408                     ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3409                     : isDIGIT_LC_utf8((U8*)locinput))
3410                 {
3411                     sayNO;
3412                 }
3413                 locinput += PL_utf8skip[nextchr];
3414                 nextchr = UCHARAT(locinput);
3415                 break;
3416             }
3417             if (OP(scan) == NDIGIT
3418                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3419                 sayNO;
3420             nextchr = UCHARAT(++locinput);
3421             break;
3422         case CLUMP:
3423             if (locinput >= PL_regeol)
3424                 sayNO;
3425             if  (do_utf8) {
3426                 LOAD_UTF8_CHARCLASS_MARK();
3427                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3428                     sayNO;
3429                 locinput += PL_utf8skip[nextchr];
3430                 while (locinput < PL_regeol &&
3431                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3432                     locinput += UTF8SKIP(locinput);
3433                 if (locinput > PL_regeol)
3434                     sayNO;
3435             }
3436             else
3437                locinput++;
3438             nextchr = UCHARAT(locinput);
3439             break;
3440         case REFFL:
3441             PL_reg_flags |= RF_tainted;
3442             /* FALL THROUGH */
3443         case REF:
3444         case REFF: {
3445             char *s;
3446             n = ARG(scan);  /* which paren pair */
3447             st->ln = PL_regstartp[n];
3448             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3449             if ((I32)*PL_reglastparen < n || st->ln == -1)
3450                 sayNO;                  /* Do not match unless seen CLOSEn. */
3451             if (st->ln == PL_regendp[n])
3452                 break;
3453
3454             s = PL_bostr + st->ln;
3455             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
3456                 char *l = locinput;
3457                 const char *e = PL_bostr + PL_regendp[n];
3458                 /*
3459                  * Note that we can't do the "other character" lookup trick as
3460                  * in the 8-bit case (no pun intended) because in Unicode we
3461                  * have to map both upper and title case to lower case.
3462                  */
3463                 if (OP(scan) == REFF) {
3464                     while (s < e) {
3465                         STRLEN ulen1, ulen2;
3466                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3467                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3468
3469                         if (l >= PL_regeol)
3470                             sayNO;
3471                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3472                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3473                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3474                             sayNO;
3475                         s += ulen1;
3476                         l += ulen2;
3477                     }
3478                 }
3479                 locinput = l;
3480                 nextchr = UCHARAT(locinput);
3481                 break;
3482             }
3483
3484             /* Inline the first character, for speed. */
3485             if (UCHARAT(s) != nextchr &&
3486                 (OP(scan) == REF ||
3487                  (UCHARAT(s) != ((OP(scan) == REFF
3488                                   ? PL_fold : PL_fold_locale)[nextchr]))))
3489                 sayNO;
3490             st->ln = PL_regendp[n] - st->ln;
3491             if (locinput + st->ln > PL_regeol)
3492                 sayNO;
3493             if (st->ln > 1 && (OP(scan) == REF
3494                            ? memNE(s, locinput, st->ln)
3495                            : (OP(scan) == REFF
3496                               ? ibcmp(s, locinput, st->ln)
3497                               : ibcmp_locale(s, locinput, st->ln))))
3498                 sayNO;
3499             locinput += st->ln;
3500             nextchr = UCHARAT(locinput);
3501             break;
3502             }
3503
3504         case NOTHING:
3505         case TAIL:
3506             break;
3507         case BACK:
3508             break;
3509
3510 #undef  ST
3511 #define ST st->u.eval
3512
3513         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3514         {
3515             SV *ret;
3516             {
3517                 /* execute the code in the {...} */
3518                 dSP;
3519                 SV ** const before = SP;
3520                 OP_4tree * const oop = PL_op;
3521                 COP * const ocurcop = PL_curcop;
3522                 PAD *old_comppad;
3523
3524                 n = ARG(scan);
3525                 PL_op = (OP_4tree*)rex->data->data[n];
3526                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3527                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3528                 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3529
3530                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3531                 SPAGAIN;
3532                 if (SP == before)
3533                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3534                 else {
3535                     ret = POPs;
3536                     PUTBACK;
3537                 }
3538
3539                 PL_op = oop;
3540                 PAD_RESTORE_LOCAL(old_comppad);
3541                 PL_curcop = ocurcop;
3542                 if (!st->logical) {
3543                     /* /(?{...})/ */
3544                     sv_setsv(save_scalar(PL_replgv), ret);
3545                     break;
3546                 }
3547             }
3548             if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3549                 regexp *re;
3550                 {
3551                     /* extract RE object from returned value; compiling if
3552                      * necessary */
3553
3554                     MAGIC *mg = NULL;
3555                     const SV *sv;
3556                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3557                         mg = mg_find(sv, PERL_MAGIC_qr);
3558                     else if (SvSMAGICAL(ret)) {
3559                         if (SvGMAGICAL(ret))
3560                             sv_unmagic(ret, PERL_MAGIC_qr);
3561                         else
3562                             mg = mg_find(ret, PERL_MAGIC_qr);
3563                     }
3564
3565                     if (mg) {
3566                         re = (regexp *)mg->mg_obj;
3567                         (void)ReREFCNT_inc(re);
3568                     }
3569                     else {
3570                         STRLEN len;
3571                         const char * const t = SvPV_const(ret, len);
3572                         PMOP pm;
3573                         const I32 osize = PL_regsize;
3574
3575                         Zero(&pm, 1, PMOP);
3576                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3577                         re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3578                         if (!(SvFLAGS(ret)
3579                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3580                                 | SVs_GMG)))
3581                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3582                                         PERL_MAGIC_qr,0,0);
3583                         PL_regsize = osize;
3584                     }
3585                 }
3586
3587                 /* run the pattern returned from (??{...}) */
3588
3589                 DEBUG_EXECUTE_r(
3590                     PerlIO_printf(Perl_debug_log,
3591                                   "Entering embedded \"%s%.60s%s%s\"\n",
3592                                   PL_colors[0],
3593                                   re->precomp,
3594                                   PL_colors[1],
3595                                   (strlen(re->precomp) > 60 ? "..." : ""))
3596                     );
3597
3598                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3599                 REGCP_SET(ST.lastcp);
3600                 *PL_reglastparen = 0;
3601                 *PL_reglastcloseparen = 0;
3602                 PL_reginput = locinput;
3603
3604                 /* XXXX This is too dramatic a measure... */
3605                 PL_reg_maxiter = 0;
3606
3607                 st->logical = 0;
3608                 ST.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3609                             ((re->reganch & ROPT_UTF8) != 0);
3610                 if (ST.toggleutf) PL_reg_flags ^= RF_utf8;
3611                 ST.prev_rex = rex;
3612                 rex = re;
3613
3614                 ST.B = next;
3615                 /* now continue  from first node in postoned RE */
3616                 PUSH_YES_STATE_GOTO(EVAL_A, re->program + 1);
3617                 /* NOTREACHED */
3618             }
3619             /* /(?(?{...})X|Y)/ */
3620             st->sw = SvTRUE(ret);
3621             st->logical = 0;
3622             break;
3623         }
3624
3625         case EVAL_A: /* successfully ran inner rex (??{rex}) */
3626             if (ST.toggleutf)
3627                 PL_reg_flags ^= RF_utf8;
3628             ReREFCNT_dec(rex);
3629             rex = ST.prev_rex;
3630             /* XXXX This is too dramatic a measure... */
3631             PL_reg_maxiter = 0;
3632             /* Restore parens of the caller without popping the
3633              * savestack */
3634             {
3635                 const I32 tmp = PL_savestack_ix;
3636                 PL_savestack_ix = ST.lastcp;
3637                 regcppop(rex);
3638                 PL_savestack_ix = tmp;
3639             }
3640             PL_reginput = locinput;
3641              /* continue at the node following the (??{...}) */
3642             scan = ST.B;
3643             continue;
3644
3645         case EVAL_A_fail: /* unsuccessfully ran inner rex (??{rex}) */
3646             /* Restore state to the outer re then re-throw the failure */
3647             if (ST.toggleutf)
3648                 PL_reg_flags ^= RF_utf8;
3649             ReREFCNT_dec(rex);
3650             rex = ST.prev_rex;
3651
3652             /* XXXX This is too dramatic a measure... */
3653             PL_reg_maxiter = 0;
3654
3655             PL_reginput = locinput;
3656             REGCP_UNWIND(ST.lastcp);
3657             regcppop(rex);
3658             sayNO_SILENT;
3659
3660 #undef ST
3661
3662         case OPEN:
3663             n = ARG(scan);  /* which paren pair */
3664             PL_reg_start_tmp[n] = locinput;
3665             if (n > PL_regsize)
3666                 PL_regsize = n;
3667             break;
3668         case CLOSE:
3669             n = ARG(scan);  /* which paren pair */
3670             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3671             PL_regendp[n] = locinput - PL_bostr;
3672             if (n > (I32)*PL_reglastparen)
3673                 *PL_reglastparen = n;
3674             *PL_reglastcloseparen = n;
3675             break;
3676         case GROUPP:
3677             n = ARG(scan);  /* which paren pair */
3678             st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3679             break;
3680         case IFTHEN:
3681             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3682             if (st->sw)
3683                 next = NEXTOPER(NEXTOPER(scan));
3684             else {
3685                 next = scan + ARG(scan);
3686                 if (OP(next) == IFTHEN) /* Fake one. */
3687                     next = NEXTOPER(NEXTOPER(next));
3688             }
3689             break;
3690         case LOGICAL:
3691             st->logical = scan->flags;
3692             break;
3693 /*******************************************************************
3694  cc points to the regmatch_state associated with the most recent CURLYX.
3695  This struct contains info about the innermost (...)* loop (an
3696  "infoblock"), and a pointer to the next outer cc.
3697
3698  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3699
3700    1) After matching Y, regnode for CURLYX is processed;
3701
3702    2) This regnode populates cc, and calls regmatch() recursively
3703       with the starting point at WHILEM node;
3704
3705    3) Each hit of WHILEM node tries to match A and Z (in the order
3706       depending on the current iteration, min/max of {min,max} and
3707       greediness).  The information about where are nodes for "A"
3708       and "Z" is read from cc, as is info on how many times "A"
3709       was already matched, and greediness.
3710
3711    4) After A matches, the same WHILEM node is hit again.
3712
3713    5) Each time WHILEM is hit, cc is the infoblock created by CURLYX
3714       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
3715       resets cc, since this Y(A)*Z can be a part of some other loop:
3716       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
3717       of the external loop.
3718
3719  Currently present infoblocks form a tree with a stem formed by st->cc
3720  and whatever it mentions via ->next, and additional attached trees
3721  corresponding to temporarily unset infoblocks as in "5" above.
3722
3723  In the following picture, infoblocks for outer loop of
3724  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
3725  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
3726  infoblocks are drawn below the "reset" infoblock.
3727
3728  In fact in the picture below we do not show failed matches for Z and T
3729  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
3730  more obvious *why* one needs to *temporary* unset infoblocks.]
3731
3732   Matched       REx position    InfoBlocks      Comment
3733                 (Y(A)*?Z)*?T    x
3734                 Y(A)*?Z)*?T     x <- O
3735   Y             (A)*?Z)*?T      x <- O
3736   Y             A)*?Z)*?T       x <- O <- I
3737   YA            )*?Z)*?T        x <- O <- I
3738   YA            A)*?Z)*?T       x <- O <- I
3739   YAA           )*?Z)*?T        x <- O <- I
3740   YAA           Z)*?T           x <- O          # Temporary unset I
3741                                      I
3742
3743   YAAZ          Y(A)*?Z)*?T     x <- O
3744                                      I
3745
3746   YAAZY         (A)*?Z)*?T      x <- O
3747                                      I
3748
3749   YAAZY         A)*?Z)*?T       x <- O <- I
3750                                      I
3751
3752   YAAZYA        )*?Z)*?T        x <- O <- I
3753                                      I
3754
3755   YAAZYA        Z)*?T           x <- O          # Temporary unset I
3756                                      I,I
3757
3758   YAAZYAZ       )*?T            x <- O
3759                                      I,I
3760
3761   YAAZYAZ       T               x               # Temporary unset O
3762                                 O
3763                                 I,I
3764
3765   YAAZYAZT                      x
3766                                 O
3767                                 I,I
3768  *******************************************************************/
3769
3770         case CURLYX: {
3771                 /* No need to save/restore up to this paren */
3772                 I32 parenfloor = scan->flags;
3773
3774                 /* Dave says:
3775
3776                    CURLYX and WHILEM are always paired: they're the moral
3777                    equivalent of pp_enteriter anbd pp_iter.
3778
3779                    The only time next could be null is if the node tree is
3780                    corrupt. This was mentioned on p5p a few days ago.
3781
3782                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3783                    So we'll assert that this is true:
3784                 */
3785                 assert(next);
3786                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3787                     next += ARG(next);
3788                 /* XXXX Probably it is better to teach regpush to support
3789                    parenfloor > PL_regsize... */
3790                 if (parenfloor > (I32)*PL_reglastparen)
3791                     parenfloor = *PL_reglastparen; /* Pessimization... */
3792
3793                 st->u.curlyx.cp = PL_savestack_ix;
3794                 st->u.curlyx.outercc = st->cc;
3795                 st->cc = st;
3796                 /* these fields contain the state of the current curly.
3797                  * they are accessed by subsequent WHILEMs;
3798                  * cur and lastloc are also updated by WHILEM */
3799                 st->u.curlyx.parenfloor = parenfloor;
3800                 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3801                 st->u.curlyx.min = ARG1(scan);
3802                 st->u.curlyx.max  = ARG2(scan);
3803                 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3804                 st->u.curlyx.lastloc = 0;
3805                 /* st->next and st->minmod are also read by WHILEM */
3806
3807                 PL_reginput = locinput;
3808                 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3809                 /*** all unsaved local vars undefined at this point */
3810                 regcpblow(st->u.curlyx.cp);
3811                 st->cc = st->u.curlyx.outercc;
3812                 saySAME(result);
3813             }
3814             /* NOTREACHED */
3815         case WHILEM: {
3816                 /*
3817                  * This is really hard to understand, because after we match
3818                  * what we're trying to match, we must make sure the rest of
3819                  * the REx is going to match for sure, and to do that we have
3820                  * to go back UP the parse tree by recursing ever deeper.  And
3821                  * if it fails, we have to reset our parent's current state
3822                  * that we can try again after backing off.
3823                  */
3824
3825                 /* Dave says:
3826
3827                    st->cc gets initialised by CURLYX ready for use by WHILEM.
3828                    So again, unless somethings been corrupted, st->cc cannot
3829                    be null at that point in WHILEM.
3830
3831                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3832                    So we'll assert that this is true:
3833                 */
3834                 assert(st->cc);
3835                 st->u.whilem.lastloc = st->cc->u.curlyx.lastloc; /* Detection of 0-len. */
3836                 st->u.whilem.cache_offset = 0;
3837                 st->u.whilem.cache_bit = 0;
3838
3839                 n = st->cc->u.curlyx.cur + 1; /* how many we know we matched */
3840                 PL_reginput = locinput;
3841
3842                 DEBUG_EXECUTE_r(
3843                     PerlIO_printf(Perl_debug_log,
3844                                   "%*s  %ld out of %ld..%ld  cc=%"UVxf"\n",
3845                                   REPORT_CODE_OFF+PL_regindent*2, "",
3846                                   (long)n, (long)st->cc->u.curlyx.min,
3847                                   (long)st->cc->u.curlyx.max, PTR2UV(st->cc))
3848                     );
3849
3850                 /* If degenerate scan matches "", assume scan done. */
3851
3852                 if (locinput == st->cc->u.curlyx.lastloc && n >= st->cc->u.curlyx.min) {
3853                     st->u.whilem.savecc = st->cc;
3854                     st->cc = st->cc->u.curlyx.outercc;
3855                     if (st->cc)
3856                         st->ln = st->cc->u.curlyx.cur;
3857                     DEBUG_EXECUTE_r(
3858                         PerlIO_printf(Perl_debug_log,
3859                            "%*s  empty match detected, try continuation...\n",
3860                            REPORT_CODE_OFF+PL_regindent*2, "")
3861                         );
3862                     REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3863                     /*** all unsaved local vars undefined at this point */
3864                     st->cc = st->u.whilem.savecc;
3865                     if (result)
3866                         sayYES;
3867                     if (st->cc->u.curlyx.outercc)
3868                         st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3869                     sayNO;
3870                 }
3871
3872                 /* First just match a string of min scans. */
3873
3874                 if (n < st->cc->u.curlyx.min) {
3875                     st->cc->u.curlyx.cur = n;
3876                     st->cc->u.curlyx.lastloc = locinput;
3877                     REGMATCH(st->cc->u.curlyx.scan, WHILEM2);
3878                     /*** all unsaved local vars undefined at this point */
3879                     if (result)
3880                         sayYES;
3881                     st->cc->u.curlyx.cur = n - 1;
3882                     st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3883                     sayNO;
3884                 }
3885
3886                 if (scan->flags) {
3887                     /* Check whether we already were at this position.
3888                         Postpone detection until we know the match is not
3889                         *that* much linear. */
3890                 if (!PL_reg_maxiter) {
3891                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3892                     /* possible overflow for long strings and many CURLYX's */
3893                     if (PL_reg_maxiter < 0)
3894                         PL_reg_maxiter = I32_MAX;
3895                     PL_reg_leftiter = PL_reg_maxiter;
3896                 }
3897                 if (PL_reg_leftiter-- == 0) {
3898                     const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8;
3899                     if (PL_reg_poscache) {
3900                         if ((I32)PL_reg_poscache_size < size) {
3901                             Renew(PL_reg_poscache, size, char);
3902                             PL_reg_poscache_size = size;
3903                         }
3904                         Zero(PL_reg_poscache, size, char);
3905                     }
3906                     else {
3907                         PL_reg_poscache_size = size;
3908                         Newxz(PL_reg_poscache, size, char);
3909                     }
3910                     DEBUG_EXECUTE_r(
3911                         PerlIO_printf(Perl_debug_log,
3912               "%sDetected a super-linear match, switching on caching%s...\n",
3913                                       PL_colors[4], PL_colors[5])
3914         &