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
2621 STATIC void
2622 S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const bool do_utf8)
2623 {
2624     const int docolor = *PL_colors[0];
2625     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2626     int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2627     /* The part of the string before starttry has one color
2628        (pref0_len chars), between starttry and current
2629        position another one (pref_len - pref0_len chars),
2630        after the current position the third one.
2631        We assume that pref0_len <= pref_len, otherwise we
2632        decrease pref0_len.  */
2633     int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2634         ? (5 + taill) - l : locinput - PL_bostr;
2635     int pref0_len;
2636
2637     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2638         pref_len++;
2639     pref0_len = pref_len  - (locinput - PL_reg_starttry);
2640     if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2641         l = ( PL_regeol - locinput > (5 + taill) - pref_len
2642               ? (5 + taill) - pref_len : PL_regeol - locinput);
2643     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2644         l--;
2645     if (pref0_len < 0)
2646         pref0_len = 0;
2647     if (pref0_len > pref_len)
2648         pref0_len = pref_len;
2649     {
2650         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2651         const char * const s0 = is_uni ?
2652             pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
2653                     pref0_len, 60, UNI_DISPLAY_REGEX) :
2654             pv_escape(PERL_DEBUG_PAD(0), (locinput - pref_len),
2655                     pref0_len, 60, 0);
2656
2657         const int len0 = strlen(s0);
2658         const char * const s1 = is_uni ?
2659             pv_uni_display(PERL_DEBUG_PAD(1),
2660                     (U8*)(locinput - pref_len + pref0_len),
2661                     pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2662             pv_escape(PERL_DEBUG_PAD(1),
2663                     (locinput - pref_len + pref0_len),
2664                     pref_len - pref0_len, 60, 0);
2665
2666         const int len1 = (int)strlen(s1);
2667         const char * const s2 = is_uni ?
2668             pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
2669                     PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2670             pv_escape(PERL_DEBUG_PAD(2), locinput,
2671                     PL_regeol - locinput, 60, 0);
2672         const int len2 = (int)strlen(s2);
2673         PerlIO_printf(Perl_debug_log,
2674                     "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|",
2675                     (IV)(locinput - PL_bostr),
2676                     PL_colors[4],
2677                     len0, s0,
2678                     PL_colors[5],
2679                     PL_colors[2],
2680                     len1, s1,
2681                     PL_colors[3],
2682                     (docolor ? "" : "> <"),
2683                     PL_colors[0],
2684                     len2, s2,
2685                     PL_colors[1],
2686                     15 - l - pref_len + 1,
2687                     "");
2688     }
2689 }
2690
2691 #endif
2692
2693 STATIC I32                      /* 0 failure, 1 success */
2694 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2695 {
2696 #if PERL_VERSION < 9
2697     dMY_CXT;
2698 #endif
2699     dVAR;
2700     register const bool do_utf8 = PL_reg_match_utf8;
2701     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2702
2703     regexp *rex = reginfo->prog;
2704
2705     regmatch_slab  *orig_slab;
2706     regmatch_state *orig_state;
2707
2708     /* the current state. This is a cached copy of PL_regmatch_state */
2709     register regmatch_state *st;
2710
2711     /* cache heavy used fields of st in registers */
2712     register regnode *scan;
2713     register regnode *next;
2714     register I32 n = 0; /* initialize to shut up compiler warning */
2715     register char *locinput = PL_reginput;
2716
2717     /* these variables are NOT saved during a recusive RFEGMATCH: */
2718     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2719     bool result;            /* return value of S_regmatch */
2720     int depth = 0;          /* depth of recursion */
2721     regmatch_state *yes_state = NULL; /* state to pop to on success of
2722                                                             subpattern */
2723     U32 state_num;
2724
2725 #ifdef DEBUGGING
2726     GET_RE_DEBUG_FLAGS_DECL;
2727     PL_regindent++;
2728 #endif
2729
2730     /* on first ever call to regmatch, allocate first slab */
2731     if (!PL_regmatch_slab) {
2732         Newx(PL_regmatch_slab, 1, regmatch_slab);
2733         PL_regmatch_slab->prev = NULL;
2734         PL_regmatch_slab->next = NULL;
2735         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2736     }
2737
2738     /* remember current high-water mark for exit */
2739     /* XXX this should be done with SAVE* instead */
2740     orig_slab  = PL_regmatch_slab;
2741     orig_state = PL_regmatch_state;
2742
2743     /* grab next free state slot */
2744     st = ++PL_regmatch_state;
2745     if (st >  SLAB_LAST(PL_regmatch_slab))
2746         st = PL_regmatch_state = S_push_slab(aTHX);
2747
2748     st->minmod = 0;
2749     st->sw = 0;
2750     st->logical = 0;
2751     st->cc = NULL;
2752     /* Note that nextchr is a byte even in UTF */
2753     nextchr = UCHARAT(locinput);
2754     scan = prog;
2755     while (scan != NULL) {
2756
2757         DEBUG_EXECUTE_r( {
2758             SV * const prop = sv_newmortal();
2759             dump_exec_pos( locinput, scan, do_utf8 );
2760             regprop(rex, prop, scan);
2761
2762             PerlIO_printf(Perl_debug_log,
2763                     "%3"IVdf":%*s%s(%"IVdf")\n",
2764                     (IV)(scan - rex->program), PL_regindent*2, "",
2765                     SvPVX_const(prop),
2766                     PL_regkind[OP(scan)] == END ? 0 : (IV)(regnext(scan) - rex->program));
2767         });
2768
2769         next = scan + NEXT_OFF(scan);
2770         if (next == scan)
2771             next = NULL;
2772         state_num = OP(scan);
2773
2774       reenter_switch:
2775         switch (state_num) {
2776         case BOL:
2777             if (locinput == PL_bostr)
2778             {
2779                 /* reginfo->till = reginfo->bol; */
2780                 break;
2781             }
2782             sayNO;
2783         case MBOL:
2784             if (locinput == PL_bostr ||
2785                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2786             {
2787                 break;
2788             }
2789             sayNO;
2790         case SBOL:
2791             if (locinput == PL_bostr)
2792                 break;
2793             sayNO;
2794         case GPOS:
2795             if (locinput == reginfo->ganch)
2796                 break;
2797             sayNO;
2798         case EOL:
2799                 goto seol;
2800         case MEOL:
2801             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2802                 sayNO;
2803             break;
2804         case SEOL:
2805           seol:
2806             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2807                 sayNO;
2808             if (PL_regeol - locinput > 1)
2809                 sayNO;
2810             break;
2811         case EOS:
2812             if (PL_regeol != locinput)
2813                 sayNO;
2814             break;
2815         case SANY:
2816             if (!nextchr && locinput >= PL_regeol)
2817                 sayNO;
2818             if (do_utf8) {
2819                 locinput += PL_utf8skip[nextchr];
2820                 if (locinput > PL_regeol)
2821                     sayNO;
2822                 nextchr = UCHARAT(locinput);
2823             }
2824             else
2825                 nextchr = UCHARAT(++locinput);
2826             break;
2827         case CANY:
2828             if (!nextchr && locinput >= PL_regeol)
2829                 sayNO;
2830             nextchr = UCHARAT(++locinput);
2831             break;
2832         case REG_ANY:
2833             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2834                 sayNO;
2835             if (do_utf8) {
2836                 locinput += PL_utf8skip[nextchr];
2837                 if (locinput > PL_regeol)
2838                     sayNO;
2839                 nextchr = UCHARAT(locinput);
2840             }
2841             else
2842                 nextchr = UCHARAT(++locinput);
2843             break;
2844
2845 #undef  ST
2846 #define ST st->u.trie
2847
2848         case TRIE:
2849             {
2850                 /* what type of TRIE am I? (utf8 makes this contextual) */
2851                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2852                     trie_type = do_utf8 ?
2853                           (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2854                         : trie_plain;
2855
2856                 /* what trie are we using right now */
2857                 reg_trie_data * const trie
2858                     = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2859                 U32 state = trie->startstate;
2860
2861                 U8 *uc = ( U8* )locinput;
2862                 U16 charid = 0;
2863                 U32 base = 0;
2864                 UV uvc = 0;
2865                 STRLEN len = 0;
2866                 STRLEN foldlen = 0;
2867                 U8 *uscan = (U8*)NULL;
2868                 STRLEN bufflen=0;
2869                 SV *sv_accept_buff = NULL;
2870                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2871
2872                 ST.accepted = 0; /* how many accepting states we have seen */
2873                 ST.B = next;
2874 #ifdef DEBUGGING
2875                 ST.me = scan;
2876 #endif
2877
2878                 if (trie->bitmap && trie_type != trie_utf8_fold &&
2879                     !TRIE_BITMAP_TEST(trie,*locinput)
2880                 ) {
2881                     if (trie->states[ state ].wordnum) {
2882                          DEBUG_EXECUTE_r(
2883                             PerlIO_printf(Perl_debug_log,
2884                                           "%*s  %smatched empty string...%s\n",
2885                                           REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2886                         );
2887                         break;
2888                     } else {
2889                         DEBUG_EXECUTE_r(
2890                             PerlIO_printf(Perl_debug_log,
2891                                           "%*s  %sfailed to match start class...%s\n",
2892                                           REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2893                         );
2894                         sayNO_SILENT;
2895                    }
2896                 }
2897
2898                 /*
2899                    traverse the TRIE keeping track of all accepting states
2900                    we transition through until we get to a failing node.
2901                 */
2902
2903                 while ( state && uc <= (U8*)PL_regeol ) {
2904
2905                     if (trie->states[ state ].wordnum) {
2906                         if (!ST.accepted ) {
2907                             ENTER;
2908                             SAVETMPS;
2909                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2910                             sv_accept_buff=newSV(bufflen *
2911                                             sizeof(reg_trie_accepted) - 1);
2912                             SvCUR_set(sv_accept_buff,
2913                                                 sizeof(reg_trie_accepted));
2914                             SvPOK_on(sv_accept_buff);
2915                             sv_2mortal(sv_accept_buff);
2916                             SAVETMPS;
2917                             ST.accept_buff =
2918                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2919                         }
2920                         else {
2921                             if (ST.accepted >= bufflen) {
2922                                 bufflen *= 2;
2923                                 ST.accept_buff =(reg_trie_accepted*)
2924                                     SvGROW(sv_accept_buff,
2925                                         bufflen * sizeof(reg_trie_accepted));
2926                             }
2927                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2928                                 + sizeof(reg_trie_accepted));
2929                         }
2930                         ST.accept_buff[ST.accepted].wordnum = trie->states[state].wordnum;
2931                         ST.accept_buff[ST.accepted].endpos = uc;
2932                         ++ST.accepted;
2933                     }
2934
2935                     base = trie->states[ state ].trans.base;
2936
2937                     DEBUG_TRIE_EXECUTE_r({
2938                                 dump_exec_pos( (char *)uc, scan, do_utf8 );
2939                                 PerlIO_printf( Perl_debug_log,
2940                                     "%*s  %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2941                                     2+PL_regindent * 2, "", PL_colors[4],
2942                                     (UV)state, (UV)base, (UV)ST.accepted );
2943                     });
2944
2945                     if ( base ) {
2946                         switch (trie_type) {
2947                         case trie_utf8_fold:
2948                             if ( foldlen>0 ) {
2949                                 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2950                                 foldlen -= len;
2951                                 uscan += len;
2952                                 len=0;
2953                             } else {
2954                                 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2955                                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2956                                 foldlen -= UNISKIP( uvc );
2957                                 uscan = foldbuf + UNISKIP( uvc );
2958                             }
2959                             break;
2960                         case trie_utf8:
2961                             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
2962                                                             &len, uniflags );
2963                             break;
2964                         case trie_plain:
2965                             uvc = (UV)*uc;
2966                             len = 1;
2967                         }
2968
2969                         if (uvc < 256) {
2970                             charid = trie->charmap[ uvc ];
2971                         }
2972                         else {
2973                             charid = 0;
2974                             if (trie->widecharmap) {
2975                                 SV** const svpp = hv_fetch(trie->widecharmap,
2976                                             (char*)&uvc, sizeof(UV), 0);
2977                                 if (svpp)
2978                                     charid = (U16)SvIV(*svpp);
2979                             }
2980                         }
2981
2982                         if (charid &&
2983                              (base + charid > trie->uniquecharcount )
2984                              && (base + charid - 1 - trie->uniquecharcount
2985                                     < trie->lasttrans)
2986                              && trie->trans[base + charid - 1 -
2987                                     trie->uniquecharcount].check == state)
2988                         {
2989                             state = trie->trans[base + charid - 1 -
2990                                 trie->uniquecharcount ].next;
2991                         }
2992                         else {
2993                             state = 0;
2994                         }
2995                         uc += len;
2996
2997                     }
2998                     else {
2999                         state = 0;
3000                     }
3001                     DEBUG_TRIE_EXECUTE_r(
3002                         PerlIO_printf( Perl_debug_log,
3003                             "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
3004                             charid, uvc, (UV)state, PL_colors[5] );
3005                     );
3006                 }
3007                 if (!ST.accepted )
3008                    sayNO;
3009
3010                 DEBUG_EXECUTE_r(
3011                     PerlIO_printf( Perl_debug_log,
3012                         "%*s  %sgot %"IVdf" possible matches%s\n",
3013                         REPORT_CODE_OFF + PL_regindent * 2, "",
3014                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3015                 );
3016             }
3017
3018             /* FALL THROUGH */
3019
3020         case TRIE_next_fail: /* we failed - try next alterative */
3021
3022             if ( ST.accepted == 1 ) {
3023                 /* only one choice left - just continue */
3024                 DEBUG_EXECUTE_r({
3025                     reg_trie_data * const trie
3026                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
3027                     SV ** const tmp = RX_DEBUG(reginfo->prog)
3028                                     ? av_fetch( trie->words, ST.accept_buff[ 0 ].wordnum-1, 0 )
3029                                     : NULL;
3030                     PerlIO_printf( Perl_debug_log,
3031                         "%*s  %sonly one match left: #%d <%s>%s\n",
3032                         REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
3033                         ST.accept_buff[ 0 ].wordnum,
3034                         tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
3035                         PL_colors[5] );
3036                 });
3037                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3038                 /* in this case we free tmps/leave before we call regmatch
3039                    as we wont be using accept_buff again. */
3040                 FREETMPS;
3041                 LEAVE;
3042                 locinput = PL_reginput;
3043                 nextchr = UCHARAT(locinput);
3044                 scan = ST.B;
3045                 continue; /* execute rest of RE */
3046             }
3047
3048             if (!ST.accepted-- ) {
3049                 FREETMPS;
3050                 LEAVE;
3051                 sayNO;
3052             }
3053
3054             /*
3055                There are at least two accepting states left.  Presumably
3056                the number of accepting states is going to be low,
3057                typically two. So we simply scan through to find the one
3058                with lowest wordnum.  Once we find it, we swap the last
3059                state into its place and decrement the size. We then try to
3060                match the rest of the pattern at the point where the word
3061                ends. If we succeed, control just continues along the
3062                regex; if we fail we return here to try the next accepting
3063                state
3064              */
3065
3066             {
3067                 U32 best = 0;
3068                 U32 cur;
3069                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3070                     DEBUG_TRIE_EXECUTE_r(
3071                         PerlIO_printf( Perl_debug_log,
3072                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3073                             REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
3074                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3075                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3076                     );
3077
3078                     if (ST.accept_buff[cur].wordnum <
3079                             ST.accept_buff[best].wordnum)
3080                         best = cur;
3081                 }
3082
3083                 DEBUG_EXECUTE_r({
3084                     reg_trie_data * const trie
3085                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
3086                     SV ** const tmp = RX_DEBUG(reginfo->prog)
3087                                 ? av_fetch( trie->words, ST.accept_buff[ best ].wordnum - 1, 0 )
3088                                 : NULL;
3089                     PerlIO_printf( Perl_debug_log, "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3090                         REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
3091                         ST.accept_buff[best].wordnum,
3092                         tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", REG_NODE_NUM(scan),
3093                         PL_colors[5] );
3094                 });
3095
3096                 if ( best<ST.accepted ) {
3097                     reg_trie_accepted tmp = ST.accept_buff[ best ];
3098                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3099                     ST.accept_buff[ ST.accepted ] = tmp;
3100                     best = ST.accepted;
3101                 }
3102                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3103             }
3104             PUSH_STATE_GOTO(TRIE_next, ST.B);
3105             /* NOTREACHED */
3106
3107 #undef  ST
3108
3109         case EXACT: {
3110             char *s = STRING(scan);
3111             st->ln = STR_LEN(scan);
3112             if (do_utf8 != UTF) {
3113                 /* The target and the pattern have differing utf8ness. */
3114                 char *l = locinput;
3115                 const char * const e = s + st->ln;
3116
3117                 if (do_utf8) {
3118                     /* The target is utf8, the pattern is not utf8. */
3119                     while (s < e) {
3120                         STRLEN ulen;
3121                         if (l >= PL_regeol)
3122                              sayNO;
3123                         if (NATIVE_TO_UNI(*(U8*)s) !=
3124                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3125                                             uniflags))
3126                              sayNO;
3127                         l += ulen;
3128                         s ++;
3129                     }
3130                 }
3131                 else {
3132                     /* The target is not utf8, the pattern is utf8. */
3133                     while (s < e) {
3134                         STRLEN ulen;
3135                         if (l >= PL_regeol)
3136                             sayNO;
3137                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3138                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3139                                            uniflags))
3140                             sayNO;
3141                         s += ulen;
3142                         l ++;
3143                     }
3144                 }
3145                 locinput = l;
3146                 nextchr = UCHARAT(locinput);
3147                 break;
3148             }
3149             /* The target and the pattern have the same utf8ness. */
3150             /* Inline the first character, for speed. */
3151             if (UCHARAT(s) != nextchr)
3152                 sayNO;
3153             if (PL_regeol - locinput < st->ln)
3154                 sayNO;
3155             if (st->ln > 1 && memNE(s, locinput, st->ln))
3156                 sayNO;
3157             locinput += st->ln;
3158             nextchr = UCHARAT(locinput);
3159             break;
3160             }
3161         case EXACTFL:
3162             PL_reg_flags |= RF_tainted;
3163             /* FALL THROUGH */
3164         case EXACTF: {
3165             char * const s = STRING(scan);
3166             st->ln = STR_LEN(scan);
3167
3168             if (do_utf8 || UTF) {
3169               /* Either target or the pattern are utf8. */
3170                 const char * const l = locinput;
3171                 char *e = PL_regeol;
3172
3173                 if (ibcmp_utf8(s, 0,  st->ln, (bool)UTF,
3174                                l, &e, 0,  do_utf8)) {
3175                      /* One more case for the sharp s:
3176                       * pack("U0U*", 0xDF) =~ /ss/i,
3177                       * the 0xC3 0x9F are the UTF-8
3178                       * byte sequence for the U+00DF. */
3179                      if (!(do_utf8 &&
3180                            toLOWER(s[0]) == 's' &&
3181                            st->ln >= 2 &&
3182                            toLOWER(s[1]) == 's' &&
3183                            (U8)l[0] == 0xC3 &&
3184                            e - l >= 2 &&
3185                            (U8)l[1] == 0x9F))
3186                           sayNO;
3187                 }
3188                 locinput = e;
3189                 nextchr = UCHARAT(locinput);
3190                 break;
3191             }
3192
3193             /* Neither the target and the pattern are utf8. */
3194
3195             /* Inline the first character, for speed. */
3196             if (UCHARAT(s) != nextchr &&
3197                 UCHARAT(s) != ((OP(scan) == EXACTF)
3198                                ? PL_fold : PL_fold_locale)[nextchr])
3199                 sayNO;
3200             if (PL_regeol - locinput < st->ln)
3201                 sayNO;
3202             if (st->ln > 1 && (OP(scan) == EXACTF
3203                            ? ibcmp(s, locinput, st->ln)
3204                            : ibcmp_locale(s, locinput, st->ln)))
3205                 sayNO;
3206             locinput += st->ln;
3207             nextchr = UCHARAT(locinput);
3208             break;
3209             }
3210         case ANYOF:
3211             if (do_utf8) {
3212                 STRLEN inclasslen = PL_regeol - locinput;
3213
3214                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3215                     sayNO_ANYOF;
3216                 if (locinput >= PL_regeol)
3217                     sayNO;
3218                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3219                 nextchr = UCHARAT(locinput);
3220                 break;
3221             }
3222             else {
3223                 if (nextchr < 0)
3224                     nextchr = UCHARAT(locinput);
3225                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3226                     sayNO_ANYOF;
3227                 if (!nextchr && locinput >= PL_regeol)
3228                     sayNO;
3229                 nextchr = UCHARAT(++locinput);
3230                 break;
3231             }
3232         no_anyof:
3233             /* If we might have the case of the German sharp s
3234              * in a casefolding Unicode character class. */
3235
3236             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3237                  locinput += SHARP_S_SKIP;
3238                  nextchr = UCHARAT(locinput);
3239             }
3240             else
3241                  sayNO;
3242             break;
3243         case ALNUML:
3244             PL_reg_flags |= RF_tainted;
3245             /* FALL THROUGH */
3246         case ALNUM:
3247             if (!nextchr)
3248                 sayNO;
3249             if (do_utf8) {
3250                 LOAD_UTF8_CHARCLASS_ALNUM();
3251                 if (!(OP(scan) == ALNUM
3252                       ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3253                       : isALNUM_LC_utf8((U8*)locinput)))
3254                 {
3255                     sayNO;
3256                 }
3257                 locinput += PL_utf8skip[nextchr];
3258                 nextchr = UCHARAT(locinput);
3259                 break;
3260             }
3261             if (!(OP(scan) == ALNUM
3262                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3263                 sayNO;
3264             nextchr = UCHARAT(++locinput);
3265             break;
3266         case NALNUML:
3267             PL_reg_flags |= RF_tainted;
3268             /* FALL THROUGH */
3269         case NALNUM:
3270             if (!nextchr && locinput >= PL_regeol)
3271                 sayNO;
3272             if (do_utf8) {
3273                 LOAD_UTF8_CHARCLASS_ALNUM();
3274                 if (OP(scan) == NALNUM
3275                     ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3276                     : isALNUM_LC_utf8((U8*)locinput))
3277                 {
3278                     sayNO;
3279                 }
3280                 locinput += PL_utf8skip[nextchr];
3281                 nextchr = UCHARAT(locinput);
3282                 break;
3283             }
3284             if (OP(scan) == NALNUM
3285                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3286                 sayNO;
3287             nextchr = UCHARAT(++locinput);
3288             break;
3289         case BOUNDL:
3290         case NBOUNDL:
3291             PL_reg_flags |= RF_tainted;
3292             /* FALL THROUGH */
3293         case BOUND:
3294         case NBOUND:
3295             /* was last char in word? */
3296             if (do_utf8) {
3297                 if (locinput == PL_bostr)
3298                     st->ln = '\n';
3299                 else {
3300                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3301
3302                     st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3303                 }
3304                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3305                     st->ln = isALNUM_uni(st->ln);
3306                     LOAD_UTF8_CHARCLASS_ALNUM();
3307                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3308                 }
3309                 else {
3310                     st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3311                     n = isALNUM_LC_utf8((U8*)locinput);
3312                 }
3313             }
3314             else {
3315                 st->ln = (locinput != PL_bostr) ?
3316                     UCHARAT(locinput - 1) : '\n';
3317                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3318                     st->ln = isALNUM(st->ln);
3319                     n = isALNUM(nextchr);
3320                 }
3321                 else {
3322                     st->ln = isALNUM_LC(st->ln);
3323                     n = isALNUM_LC(nextchr);
3324                 }
3325             }
3326             if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3327                                     OP(scan) == BOUNDL))
3328                     sayNO;
3329             break;
3330         case SPACEL:
3331             PL_reg_flags |= RF_tainted;
3332             /* FALL THROUGH */
3333         case SPACE:
3334             if (!nextchr)
3335                 sayNO;
3336             if (do_utf8) {
3337                 if (UTF8_IS_CONTINUED(nextchr)) {
3338                     LOAD_UTF8_CHARCLASS_SPACE();
3339                     if (!(OP(scan) == SPACE
3340                           ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3341                           : isSPACE_LC_utf8((U8*)locinput)))
3342                     {
3343                         sayNO;
3344                     }
3345                     locinput += PL_utf8skip[nextchr];
3346                     nextchr = UCHARAT(locinput);
3347                     break;
3348                 }
3349                 if (!(OP(scan) == SPACE
3350                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3351                     sayNO;
3352                 nextchr = UCHARAT(++locinput);
3353             }
3354             else {
3355                 if (!(OP(scan) == SPACE
3356                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3357                     sayNO;
3358                 nextchr = UCHARAT(++locinput);
3359             }
3360             break;
3361         case NSPACEL:
3362             PL_reg_flags |= RF_tainted;
3363             /* FALL THROUGH */
3364         case NSPACE:
3365             if (!nextchr && locinput >= PL_regeol)
3366                 sayNO;
3367             if (do_utf8) {
3368                 LOAD_UTF8_CHARCLASS_SPACE();
3369                 if (OP(scan) == NSPACE
3370                     ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3371                     : isSPACE_LC_utf8((U8*)locinput))
3372                 {
3373                     sayNO;
3374                 }
3375                 locinput += PL_utf8skip[nextchr];
3376                 nextchr = UCHARAT(locinput);
3377                 break;
3378             }
3379             if (OP(scan) == NSPACE
3380                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3381                 sayNO;
3382             nextchr = UCHARAT(++locinput);
3383             break;
3384         case DIGITL:
3385             PL_reg_flags |= RF_tainted;
3386             /* FALL THROUGH */
3387         case DIGIT:
3388             if (!nextchr)
3389                 sayNO;
3390             if (do_utf8) {
3391                 LOAD_UTF8_CHARCLASS_DIGIT();
3392                 if (!(OP(scan) == DIGIT
3393                       ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3394                       : isDIGIT_LC_utf8((U8*)locinput)))
3395                 {
3396                     sayNO;
3397                 }
3398                 locinput += PL_utf8skip[nextchr];
3399                 nextchr = UCHARAT(locinput);
3400                 break;
3401             }
3402             if (!(OP(scan) == DIGIT
3403                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3404                 sayNO;
3405             nextchr = UCHARAT(++locinput);
3406             break;
3407         case NDIGITL:
3408             PL_reg_flags |= RF_tainted;
3409             /* FALL THROUGH */
3410         case NDIGIT:
3411             if (!nextchr && locinput >= PL_regeol)
3412                 sayNO;
3413             if (do_utf8) {
3414                 LOAD_UTF8_CHARCLASS_DIGIT();
3415                 if (OP(scan) == NDIGIT
3416                     ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3417                     : isDIGIT_LC_utf8((U8*)locinput))
3418                 {
3419                     sayNO;
3420                 }
3421                 locinput += PL_utf8skip[nextchr];
3422                 nextchr = UCHARAT(locinput);
3423                 break;
3424             }
3425             if (OP(scan) == NDIGIT
3426                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3427                 sayNO;
3428             nextchr = UCHARAT(++locinput);
3429             break;
3430         case CLUMP:
3431             if (locinput >= PL_regeol)
3432                 sayNO;
3433             if  (do_utf8) {
3434                 LOAD_UTF8_CHARCLASS_MARK();
3435                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3436                     sayNO;
3437                 locinput += PL_utf8skip[nextchr];
3438                 while (locinput < PL_regeol &&
3439                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3440                     locinput += UTF8SKIP(locinput);
3441                 if (locinput > PL_regeol)
3442                     sayNO;
3443             }
3444             else
3445                locinput++;
3446             nextchr = UCHARAT(locinput);
3447             break;
3448         case REFFL:
3449             PL_reg_flags |= RF_tainted;
3450             /* FALL THROUGH */
3451         case REF:
3452         case REFF: {
3453             char *s;
3454             n = ARG(scan);  /* which paren pair */
3455             st->ln = PL_regstartp[n];
3456             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3457             if ((I32)*PL_reglastparen < n || st->ln == -1)
3458                 sayNO;                  /* Do not match unless seen CLOSEn. */
3459             if (st->ln == PL_regendp[n])
3460                 break;
3461
3462             s = PL_bostr + st->ln;
3463             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
3464                 char *l = locinput;
3465                 const char *e = PL_bostr + PL_regendp[n];
3466                 /*
3467                  * Note that we can't do the "other character" lookup trick as
3468                  * in the 8-bit case (no pun intended) because in Unicode we
3469                  * have to map both upper and title case to lower case.
3470                  */
3471                 if (OP(scan) == REFF) {
3472                     while (s < e) {
3473                         STRLEN ulen1, ulen2;
3474                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3475                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3476
3477                         if (l >= PL_regeol)
3478                             sayNO;
3479                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3480                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3481                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3482                             sayNO;
3483                         s += ulen1;
3484                         l += ulen2;
3485                     }
3486                 }
3487                 locinput = l;
3488                 nextchr = UCHARAT(locinput);
3489                 break;
3490             }
3491
3492             /* Inline the first character, for speed. */
3493             if (UCHARAT(s) != nextchr &&
3494                 (OP(scan) == REF ||
3495                  (UCHARAT(s) != ((OP(scan) == REFF
3496                                   ? PL_fold : PL_fold_locale)[nextchr]))))
3497                 sayNO;
3498             st->ln = PL_regendp[n] - st->ln;
3499             if (locinput + st->ln > PL_regeol)
3500                 sayNO;
3501             if (st->ln > 1 && (OP(scan) == REF
3502                            ? memNE(s, locinput, st->ln)
3503                            : (OP(scan) == REFF
3504                               ? ibcmp(s, locinput, st->ln)
3505                               : ibcmp_locale(s, locinput, st->ln))))
3506                 sayNO;
3507             locinput += st->ln;
3508             nextchr = UCHARAT(locinput);
3509             break;
3510             }
3511
3512         case NOTHING:
3513         case TAIL:
3514             break;
3515         case BACK:
3516             break;
3517
3518 #undef  ST
3519 #define ST st->u.eval
3520
3521         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3522         {
3523             SV *ret;
3524             {
3525                 /* execute the code in the {...} */
3526                 dSP;
3527                 SV ** const before = SP;
3528                 OP_4tree * const oop = PL_op;
3529                 COP * const ocurcop = PL_curcop;
3530                 PAD *old_comppad;
3531
3532                 n = ARG(scan);
3533                 PL_op = (OP_4tree*)rex->data->data[n];
3534                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3535                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3536                 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3537
3538                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3539                 SPAGAIN;
3540                 if (SP == before)
3541                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3542                 else {
3543                     ret = POPs;
3544                     PUTBACK;
3545                 }
3546
3547                 PL_op = oop;
3548                 PAD_RESTORE_LOCAL(old_comppad);
3549                 PL_curcop = ocurcop;
3550                 if (!st->logical) {
3551                     /* /(?{...})/ */
3552                     sv_setsv(save_scalar(PL_replgv), ret);
3553                     break;
3554                 }
3555             }
3556             if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3557                 regexp *re;
3558                 {
3559                     /* extract RE object from returned value; compiling if
3560                      * necessary */
3561
3562                     MAGIC *mg = NULL;
3563                     const SV *sv;
3564                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3565                         mg = mg_find(sv, PERL_MAGIC_qr);
3566                     else if (SvSMAGICAL(ret)) {
3567                         if (SvGMAGICAL(ret))
3568                             sv_unmagic(ret, PERL_MAGIC_qr);
3569                         else
3570                             mg = mg_find(ret, PERL_MAGIC_qr);
3571                     }
3572
3573                     if (mg) {
3574                         re = (regexp *)mg->mg_obj;
3575                         (void)ReREFCNT_inc(re);
3576                     }
3577                     else {
3578                         STRLEN len;
3579                         const char * const t = SvPV_const(ret, len);
3580                         PMOP pm;
3581                         const I32 osize = PL_regsize;
3582
3583                         Zero(&pm, 1, PMOP);
3584                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3585                         re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3586                         if (!(SvFLAGS(ret)
3587                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3588                                 | SVs_GMG)))
3589                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3590                                         PERL_MAGIC_qr,0,0);
3591                         PL_regsize = osize;
3592                     }
3593                 }
3594
3595                 /* run the pattern returned from (??{...}) */
3596
3597                 DEBUG_EXECUTE_r(
3598                     PerlIO_printf(Perl_debug_log,
3599                                   "Entering embedded \"%s%.60s%s%s\"\n",
3600                                   PL_colors[0],
3601                                   re->precomp,
3602                                   PL_colors[1],
3603                                   (strlen(re->precomp) > 60 ? "..." : ""))
3604                     );
3605
3606                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3607                 REGCP_SET(ST.lastcp);
3608                 *PL_reglastparen = 0;
3609                 *PL_reglastcloseparen = 0;
3610                 PL_reginput = locinput;
3611
3612                 /* XXXX This is too dramatic a measure... */
3613                 PL_reg_maxiter = 0;
3614
3615                 st->logical = 0;
3616                 ST.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3617                             ((re->reganch & ROPT_UTF8) != 0);
3618                 if (ST.toggleutf) PL_reg_flags ^= RF_utf8;
3619                 ST.prev_rex = rex;
3620                 rex = re;
3621
3622                 ST.B = next;
3623                 /* now continue  from first node in postoned RE */
3624                 PUSH_YES_STATE_GOTO(EVAL_A, re->program + 1);
3625                 /* NOTREACHED */
3626             }
3627             /* /(?(?{...})X|Y)/ */
3628             st->sw = SvTRUE(ret);
3629             st->logical = 0;
3630             break;
3631         }
3632
3633         case EVAL_A: /* successfully ran inner rex (??{rex}) */
3634             if (ST.toggleutf)
3635                 PL_reg_flags ^= RF_utf8;
3636             ReREFCNT_dec(rex);
3637             rex = ST.prev_rex;
3638             /* XXXX This is too dramatic a measure... */
3639             PL_reg_maxiter = 0;
3640             /* Restore parens of the caller without popping the
3641              * savestack */
3642             {
3643                 const I32 tmp = PL_savestack_ix;
3644                 PL_savestack_ix = ST.lastcp;
3645                 regcppop(rex);
3646                 PL_savestack_ix = tmp;
3647             }
3648             PL_reginput = locinput;
3649              /* continue at the node following the (??{...}) */
3650             scan = ST.B;
3651             continue;
3652
3653         case EVAL_A_fail: /* unsuccessfully ran inner rex (??{rex}) */
3654             /* Restore state to the outer re then re-throw the failure */
3655             if (ST.toggleutf)
3656                 PL_reg_flags ^= RF_utf8;
3657             ReREFCNT_dec(rex);
3658             rex = ST.prev_rex;
3659
3660             /* XXXX This is too dramatic a measure... */
3661             PL_reg_maxiter = 0;
3662
3663             PL_reginput = locinput;
3664             REGCP_UNWIND(ST.lastcp);
3665             regcppop(rex);
3666             sayNO_SILENT;
3667
3668 #undef ST
3669
3670         case OPEN:
3671             n = ARG(scan);  /* which paren pair */
3672             PL_reg_start_tmp[n] = locinput;
3673             if (n > PL_regsize)
3674                 PL_regsize = n;
3675             break;
3676         case CLOSE:
3677             n = ARG(scan);  /* which paren pair */
3678             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3679             PL_regendp[n] = locinput - PL_bostr;
3680             if (n > (I32)*PL_reglastparen)
3681                 *PL_reglastparen = n;
3682             *PL_reglastcloseparen = n;
3683             break;
3684         case GROUPP:
3685             n = ARG(scan);  /* which paren pair */
3686             st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3687             break;
3688         case IFTHEN:
3689             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3690             if (st->sw)
3691                 next = NEXTOPER(NEXTOPER(scan));
3692             else {
3693                 next = scan + ARG(scan);
3694                 if (OP(next) == IFTHEN) /* Fake one. */
3695                     next = NEXTOPER(NEXTOPER(next));
3696             }
3697             break;
3698         case LOGICAL:
3699             st->logical = scan->flags;
3700             break;
3701 /*******************************************************************
3702  cc points to the regmatch_state associated with the most recent CURLYX.
3703  This struct contains info about the innermost (...)* loop (an
3704  "infoblock"), and a pointer to the next outer cc.
3705
3706  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3707
3708    1) After matching Y, regnode for CURLYX is processed;
3709
3710    2) This regnode populates cc, and calls regmatch() recursively
3711       with the starting point at WHILEM node;
3712
3713    3) Each hit of WHILEM node tries to match A and Z (in the order
3714       depending on the current iteration, min/max of {min,max} and
3715       greediness).  The information about where are nodes for "A"
3716       and "Z" is read from cc, as is info on how many times "A"
3717       was already matched, and greediness.
3718
3719    4) After A matches, the same WHILEM node is hit again.
3720
3721    5) Each time WHILEM is hit, cc is the infoblock created by CURLYX
3722       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
3723       resets cc, since this Y(A)*Z can be a part of some other loop:
3724       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
3725       of the external loop.
3726
3727  Currently present infoblocks form a tree with a stem formed by st->cc
3728  and whatever it mentions via ->next, and additional attached trees
3729  corresponding to temporarily unset infoblocks as in "5" above.
3730
3731  In the following picture, infoblocks for outer loop of
3732  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
3733  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
3734  infoblocks are drawn below the "reset" infoblock.
3735
3736  In fact in the picture below we do not show failed matches for Z and T
3737  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
3738  more obvious *why* one needs to *temporary* unset infoblocks.]
3739
3740   Matched       REx position    InfoBlocks      Comment
3741                 (Y(A)*?Z)*?T    x
3742                 Y(A)*?Z)*?T     x <- O
3743   Y             (A)*?Z)*?T      x <- O
3744   Y             A)*?Z)*?T       x <- O <- I
3745   YA            )*?Z)*?T        x <- O <- I
3746   YA            A)*?Z)*?T       x <- O <- I
3747   YAA           )*?Z)*?T        x <- O <- I
3748   YAA           Z)*?T           x <- O          # Temporary unset I
3749                                      I
3750
3751   YAAZ          Y(A)*?Z)*?T     x <- O
3752                                      I
3753
3754   YAAZY         (A)*?Z)*?T      x <- O
3755                                      I
3756
3757   YAAZY         A)*?Z)*?T       x <- O <- I
3758                                      I
3759
3760   YAAZYA        )*?Z)*?T        x <- O <- I
3761                                      I
3762
3763   YAAZYA        Z)*?T           x <- O          # Temporary unset I
3764                                      I,I
3765
3766   YAAZYAZ       )*?T            x <- O
3767                                      I,I
3768
3769   YAAZYAZ       T               x               # Temporary unset O
3770                                 O
3771                                 I,I
3772
3773   YAAZYAZT                      x
3774                                 O
3775                                 I,I
3776  *******************************************************************/
3777
3778         case CURLYX: {
3779                 /* No need to save/restore up to this paren */
3780                 I32 parenfloor = scan->flags;
3781
3782                 /* Dave says:
3783
3784                    CURLYX and WHILEM are always paired: they're the moral
3785                    equivalent of pp_enteriter anbd pp_iter.
3786
3787                    The only time next could be null is if the node tree is
3788                    corrupt. This was mentioned on p5p a few days ago.
3789
3790                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3791                    So we'll assert that this is true:
3792                 */
3793                 assert(next);
3794                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3795                     next += ARG(next);
3796                 /* XXXX Probably it is better to teach regpush to support
3797                    parenfloor > PL_regsize... */
3798                 if (parenfloor > (I32)*PL_reglastparen)
3799                     parenfloor = *PL_reglastparen; /* Pessimization... */
3800
3801                 st->u.curlyx.cp = PL_savestack_ix;
3802                 st->u.curlyx.outercc = st->cc;
3803                 st->cc = st;
3804                 /* these fields contain the state of the current curly.
3805                  * they are accessed by subsequent WHILEMs;
3806                  * cur and lastloc are also updated by WHILEM */
3807                 st->u.curlyx.parenfloor = parenfloor;
3808                 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3809                 st->u.curlyx.min = ARG1(scan);
3810                 st->u.curlyx.max  = ARG2(scan);
3811                 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3812                 st->u.curlyx.lastloc = 0;
3813                 /* st->next and st->minmod are also read by WHILEM */
3814
3815                 PL_reginput = locinput;
3816                 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3817                 /*** all unsaved local vars undefined at this point */
3818                 regcpblow(st->u.curlyx.cp);
3819                 st->cc = st->u.curlyx.outercc;
3820                 saySAME(result);
3821             }
3822             /* NOTREACHED */
3823         case WHILEM: {
3824                 /*
3825                  * This is really hard to understand, because after we match
3826                  * what we're trying to match, we must make sure the rest of
3827                  * the REx is going to match for sure, and to do that we have
3828                  * to go back UP the parse tree by recursing ever deeper.  And
3829                  * if it fails, we have to reset our parent's current state
3830                  * that we can try again after backing off.
3831                  */
3832
3833                 /* Dave says:
3834
3835                    st->cc gets initialised by CURLYX ready for use by WHILEM.
3836                    So again, unless somethings been corrupted, st->cc cannot
3837                    be null at that point in WHILEM.
3838
3839                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3840                    So we'll assert that this is true:
3841                 */
3842                 assert(st->cc);
3843                 st->u.whilem.lastloc = st->cc->u.curlyx.lastloc; /* Detection of 0-len. */
3844                 st->u.whilem.cache_offset = 0;
3845                 st->u.whilem.cache_bit = 0;
3846
3847                 n = st->cc->u.curlyx.cur + 1; /* how many we know we matched */
3848                 PL_reginput = locinput;
3849
3850                 DEBUG_EXECUTE_r(
3851                     PerlIO_printf(Perl_debug_log,
3852                                   "%*s  %ld out of %ld..%ld  cc=%"UVxf"\n",
3853                                   REPORT_CODE_OFF+PL_regindent*2, "",
3854                                   (long)n, (long)st->cc->u.curlyx.min,
3855                                   (long)st->cc->u.curlyx.max, PTR2UV(st->cc))
3856                     );
3857
3858                 /* If degenerate scan matches "", assume scan done. */
3859
3860                 if (locinput == st->cc->u.curlyx.lastloc && n >= st->cc->u.curlyx.min) {
3861                     st->u.whilem.savecc = st->cc;
3862                     st->cc = st->cc->u.curlyx.outercc;
3863                     if (st->cc)
3864                         st->ln = st->cc->u.curlyx.cur;
3865                     DEBUG_EXECUTE_r(
3866                         PerlIO_printf(Perl_debug_log,
3867                            "%*s  empty match detected, try continuation...\n",
3868                            REPORT_CODE_OFF+PL_regindent*2, "")
3869                         );
3870                     REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3871                     /*** all unsaved local vars undefined at this point */
3872                     st->cc = st->u.whilem.savecc;
3873                     if (result)
3874                         sayYES;
3875                     if (st->cc->u.curlyx.outercc)
3876                         st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3877                     sayNO;
3878                 }
3879
3880                 /* First just match a string of min scans. */
3881
3882                 if (n < st->cc->u.curlyx.min) {
3883                     st->cc->u.curlyx.cur = n;
3884                     st->cc->u.curlyx.lastloc = locinput;
3885                     REGMATCH(st->cc->u.curlyx.scan, WHILEM2);
3886                     /*** all unsaved local vars undefined at this point */
3887                     if (result)
3888                         sayYES;
3889                     st->cc->u.curlyx.cur = n - 1;
3890                     st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3891                     sayNO;
3892                 }
3893
3894                 if (scan->flags) {
3895                     /* Check whether we already were at this position.
3896                         Postpone detection until we know the match is not
3897                         *that* much linear. */
3898                 if (!PL_reg_maxiter) {
3899                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3900                     /* possible overflow for long strings and many CURLYX's */
3901                     if (PL_reg_maxiter < 0)
3902                         PL_reg_maxiter = I32_MAX;
3903                     PL_reg_leftiter = PL_reg_maxiter;
3904                 }
3905                 if (PL_reg_leftiter-- == 0) {
3906                     const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8;
3907                     if (PL_reg_poscache) {
3908                         if ((I32)PL_reg_poscache_size < size) {
3909                             Renew(PL_reg_poscache, size, char);
3910                             PL_reg_poscache_size = size;
3911                         }
3912                         Zero(PL_reg_poscache, size, char);
3913                     }
3914                     else {
3915                         PL_reg_poscache_size = size;
3916                         Newxz(PL_reg_poscache, size, char);
3917                     }
3918                     DEBUG_EXECUTE_r(
3919                         PerlIO_printf(Perl_debug_log,
3920               "%sDetected a super-linear match, switching on caching%s...\n",
3921                                       PL_colors[4], PL_colors[5])
3922                         );
3923                 }
3924                 if (PL_reg_leftiter < 0) {
3925                     st->u.whilem.cache_offset = locinput - PL_bostr;
3926
3927                     st->u.whilem.cache_offset = (scan->flags & 0xf) - 1 + POSCACHE_START
3928                             + st->u.whilem.cache_offset * (scan->flags>>4);
3929                     st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
3930                     st->u.whilem.cache_offset /= 8;
3931                     if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
3932                     DEBUG_EXECUTE_r(
3933                         PerlIO_printf(Perl_debug_log,
3934                                       "%*s  already tried at this position...\n",
3935                                       REPORT_CODE_OFF+PL_regindent*2, "")
3936                         );
3937                         if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))
3938                             /* cache records success */
3939                             sayYES;
3940                         else
3941                             /* cache records failure */
3942                             sayNO_SILENT;
3943                     }
3944                 }
3945                 }
3946
3947                 /* Prefer next over scan for minimal matching. */
3948
3949                 if (st->cc->minmod) {
3950                     st->u.whilem.savecc = st->cc;
3951                     st->cc = st->cc->u.curlyx.outercc;
3952                     if (st->cc)
3953                         st->ln = st->cc->u.curlyx.cur;
3954                     st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
3955                     REGCP_SET(st->u.whilem.lastcp);
3956                     REGMATCH(st->u.whilem.savecc->next, WHILEM3);
3957                     /*** all unsaved local vars undefined at this point */
3958                     st->cc = st->u.whilem.savecc;
3959                     if (result) {
3960                         regcpblow(st->u.whilem.cp);
3961                         CACHEsayYES;    /* All done. */
3962                     }
3963                     REGCP_UNWIND(st->u.whilem.lastcp);
3964                     regcppop(rex);
3965                     if (st->cc->u.curlyx.outercc)
3966                         st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3967
3968                     if (n >= st->cc->u.curlyx.max) { /* Maximum greed exceeded? */
3969                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3970                             && !(PL_reg_flags & RF_warned)) {
3971                             PL_reg_flags |= RF_warned;
3972                             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3973                                  "Complex regular subexpression recursion",
3974                                  REG_INFTY - 1);
3975                         }
3976                         CACHEsayNO;
3977                     }
3978
3979                     DEBUG_EXECUTE_r(
3980                         PerlIO_printf(Perl_debug_log,
3981                                       "%*s  trying longer...\n",
3982                                       REPORT_CODE_OFF+PL_regindent*2, "")
3983                         );
3984                     /* Try scanning more and see if it helps. */
3985                     PL_reginput = locinput;
3986                     st->cc->u.curlyx.cur = n;
3987                     st->cc->u.curlyx.lastloc = locinput;
3988                     st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3989                     REGCP_SET(st->u.whilem.lastcp);
3990                     REGMATCH(st->cc->u.curlyx.scan, WHILEM4);
3991                     /*** all unsaved local vars undefined at this point */
3992                     if (result) {
3993                         regcpblow(st->u.whilem.cp);
3994                         CACHEsayYES;
3995                     }
3996                     REGCP_UNWIND(st->u.whilem.lastcp);
3997                     regcppop(rex);
3998                     st->cc->u.curlyx.cur = n - 1;
3999                     st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
4000                     CACHEsayNO;
4001                 }
4002
4003                 /* Prefer scan over next for maximal matching. */
4004
4005                 if (n < st->cc->u.curlyx.max) { /* More greed allowed? */
4006                     st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
4007                     st->cc->u.curlyx.cur = n;
4008                     st->cc->u.curlyx.lastloc = locinput;
4009                     REGCP_SET(st->u.whilem.lastcp);
4010                     REGMATCH(st->cc->u.curlyx.scan, WHILEM5);
4011                     /*** all unsaved local vars undefined at this point */
4012                     if (result) {
4013                         regcpblow(st->u.whilem.cp);
4014                         CACHEsayYES;
4015                     }
4016                     REGCP_UNWIND(st->u.whilem.lastcp);
4017                     regcppop(rex);      /* Restore some previous $<digit>s? */
4018                     PL_reginput = locinput;
4019                     DEBUG_EXECUTE_r(
4020                         PerlIO_printf(Perl_debug_log,
4021                                       "%*s  failed, try continuation...\n",
4022                                       REPORT_CODE_OFF+PL_regindent*2, "")
4023                         );
4024                 }
4025                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
4026                         && !(PL_reg_flags & RF_warned)) {
4027                     PL_reg_flags |= RF_warned;
4028                     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4029                          "Complex regular subexpression recursion",
4030                          REG_INFTY - 1);
4031                 }
4032
4033                 /* Failed deeper matches of scan, so see if this one works. */
4034                 st->u.whilem.savecc = st->cc;
4035                 st->cc = st->cc->u.curlyx.outercc;
4036                 if (st->cc)
4037                     st->ln = st->cc->u.curlyx.cur;
4038                 REGMATCH(st->u.whilem.savecc->next, WHILEM6);
4039                 /*** all unsaved local vars undefined at this point */
4040                 st->cc = st->u.whilem.savecc;
4041                 if (result)
4042                     CACHEsayYES;
4043                 if (st->cc->u.curlyx.outercc)
4044                     st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
4045                 st->cc->u.curlyx.cur = n - 1;
4046                 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
4047                 CACHEsayNO;
4048             }
4049             /* NOTREACHED */
4050
4051 #undef  ST
4052 #define ST st->u.branch
4053
4054         case BRANCHJ:       /*  /(...|A|...)/ with long next pointer */
4055             next = scan + ARG(scan);
4056             if (next == scan)
4057                 next = NULL;
4058             scan = NEXTOPER(scan);
4059             /* FALL THROUGH */
4060
4061         case BRANCH:        /*  /(...|A|...)/ */
4062             scan = NEXTOPER(scan); /* scan now points to inner node */
4063             if (!next || (OP(next) != BRANCH && OP(next) != BRANCHJ))
4064                 /* last branch; skip state push and jump direct to node */
4065                 continue;
4066             ST.lastparen = *PL_reglastparen;
4067             ST.next_branch = next;
4068             REGCP_SET(ST.cp);
4069             PL_reginput = locinput;
4070
4071             /* Now go into the branch */
4072             PUSH_STATE_GOTO(BRANCH_next, scan);
4073             /* NOTREACHED */
4074
4075         case BRANCH_next_fail: /* that branch failed; try the next, if any */
4076             REGCP_UNWIND(ST.cp);
4077             for (n = *PL_reglastparen; n > ST.lastparen; n--)
4078                 PL_regendp[n] = -1;
4079             *PL_reglastparen = n;
4080             scan = ST.next_branch;
4081             /* no more branches? */
4082             if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ))
4083                 sayNO;
4084             continue; /* execute next BRANCH[J] op */
4085             /* NOTREACHED */
4086
4087         case MINMOD:
4088             st->minmod = 1;
4089             break;
4090
4091 #undef  ST
4092 #define ST st->u.curlym
4093
4094         case CURLYM:    /* /A{m,n}B/ where A is fixed-length */
4095
4096             /* This is an optimisation of CURLYX that enables us to push
4097              * only a single backtracking state, no matter now many matches
4098              * there are in {m,n}. It relies on the pattern being constant
4099              * length, with no parens to influence future backrefs
4100              */
4101
4102             ST.me = scan;
4103             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4104
4105             /* if paren positive, emulate an OPEN/CLOSE around A */
4106             if (ST.me->flags) {
4107                 I32 paren = ST.me->flags;
4108                 if (paren > PL_regsize)
4109                     PL_regsize = paren;
4110                 if (paren > (I32)*PL_reglastparen)
4111                     *PL_reglastparen = paren;
4112                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4113             }
4114             ST.A = scan;
4115             ST.B = next;
4116             ST.alen = 0;
4117             ST.count = 0;
4118             ST.minmod = st->minmod;
4119             st->minmod = 0;
4120             ST.c1 = CHRTEST_UNINIT;
4121             REGCP_SET(ST.cp);
4122
4123             if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4124                 goto curlym_do_B;
4125
4126           curlym_do_A: /* execute the A in /A{m,n}B/  */
4127             PL_reginput = locinput;
4128             PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4129             /* NOTREACHED */
4130
4131         case CURLYM_A: /* we've just matched an A */
4132             locinput = st->locinput;
4133             nextchr = UCHARAT(locinput);
4134
4135             ST.count++;
4136             /* after first match, determine A's length: u.curlym.alen */
4137             if (ST.count == 1) {
4138                 if (PL_reg_match_utf8) {
4139                     char *s = locinput;
4140                     while (s < PL_reginput) {
4141                         ST.alen++;
4142                         s += UTF8SKIP(s);
4143                     }
4144                 }
4145                 else {
4146                     ST.alen = PL_reginput - locinput;
4147                 }
4148                 if (ST.alen == 0)
4149                     ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4150             }
4151             DEBUG_EXECUTE_r(
4152                 PerlIO_printf(Perl_debug_log,
4153                           "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4154                           (int)(REPORT_CODE_OFF+PL_regindent*2), "",
4155                           (IV) ST.count, (IV)ST.alen)
4156             );
4157
4158             locinput = PL_reginput;
4159             if (ST.count < (ST.minmod ? ARG1(ST.me) : ARG2(ST.me)))
4160                 goto curlym_do_A; /* try to match another A */
4161             goto curlym_do_B; /* try to match B */
4162
4163         case CURLYM_A_fail: /* just failed to match an A */
4164             REGCP_UNWIND(ST.cp);
4165             if (ST.minmod || ST.count < ARG1(ST.me) /* min*/ )
4166                 sayNO;
4167
4168           curlym_do_B: /* execute the B in /A{m,n}B/  */
4169             PL_reginput = locinput;
4170             if (ST.c1 == CHRTEST_UNINIT) {
4171                 /* calculate c1 and c2 for possible match of 1st char
4172                  * following curly */
4173                 ST.c1 = ST.c2 = CHRTEST_VOID;
4174                 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4175                     regnode *text_node = ST.B;
4176                     if (! HAS_TEXT(text_node))
4177                         FIND_NEXT_IMPT(text_node);
4178                     if (HAS_TEXT(text_node)
4179                         && PL_regkind[OP(text_node)] != REF)
4180                     {
4181                         ST.c1 = (U8)*STRING(text_node);
4182                         ST.c2 =
4183                             (OP(text_node) == EXACTF || OP(text_node) == REFF)
4184                             ? PL_fold[ST.c1]
4185                             : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4186                                 ? PL_fold_locale[ST.c1]
4187                                 : ST.c1;
4188                     }
4189                 }
4190             }
4191
4192             DEBUG_EXECUTE_r(
4193                 PerlIO_printf(Perl_debug_log,
4194                     "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
4195                     (int)(REPORT_CODE_OFF+PL_regindent*2),
4196                     "", (IV)ST.count)
4197                 );
4198             if (ST.c1 != CHRTEST_VOID
4199                     && UCHARAT(PL_reginput) != ST.c1
4200                     && UCHARAT(PL_reginput) != ST.c2)
4201             {
4202                 /* simulate B failing */
4203                 state_num = CURLYM_B_fail;
4204                 goto reenter_switch;
4205             }
4206
4207             if (ST.me->flags) {
4208                 /* mark current A as captured */
4209                 I32 paren = ST.me->flags;
4210                 if (ST.count) {
4211                     PL_regstartp[paren]
4212                         = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4213                     PL_regendp[paren] = PL_reginput - PL_bostr;
4214                 }
4215                 else
4216                     PL_regendp[paren] = -1;
4217             }
4218             PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4219             /* NOTREACHED */
4220
4221         case CURLYM_B_fail: /* just failed to match a B */
4222             REGCP_UNWIND(ST.cp);
4223             if (ST.minmod) {
4224                 if (ST.count == ARG2(ST.me) /* max */)
4225                     sayNO;
4226                 goto curlym_do_A; /* try to match a further A */
4227             }
4228             /* backtrack one A */
4229             if (ST.count == ARG1(ST.me) /* min */)
4230                 sayNO;
4231             ST.count--;
4232             locinput = HOPc(locinput, -ST.alen);
4233             goto curlym_do_B; /* try to match B */
4234
4235 #undef ST
4236 #define ST st->u.curly
4237
4238 #define CURLY_SETPAREN(paren, success) \
4239     if (paren) { \
4240         if (success) { \
4241             PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr; \
4242             PL_regendp[paren] = locinput - PL_bostr; \
4243         } \
4244         else \
4245             PL_regendp[paren] = -1; \
4246     }
4247
4248         case STAR:              /*  /A*B/ where A is width 1 */
4249             ST.paren = 0;
4250             ST.min = 0;
4251             ST.max = REG_INFTY;
4252             scan = NEXTOPER(scan);
4253             goto repeat;
4254         case PLUS:              /*  /A+B/ where A is width 1 */
4255             ST.paren = 0;
4256             ST.min = 1;
4257             ST.max = REG_INFTY;
4258             scan = NEXTOPER(scan);
4259             goto repeat;
4260         case CURLYN:            /*  /(A){m,n}B/ where A is width 1 */
4261             ST.paren = scan->flags;     /* Which paren to set */
4262             if (ST.paren > PL_regsize)
4263                 PL_regsize = ST.paren;
4264             if (ST.paren > (I32)*PL_reglastparen)
4265                 *PL_reglastparen = ST.paren;
4266             ST.min = ARG1(scan);  /* min to match */
4267             ST.max = ARG2(scan);  /* max to match */
4268             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4269             goto repeat;
4270         case CURLY:             /*  /A{m,n}B/ where A is width 1 */
4271             ST.paren = 0;
4272             ST.min = ARG1(scan);  /* min to match */
4273             ST.max = ARG2(scan);  /* max to match */
4274             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4275           repeat:
4276             /*
4277             * Lookahead to avoid useless match attempts
4278             * when we know what character comes next.
4279             *
4280             * Used to only do .*x and .*?x, but now it allows
4281             * for )'s, ('s and (?{ ... })'s to be in the way
4282             * of the quantifier and the EXACT-like node.  -- japhy
4283             */
4284
4285             if (ST.min > ST.max) /* XXX make this a compile-time check? */
4286                 sayNO;
4287             if (HAS_TEXT(next) || JUMPABLE(next)) {
4288                 U8 *s;
4289                 regnode *text_node = next;
4290
4291                 if (! HAS_TEXT(text_node))
4292                     FIND_NEXT_IMPT(text_node);
4293
4294                 if (! HAS_TEXT(text_node))
4295                     ST.c1 = ST.c2 = CHRTEST_VOID;
4296                 else {
4297                     if (PL_regkind[OP(text_node)] == REF) {
4298                         ST.c1 = ST.c2 = CHRTEST_VOID;
4299                         goto assume_ok_easy;
4300                     }
4301                     else
4302                         s = (U8*)STRING(text_node);
4303
4304                     if (!UTF) {
4305                         ST.c2 = ST.c1 = *s;
4306                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4307                             ST.c2 = PL_fold[ST.c1];
4308                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4309                             ST.c2 = PL_fold_locale[ST.c1];
4310                     }
4311                     else { /* UTF */
4312                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4313                              STRLEN ulen1, ulen2;
4314                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4315                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4316
4317                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4318                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4319
4320                              ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4321                                                  uniflags);
4322                              ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4323                                                  uniflags);
4324                         }
4325                         else {
4326                             ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4327                                                      uniflags);
4328                         }
4329                     }
4330                 }
4331             }
4332             else
4333                 ST.c1 = ST.c2 = CHRTEST_VOID;
4334         assume_ok_easy:
4335
4336             ST.A = scan;
4337             ST.B = next;
4338             PL_reginput = locinput;
4339             if (st->minmod) {
4340                 st->minmod = 0;
4341                 if (ST.min && regrepeat(rex, ST.A, ST.min) < ST.min)
4342                     sayNO;
4343                 ST.count = ST.min;
4344                 locinput = PL_reginput;
4345                 REGCP_SET(ST.cp);
4346                 if (ST.c1 == CHRTEST_VOID)
4347                     goto curly_try_B_min;
4348
4349                 ST.oldloc = locinput;
4350
4351                 /* set ST.maxpos to the furthest point along the
4352                  * string that could possibly match */
4353                 if  (ST.max == REG_INFTY) {
4354                     ST.maxpos = PL_regeol - 1;
4355                     if (do_utf8)
4356                         while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4357                             ST.maxpos--;
4358                 }
4359                 else if (do_utf8) {
4360                     int m = ST.max - ST.min;
4361                     for (ST.maxpos = locinput;
4362                          m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4363                         ST.maxpos += UTF8SKIP(ST.maxpos);
4364                 }
4365                 else {
4366                     ST.maxpos = locinput + ST.max - ST.min;
4367                     if (ST.maxpos >= PL_regeol)
4368                         ST.maxpos = PL_regeol - 1;
4369                 }
4370                 goto curly_try_B_min_known;
4371
4372             }
4373             else {
4374                 ST.count = regrepeat(rex, ST.A, ST.max);
4375                 locinput = PL_reginput;
4376                 if (ST.count < ST.min)
4377                     sayNO;
4378                 if ((ST.count > ST.min)
4379                     && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4380                 {
4381                     /* A{m,n} must come at the end of the string, there's
4382                      * no point in backing off ... */
4383                     ST.min = ST.count;
4384                     /* ...except that $ and \Z can match before *and* after
4385                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4386                        We may back off by one in this case. */
4387                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4388                         ST.min--;
4389                 }
4390                 REGCP_SET(ST.cp);
4391                 goto curly_try_B_max;
4392             }
4393             /* NOTREACHED */
4394
4395
4396         case CURLY_B_min_known_fail:
4397             /* failed to find B in a non-greedy match where c1,c2 valid */
4398             if (ST.paren && ST.count)
4399                 PL_regendp[ST.paren] = -1;
4400
4401             PL_reginput = locinput;     /* Could be reset... */
4402             REGCP_UNWIND(ST.cp);
4403             /* Couldn't or didn't -- move forward. */
4404             ST.oldloc = locinput;
4405             if (do_utf8)
4406                 locinput += UTF8SKIP(locinput);
4407             else
4408                 locinput++;
4409             ST.count++;
4410           curly_try_B_min_known:
4411              /* find the next place where 'B' could work, then call B */
4412             {
4413                 int n;
4414                 if (do_utf8) {
4415                     n = (ST.oldloc == locinput) ? 0 : 1;
4416                     if (ST.c1 == ST.c2) {
4417                         STRLEN len;
4418                         /* set n to utf8_distance(oldloc, locinput) */
4419                         while (locinput <= ST.maxpos &&
4420                                utf8n_to_uvchr((U8*)locinput,
4421                                               UTF8_MAXBYTES, &len,
4422                                               uniflags) != (UV)ST.c1) {
4423                             locinput += len;
4424                             n++;
4425                         }
4426                     }
4427                     else {
4428                         /* set n to utf8_distance(oldloc, locinput) */
4429                         while (locinput <= ST.maxpos) {
4430                             STRLEN len;
4431                             const UV c = utf8n_to_uvchr((U8*)locinput,
4432                                                   UTF8_MAXBYTES, &len,
4433                                                   uniflags);
4434                             if (c == (UV)ST.c1 || c == (UV)ST.c2)
4435                                 break;
4436                             locinput += len;
4437                             n++;
4438                         }
4439                     }
4440                 }
4441                 else {
4442                     if (ST.c1 == ST.c2) {
4443                         while (locinput <= ST.maxpos &&
4444                                UCHARAT(locinput) != ST.c1)
4445                             locinput++;
4446                     }
4447                     else {
4448                         while (locinput <= ST.maxpos
4449                                && UCHARAT(locinput) != ST.c1
4450                                && UCHARAT(locinput) != ST.c2)
4451                             locinput++;
4452                     }
4453                     n = locinput - ST.oldloc;
4454                 }
4455                 if (locinput > ST.maxpos)
4456                     sayNO;
4457                 /* PL_reginput == oldloc now */
4458                 if (n) {
4459                     ST.count += n;
4460                     if (regrepeat(rex, ST.A, n) < n)
4461                         sayNO;
4462                 }
4463                 PL_reginput = locinput;
4464                 CURLY_SETPAREN(ST.paren, ST.count);
4465                 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
4466             }
4467             /* NOTREACHED */
4468
4469
4470         case CURLY_B_min_fail:
4471             /* failed to find B in a non-greedy match where c1,c2 invalid */
4472             if (ST.paren && ST.count)
4473                 PL_regendp[ST.paren] = -1;
4474
4475             REGCP_UNWIND(ST.cp);
4476             /* failed -- move forward one */
4477             PL_reginput = locinput;
4478             if (regrepeat(rex, ST.A, 1)) {
4479                 ST.count++;
4480                 locinput = PL_reginput;
4481                 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
4482                         ST.count > 0)) /* count overflow ? */
4483                 {
4484                   curly_try_B_min:
4485                     CURLY_SETPAREN(ST.paren, ST.count);
4486                     PUSH_STATE_GOTO(CURLY_B_min, ST.B);
4487                 }
4488             }
4489             sayNO;
4490             /* NOTREACHED */
4491
4492
4493         curly_try_B_max:
4494             /* a successful greedy match: now try to match B */
4495             {
4496                 UV c = 0;
4497                 if (ST.c1 != CHRTEST_VOID)
4498                     c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
4499                                            UTF8_MAXBYTES, 0, uniflags)
4500                                 : (UV) UCHARAT(PL_reginput);
4501                 /* If it could work, try it. */
4502                 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
4503                     CURLY_SETPAREN(ST.paren, ST.count);
4504                     PUSH_STATE_GOTO(CURLY_B_max, ST.B);
4505                     /* NOTREACHED */
4506                 }
4507             }
4508             /* FALL THROUGH */
4509         case CURLY_B_max_fail:
4510             /* failed to find B in a greedy match */
4511             if (ST.paren && ST.count)
4512                 PL_regendp[ST.paren] = -1;
4513
4514             REGCP_UNWIND(ST.cp);
4515             /*  back up. */
4516             if (--ST.count < ST.min)
4517                 sayNO;
4518             PL_reginput = locinput = HOPc(locinput, -1);
4519             goto curly_try_B_max;
4520
4521 #undef ST
4522
4523
4524         case END:
4525             if (locinput < reginfo->till) {
4526                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4527                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4528                                       PL_colors[4],
4529                                       (long)(locinput - PL_reg_starttry),
4530                                       (long)(reginfo->till - PL_reg_starttry),
4531                                       PL_colors[5]));
4532                 sayNO_FINAL;            /* Cannot match: too short. */
4533             }
4534             PL_reginput = locinput;     /* put where regtry can find it */
4535             sayYES_FINAL;               /* Success! */
4536
4537         case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4538             DEBUG_EXECUTE_r(
4539             PerlIO_printf(Perl_debug_log,
4540                 "%*s  %ssubpattern success...%s\n",
4541                 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5]));
4542             PL_reginput = locinput;     /* put where regtry can find it */
4543             sayYES_FINAL;               /* Success! */
4544
4545 #undef  ST
4546 #define ST st->u.ifmatch
4547
4548         case SUSPEND:   /* (?>A) */
4549             ST.wanted = 1;
4550             PL_reginput = locinput;
4551             goto do_ifmatch;
4552
4553         case UNLESSM:   /* -ve lookaround: (?!A), or with flags, (?<!A) */
4554             ST.wanted = 0;
4555             goto ifmatch_trivial_fail_test;
4556
4557         case IFMATCH:   /* +ve lookaround: (?=A), or with flags, (?<=A) */
4558             ST.wanted = 1;
4559           ifmatch_trivial_fail_test:
4560             if (scan->flags) {
4561                 char * const s = HOPBACKc(locinput, scan->flags);
4562                 if (!s) {
4563                     /* trivial fail */
4564                     if (st->logical) {
4565                         st->logical = 0;
4566                         st->sw = 1 - (bool)ST.wanted;
4567                     }
4568                     else if (ST.wanted)
4569                         sayNO;
4570                     next = scan + ARG(scan);
4571                     if (next == scan)
4572                         next = NULL;
4573                     break;
4574                 }
4575                 PL_reginput = s;
4576             }
4577             else
4578                 PL_reginput = locinput;
4579
4580           do_ifmatch:
4581             ST.me = scan;
4582             /* execute body of (?...A) */
4583             PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
4584             /* NOTREACHED */
4585
4586         case IFMATCH_A_fail: /* body of (?...A) failed */
4587             ST.wanted = !ST.wanted;
4588             /* FALL THROUGH */
4589
4590         case IFMATCH_A: /* body of (?...A) succeeded */
4591             if (st->logical) {
4592                 st->logical = 0;
4593                 st->sw = (bool)ST.wanted;
4594             }
4595             else if (!ST.wanted)
4596                 sayNO;
4597
4598             if (OP(ST.me) == SUSPEND)
4599                 locinput = PL_reginput;
4600             else {
4601                 locinput = PL_reginput = st->locinput;
4602                 nextchr = UCHARAT(locinput);
4603             }
4604             scan = ST.me + ARG(ST.me);
4605             if (scan == ST.me)
4606                 scan = NULL;
4607             continue; /* execute B */
4608
4609 #undef ST
4610
4611         case LONGJMP:
4612             next = scan + ARG(scan);
4613             if (next == scan)
4614                 next = NULL;
4615             break;
4616         default:
4617             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4618                           PTR2UV(scan), OP(scan));
4619             Perl_croak(aTHX_ "regexp memory corruption");
4620         }
4621
4622         scan = next;
4623         continue;
4624         /* NOTREACHED */
4625
4626       push_yes_state:
4627         /* push a state that backtracks on success */
4628         st->u.yes.prev_yes_state = yes_state;
4629         yes_state = st;
4630         /* FALL THROUGH */
4631       push_state:
4632         /* push a new regex state, then continue at scan  */
4633         {
4634             regmatch_state *newst;
4635
4636             depth++;
4637             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4638                         "PUSH STATE(%d)\n", depth));
4639             st->locinput = locinput;
4640             newst = st+1;
4641             if (newst >  SLAB_LAST(PL_regmatch_slab))
4642                 newst = S_push_slab(aTHX);
4643             PL_regmatch_state = newst;
4644             newst->cc = st->cc;
4645             /* XXX probably don't need to initialise these */
4646             newst->minmod = 0;
4647             newst->sw = 0;
4648             newst->logical = 0;
4649
4650             locinput = PL_reginput;
4651             nextchr = UCHARAT(locinput);
4652             st = newst;
4653             continue;
4654             /* NOTREACHED */
4655         }
4656
4657         /* simulate recursively calling regmatch(), but without actually
4658          * recursing - ie save the current state on the heap rather than on
4659          * the stack, then re-enter the loop. This avoids complex regexes
4660          * blowing the processor stack */
4661
4662       start_recurse:
4663         {
4664             /* push new state */
4665             regmatch_state *oldst = st;
4666
4667             depth++;
4668             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "PUSH RECURSE STATE(%d)\n", depth));
4669
4670             /* grab the next free state slot */
4671             st++;
4672             if (st >  SLAB_LAST(PL_regmatch_slab))
4673                 st = S_push_slab(aTHX);
4674             PL_regmatch_state = st;
4675
4676             oldst->next = next;
4677             oldst->n = n;
4678             oldst->locinput = locinput;
4679
4680             st->cc = oldst->cc;
4681             locinput = PL_reginput;
4682             nextchr = UCHARAT(locinput);
4683             st->minmod = 0;
4684             st->sw = 0;
4685             st->logical = 0;
4686 #ifdef DEBUGGING
4687             PL_regindent++;
4688 #endif
4689         }
4690     }
4691
4692
4693
4694     /*
4695     * We get here only if there's trouble -- normally "case END" is
4696     * the terminating point.
4697     */
4698     Perl_croak(aTHX_ "corrupted regexp pointers");
4699     /*NOTREACHED*/
4700     sayNO;
4701
4702 yes_final:
4703
4704     if (yes_state) {
4705         /* we have successfully completed a subexpression, but we must now
4706          * pop to the state marked by yes_state and continue from there */
4707
4708         assert(st != yes_state);
4709         while (yes_state < SLAB_FIRST(PL_regmatch_slab)
4710             || yes_state > SLAB_LAST(PL_regmatch_slab))
4711         {
4712             /* not in this slab, pop slab */
4713             depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
4714             PL_regmatch_slab = PL_regmatch_slab->prev;
4715             st = SLAB_LAST(PL_regmatch_slab);
4716         }
4717         depth -= (st - yes_state);
4718         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATES (%d..%d)\n",
4719             depth+1, depth+(st - yes_state)));
4720         st = yes_state;
4721         yes_state = st->u.yes.prev_yes_state;
4722         PL_regmatch_state = st;
4723
4724         switch (st->resume_state) {
4725         case IFMATCH_A:
4726         case CURLYM_A:
4727         case EVAL_A:
4728             state_num = st->resume_state;
4729             goto reenter_switch;
4730
4731         case CURLYM_B:
4732         case BRANCH_next:
4733         case TRIE_next:
4734         case CURLY_B_max:
4735         default:
4736             Perl_croak(aTHX_ "unexpected yes resume state");
4737         }
4738     }
4739
4740     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4741                           PL_colors[4], PL_colors[5]));
4742 yes:
4743 #ifdef DEBUGGING
4744     PL_regindent--;
4745 #endif
4746
4747     result = 1;
4748     /* XXX this is duplicate(ish) code to that in the do_no section.
4749      * will disappear when REGFMATCH goes */
4750     if (depth) {
4751         /* restore previous state and re-enter */
4752         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
4753         depth--;
4754         st--;
4755         if (st < SLAB_FIRST(PL_regmatch_slab)) {
4756             PL_regmatch_slab = PL_regmatch_slab->prev;
4757             st = SLAB_LAST(PL_regmatch_slab);
4758         }
4759         PL_regmatch_state = st;
4760         scan    = st->scan;
4761         next    = st->next;
4762         n       = st->n;
4763         locinput= st->locinput;
4764         nextchr = UCHARAT(locinput);
4765
4766         switch (st->resume_state) {
4767         case resume_CURLYX:
4768             goto resume_point_CURLYX;
4769         case resume_WHILEM1:
4770             goto resume_point_WHILEM1;
4771         case resume_WHILEM2:
4772             goto resume_point_WHILEM2;
4773         case resume_WHILEM3:
4774             goto resume_point_WHILEM3;
4775         case resume_WHILEM4:
4776             goto resume_point_WHILEM4;
4777         case resume_WHILEM5:
4778             goto resume_point_WHILEM5;
4779         case resume_WHILEM6:
4780             goto resume_point_WHILEM6;
4781
4782         case TRIE_next:
4783         case CURLYM_A:
4784         case CURLYM_B:
4785         case EVAL_A:
4786         case IFMATCH_A:
4787         case BRANCH_next:
4788         case CURLY_B_max:
4789         case CURLY_B_min:
4790         case CURLY_B_min_known:
4791             break;
4792
4793         default:
4794             Perl_croak(aTHX_ "regexp resume memory corruption");
4795         }
4796     }
4797     goto final_exit;
4798
4799 no:
4800     DEBUG_EXECUTE_r(
4801         PerlIO_printf(Perl_debug_log,
4802                       "%*s  %sfailed...%s\n",
4803                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4804         );
4805 no_final:
4806 do_no:
4807
4808 #ifdef DEBUGGING
4809     PL_regindent--;
4810 #endif
4811     result = 0;
4812
4813     if (depth) {
4814         /* there's a previous state to backtrack to */
4815         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
4816         depth--;
4817         st--;
4818         if (st < SLAB_FIRST(PL_regmatch_slab)) {
4819             PL_regmatch_slab = PL_regmatch_slab->prev;
4820             st = SLAB_LAST(PL_regmatch_slab);
4821         }
4822         PL_regmatch_state = st;
4823         scan    = st->scan;
4824         next    = st->next;
4825         n       = st->n;
4826         locinput= st->locinput;
4827         nextchr = UCHARAT(locinput);
4828
4829         switch (st->resume_state) {
4830         case resume_CURLYX:
4831             goto resume_point_CURLYX;
4832         case resume_WHILEM1:
4833             goto resume_point_WHILEM1;
4834         case resume_WHILEM2:
4835             goto resume_point_WHILEM2;
4836         case resume_WHILEM3:
4837             goto resume_point_WHILEM3;
4838         case resume_WHILEM4:
4839             goto resume_point_WHILEM4;
4840         case resume_WHILEM5:
4841             goto resume_point_WHILEM5;
4842         case resume_WHILEM6:
4843             goto resume_point_WHILEM6;
4844
4845         case TRIE_next:
4846         case EVAL_A:
4847         case BRANCH_next:
4848         case CURLYM_A:
4849         case CURLYM_B:
4850         case IFMATCH_A:
4851         case CURLY_B_max:
4852         case CURLY_B_min:
4853         case CURLY_B_min_known:
4854             if (yes_state == st)
4855                 yes_state = st->u.yes.prev_yes_state;
4856             state_num = st->resume_state + 1; /* failure = success + 1 */
4857             goto reenter_switch;
4858
4859         default:
4860             Perl_croak(aTHX_ "regexp resume memory corruption");
4861         }
4862     }
4863
4864 final_exit:
4865
4866     /* restore original high-water mark */
4867     PL_regmatch_slab  = orig_slab;
4868     PL_regmatch_state = orig_state;
4869
4870     /* free all slabs above current one */
4871     if (orig_slab->next) {
4872         regmatch_slab *sl = orig_slab->next;
4873         orig_slab->next = NULL;
4874         while (sl) {
4875             regmatch_slab * const osl = sl;
4876             sl = sl->next;
4877             Safefree(osl);
4878         }
4879     }
4880
4881     return result;
4882
4883 }
4884
4885 /*
4886  - regrepeat - repeatedly match something simple, report how many
4887  */
4888 /*
4889  * [This routine now assumes that it will only match on things of length 1.
4890  * That was true before, but now we assume scan - reginput is the count,
4891  * rather than incrementing count on every character.  [Er, except utf8.]]
4892  */
4893 STATIC I32
4894 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max)
4895 {
4896     dVAR;
4897     register char *scan;
4898     register I32 c;
4899     register char *loceol = PL_regeol;
4900     register I32 hardcount = 0;
4901     register bool do_utf8 = PL_reg_match_utf8;
4902
4903     scan = PL_reginput;
4904     if (max == REG_INFTY)
4905         max = I32_MAX;
4906     else if (max < loceol - scan)
4907         loceol = scan + max;
4908     switch (OP(p)) {
4909     case REG_ANY:
4910         if (do_utf8) {
4911             loceol = PL_regeol;
4912             while (scan < loceol && hardcount < max && *scan != '\n') {
4913                 scan += UTF8SKIP(scan);
4914                 hardcount++;
4915             }
4916         } else {
4917             while (scan < loceol && *scan != '\n')
4918                 scan++;
4919         }
4920         break;
4921     case SANY:
4922         if (do_utf8) {
4923             loceol = PL_regeol;
4924             while (scan < loceol && hardcount < max) {
4925                 scan += UTF8SKIP(scan);
4926                 hardcount++;
4927             }
4928         }
4929         else
4930             scan = loceol;
4931         break;
4932     case CANY:
4933         scan = loceol;
4934         break;
4935     case EXACT:         /* length of string is 1 */
4936         c = (U8)*STRING(p);
4937         while (scan < loceol && UCHARAT(scan) == c)
4938             scan++;
4939         break;
4940     case EXACTF:        /* length of string is 1 */
4941         c = (U8)*STRING(p);
4942         while (scan < loceol &&
4943                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4944             scan++;
4945         break;
4946     case EXACTFL:       /* length of string is 1 */
4947         PL_reg_flags |= RF_tainted;
4948         c = (U8)*STRING(p);
4949         while (scan < loceol &&
4950                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4951             scan++;
4952         break;
4953     case ANYOF:
4954         if (do_utf8) {
4955             loceol = PL_regeol;
4956             while (hardcount < max && scan < loceol &&
4957                    reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
4958                 scan += UTF8SKIP(scan);
4959                 hardcount++;
4960             }
4961         } else {
4962             while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
4963                 scan++;
4964         }
4965         break;
4966     case ALNUM:
4967         if (do_utf8) {
4968             loceol = PL_regeol;
4969             LOAD_UTF8_CHARCLASS_ALNUM();
4970             while (hardcount < max && scan < loceol &&
4971                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4972                 scan += UTF8SKIP(scan);
4973                 hardcount++;
4974             }
4975         } else {
4976             while (scan < loceol && isALNUM(*scan))
4977                 scan++;
4978         }
4979         break;
4980     case ALNUML:
4981         PL_reg_flags |= RF_tainted;
4982         if (do_utf8) {
4983             loceol = PL_regeol;
4984             while (hardcount < max && scan < loceol &&
4985                    isALNUM_LC_utf8((U8*)scan)) {
4986                 scan += UTF8SKIP(scan);
4987                 hardcount++;
4988             }
4989         } else {
4990             while (scan < loceol && isALNUM_LC(*scan))
4991                 scan++;
4992         }
4993         break;
4994     case NALNUM:
4995         if (do_utf8) {
4996             loceol = PL_regeol;
4997             LOAD_UTF8_CHARCLASS_ALNUM();
4998             while (hardcount < max && scan < loceol &&
4999                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5000                 scan += UTF8SKIP(scan);
5001                 hardcount++;
5002             }
5003         } else {
5004             while (scan < loceol && !isALNUM(*scan))
5005                 scan++;
5006         }
5007         break;
5008     case NALNUML:
5009         PL_reg_flags |= RF_tainted;
5010         if (do_utf8) {
5011             loceol = PL_regeol;
5012             while (hardcount < max && scan < loceol &&
5013                    !isALNUM_LC_utf8((U8*)scan)) {
5014                 scan += UTF8SKIP(scan);
5015                 hardcount++;
5016             }
5017         } else {
5018             while (scan < loceol && !isALNUM_LC(*scan))
5019                 scan++;
5020         }
5021         break;
5022     case SPACE:
5023         if (do_utf8) {
5024             loceol = PL_regeol;
5025             LOAD_UTF8_CHARCLASS_SPACE();
5026             while (hardcount < max && scan < loceol &&
5027                    (*scan == ' ' ||
5028                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5029                 scan += UTF8SKIP(scan);
5030                 hardcount++;
5031             }
5032         } else {
5033             while (scan < loceol && isSPACE(*scan))
5034                 scan++;
5035         }
5036         break;
5037     case SPACEL:
5038         PL_reg_flags |= RF_tainted;
5039         if (do_utf8) {
5040             loceol = PL_regeol;
5041             while (hardcount < max && scan < loceol &&
5042                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5043                 scan += UTF8SKIP(scan);
5044                 hardcount++;
5045             }
5046         } else {
5047             while (scan < loceol && isSPACE_LC(*scan))
5048                 scan++;
5049         }
5050         break;
5051     case NSPACE:
5052         if (do_utf8) {
5053             loceol = PL_regeol;
5054             LOAD_UTF8_CHARCLASS_SPACE();
5055             while (hardcount < max && scan < loceol &&
5056                    !(*scan == ' ' ||
5057                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5058                 scan += UTF8SKIP(scan);
5059                 hardcount++;
5060             }
5061         } else {
5062             while (scan < loceol && !isSPACE(*scan))
5063                 scan++;
5064             break;
5065         }
5066     case NSPACEL:
5067         PL_reg_flags |= RF_tainted;
5068         if (do_utf8) {
5069             loceol = PL_regeol;
5070             while (hardcount < max && scan < loceol &&
5071                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5072                 scan += UTF8SKIP(scan);
5073                 hardcount++;
5074             }
5075         } else {
5076             while (scan < loceol && !isSPACE_LC(*scan))
5077                 scan++;
5078         }
5079         break;
5080     case DIGIT:
5081         if (do_utf8) {
5082             loceol = PL_regeol;
5083             LOAD_UTF8_CHARCLASS_DIGIT();
5084             while (hardcount < max && scan < loceol &&
5085                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5086                 scan += UTF8SKIP(scan);
5087                 hardcount++;
5088             }
5089         } else {
5090             while (scan < loceol && isDIGIT(*scan))
5091                 scan++;
5092         }
5093         break;
5094     case NDIGIT:
5095         if (do_utf8) {
5096             loceol = PL_regeol;
5097             LOAD_UTF8_CHARCLASS_DIGIT();
5098             while (hardcount < max && scan < loceol &&
5099                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5100                 scan += UTF8SKIP(scan);
5101                 hardcount++;
5102             }
5103         } else {
5104             while (scan < loceol && !isDIGIT(*scan))
5105                 scan++;
5106         }
5107         break;
5108     default:            /* Called on something of 0 width. */
5109         break;          /* So match right here or not at all. */
5110     }
5111
5112     if (hardcount)
5113         c = hardcount;
5114     else
5115         c = scan - PL_reginput;
5116     PL_reginput = scan;
5117
5118     DEBUG_r({
5119         GET_RE_DEBUG_FLAGS_DECL;
5120         DEBUG_EXECUTE_r({
5121             SV * const prop = sv_newmortal();
5122             regprop(prog, prop, p);
5123             PerlIO_printf(Perl_debug_log,
5124                         "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
5125                         REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
5126         });
5127     });
5128
5129     return(c);
5130 }
5131
5132
5133 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5134 /*
5135 - regclass_swash - prepare the utf8 swash
5136 */
5137
5138 SV *
5139 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5140 {
5141     dVAR;
5142     SV *sw  = NULL;
5143     SV *si  = NULL;
5144     SV *alt = NULL;
5145     const struct reg_data * const data = prog ? prog->data : NULL;
5146
5147     if (data && data->count) {
5148         const U32 n = ARG(node);
5149
5150         if (data->what[n] == 's') {
5151             SV * const rv = (SV*)data->data[n];
5152             AV * const av = (AV*)SvRV((SV*)rv);
5153             SV **const ary = AvARRAY(av);
5154             SV **a, **b;
5155
5156             /* See the end of regcomp.c:S_regclass() for
5157              * documentation of these array elements. */
5158
5159             si = *ary;
5160             a  = SvROK(ary[1]) ? &ary[1] : 0;
5161             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
5162
5163             if (a)
5164                 sw = *a;
5165             else if (si && doinit) {
5166                 sw = swash_init("utf8", "", si, 1, 0);
5167                 (void)av_store(av, 1, sw);
5168             }
5169             if (b)
5170                 alt = *b;
5171         }
5172     }
5173
5174     if (listsvp)
5175         *listsvp = si;
5176     if (altsvp)
5177         *altsvp  = alt;
5178
5179     return sw;
5180 }
5181 #endif
5182
5183 /*
5184  - reginclass - determine if a character falls into a character class
5185
5186   The n is the ANYOF regnode, the p is the target string, lenp
5187   is pointer to the maximum length of how far to go in the p
5188   (if the lenp is zero, UTF8SKIP(p) is used),
5189   do_utf8 tells whether the target string is in UTF-8.
5190
5191  */
5192
5193 STATIC bool
5194 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5195 {
5196     dVAR;
5197     const char flags = ANYOF_FLAGS(n);
5198     bool match = FALSE;
5199     UV c = *p;
5200     STRLEN len = 0;
5201     STRLEN plen;
5202
5203     if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5204         c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5205                 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5206                 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5207         if (len == (STRLEN)-1)
5208             Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5209     }
5210
5211     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5212     if (do_utf8 || (flags & ANYOF_UNICODE)) {
5213         if (lenp)
5214             *lenp = 0;
5215         if (do_utf8 && !ANYOF_RUNTIME(n)) {
5216             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5217                 match = TRUE;
5218         }
5219         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5220             match = TRUE;
5221         if (!match) {
5222             AV *av;
5223             SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5224
5225             if (sw) {
5226                 if (swash_fetch(sw, p, do_utf8))
5227                     match = TRUE;
5228                 else if (flags & ANYOF_FOLD) {
5229                     if (!match && lenp && av) {
5230                         I32 i;
5231                         for (i = 0; i <= av_len(av); i++) {
5232                             SV* const sv = *av_fetch(av, i, FALSE);
5233                             STRLEN len;
5234                             const char * const s = SvPV_const(sv, len);
5235
5236                             if (len <= plen && memEQ(s, (char*)p, len)) {
5237                                 *lenp = len;
5238                                 match = TRUE;
5239                                 break;
5240                             }
5241                         }
5242                     }
5243                     if (!match) {
5244                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5245                         STRLEN tmplen;
5246
5247                         to_utf8_fold(p, tmpbuf, &tmplen);
5248                         if (swash_fetch(sw, tmpbuf, do_utf8))
5249                             match = TRUE;
5250                     }
5251                 }
5252             }
5253         }
5254         if (match && lenp && *lenp == 0)
5255             *lenp = UNISKIP(NATIVE_TO_UNI(c));
5256     }
5257     if (!match && c < 256) {
5258         if (ANYOF_BITMAP_TEST(n, c))
5259             match = TRUE;
5260         else if (flags & ANYOF_FOLD) {
5261             U8 f;
5262
5263             if (flags & ANYOF_LOCALE) {
5264                 PL_reg_flags |= RF_tainted;
5265                 f = PL_fold_locale[c];
5266             }
5267             else
5268                 f = PL_fold[c];
5269             if (f != c && ANYOF_BITMAP_TEST(n, f))
5270                 match = TRUE;
5271         }
5272
5273         if (!match && (flags & ANYOF_CLASS)) {
5274             PL_reg_flags |= RF_tainted;
5275             if (
5276                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
5277                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
5278                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
5279                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
5280                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
5281                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
5282                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
5283                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5284                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
5285                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
5286                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
5287                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
5288                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
5289                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
5290                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
5291                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
5292                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
5293                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
5294                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
5295                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
5296                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
5297                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
5298                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
5299                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
5300                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
5301                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
5302                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
5303                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
5304                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
5305                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
5306                 ) /* How's that for a conditional? */
5307             {
5308                 match = TRUE;
5309             }
5310         }
5311     }
5312
5313     return (flags & ANYOF_INVERT) ? !match : match;
5314 }
5315
5316 STATIC U8 *
5317 S_reghop3(U8 *s, I32 off, const U8* lim)
5318 {
5319     dVAR;
5320     if (off >= 0) {
5321         while (off-- && s < lim) {
5322             /* XXX could check well-formedness here */
5323             s += UTF8SKIP(s);
5324         }
5325     }
5326     else {
5327         while (off++) {
5328             if (s > lim) {
5329                 s--;
5330                 if (UTF8_IS_CONTINUED(*s)) {
5331                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5332                         s--;
5333                 }
5334                 /* XXX could check well-formedness here */
5335             }
5336         }
5337     }
5338     return s;
5339 }
5340
5341 STATIC U8 *
5342 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5343 {
5344     dVAR;
5345     if (off >= 0) {
5346         while (off-- && s < lim) {
5347             /* XXX could check well-formedness here */
5348             s += UTF8SKIP(s);
5349         }
5350         if (off >= 0)
5351             return NULL;
5352     }
5353     else {
5354         while (off++) {
5355             if (s > lim) {
5356                 s--;
5357                 if (UTF8_IS_CONTINUED(*s)) {
5358                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5359                         s--;
5360                 }
5361                 /* XXX could check well-formedness here */
5362             }
5363             else
5364                 break;
5365         }
5366         if (off <= 0)
5367             return NULL;
5368     }
5369     return s;
5370 }
5371
5372 static void
5373 restore_pos(pTHX_ void *arg)
5374 {
5375     dVAR;
5376     regexp * const rex = (regexp *)arg;
5377     if (PL_reg_eval_set) {
5378         if (PL_reg_oldsaved) {
5379             rex->subbeg = PL_reg_oldsaved;
5380             rex->sublen = PL_reg_oldsavedlen;
5381 #ifdef PERL_OLD_COPY_ON_WRITE
5382             rex->saved_copy = PL_nrs;
5383 #endif
5384             RX_MATCH_COPIED_on(rex);
5385         }
5386         PL_reg_magic->mg_len = PL_reg_oldpos;
5387         PL_reg_eval_set = 0;
5388         PL_curpm = PL_reg_oldcurpm;
5389     }
5390 }
5391
5392 STATIC void
5393 S_to_utf8_substr(pTHX_ register regexp *prog)
5394 {
5395     if (prog->float_substr && !prog->float_utf8) {
5396         SV* const sv = newSVsv(prog->float_substr);
5397         prog->float_utf8 = sv;
5398         sv_utf8_upgrade(sv);
5399         if (SvTAIL(prog->float_substr))
5400             SvTAIL_on(sv);
5401         if (prog->float_substr == prog->check_substr)
5402             prog->check_utf8 = sv;
5403     }
5404     if (prog->anchored_substr && !prog->anchored_utf8) {
5405         SV* const sv = newSVsv(prog->anchored_substr);
5406         prog->anchored_utf8 = sv;
5407         sv_utf8_upgrade(sv);
5408         if (SvTAIL(prog->anchored_substr))
5409             SvTAIL_on(sv);
5410         if (prog->anchored_substr == prog->check_substr)
5411             prog->check_utf8 = sv;
5412     }
5413 }
5414
5415 STATIC void
5416 S_to_byte_substr(pTHX_ register regexp *prog)
5417 {
5418     dVAR;
5419     if (prog->float_utf8 && !prog->float_substr) {
5420         SV* sv = newSVsv(prog->float_utf8);
5421         prog->float_substr = sv;
5422         if (sv_utf8_downgrade(sv, TRUE)) {
5423             if (SvTAIL(prog->float_utf8))
5424                 SvTAIL_on(sv);
5425         } else {
5426             SvREFCNT_dec(sv);
5427             prog->float_substr = sv = &PL_sv_undef;
5428         }
5429         if (prog->float_utf8 == prog->check_utf8)
5430             prog->check_substr = sv;
5431     }
5432     if (prog->anchored_utf8 && !prog->anchored_substr) {
5433         SV* sv = newSVsv(prog->anchored_utf8);
5434         prog->anchored_substr = sv;
5435         if (sv_utf8_downgrade(sv, TRUE)) {
5436             if (SvTAIL(prog->anchored_utf8))
5437                 SvTAIL_on(sv);
5438         } else {
5439             SvREFCNT_dec(sv);
5440             prog->anchored_substr = sv = &PL_sv_undef;
5441         }
5442         if (prog->anchored_utf8 == prog->check_utf8)
5443             prog->check_substr = sv;
5444     }
5445 }
5446
5447 /*
5448  * Local variables:
5449  * c-indentation-style: bsd
5450  * c-basic-offset: 4
5451  * indent-tabs-mode: t
5452  * End:
5453  *
5454  * ex: set ts=8 sts=4 sw=4 noet:
5455  */