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