regexec.c

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