regexec.c

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