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