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 sayYES_LOUD  goto yes_loud
2238 #define sayNO_FINAL  goto no_final
2239 #define sayNO_SILENT goto do_no
2240 #define saySAME(x) if (x) goto yes; else goto no
2241
2242 #define POSCACHE_SUCCESS 0      /* caching success rather than failure */
2243 #define POSCACHE_SEEN 1         /* we know what we're caching */
2244 #define POSCACHE_START 2        /* the real cache: this bit maps to pos 0 */
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         else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2250             /* cache records failure, but this is success */ \
2251             DEBUG_r( \
2252                 PerlIO_printf(Perl_debug_log, \
2253                     "%*s  (remove success from failure cache)\n", \
2254                     REPORT_CODE_OFF+PL_regindent*2, "") \
2255             ); \
2256             PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2257         } \
2258     } \
2259     sayYES; \
2260 } STMT_END
2261 #define CACHEsayNO STMT_START { \
2262     if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2263         if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) \
2264             PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2265         else if ((PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2266             /* cache records success, but this is failure */ \
2267             DEBUG_r( \
2268                 PerlIO_printf(Perl_debug_log, \
2269                     "%*s  (remove failure from success cache)\n", \
2270                     REPORT_CODE_OFF+PL_regindent*2, "") \
2271             ); \
2272             PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2273         } \
2274     } \
2275     sayNO; \
2276 } STMT_END
2277
2278 /* this is used to determine how far from the left messages like
2279    'failed...' are printed. Currently 29 makes these messages line
2280    up with the opcode they refer to. Earlier perls used 25 which
2281    left these messages outdented making reviewing a debug output
2282    quite difficult.
2283 */
2284 #define REPORT_CODE_OFF 29
2285
2286
2287 /* Make sure there is a test for this +1 options in re_tests */
2288 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2289
2290 /* grab a new slab and return the first slot in it */
2291
2292 STATIC regmatch_state *
2293 S_push_slab(pTHX)
2294 {
2295     regmatch_slab *s = PL_regmatch_slab->next;
2296     if (!s) {
2297         Newx(s, 1, regmatch_slab);
2298         s->prev = PL_regmatch_slab;
2299         s->next = NULL;
2300         PL_regmatch_slab->next = s;
2301     }
2302     PL_regmatch_slab = s;
2303     return &s->states[0];
2304 }
2305
2306 /* simulate a recursive call to regmatch */
2307
2308 #define REGMATCH(ns, where) \
2309     st->scan = scan; \
2310     scan = (ns); \
2311     st->resume_state = resume_##where; \
2312     goto start_recurse; \
2313     resume_point_##where:
2314
2315
2316 /* push a new regex state. Set newst to point to it */
2317
2318 #define PUSH_STATE(newst, resume) \
2319     depth++;    \
2320     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "PUSH STATE(%d)\n", depth)); \
2321     st->scan = scan;    \
2322     st->next = next;    \
2323     st->n = n;  \
2324     st->locinput = locinput;    \
2325     st->resume_state = resume;  \
2326     newst = st+1;   \
2327     if (newst >  &(PL_regmatch_slab->states[PERL_REGMATCH_SLAB_SLOTS-1])) \
2328         newst = S_push_slab(aTHX);  \
2329     PL_regmatch_state = newst;  \
2330     newst->cc = 0;  \
2331     newst->minmod = 0;  \
2332     newst->sw = 0;  \
2333     newst->logical = 0; \
2334     newst->unwind = 0;  \
2335     locinput = PL_reginput; \
2336     nextchr = UCHARAT(locinput);
2337
2338 #define POP_STATE \
2339     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth)); \
2340     depth--; \
2341     st--; \
2342     if (st < &PL_regmatch_slab->states[0]) { \
2343         PL_regmatch_slab = PL_regmatch_slab->prev; \
2344         st = &PL_regmatch_slab->states[PERL_REGMATCH_SLAB_SLOTS-1]; \
2345     } \
2346     PL_regmatch_state = st; \
2347     scan        = st->scan; \
2348     next        = st->next; \
2349     n           = st->n; \
2350     locinput    = st->locinput; \
2351     nextchr = UCHARAT(locinput);
2352
2353 /*
2354  - regmatch - main matching routine
2355  *
2356  * Conceptually the strategy is simple:  check to see whether the current
2357  * node matches, call self recursively to see whether the rest matches,
2358  * and then act accordingly.  In practice we make some effort to avoid
2359  * recursion, in particular by going through "ordinary" nodes (that don't
2360  * need to know whether the rest of the match failed) by a loop instead of
2361  * by recursion.
2362  */
2363 /* [lwall] I've hoisted the register declarations to the outer block in order to
2364  * maybe save a little bit of pushing and popping on the stack.  It also takes
2365  * advantage of machines that use a register save mask on subroutine entry.
2366  *
2367  * This function used to be heavily recursive, but since this had the
2368  * effect of blowing the CPU stack on complex regexes, it has been
2369  * restructured to be iterative, and to save state onto the heap rather
2370  * than the stack. Essentially whereever regmatch() used to be called, it
2371  * pushes the current state, notes where to return, then jumps back into
2372  * the main loop.
2373  *
2374  * Originally the structure of this function used to look something like
2375
2376     S_regmatch() {
2377         int a = 1, b = 2;
2378         ...
2379         while (scan != NULL) {
2380             a++; // do stuff with a and b
2381             ...
2382             switch (OP(scan)) {
2383                 case FOO: {
2384                     int local = 3;
2385                     ...
2386                     if (regmatch(...))  // recurse
2387                         goto yes;
2388                 }
2389                 ...
2390             }
2391         }
2392         yes:
2393         return 1;
2394     }
2395
2396  * Now it looks something like this:
2397
2398     typedef struct {
2399         int a, b, local;
2400         int resume_state;
2401     } regmatch_state;
2402
2403     S_regmatch() {
2404         regmatch_state *st = new();
2405         int depth=0;
2406         st->a++; // do stuff with a and b
2407         ...
2408         while (scan != NULL) {
2409             ...
2410             switch (OP(scan)) {
2411                 case FOO: {
2412                     st->local = 3;
2413                     ...
2414                     st->scan = scan;
2415                     scan = ...;
2416                     st->resume_state = resume_FOO;
2417                     goto start_recurse; // recurse
2418
2419                     resume_point_FOO:
2420                     if (result)
2421                         goto yes;
2422                 }
2423                 ...
2424             }
2425           start_recurse:
2426             st = new(); push a new state
2427             st->a = 1; st->b = 2;
2428             depth++;
2429         }
2430       yes:
2431         result = 1;
2432         if (depth--) {
2433             st = pop();
2434             switch (resume_state) {
2435             case resume_FOO:
2436                 goto resume_point_FOO;
2437             ...
2438             }
2439         }
2440         return result
2441     }
2442
2443  * WARNING: this means that any line in this function that contains a
2444  * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2445  * regmatch() using gotos instead. Thus the values of any local variables
2446  * not saved in the regmatch_state structure will have been lost when
2447  * execution resumes on the next line .
2448  *
2449  * States (ie the st pointer) are allocated in slabs of about 4K in size.
2450  * PL_regmatch_state always points to the currently active state, and
2451  * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2452  * The first time regmatch is called, the first slab is allocated, and is
2453  * never freed until interpreter desctruction. When the slab is full,
2454  * a new one is allocated chained to the end. At exit from regmatch, slabs
2455  * allocated since entry are freed.
2456  */
2457
2458
2459 STATIC I32                      /* 0 failure, 1 success */
2460 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2461 {
2462     dVAR;
2463     register const bool do_utf8 = PL_reg_match_utf8;
2464     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2465
2466     regexp *rex = reginfo->prog;
2467
2468     regmatch_slab  *orig_slab;
2469     regmatch_state *orig_state;
2470
2471     /* the current state. This is a cached copy of PL_regmatch_state */
2472     register regmatch_state *st;
2473
2474     /* cache heavy used fields of st in registers */
2475     register regnode *scan;
2476     register regnode *next;
2477     register I32 n = 0; /* initialize to shut up compiler warning */
2478     register char *locinput = PL_reginput;
2479
2480     /* these variables are NOT saved during a recusive RFEGMATCH: */
2481     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2482     bool result;            /* return value of S_regmatch */
2483     regnode *inner;         /* Next node in internal branch. */
2484     int depth = 0;          /* depth of recursion */
2485     regmatch_state *newst;  /* when pushing a state, this is the new one */
2486     regmatch_state *cur_eval = NULL;  /* most recent (??{}) state */
2487
2488 #ifdef DEBUGGING
2489     SV *re_debug_flags = NULL;
2490     GET_RE_DEBUG_FLAGS;
2491     PL_regindent++;
2492 #endif
2493
2494     /* on first ever call to regmatch, allocate first slab */
2495     if (!PL_regmatch_slab) {
2496         Newx(PL_regmatch_slab, 1, regmatch_slab);
2497         PL_regmatch_slab->prev = NULL;
2498         PL_regmatch_slab->next = NULL;
2499         PL_regmatch_state = &PL_regmatch_slab->states[0] - 1;
2500     }
2501
2502     /* remember current high-water mark for exit */
2503     /* XXX this should be done with SAVE* instead */
2504     orig_slab  = PL_regmatch_slab;
2505     orig_state = PL_regmatch_state;
2506
2507     /* grab next free state slot */
2508     st = ++PL_regmatch_state;
2509     if (st >  &(PL_regmatch_slab->states[PERL_REGMATCH_SLAB_SLOTS-1]))
2510         st = PL_regmatch_state = S_push_slab(aTHX);
2511
2512     st->minmod = 0;
2513     st->sw = 0;
2514     st->logical = 0;
2515     st->unwind = 0;
2516     st->cc = NULL;
2517     /* Note that nextchr is a byte even in UTF */
2518     nextchr = UCHARAT(locinput);
2519     scan = prog;
2520     while (scan != NULL) {
2521
2522         DEBUG_EXECUTE_r( {
2523             SV * const prop = sv_newmortal();
2524             const int docolor = *PL_colors[0];
2525             const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2526             int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2527             /* The part of the string before starttry has one color
2528                (pref0_len chars), between starttry and current
2529                position another one (pref_len - pref0_len chars),
2530                after the current position the third one.
2531                We assume that pref0_len <= pref_len, otherwise we
2532                decrease pref0_len.  */
2533             int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2534                 ? (5 + taill) - l : locinput - PL_bostr;
2535             int pref0_len;
2536
2537             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2538                 pref_len++;
2539             pref0_len = pref_len  - (locinput - PL_reg_starttry);
2540             if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2541                 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2542                       ? (5 + taill) - pref_len : PL_regeol - locinput);
2543             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2544                 l--;
2545             if (pref0_len < 0)
2546                 pref0_len = 0;
2547             if (pref0_len > pref_len)
2548                 pref0_len = pref_len;
2549             regprop(rex, prop, scan);
2550             {
2551               const char * const s0 =
2552                 do_utf8 && OP(scan) != CANY ?
2553                 pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
2554                                pref0_len, 60, UNI_DISPLAY_REGEX) :
2555                 locinput - pref_len;
2556               const int len0 = do_utf8 ? strlen(s0) : pref0_len;
2557               const char * const s1 = do_utf8 && OP(scan) != CANY ?
2558                 pv_uni_display(PERL_DEBUG_PAD(1),
2559                                (U8*)(locinput - pref_len + pref0_len),
2560                                pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2561                 locinput - pref_len + pref0_len;
2562               const int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
2563               const char * const s2 = do_utf8 && OP(scan) != CANY ?
2564                 pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
2565                                PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2566                 locinput;
2567               const int len2 = do_utf8 ? strlen(s2) : l;
2568               PerlIO_printf(Perl_debug_log,
2569                             "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2570                             (IV)(locinput - PL_bostr),
2571                             PL_colors[4],
2572                             len0, s0,
2573                             PL_colors[5],
2574                             PL_colors[2],
2575                             len1, s1,
2576                             PL_colors[3],
2577                             (docolor ? "" : "> <"),
2578                             PL_colors[0],
2579                             len2, s2,
2580                             PL_colors[1],
2581                             15 - l - pref_len + 1,
2582                             "",
2583                             (IV)(scan - rex->program), PL_regindent*2, "",
2584                             SvPVX_const(prop));
2585             }
2586         });
2587
2588         next = scan + NEXT_OFF(scan);
2589         if (next == scan)
2590             next = NULL;
2591
2592         switch (OP(scan)) {
2593         case BOL:
2594             if (locinput == PL_bostr)
2595             {
2596                 /* reginfo->till = reginfo->bol; */
2597                 break;
2598             }
2599             sayNO;
2600         case MBOL:
2601             if (locinput == PL_bostr ||
2602                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2603             {
2604                 break;
2605             }
2606             sayNO;
2607         case SBOL:
2608             if (locinput == PL_bostr)
2609                 break;
2610             sayNO;
2611         case GPOS:
2612             if (locinput == reginfo->ganch)
2613                 break;
2614             sayNO;
2615         case EOL:
2616                 goto seol;
2617         case MEOL:
2618             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2619                 sayNO;
2620             break;
2621         case SEOL:
2622           seol:
2623             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2624                 sayNO;
2625             if (PL_regeol - locinput > 1)
2626                 sayNO;
2627             break;
2628         case EOS:
2629             if (PL_regeol != locinput)
2630                 sayNO;
2631             break;
2632         case SANY:
2633             if (!nextchr && locinput >= PL_regeol)
2634                 sayNO;
2635             if (do_utf8) {
2636                 locinput += PL_utf8skip[nextchr];
2637                 if (locinput > PL_regeol)
2638                     sayNO;
2639                 nextchr = UCHARAT(locinput);
2640             }
2641             else
2642                 nextchr = UCHARAT(++locinput);
2643             break;
2644         case CANY:
2645             if (!nextchr && locinput >= PL_regeol)
2646                 sayNO;
2647             nextchr = UCHARAT(++locinput);
2648             break;
2649         case REG_ANY:
2650             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2651                 sayNO;
2652             if (do_utf8) {
2653                 locinput += PL_utf8skip[nextchr];
2654                 if (locinput > PL_regeol)
2655                     sayNO;
2656                 nextchr = UCHARAT(locinput);
2657             }
2658             else
2659                 nextchr = UCHARAT(++locinput);
2660             break;
2661
2662
2663
2664         /*
2665            traverse the TRIE keeping track of all accepting states
2666            we transition through until we get to a failing node.
2667
2668
2669         */
2670         case TRIE:
2671         case TRIEF:
2672         case TRIEFL:
2673             {
2674                 U8 *uc = ( U8* )locinput;
2675                 U32 state = 1;
2676                 U16 charid = 0;
2677                 U32 base = 0;
2678                 UV uvc = 0;
2679                 STRLEN len = 0;
2680                 STRLEN foldlen = 0;
2681                 U8 *uscan = (U8*)NULL;
2682                 STRLEN bufflen=0;
2683                 SV *sv_accept_buff = NULL;
2684                 const enum { trie_plain, trie_utf8, trie_uft8_fold }
2685                     trie_type = do_utf8 ?
2686                           (OP(scan) == TRIE ? trie_utf8 : trie_uft8_fold)
2687                         : trie_plain;
2688
2689                 /* what trie are we using right now */
2690                 reg_trie_data *trie
2691                     = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2692                 st->u.trie.accepted = 0; /* how many accepting states we have seen */
2693                 result = 0;
2694
2695                 while ( state && uc <= (U8*)PL_regeol ) {
2696
2697                     if (trie->states[ state ].wordnum) {
2698                         if (!st->u.trie.accepted ) {
2699                             ENTER;
2700                             SAVETMPS;
2701                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2702                             sv_accept_buff=newSV(bufflen *
2703                                             sizeof(reg_trie_accepted) - 1);
2704                             SvCUR_set(sv_accept_buff,
2705                                                 sizeof(reg_trie_accepted));
2706                             SvPOK_on(sv_accept_buff);
2707                             sv_2mortal(sv_accept_buff);
2708                             st->u.trie.accept_buff =
2709                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2710                         }
2711                         else {
2712                             if (st->u.trie.accepted >= bufflen) {
2713                                 bufflen *= 2;
2714                                 st->u.trie.accept_buff =(reg_trie_accepted*)
2715                                     SvGROW(sv_accept_buff,
2716                                         bufflen * sizeof(reg_trie_accepted));
2717                             }
2718                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2719                                 + sizeof(reg_trie_accepted));
2720                         }
2721                         st->u.trie.accept_buff[st->u.trie.accepted].wordnum = trie->states[state].wordnum;
2722                         st->u.trie.accept_buff[st->u.trie.accepted].endpos = uc;
2723                         ++st->u.trie.accepted;
2724                     }
2725
2726                     base = trie->states[ state ].trans.base;
2727
2728                     DEBUG_TRIE_EXECUTE_r(
2729                                 PerlIO_printf( Perl_debug_log,
2730                                     "%*s  %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2731                                     REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2732                                     (UV)state, (UV)base, (UV)st->u.trie.accepted );
2733                     );
2734
2735                     if ( base ) {
2736                         switch (trie_type) {
2737                         case trie_uft8_fold:
2738                             if ( foldlen>0 ) {
2739                                 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2740                                 foldlen -= len;
2741                                 uscan += len;
2742                                 len=0;
2743                             } else {
2744                                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2745                                 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2746                                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2747                                 foldlen -= UNISKIP( uvc );
2748                                 uscan = foldbuf + UNISKIP( uvc );
2749                             }
2750                             break;
2751                         case trie_utf8:
2752                             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
2753                                                             &len, uniflags );
2754                             break;
2755                         case trie_plain:
2756                             uvc = (UV)*uc;
2757                             len = 1;
2758                         }
2759
2760                         if (uvc < 256) {
2761                             charid = trie->charmap[ uvc ];
2762                         }
2763                         else {
2764                             charid = 0;
2765                             if (trie->widecharmap) {
2766                                 SV** svpp = (SV**)NULL;
2767                                 svpp = hv_fetch(trie->widecharmap,
2768                                             (char*)&uvc, sizeof(UV), 0);
2769                                 if (svpp)
2770                                     charid = (U16)SvIV(*svpp);
2771                             }
2772                         }
2773
2774                         if (charid &&
2775                              (base + charid > trie->uniquecharcount )
2776                              && (base + charid - 1 - trie->uniquecharcount
2777                                     < trie->lasttrans)
2778                              && trie->trans[base + charid - 1 -
2779                                     trie->uniquecharcount].check == state)
2780                         {
2781                             state = trie->trans[base + charid - 1 -
2782                                 trie->uniquecharcount ].next;
2783                         }
2784                         else {
2785                             state = 0;
2786                         }
2787                         uc += len;
2788
2789                     }
2790                     else {
2791                         state = 0;
2792                     }
2793                     DEBUG_TRIE_EXECUTE_r(
2794                         PerlIO_printf( Perl_debug_log,
2795                             "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
2796                             charid, uvc, (UV)state, PL_colors[5] );
2797                     );
2798                 }
2799                 if (!st->u.trie.accepted )
2800                    sayNO;
2801
2802             /*
2803                There was at least one accepting state that we
2804                transitioned through. Presumably the number of accepting
2805                states is going to be low, typically one or two. So we
2806                simply scan through to find the one with lowest wordnum.
2807                Once we find it, we swap the last state into its place
2808                and decrement the size. We then try to match the rest of
2809                the pattern at the point where the word ends, if we
2810                succeed then we end the loop, otherwise the loop
2811                eventually terminates once all of the accepting states
2812                have been tried.
2813             */
2814
2815                 if ( st->u.trie.accepted == 1 ) {
2816                     DEBUG_EXECUTE_r({
2817                         SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ 0 ].wordnum-1, 0 );
2818                         PerlIO_printf( Perl_debug_log,
2819                             "%*s  %sonly one match : #%d <%s>%s\n",
2820                             REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2821                             st->u.trie.accept_buff[ 0 ].wordnum,
2822                             tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2823                             PL_colors[5] );
2824                     });
2825                     PL_reginput = (char *)st->u.trie.accept_buff[ 0 ].endpos;
2826                     /* in this case we free tmps/leave before we call regmatch
2827                        as we wont be using accept_buff again. */
2828                     FREETMPS;
2829                     LEAVE;
2830                     REGMATCH(scan + NEXT_OFF(scan), TRIE1);
2831                     /*** all unsaved local vars undefined at this point */
2832                 } else {
2833                     DEBUG_EXECUTE_r(
2834                         PerlIO_printf( Perl_debug_log,"%*s  %sgot %"IVdf" possible matches%s\n",
2835                             REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], (IV)st->u.trie.accepted,
2836                             PL_colors[5] );
2837                     );
2838                     while ( !result && st->u.trie.accepted-- ) {
2839                         U32 best = 0;
2840                         U32 cur;
2841                         for( cur = 1 ; cur <= st->u.trie.accepted ; cur++ ) {
2842                             DEBUG_TRIE_EXECUTE_r(
2843                                 PerlIO_printf( Perl_debug_log,
2844                                     "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
2845                                     REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2846                                     (IV)best, st->u.trie.accept_buff[ best ].wordnum, (IV)cur,
2847                                     st->u.trie.accept_buff[ cur ].wordnum, PL_colors[5] );
2848                             );
2849
2850                             if (st->u.trie.accept_buff[cur].wordnum <
2851                                     st->u.trie.accept_buff[best].wordnum)
2852                                 best = cur;
2853                         }
2854                         DEBUG_EXECUTE_r({
2855                             reg_trie_data * const trie = (reg_trie_data*)
2856                                             rex->data->data[ARG(scan)];
2857                             SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ best ].wordnum - 1, 0 );
2858                             PerlIO_printf( Perl_debug_log, "%*s  %strying alternation #%d <%s> at 0x%p%s\n",
2859                                 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2860                                 st->u.trie.accept_buff[best].wordnum,
2861                                 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",scan,
2862                                 PL_colors[5] );
2863                         });
2864                         if ( best<st->u.trie.accepted ) {
2865                             reg_trie_accepted tmp = st->u.trie.accept_buff[ best ];
2866                             st->u.trie.accept_buff[ best ] = st->u.trie.accept_buff[ st->u.trie.accepted ];
2867                             st->u.trie.accept_buff[ st->u.trie.accepted ] = tmp;
2868                             best = st->u.trie.accepted;
2869                         }
2870                         PL_reginput = (char *)st->u.trie.accept_buff[ best ].endpos;
2871
2872                         /*
2873                            as far as I can tell we only need the SAVETMPS/FREETMPS
2874                            for re's with EVAL in them but I'm leaving them in for
2875                            all until I can be sure.
2876                          */
2877                         SAVETMPS;
2878                         REGMATCH(scan + NEXT_OFF(scan), TRIE2);
2879                         /*** all unsaved local vars undefined at this point */
2880                         FREETMPS;
2881                     }
2882                     FREETMPS;
2883                     LEAVE;
2884                 }
2885
2886                 if (result) {
2887                     sayYES;
2888                 } else {
2889                     sayNO;
2890                 }
2891             }
2892             /* unreached codepoint */
2893         case EXACT: {
2894             char *s = STRING(scan);
2895             st->ln = STR_LEN(scan);
2896             if (do_utf8 != UTF) {
2897                 /* The target and the pattern have differing utf8ness. */
2898                 char *l = locinput;
2899                 const char *e = s + st->ln;
2900
2901                 if (do_utf8) {
2902                     /* The target is utf8, the pattern is not utf8. */
2903                     while (s < e) {
2904                         STRLEN ulen;
2905                         if (l >= PL_regeol)
2906                              sayNO;
2907                         if (NATIVE_TO_UNI(*(U8*)s) !=
2908                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
2909                                             uniflags))
2910                              sayNO;
2911                         l += ulen;
2912                         s ++;
2913                     }
2914                 }
2915                 else {
2916                     /* The target is not utf8, the pattern is utf8. */
2917                     while (s < e) {
2918                         STRLEN ulen;
2919                         if (l >= PL_regeol)
2920                             sayNO;
2921                         if (NATIVE_TO_UNI(*((U8*)l)) !=
2922                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
2923                                            uniflags))
2924                             sayNO;
2925                         s += ulen;
2926                         l ++;
2927                     }
2928                 }
2929                 locinput = l;
2930                 nextchr = UCHARAT(locinput);
2931                 break;
2932             }
2933             /* The target and the pattern have the same utf8ness. */
2934             /* Inline the first character, for speed. */
2935             if (UCHARAT(s) != nextchr)
2936                 sayNO;
2937             if (PL_regeol - locinput < st->ln)
2938                 sayNO;
2939             if (st->ln > 1 && memNE(s, locinput, st->ln))
2940                 sayNO;
2941             locinput += st->ln;
2942             nextchr = UCHARAT(locinput);
2943             break;
2944             }
2945         case EXACTFL:
2946             PL_reg_flags |= RF_tainted;
2947             /* FALL THROUGH */
2948         case EXACTF: {
2949             char *s = STRING(scan);
2950             st->ln = STR_LEN(scan);
2951
2952             if (do_utf8 || UTF) {
2953               /* Either target or the pattern are utf8. */
2954                 char *l = locinput;
2955                 char *e = PL_regeol;
2956
2957                 if (ibcmp_utf8(s, 0,  st->ln, (bool)UTF,
2958                                l, &e, 0,  do_utf8)) {
2959                      /* One more case for the sharp s:
2960                       * pack("U0U*", 0xDF) =~ /ss/i,
2961                       * the 0xC3 0x9F are the UTF-8
2962                       * byte sequence for the U+00DF. */
2963                      if (!(do_utf8 &&
2964                            toLOWER(s[0]) == 's' &&
2965                            st->ln >= 2 &&
2966                            toLOWER(s[1]) == 's' &&
2967                            (U8)l[0] == 0xC3 &&
2968                            e - l >= 2 &&
2969                            (U8)l[1] == 0x9F))
2970                           sayNO;
2971                 }
2972                 locinput = e;
2973                 nextchr = UCHARAT(locinput);
2974                 break;
2975             }
2976
2977             /* Neither the target and the pattern are utf8. */
2978
2979             /* Inline the first character, for speed. */
2980             if (UCHARAT(s) != nextchr &&
2981                 UCHARAT(s) != ((OP(scan) == EXACTF)
2982                                ? PL_fold : PL_fold_locale)[nextchr])
2983                 sayNO;
2984             if (PL_regeol - locinput < st->ln)
2985                 sayNO;
2986             if (st->ln > 1 && (OP(scan) == EXACTF
2987                            ? ibcmp(s, locinput, st->ln)
2988                            : ibcmp_locale(s, locinput, st->ln)))
2989                 sayNO;
2990             locinput += st->ln;
2991             nextchr = UCHARAT(locinput);
2992             break;
2993             }
2994         case ANYOF:
2995             if (do_utf8) {
2996                 STRLEN inclasslen = PL_regeol - locinput;
2997
2998                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
2999                     sayNO_ANYOF;
3000                 if (locinput >= PL_regeol)
3001                     sayNO;
3002                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3003                 nextchr = UCHARAT(locinput);
3004                 break;
3005             }
3006             else {
3007                 if (nextchr < 0)
3008                     nextchr = UCHARAT(locinput);
3009                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3010                     sayNO_ANYOF;
3011                 if (!nextchr && locinput >= PL_regeol)
3012                     sayNO;
3013                 nextchr = UCHARAT(++locinput);
3014                 break;
3015             }
3016         no_anyof:
3017             /* If we might have the case of the German sharp s
3018              * in a casefolding Unicode character class. */
3019
3020             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3021                  locinput += SHARP_S_SKIP;
3022                  nextchr = UCHARAT(locinput);
3023             }
3024             else
3025                  sayNO;
3026             break;
3027         case ALNUML:
3028             PL_reg_flags |= RF_tainted;
3029             /* FALL THROUGH */
3030         case ALNUM:
3031             if (!nextchr)
3032                 sayNO;
3033             if (do_utf8) {
3034                 LOAD_UTF8_CHARCLASS_ALNUM();
3035                 if (!(OP(scan) == ALNUM
3036                       ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3037                       : isALNUM_LC_utf8((U8*)locinput)))
3038                 {
3039                     sayNO;
3040                 }
3041                 locinput += PL_utf8skip[nextchr];
3042                 nextchr = UCHARAT(locinput);
3043                 break;
3044             }
3045             if (!(OP(scan) == ALNUM
3046                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3047                 sayNO;
3048             nextchr = UCHARAT(++locinput);
3049             break;
3050         case NALNUML:
3051             PL_reg_flags |= RF_tainted;
3052             /* FALL THROUGH */
3053         case NALNUM:
3054             if (!nextchr && locinput >= PL_regeol)
3055                 sayNO;
3056             if (do_utf8) {
3057                 LOAD_UTF8_CHARCLASS_ALNUM();
3058                 if (OP(scan) == NALNUM
3059                     ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3060                     : isALNUM_LC_utf8((U8*)locinput))
3061                 {
3062                     sayNO;
3063                 }
3064                 locinput += PL_utf8skip[nextchr];
3065                 nextchr = UCHARAT(locinput);
3066                 break;
3067             }
3068             if (OP(scan) == NALNUM
3069                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3070                 sayNO;
3071             nextchr = UCHARAT(++locinput);
3072             break;
3073         case BOUNDL:
3074         case NBOUNDL:
3075             PL_reg_flags |= RF_tainted;
3076             /* FALL THROUGH */
3077         case BOUND:
3078         case NBOUND:
3079             /* was last char in word? */
3080             if (do_utf8) {
3081                 if (locinput == PL_bostr)
3082                     st->ln = '\n';
3083                 else {
3084                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3085
3086                     st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3087                 }
3088                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3089                     st->ln = isALNUM_uni(st->ln);
3090                     LOAD_UTF8_CHARCLASS_ALNUM();
3091                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3092                 }
3093                 else {
3094                     st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3095                     n = isALNUM_LC_utf8((U8*)locinput);
3096                 }
3097             }
3098             else {
3099                 st->ln = (locinput != PL_bostr) ?
3100                     UCHARAT(locinput - 1) : '\n';
3101                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3102                     st->ln = isALNUM(st->ln);
3103                     n = isALNUM(nextchr);
3104                 }
3105                 else {
3106                     st->ln = isALNUM_LC(st->ln);
3107                     n = isALNUM_LC(nextchr);
3108                 }
3109             }
3110             if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3111                                     OP(scan) == BOUNDL))
3112                     sayNO;
3113             break;
3114         case SPACEL:
3115             PL_reg_flags |= RF_tainted;
3116             /* FALL THROUGH */
3117         case SPACE:
3118             if (!nextchr)
3119                 sayNO;
3120             if (do_utf8) {
3121                 if (UTF8_IS_CONTINUED(nextchr)) {
3122                     LOAD_UTF8_CHARCLASS_SPACE();
3123                     if (!(OP(scan) == SPACE
3124                           ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3125                           : isSPACE_LC_utf8((U8*)locinput)))
3126                     {
3127                         sayNO;
3128                     }
3129                     locinput += PL_utf8skip[nextchr];
3130                     nextchr = UCHARAT(locinput);
3131                     break;
3132                 }
3133                 if (!(OP(scan) == SPACE
3134                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3135                     sayNO;
3136                 nextchr = UCHARAT(++locinput);
3137             }
3138             else {
3139                 if (!(OP(scan) == SPACE
3140                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3141                     sayNO;
3142                 nextchr = UCHARAT(++locinput);
3143             }
3144             break;
3145         case NSPACEL:
3146             PL_reg_flags |= RF_tainted;
3147             /* FALL THROUGH */
3148         case NSPACE:
3149             if (!nextchr && locinput >= PL_regeol)
3150                 sayNO;
3151             if (do_utf8) {
3152                 LOAD_UTF8_CHARCLASS_SPACE();
3153                 if (OP(scan) == NSPACE
3154                     ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3155                     : isSPACE_LC_utf8((U8*)locinput))
3156                 {
3157                     sayNO;
3158                 }
3159                 locinput += PL_utf8skip[nextchr];
3160                 nextchr = UCHARAT(locinput);
3161                 break;
3162             }
3163             if (OP(scan) == NSPACE
3164                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3165                 sayNO;
3166             nextchr = UCHARAT(++locinput);
3167             break;
3168         case DIGITL:
3169             PL_reg_flags |= RF_tainted;
3170             /* FALL THROUGH */
3171         case DIGIT:
3172             if (!nextchr)
3173                 sayNO;
3174             if (do_utf8) {
3175                 LOAD_UTF8_CHARCLASS_DIGIT();
3176                 if (!(OP(scan) == DIGIT
3177                       ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3178                       : isDIGIT_LC_utf8((U8*)locinput)))
3179                 {
3180                     sayNO;
3181                 }
3182                 locinput += PL_utf8skip[nextchr];
3183                 nextchr = UCHARAT(locinput);
3184                 break;
3185             }
3186             if (!(OP(scan) == DIGIT
3187                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3188                 sayNO;
3189             nextchr = UCHARAT(++locinput);
3190             break;
3191         case NDIGITL:
3192             PL_reg_flags |= RF_tainted;
3193             /* FALL THROUGH */
3194         case NDIGIT:
3195             if (!nextchr && locinput >= PL_regeol)
3196                 sayNO;
3197             if (do_utf8) {
3198                 LOAD_UTF8_CHARCLASS_DIGIT();
3199                 if (OP(scan) == NDIGIT
3200                     ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3201                     : isDIGIT_LC_utf8((U8*)locinput))
3202                 {
3203                     sayNO;
3204                 }
3205                 locinput += PL_utf8skip[nextchr];
3206                 nextchr = UCHARAT(locinput);
3207                 break;
3208             }
3209             if (OP(scan) == NDIGIT
3210                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3211                 sayNO;
3212             nextchr = UCHARAT(++locinput);
3213             break;
3214         case CLUMP:
3215             if (locinput >= PL_regeol)
3216                 sayNO;
3217             if  (do_utf8) {
3218                 LOAD_UTF8_CHARCLASS_MARK();
3219                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3220                     sayNO;
3221                 locinput += PL_utf8skip[nextchr];
3222                 while (locinput < PL_regeol &&
3223                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3224                     locinput += UTF8SKIP(locinput);
3225                 if (locinput > PL_regeol)
3226                     sayNO;
3227             }
3228             else
3229                locinput++;
3230             nextchr = UCHARAT(locinput);
3231             break;
3232         case REFFL:
3233             PL_reg_flags |= RF_tainted;
3234             /* FALL THROUGH */
3235         case REF:
3236         case REFF: {
3237             char *s;
3238             n = ARG(scan);  /* which paren pair */
3239             st->ln = PL_regstartp[n];
3240             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3241             if ((I32)*PL_reglastparen < n || st->ln == -1)
3242                 sayNO;                  /* Do not match unless seen CLOSEn. */
3243             if (st->ln == PL_regendp[n])
3244                 break;
3245
3246             s = PL_bostr + st->ln;
3247             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
3248                 char *l = locinput;
3249                 const char *e = PL_bostr + PL_regendp[n];
3250                 /*
3251                  * Note that we can't do the "other character" lookup trick as
3252                  * in the 8-bit case (no pun intended) because in Unicode we
3253                  * have to map both upper and title case to lower case.
3254                  */
3255                 if (OP(scan) == REFF) {
3256                     while (s < e) {
3257                         STRLEN ulen1, ulen2;
3258                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3259                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3260
3261                         if (l >= PL_regeol)
3262                             sayNO;
3263                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3264                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3265                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3266                             sayNO;
3267                         s += ulen1;
3268                         l += ulen2;
3269                     }
3270                 }
3271                 locinput = l;
3272                 nextchr = UCHARAT(locinput);
3273                 break;
3274             }
3275
3276             /* Inline the first character, for speed. */
3277             if (UCHARAT(s) != nextchr &&
3278                 (OP(scan) == REF ||
3279                  (UCHARAT(s) != ((OP(scan) == REFF
3280                                   ? PL_fold : PL_fold_locale)[nextchr]))))
3281                 sayNO;
3282             st->ln = PL_regendp[n] - st->ln;
3283             if (locinput + st->ln > PL_regeol)
3284                 sayNO;
3285             if (st->ln > 1 && (OP(scan) == REF
3286                            ? memNE(s, locinput, st->ln)
3287                            : (OP(scan) == REFF
3288                               ? ibcmp(s, locinput, st->ln)
3289                               : ibcmp_locale(s, locinput, st->ln))))
3290                 sayNO;
3291             locinput += st->ln;
3292             nextchr = UCHARAT(locinput);
3293             break;
3294             }
3295
3296         case NOTHING:
3297         case TAIL:
3298             break;
3299         case BACK:
3300             break;
3301         case EVAL:
3302         {
3303             SV *ret;
3304             {
3305                 /* execute the code in the {...} */
3306                 dSP;
3307                 SV ** const before = SP;
3308                 OP_4tree * const oop = PL_op;
3309                 COP * const ocurcop = PL_curcop;
3310                 PAD *old_comppad;
3311
3312                 n = ARG(scan);
3313                 PL_op = (OP_4tree*)rex->data->data[n];
3314                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3315                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3316                 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3317
3318                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3319                 SPAGAIN;
3320                 if (SP == before)
3321                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3322                 else {
3323                     ret = POPs;
3324                     PUTBACK;
3325                 }
3326
3327                 PL_op = oop;
3328                 PAD_RESTORE_LOCAL(old_comppad);
3329                 PL_curcop = ocurcop;
3330                 if (!st->logical) {
3331                     /* /(?{...})/ */
3332                     sv_setsv(save_scalar(PL_replgv), ret);
3333                     break;
3334                 }
3335             }
3336             if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3337                 regexp *re;
3338                 {
3339                     /* extract RE object from returned value; compiling if
3340                      * necessary */
3341
3342                     MAGIC *mg = NULL;
3343                     SV *sv;
3344                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3345                         mg = mg_find(sv, PERL_MAGIC_qr);
3346                     else if (SvSMAGICAL(ret)) {
3347                         if (SvGMAGICAL(ret))
3348                             sv_unmagic(ret, PERL_MAGIC_qr);
3349                         else
3350                             mg = mg_find(ret, PERL_MAGIC_qr);
3351                     }
3352
3353                     if (mg) {
3354                         re = (regexp *)mg->mg_obj;
3355                         (void)ReREFCNT_inc(re);
3356                     }
3357                     else {
3358                         STRLEN len;
3359                         const char * const t = SvPV_const(ret, len);
3360                         PMOP pm;
3361                         const I32 osize = PL_regsize;
3362
3363                         Zero(&pm, 1, PMOP);
3364                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3365                         re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3366                         if (!(SvFLAGS(ret)
3367                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3368                                 | SVs_GMG)))
3369                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3370                                         PERL_MAGIC_qr,0,0);
3371                         PL_regsize = osize;
3372                     }
3373                 }
3374
3375                 /* run the pattern returned from (??{...}) */
3376
3377                 DEBUG_EXECUTE_r(
3378                     PerlIO_printf(Perl_debug_log,
3379                                   "Entering embedded \"%s%.60s%s%s\"\n",
3380                                   PL_colors[0],
3381                                   re->precomp,
3382                                   PL_colors[1],
3383                                   (strlen(re->precomp) > 60 ? "..." : ""))
3384                     );
3385
3386                 st->u.eval.cp = regcppush(0);   /* Save *all* the positions. */
3387                 REGCP_SET(st->u.eval.lastcp);
3388                 *PL_reglastparen = 0;
3389                 *PL_reglastcloseparen = 0;
3390                 PL_reginput = locinput;
3391
3392                 /* XXXX This is too dramatic a measure... */
3393                 PL_reg_maxiter = 0;
3394
3395                 st->logical = 0;
3396                 st->u.eval.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3397                             ((re->reganch & ROPT_UTF8) != 0);
3398                 if (st->u.eval.toggleutf) PL_reg_flags ^= RF_utf8;
3399                 st->u.eval.prev_rex = rex;
3400                 rex = re;
3401
3402                 st->u.eval.prev_eval = cur_eval;
3403                 st->u.eval.prev_slab = PL_regmatch_slab;
3404                 st->u.eval.depth = depth;
3405                 cur_eval = st;
3406                 PUSH_STATE(newst, resume_EVAL);
3407                 st = newst;
3408
3409                 /* now continue  from first node in postoned RE */
3410                 next = re->program + 1;
3411                 break;
3412                 /* NOTREACHED */
3413             }
3414             /* /(?(?{...})X|Y)/ */
3415             st->sw = SvTRUE(ret);
3416             st->logical = 0;
3417             break;
3418         }
3419         case OPEN:
3420             n = ARG(scan);  /* which paren pair */
3421             PL_reg_start_tmp[n] = locinput;
3422             if (n > PL_regsize)
3423                 PL_regsize = n;
3424             break;
3425         case CLOSE:
3426             n = ARG(scan);  /* which paren pair */
3427             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3428             PL_regendp[n] = locinput - PL_bostr;
3429             if (n > (I32)*PL_reglastparen)
3430                 *PL_reglastparen = n;
3431             *PL_reglastcloseparen = n;
3432             break;
3433         case GROUPP:
3434             n = ARG(scan);  /* which paren pair */
3435             st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3436             break;
3437         case IFTHEN:
3438             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3439             if (st->sw)
3440                 next = NEXTOPER(NEXTOPER(scan));
3441             else {
3442                 next = scan + ARG(scan);
3443                 if (OP(next) == IFTHEN) /* Fake one. */
3444                     next = NEXTOPER(NEXTOPER(next));
3445             }
3446             break;
3447         case LOGICAL:
3448             st->logical = scan->flags;
3449             break;
3450 /*******************************************************************
3451  cc points to the regmatch_state associated with the most recent CURLYX.
3452  This struct contains info about the innermost (...)* loop (an
3453  "infoblock"), and a pointer to the next outer cc.
3454
3455  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3456
3457    1) After matching Y, regnode for CURLYX is processed;
3458
3459    2) This regnode populates cc, and calls regmatch() recursively
3460       with the starting point at WHILEM node;
3461
3462    3) Each hit of WHILEM node tries to match A and Z (in the order
3463       depending on the current iteration, min/max of {min,max} and
3464       greediness).  The information about where are nodes for "A"
3465       and "Z" is read from cc, as is info on how many times "A"
3466       was already matched, and greediness.
3467
3468    4) After A matches, the same WHILEM node is hit again.
3469
3470    5) Each time WHILEM is hit, cc is the infoblock created by CURLYX
3471       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
3472       resets cc, since this Y(A)*Z can be a part of some other loop:
3473       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
3474       of the external loop.
3475
3476  Currently present infoblocks form a tree with a stem formed by st->cc
3477  and whatever it mentions via ->next, and additional attached trees
3478  corresponding to temporarily unset infoblocks as in "5" above.
3479
3480  In the following picture, infoblocks for outer loop of
3481  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
3482  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
3483  infoblocks are drawn below the "reset" infoblock.
3484
3485  In fact in the picture below we do not show failed matches for Z and T
3486  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
3487  more obvious *why* one needs to *temporary* unset infoblocks.]
3488
3489   Matched       REx position    InfoBlocks      Comment
3490                 (Y(A)*?Z)*?T    x
3491                 Y(A)*?Z)*?T     x <- O
3492   Y             (A)*?Z)*?T      x <- O
3493   Y             A)*?Z)*?T       x <- O <- I
3494   YA            )*?Z)*?T        x <- O <- I
3495   YA            A)*?Z)*?T       x <- O <- I
3496   YAA           )*?Z)*?T        x <- O <- I
3497   YAA           Z)*?T           x <- O          # Temporary unset I
3498                                      I
3499
3500   YAAZ          Y(A)*?Z)*?T     x <- O
3501                                      I
3502
3503   YAAZY         (A)*?Z)*?T      x <- O
3504                                      I
3505
3506   YAAZY         A)*?Z)*?T       x <- O <- I
3507                                      I
3508
3509   YAAZYA        )*?Z)*?T        x <- O <- I
3510                                      I
3511
3512   YAAZYA        Z)*?T           x <- O          # Temporary unset I
3513                                      I,I
3514
3515   YAAZYAZ       )*?T            x <- O
3516                                      I,I
3517
3518   YAAZYAZ       T               x               # Temporary unset O
3519                                 O
3520                                 I,I
3521
3522   YAAZYAZT                      x
3523                                 O
3524                                 I,I
3525  *******************************************************************/
3526
3527         case CURLYX: {
3528                 /* No need to save/restore up to this paren */
3529                 I32 parenfloor = scan->flags;
3530
3531                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3532                     next += ARG(next);
3533                 /* XXXX Probably it is better to teach regpush to support
3534                    parenfloor > PL_regsize... */
3535                 if (parenfloor > (I32)*PL_reglastparen)
3536                     parenfloor = *PL_reglastparen; /* Pessimization... */
3537
3538                 st->u.curlyx.cp = PL_savestack_ix;
3539                 st->u.curlyx.outercc = st->cc;
3540                 st->cc = st;
3541                 /* these fields contain the state of the current curly.
3542                  * they are accessed by subsequent WHILEMs;
3543                  * cur and lastloc are also updated by WHILEM */
3544                 st->u.curlyx.parenfloor = parenfloor;
3545                 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3546                 st->u.curlyx.min = ARG1(scan);
3547                 st->u.curlyx.max  = ARG2(scan);
3548                 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3549                 st->u.curlyx.lastloc = 0;
3550                 /* st->next and st->minmod are also read by WHILEM */
3551
3552                 PL_reginput = locinput;
3553                 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3554                 /*** all unsaved local vars undefined at this point */
3555                 regcpblow(st->u.curlyx.cp);
3556                 st->cc = st->u.curlyx.outercc;
3557                 saySAME(result);
3558             }
3559             /* NOTREACHED */
3560         case WHILEM: {
3561                 /*
3562                  * This is really hard to understand, because after we match
3563                  * what we're trying to match, we must make sure the rest of
3564                  * the REx is going to match for sure, and to do that we have
3565                  * to go back UP the parse tree by recursing ever deeper.  And
3566                  * if it fails, we have to reset our parent's current state
3567                  * that we can try again after backing off.
3568                  */
3569
3570                 st->u.whilem.lastloc = st->cc->u.curlyx.lastloc; /* Detection of 0-len. */
3571                 st->u.whilem.cache_offset = 0;
3572                 st->u.whilem.cache_bit = 0;
3573
3574                 n = st->cc->u.curlyx.cur + 1; /* how many we know we matched */
3575                 PL_reginput = locinput;
3576
3577                 DEBUG_EXECUTE_r(
3578                     PerlIO_printf(Perl_debug_log,
3579                                   "%*s  %ld out of %ld..%ld  cc=%"UVxf"\n",
3580                                   REPORT_CODE_OFF+PL_regindent*2, "",
3581                                   (long)n, (long)st->cc->u.curlyx.min,
3582                                   (long)st->cc->u.curlyx.max, PTR2UV(st->cc))
3583                     );
3584
3585                 /* If degenerate scan matches "", assume scan done. */
3586
3587                 if (locinput == st->cc->u.curlyx.lastloc && n >= st->cc->u.curlyx.min) {
3588                     st->u.whilem.savecc = st->cc;
3589                     st->cc = st->cc->u.curlyx.outercc;
3590                     if (st->cc)
3591                         st->ln = st->cc->u.curlyx.cur;
3592                     DEBUG_EXECUTE_r(
3593                         PerlIO_printf(Perl_debug_log,
3594                            "%*s  empty match detected, try continuation...\n",
3595                            REPORT_CODE_OFF+PL_regindent*2, "")
3596                         );
3597                     REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3598                     /*** all unsaved local vars undefined at this point */
3599                     st->cc = st->u.whilem.savecc;
3600                     if (result)
3601                         sayYES;
3602                     if (st->cc->u.curlyx.outercc)
3603                         st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3604                     sayNO;
3605                 }
3606
3607                 /* First just match a string of min scans. */
3608
3609                 if (n < st->cc->u.curlyx.min) {
3610                     st->cc->u.curlyx.cur = n;
3611                     st->cc->u.curlyx.lastloc = locinput;
3612                     REGMATCH(st->cc->u.curlyx.scan, WHILEM2);
3613                     /*** all unsaved local vars undefined at this point */
3614                     if (result)
3615                         sayYES;
3616                     st->cc->u.curlyx.cur = n - 1;
3617                     st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3618                     sayNO;
3619                 }
3620
3621                 if (scan->flags) {
3622                     /* Check whether we already were at this position.
3623                         Postpone detection until we know the match is not
3624                         *that* much linear. */
3625                 if (!PL_reg_maxiter) {
3626                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3627                     PL_reg_leftiter = PL_reg_maxiter;
3628                 }
3629                 if (PL_reg_leftiter-- == 0) {
3630                     const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8;
3631                     if (PL_reg_poscache) {
3632                         if ((I32)PL_reg_poscache_size < size) {
3633                             Renew(PL_reg_poscache, size, char);
3634                             PL_reg_poscache_size = size;
3635                         }
3636                         Zero(PL_reg_poscache, size, char);
3637                     }
3638                     else {
3639                         PL_reg_poscache_size = size;
3640                         Newxz(PL_reg_poscache, size, char);
3641                     }
3642                     DEBUG_EXECUTE_r(
3643                         PerlIO_printf(Perl_debug_log,
3644               "%sDetected a super-linear match, switching on caching%s...\n",
3645                                       PL_colors[4], PL_colors[5])
3646                         );
3647                 }
3648                 if (PL_reg_leftiter < 0) {
3649                     st->u.whilem.cache_offset = locinput - PL_bostr;
3650
3651                     st->u.whilem.cache_offset = (scan->flags & 0xf) - 1 + POSCACHE_START
3652                             + st->u.whilem.cache_offset * (scan->flags>>4);
3653                     st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
3654                     st->u.whilem.cache_offset /= 8;
3655                     if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
3656                     DEBUG_EXECUTE_r(
3657                         PerlIO_printf(Perl_debug_log,
3658                                       "%*s  already tried at this position...\n",
3659                                       REPORT_CODE_OFF+PL_regindent*2, "")
3660                         );
3661                         if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))
3662                             /* cache records success */
3663                             sayYES;
3664                         else
3665                             /* cache records failure */
3666                             sayNO_SILENT;
3667                     }
3668                     PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit);
3669                 }
3670                 }
3671
3672                 /* Prefer next over scan for minimal matching. */
3673
3674                 if (st->cc->minmod) {
3675                     st->u.whilem.savecc = st->cc;
3676                     st->cc = st->cc->u.curlyx.outercc;
3677                     if (st->cc)
3678                         st->ln = st->cc->u.curlyx.cur;
3679                     st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
3680                     REGCP_SET(st->u.whilem.lastcp);
3681                     REGMATCH(st->u.whilem.savecc->next, WHILEM3);
3682                     /*** all unsaved local vars undefined at this point */
3683                     st->cc = st->u.whilem.savecc;
3684                     if (result) {
3685                         regcpblow(st->u.whilem.cp);
3686                         CACHEsayYES;    /* All done. */
3687                     }
3688                     REGCP_UNWIND(st->u.whilem.lastcp);
3689                     regcppop(rex);
3690                     if (st->cc->u.curlyx.outercc)
3691                         st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3692
3693                     if (n >= st->cc->u.curlyx.max) { /* Maximum greed exceeded? */
3694                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3695                             && !(PL_reg_flags & RF_warned)) {
3696                             PL_reg_flags |= RF_warned;
3697                             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3698                                  "Complex regular subexpression recursion",
3699                                  REG_INFTY - 1);
3700                         }
3701                         CACHEsayNO;
3702                     }
3703
3704                     DEBUG_EXECUTE_r(
3705                         PerlIO_printf(Perl_debug_log,
3706                                       "%*s  trying longer...\n",
3707                                       REPORT_CODE_OFF+PL_regindent*2, "")
3708                         );
3709                     /* Try scanning more and see if it helps. */
3710                     PL_reginput = locinput;
3711                     st->cc->u.curlyx.cur = n;
3712                     st->cc->u.curlyx.lastloc = locinput;
3713                     st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3714                     REGCP_SET(st->u.whilem.lastcp);
3715                     REGMATCH(st->cc->u.curlyx.scan, WHILEM4);
3716                     /*** all unsaved local vars undefined at this point */
3717                     if (result) {
3718                         regcpblow(st->u.whilem.cp);
3719                         CACHEsayYES;
3720                     }
3721                     REGCP_UNWIND(st->u.whilem.lastcp);
3722                     regcppop(rex);
3723                     st->cc->u.curlyx.cur = n - 1;
3724                     st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3725                     CACHEsayNO;
3726                 }
3727
3728                 /* Prefer scan over next for maximal matching. */
3729
3730                 if (n < st->cc->u.curlyx.max) { /* More greed allowed? */
3731                     st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3732                     st->cc->u.curlyx.cur = n;
3733                     st->cc->u.curlyx.lastloc = locinput;
3734                     REGCP_SET(st->u.whilem.lastcp);
3735                     REGMATCH(st->cc->u.curlyx.scan, WHILEM5);
3736                     /*** all unsaved local vars undefined at this point */
3737                     if (result) {
3738                         regcpblow(st->u.whilem.cp);
3739                         CACHEsayYES;
3740                     }
3741                     REGCP_UNWIND(st->u.whilem.lastcp);
3742                     regcppop(rex);      /* Restore some previous $<digit>s? */
3743                     PL_reginput = locinput;
3744                     DEBUG_EXECUTE_r(
3745                         PerlIO_printf(Perl_debug_log,
3746                                       "%*s  failed, try continuation...\n",
3747                                       REPORT_CODE_OFF+PL_regindent*2, "")
3748                         );
3749                 }
3750                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3751                         && !(PL_reg_flags & RF_warned)) {
3752                     PL_reg_flags |= RF_warned;
3753                     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3754                          "Complex regular subexpression recursion",
3755                          REG_INFTY - 1);
3756                 }
3757
3758                 /* Failed deeper matches of scan, so see if this one works. */
3759                 st->u.whilem.savecc = st->cc;
3760                 st->cc = st->cc->u.curlyx.outercc;
3761                 if (st->cc)
3762                     st->ln = st->cc->u.curlyx.cur;
3763                 REGMATCH(st->u.whilem.savecc->next, WHILEM6);
3764                 /*** all unsaved local vars undefined at this point */
3765                 st->cc = st->u.whilem.savecc;
3766                 if (result)
3767                     CACHEsayYES;
3768                 if (st->cc->u.curlyx.outercc)
3769                     st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3770                 st->cc->u.curlyx.cur = n - 1;
3771                 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3772                 CACHEsayNO;
3773             }
3774             /* NOTREACHED */
3775         case BRANCHJ:
3776             next = scan + ARG(scan);
3777             if (next == scan)
3778                 next = NULL;
3779             inner = NEXTOPER(NEXTOPER(scan));
3780             goto do_branch;
3781         case BRANCH:
3782             inner = NEXTOPER(scan);
3783           do_branch:
3784             {
3785                 I32 type;
3786                 type = OP(scan);
3787                 if (!next || OP(next) != type)  /* No choice. */
3788                     next = inner;       /* Avoid recursion. */
3789                 else {
3790                     const I32 lastparen = *PL_reglastparen;
3791                     /* Put unwinding data on stack */
3792                     const I32 unwind1 = SSNEWt(1,re_unwind_branch_t);
3793                     re_unwind_branch_t * const uw = SSPTRt(unwind1,re_unwind_branch_t);
3794
3795                     uw->prev = st->unwind;
3796                     st->unwind = unwind1;
3797                     uw->type = ((type == BRANCH)
3798                                 ? RE_UNWIND_BRANCH
3799                                 : RE_UNWIND_BRANCHJ);
3800                     uw->lastparen = lastparen;
3801                     uw->next = next;
3802                     uw->locinput = locinput;
3803                     uw->nextchr = nextchr;
3804                     uw->minmod = st->minmod;
3805 #ifdef DEBUGGING
3806                     uw->regindent = ++PL_regindent;
3807 #endif
3808
3809                     REGCP_SET(uw->lastcp);
3810
3811                     /* Now go into the first branch */
3812                     next = inner;
3813                 }
3814             }
3815             break;
3816         case MINMOD:
3817             st->minmod = 1;
3818             break;
3819         case CURLYM:
3820         {
3821             st->u.curlym.l = st->u.curlym.matches = 0;
3822
3823             /* We suppose that the next guy does not need
3824                backtracking: in particular, it is of constant non-zero length,
3825                and has no parenths to influence future backrefs. */
3826             st->ln = ARG1(scan);  /* min to match */
3827             n  = ARG2(scan);  /* max to match */
3828             st->u.curlym.paren = scan->flags;
3829             if (st->u.curlym.paren) {
3830                 if (st->u.curlym.paren > PL_regsize)
3831                     PL_regsize = st->u.curlym.paren;
3832                 if (st->u.curlym.paren > (I32)*PL_reglastparen)
3833                     *PL_reglastparen = st->u.curlym.paren;
3834             }
3835             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3836             if (st->u.curlym.paren)
3837                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3838             PL_reginput = locinput;
3839             st->u.curlym.maxwanted = st->minmod ? st->ln : n;
3840             if (st->u.curlym.maxwanted) {
3841                 while (PL_reginput < PL_regeol && st->u.curlym.matches < st->u.curlym.maxwanted) {
3842                     REGMATCH(scan, CURLYM1);
3843                     /*** all unsaved local vars undefined at this point */
3844                     if (!result)
3845                         break;
3846                     /* on first match, determine length, u.curlym.l */
3847                     if (!st->u.curlym.matches++) {
3848                         if (PL_reg_match_utf8) {
3849                             char *s = locinput;
3850                             while (s < PL_reginput) {
3851                                 st->u.curlym.l++;
3852                                 s += UTF8SKIP(s);
3853                             }
3854                         }
3855                         else {
3856                             st->u.curlym.l = PL_reginput - locinput;
3857                         }
3858                         if (st->u.curlym.l == 0) {
3859                             st->u.curlym.matches = st->u.curlym.maxwanted;
3860                             break;
3861                         }
3862                     }
3863                     locinput = PL_reginput;
3864                 }
3865             }
3866
3867             PL_reginput = locinput;
3868
3869             if (st->minmod) {
3870                 st->minmod = 0;
3871                 if (st->ln && st->u.curlym.matches < st->ln)
3872                     sayNO;
3873                 if (HAS_TEXT(next) || JUMPABLE(next)) {
3874                     regnode *text_node = next;
3875
3876                     if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3877
3878                     if (! HAS_TEXT(text_node)) st->u.curlym.c1 = st->u.curlym.c2 = -1000;
3879                     else {
3880                         if (PL_regkind[(U8)OP(text_node)] == REF) {
3881                             st->u.curlym.c1 = st->u.curlym.c2 = -1000;
3882                             goto assume_ok_MM;
3883                         }
3884                         else { st->u.curlym.c1 = (U8)*STRING(text_node); }
3885                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3886                             st->u.curlym.c2 = PL_fold[st->u.curlym.c1];
3887                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3888                             st->u.curlym.c2 = PL_fold_locale[st->u.curlym.c1];
3889                         else
3890                             st->u.curlym.c2 = st->u.curlym.c1;
3891                     }
3892                 }
3893                 else
3894                     st->u.curlym.c1 = st->u.curlym.c2 = -1000;
3895             assume_ok_MM:
3896                 REGCP_SET(st->u.curlym.lastcp);
3897                 while (n >= st->ln || (n == REG_INFTY && st->ln > 0)) { /* ln overflow ? */
3898                     /* If it could work, try it. */
3899                     if (st->u.curlym.c1 == -1000 ||
3900                         UCHARAT(PL_reginput) == st->u.curlym.c1 ||
3901                         UCHARAT(PL_reginput) == st->u.curlym.c2)
3902                     {
3903                         if (st->u.curlym.paren) {
3904                             if (st->ln) {
3905                                 PL_regstartp[st->u.curlym.paren] =
3906                                     HOPc(PL_reginput, -st->u.curlym.l) - PL_bostr;
3907                                 PL_regendp[st->u.curlym.paren] = PL_reginput - PL_bostr;
3908                             }
3909                             else
3910                                 PL_regendp[st->u.curlym.paren] = -1;
3911                         }
3912                         REGMATCH(next, CURLYM2);
3913                         /*** all unsaved local vars undefined at this point */
3914                         if (result)
3915                             sayYES;
3916                         REGCP_UNWIND(st->u.curlym.lastcp);
3917                     }
3918                     /* Couldn't or didn't -- move forward. */
3919                     PL_reginput = locinput;
3920                     REGMATCH(scan, CURLYM3);
3921                     /*** all unsaved local vars undefined at this point */
3922                     if (result) {
3923                         st->ln++;
3924                         locinput = PL_reginput;
3925                     }
3926                     else
3927                         sayNO;
3928                 }
3929             }
3930             else {
3931                 DEBUG_EXECUTE_r(
3932                     PerlIO_printf(Perl_debug_log,
3933                               "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3934                               (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3935                               (IV) st->u.curlym.matches, (IV)st->u.curlym.l)
3936                     );
3937                 if (st->u.curlym.matches >= st->ln) {
3938                     if (HAS_TEXT(next) || JUMPABLE(next)) {
3939                         regnode *text_node = next;
3940
3941                         if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3942
3943                         if (! HAS_TEXT(text_node)) st->u.curlym.c1 = st->u.curlym.c2 = -1000;
3944                         else {
3945                             if (PL_regkind[(U8)OP(text_node)] == REF) {
3946                                 st->u.curlym.c1 = st->u.curlym.c2 = -1000;
3947                                 goto assume_ok_REG;
3948                             }
3949                             else { st->u.curlym.c1 = (U8)*STRING(text_node); }
3950
3951                             if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3952                                 st->u.curlym.c2 = PL_fold[st->u.curlym.c1];
3953                             else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3954                                 st->u.curlym.c2 = PL_fold_locale[st->u.curlym.c1];
3955                             else
3956                                 st->u.curlym.c2 = st->u.curlym.c1;
3957                         }
3958                     }
3959                     else
3960                         st->u.curlym.c1 = st->u.curlym.c2 = -1000;
3961                 }
3962             assume_ok_REG:
3963                 REGCP_SET(st->u.curlym.lastcp);
3964                 while (st->u.curlym.matches >= st->ln) {
3965                     /* If it could work, try it. */
3966                     if (st->u.curlym.c1 == -1000 ||
3967                         UCHARAT(PL_reginput) == st->u.curlym.c1 ||
3968                         UCHARAT(PL_reginput) == st->u.curlym.c2)
3969                     {
3970                         DEBUG_EXECUTE_r(
3971                             PerlIO_printf(Perl_debug_log,
3972                                 "%*s  trying tail with matches=%"IVdf"...\n",
3973                                 (int)(REPORT_CODE_OFF+PL_regindent*2),
3974                                 "", (IV)st->u.curlym.matches)
3975                             );
3976                         if (st->u.curlym.paren) {
3977                             if (st->u.curlym.matches) {
3978                                 PL_regstartp[st->u.curlym.paren]
3979                                     = HOPc(PL_reginput, -st->u.curlym.l) - PL_bostr;
3980                                 PL_regendp[st->u.curlym.paren] = PL_reginput - PL_bostr;
3981                             }
3982                             else
3983                                 PL_regendp[st->u.curlym.paren] = -1;
3984                         }
3985                         REGMATCH(next, CURLYM4);
3986                         /*** all unsaved local vars undefined at this point */
3987                         if (result)
3988                             sayYES;
3989                         REGCP_UNWIND(st->u.curlym.lastcp);
3990                     }
3991                     /* Couldn't or didn't -- back up. */
3992                     st->u.curlym.matches--;
3993                     locinput = HOPc(locinput, -st->u.curlym.l);
3994                     PL_reginput = locinput;
3995                 }
3996             }
3997             sayNO;
3998             /* NOTREACHED */
3999             break;
4000         }
4001         case CURLYN:
4002             st->u.plus.paren = scan->flags;     /* Which paren to set */
4003             if (st->u.plus.paren > PL_regsize)
4004                 PL_regsize = st->u.plus.paren;
4005             if (st->u.plus.paren > (I32)*PL_reglastparen)
4006                 *PL_reglastparen = st->u.plus.paren;
4007             st->ln = ARG1(scan);  /* min to match */
4008             n  = ARG2(scan);  /* max to match */
4009             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4010             goto repeat;
4011         case CURLY:
4012             st->u.plus.paren = 0;
4013             st->ln = ARG1(scan);  /* min to match */
4014             n  = ARG2(scan);  /* max to match */
4015             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4016             goto repeat;
4017         case STAR:
4018             st->ln = 0;
4019             n = REG_INFTY;
4020             scan = NEXTOPER(scan);
4021             st->u.plus.paren = 0;
4022             goto repeat;
4023         case PLUS:
4024             st->ln = 1;
4025             n = REG_INFTY;
4026             scan = NEXTOPER(scan);
4027             st->u.plus.paren = 0;
4028           repeat:
4029             /*
4030             * Lookahead to avoid useless match attempts
4031             * when we know what character comes next.
4032             */
4033
4034             /*
4035             * Used to only do .*x and .*?x, but now it allows
4036             * for )'s, ('s and (?{ ... })'s to be in the way
4037             * of the quantifier and the EXACT-like node.  -- japhy
4038             */
4039
4040             if (HAS_TEXT(next) || JUMPABLE(next)) {
4041                 U8 *s;
4042                 regnode *text_node = next;
4043
4044                 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
4045
4046                 if (! HAS_TEXT(text_node)) st->u.plus.c1 = st->u.plus.c2 = -1000;
4047                 else {
4048                     if (PL_regkind[(U8)OP(text_node)] == REF) {
4049                         st->u.plus.c1 = st->u.plus.c2 = -1000;
4050                         goto assume_ok_easy;
4051                     }
4052                     else { s = (U8*)STRING(text_node); }
4053
4054                     if (!UTF) {
4055                         st->u.plus.c2 = st->u.plus.c1 = *s;
4056                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4057                             st->u.plus.c2 = PL_fold[st->u.plus.c1];
4058                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4059                             st->u.plus.c2 = PL_fold_locale[st->u.plus.c1];
4060                     }
4061                     else { /* UTF */
4062                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4063                              STRLEN ulen1, ulen2;
4064                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4065                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4066
4067                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4068                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4069
4070                              st->u.plus.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4071                                                  uniflags);
4072                              st->u.plus.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4073                                                  uniflags);
4074                         }
4075                         else {
4076                             st->u.plus.c2 = st->u.plus.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4077                                                      uniflags);
4078                         }
4079                     }
4080                 }
4081             }
4082             else
4083                 st->u.plus.c1 = st->u.plus.c2 = -1000;
4084         assume_ok_easy:
4085             PL_reginput = locinput;
4086             if (st->minmod) {
4087                 st->minmod = 0;
4088                 if (st->ln && regrepeat(rex, scan, st->ln) < st->ln)
4089                     sayNO;
4090                 locinput = PL_reginput;
4091                 REGCP_SET(st->u.plus.lastcp);
4092                 if (st->u.plus.c1 != -1000) {
4093                     st->u.plus.old = locinput;
4094                     st->u.plus.count = 0;
4095
4096                     if  (n == REG_INFTY) {
4097                         st->u.plus.e = PL_regeol - 1;
4098                         if (do_utf8)
4099                             while (UTF8_IS_CONTINUATION(*(U8*)st->u.plus.e))
4100                                 st->u.plus.e--;
4101                     }
4102                     else if (do_utf8) {
4103                         int m = n - st->ln;
4104                         for (st->u.plus.e = locinput;
4105                              m >0 && st->u.plus.e + UTF8SKIP(st->u.plus.e) <= PL_regeol; m--)
4106                             st->u.plus.e += UTF8SKIP(st->u.plus.e);
4107                     }
4108                     else {
4109                         st->u.plus.e = locinput + n - st->ln;
4110                         if (st->u.plus.e >= PL_regeol)
4111                             st->u.plus.e = PL_regeol - 1;
4112                     }
4113                     while (1) {
4114                         /* Find place 'next' could work */
4115                         if (!do_utf8) {
4116                             if (st->u.plus.c1 == st->u.plus.c2) {
4117                                 while (locinput <= st->u.plus.e &&
4118                                        UCHARAT(locinput) != st->u.plus.c1)
4119                                     locinput++;
4120                             } else {
4121                                 while (locinput <= st->u.plus.e
4122                                        && UCHARAT(locinput) != st->u.plus.c1
4123                                        && UCHARAT(locinput) != st->u.plus.c2)
4124                                     locinput++;
4125                             }
4126                             st->u.plus.count = locinput - st->u.plus.old;
4127                         }
4128                         else {
4129                             if (st->u.plus.c1 == st->u.plus.c2) {
4130                                 STRLEN len;
4131                                 /* count initialised to
4132                                  * utf8_distance(old, locinput) */
4133                                 while (locinput <= st->u.plus.e &&
4134                                        utf8n_to_uvchr((U8*)locinput,
4135                                                       UTF8_MAXBYTES, &len,
4136                                                       uniflags) != (UV)st->u.plus.c1) {
4137                                     locinput += len;
4138                                     st->u.plus.count++;
4139                                 }
4140                             } else {
4141                                 STRLEN len;
4142                                 /* count initialised to
4143                                  * utf8_distance(old, locinput) */
4144                                 while (locinput <= st->u.plus.e) {
4145                                     UV c = utf8n_to_uvchr((U8*)locinput,
4146                                                           UTF8_MAXBYTES, &len,
4147                                                           uniflags);
4148                                     if (c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4149                                         break;
4150                                     locinput += len;
4151                                     st->u.plus.count++;
4152                                 }
4153                             }
4154                         }
4155                         if (locinput > st->u.plus.e)
4156                             sayNO;
4157                         /* PL_reginput == old now */
4158                         if (locinput != st->u.plus.old) {
4159                             st->ln = 1; /* Did some */
4160                             if (regrepeat(rex, scan, st->u.plus.count) < st->u.plus.count)
4161                                 sayNO;
4162                         }
4163                         /* PL_reginput == locinput now */
4164                         TRYPAREN(st->u.plus.paren, st->ln, locinput, PLUS1);
4165                         /*** all unsaved local vars undefined at this point */
4166                         PL_reginput = locinput; /* Could be reset... */
4167                         REGCP_UNWIND(st->u.plus.lastcp);
4168                         /* Couldn't or didn't -- move forward. */
4169                         st->u.plus.old = locinput;
4170                         if (do_utf8)
4171                             locinput += UTF8SKIP(locinput);
4172                         else
4173                             locinput++;
4174                         st->u.plus.count = 1;
4175                     }
4176                 }
4177                 else
4178                 while (n >= st->ln || (n == REG_INFTY && st->ln > 0)) { /* ln overflow ? */
4179                     UV c;
4180                     if (st->u.plus.c1 != -1000) {
4181                         if (do_utf8)
4182                             c = utf8n_to_uvchr((U8*)PL_reginput,
4183                                                UTF8_MAXBYTES, 0,
4184                                                uniflags);
4185                         else
4186                             c = UCHARAT(PL_reginput);
4187                         /* If it could work, try it. */
4188                         if (c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4189                         {
4190                             TRYPAREN(st->u.plus.paren, st->ln, PL_reginput, PLUS2);
4191                             /*** all unsaved local vars undefined at this point */
4192                             REGCP_UNWIND(st->u.plus.lastcp);
4193                         }
4194                     }
4195                     /* If it could work, try it. */
4196                     else if (st->u.plus.c1 == -1000)
4197                     {
4198                         TRYPAREN(st->u.plus.paren, st->ln, PL_reginput, PLUS3);
4199                         /*** all unsaved local vars undefined at this point */
4200                         REGCP_UNWIND(st->u.plus.lastcp);
4201                     }
4202                     /* Couldn't or didn't -- move forward. */
4203                     PL_reginput = locinput;
4204                     if (regrepeat(rex, scan, 1)) {
4205                         st->ln++;
4206                         locinput = PL_reginput;
4207                     }
4208                     else
4209                         sayNO;
4210                 }
4211             }
4212             else {
4213                 n = regrepeat(rex, scan, n);
4214                 locinput = PL_reginput;
4215                 if (st->ln < n && PL_regkind[(U8)OP(next)] == EOL &&
4216                     (OP(next) != MEOL ||
4217                         OP(next) == SEOL || OP(next) == EOS))
4218                 {
4219                     st->ln = n;                 /* why back off? */
4220                     /* ...because $ and \Z can match before *and* after
4221                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4222                        We should back off by one in this case. */
4223                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
4224                         st->ln--;
4225                 }
4226                 REGCP_SET(st->u.plus.lastcp);
4227                 {
4228                     UV c = 0;
4229                     while (n >= st->ln) {
4230                         if (st->u.plus.c1 != -1000) {
4231                             if (do_utf8)
4232                                 c = utf8n_to_uvchr((U8*)PL_reginput,
4233                                                    UTF8_MAXBYTES, 0,
4234                                                    uniflags);
4235                             else
4236                                 c = UCHARAT(PL_reginput);
4237                         }
4238                         /* If it could work, try it. */
4239                         if (st->u.plus.c1 == -1000 || c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4240                             {
4241                                 TRYPAREN(st->u.plus.paren, n, PL_reginput, PLUS4);
4242                                 /*** all unsaved local vars undefined at this point */
4243                                 REGCP_UNWIND(st->u.plus.lastcp);
4244                             }
4245                         /* Couldn't or didn't -- back up. */
4246                         n--;
4247                         PL_reginput = locinput = HOPc(locinput, -1);
4248                     }
4249                 }
4250             }
4251             sayNO;
4252             break;
4253         case END:
4254             if (cur_eval) {
4255                 /* we have successfully completed the execution of a
4256                  * postponed re. Pop all states back to the last EVAL
4257                  * then continue with the node following the (??{...})
4258                  */
4259
4260                 /* this simulates a POP_STATE, except that it pops several
4261                  * levels, and doesn't restore locinput */
4262
4263                 st = cur_eval;
4264                 PL_regmatch_slab = st->u.eval.prev_slab;
4265                 cur_eval = st->u.eval.prev_eval;
4266                 depth = st->u.eval.depth;
4267
4268                 PL_regmatch_state = st;
4269                 scan    = st->scan;
4270                 next    = st->next;
4271                 n               = st->n;
4272
4273                 if (st->u.eval.toggleutf)
4274                     PL_reg_flags ^= RF_utf8;
4275                 ReREFCNT_dec(rex);
4276                 rex = st->u.eval.prev_rex;
4277                 /* XXXX This is too dramatic a measure... */
4278                 PL_reg_maxiter = 0;
4279
4280                 /* Restore parens of the caller without popping the
4281                  * savestack */
4282                 {
4283                     I32 tmp = PL_savestack_ix;
4284                     PL_savestack_ix = st->u.eval.lastcp;
4285                     regcppop(rex);
4286                     PL_savestack_ix = tmp;
4287                 }
4288
4289
4290                 PL_reginput = locinput;
4291                 /* resume at node following the (??{...}) */
4292                 break;
4293
4294             }
4295
4296             if (locinput < reginfo->till) {
4297                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4298                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4299                                       PL_colors[4],
4300                                       (long)(locinput - PL_reg_starttry),
4301                                       (long)(reginfo->till - PL_reg_starttry),
4302                                       PL_colors[5]));
4303                 sayNO_FINAL;            /* Cannot match: too short. */
4304             }
4305             PL_reginput = locinput;     /* put where regtry can find it */
4306             sayYES_FINAL;               /* Success! */
4307         case SUCCEED:
4308             PL_reginput = locinput;     /* put where regtry can find it */
4309             sayYES_LOUD;                /* Success! */
4310         case SUSPEND:
4311             n = 1;
4312             PL_reginput = locinput;
4313             goto do_ifmatch;
4314         case UNLESSM:
4315             n = 0;
4316             if (scan->flags) {
4317                 char * const s = HOPBACKc(locinput, scan->flags);
4318                 if (!s)
4319                     goto say_yes;
4320                 PL_reginput = s;
4321             }
4322             else
4323                 PL_reginput = locinput;
4324             goto do_ifmatch;
4325         case IFMATCH:
4326             n = 1;
4327             if (scan->flags) {
4328                 char * const s = HOPBACKc(locinput, scan->flags);
4329                 if (!s)
4330                     goto say_no;
4331                 PL_reginput = s;
4332             }
4333             else
4334                 PL_reginput = locinput;
4335
4336           do_ifmatch:
4337             REGMATCH(NEXTOPER(NEXTOPER(scan)), IFMATCH);
4338             /*** all unsaved local vars undefined at this point */
4339             if (result != n) {
4340               say_no:
4341                 if (st->logical) {
4342                     st->logical = 0;
4343                     st->sw = 0;
4344                     goto do_longjump;
4345                 }
4346                 else
4347                     sayNO;
4348             }
4349           say_yes:
4350             if (st->logical) {
4351                 st->logical = 0;
4352                 st->sw = 1;
4353             }
4354             if (OP(scan) == SUSPEND) {
4355                 locinput = PL_reginput;
4356                 nextchr = UCHARAT(locinput);
4357             }
4358             /* FALL THROUGH. */
4359         case LONGJMP:
4360           do_longjump:
4361             next = scan + ARG(scan);
4362             if (next == scan)
4363                 next = NULL;
4364             break;
4365         default:
4366             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4367                           PTR2UV(scan), OP(scan));
4368             Perl_croak(aTHX_ "regexp memory corruption");
4369         }
4370
4371       reenter:
4372         scan = next;
4373         continue;
4374         /* NOTREACHED */
4375
4376         /* simulate recursively calling regmatch(), but without actually
4377          * recursing - ie save the current state on the heap rather than on
4378          * the stack, then re-enter the loop. This avoids complex regexes
4379          * blowing the processor stack */
4380
4381       start_recurse:
4382         {
4383             /* push new state */
4384             regmatch_state *oldst = st;
4385
4386             depth++;
4387
4388             /* grab the next free state slot */
4389             st++;
4390             if (st >  &(PL_regmatch_slab->states[PERL_REGMATCH_SLAB_SLOTS-1]))
4391                 st = S_push_slab(aTHX);
4392             PL_regmatch_state = st;
4393
4394             oldst->next = next;
4395             oldst->n = n;
4396             oldst->locinput = locinput;
4397
4398             st->cc = oldst->cc;
4399             locinput = PL_reginput;
4400             nextchr = UCHARAT(locinput);
4401             st->minmod = 0;
4402             st->sw = 0;
4403             st->logical = 0;
4404             st->unwind = 0;
4405 #ifdef DEBUGGING
4406             PL_regindent++;
4407 #endif
4408         }
4409     }
4410
4411
4412
4413     /*
4414     * We get here only if there's trouble -- normally "case END" is
4415     * the terminating point.
4416     */
4417     Perl_croak(aTHX_ "corrupted regexp pointers");
4418     /*NOTREACHED*/
4419     sayNO;
4420
4421 yes_loud:
4422     DEBUG_EXECUTE_r(
4423         PerlIO_printf(Perl_debug_log,
4424                       "%*s  %scould match...%s\n",
4425                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4426         );
4427     goto yes;
4428 yes_final:
4429     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4430                           PL_colors[4], PL_colors[5]));
4431 yes:
4432 #ifdef DEBUGGING
4433     PL_regindent--;
4434 #endif
4435
4436     result = 1;
4437     /* XXX this is duplicate(ish) code to that in the do_no section.
4438      * eventually a yes should just pop the whole stack */
4439     if (depth) {
4440         /* restore previous state and re-enter */
4441         POP_STATE;
4442
4443         switch (st->resume_state) {
4444         case resume_TRIE1:
4445             goto resume_point_TRIE1;
4446         case resume_TRIE2:
4447             goto resume_point_TRIE2;
4448         case resume_EVAL:
4449             break;
4450         case resume_CURLYX:
4451             goto resume_point_CURLYX;
4452         case resume_WHILEM1:
4453             goto resume_point_WHILEM1;
4454         case resume_WHILEM2:
4455             goto resume_point_WHILEM2;
4456         case resume_WHILEM3:
4457             goto resume_point_WHILEM3;
4458         case resume_WHILEM4:
4459             goto resume_point_WHILEM4;
4460         case resume_WHILEM5:
4461             goto resume_point_WHILEM5;
4462         case resume_WHILEM6:
4463             goto resume_point_WHILEM6;
4464         case resume_CURLYM1:
4465             goto resume_point_CURLYM1;
4466         case resume_CURLYM2:
4467             goto resume_point_CURLYM2;
4468         case resume_CURLYM3:
4469             goto resume_point_CURLYM3;
4470         case resume_CURLYM4:
4471             goto resume_point_CURLYM4;
4472         case resume_IFMATCH:
4473             goto resume_point_IFMATCH;
4474         case resume_PLUS1:
4475             goto resume_point_PLUS1;
4476         case resume_PLUS2:
4477             goto resume_point_PLUS2;
4478         case resume_PLUS3:
4479             goto resume_point_PLUS3;
4480         case resume_PLUS4:
4481             goto resume_point_PLUS4;
4482         default:
4483             Perl_croak(aTHX_ "regexp resume memory corruption");
4484         }
4485     }
4486     goto final_exit;
4487
4488 no:
4489     DEBUG_EXECUTE_r(
4490         PerlIO_printf(Perl_debug_log,
4491                       "%*s  %sfailed...%s\n",
4492                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4493         );
4494     goto do_no;
4495 no_final:
4496 do_no:
4497     if (st->unwind) {
4498         re_unwind_t * const uw = SSPTRt(st->unwind,re_unwind_t);
4499
4500         switch (uw->type) {
4501         case RE_UNWIND_BRANCH:
4502         case RE_UNWIND_BRANCHJ:
4503         {
4504             re_unwind_branch_t * const uwb = &(uw->branch);
4505             const I32 lastparen = uwb->lastparen;
4506
4507             REGCP_UNWIND(uwb->lastcp);
4508             for (n = *PL_reglastparen; n > lastparen; n--)
4509                 PL_regendp[n] = -1;
4510             *PL_reglastparen = n;
4511             scan = next = uwb->next;
4512             st->minmod = uwb->minmod;
4513             if ( !scan ||
4514                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
4515                               ? BRANCH : BRANCHJ) ) {           /* Failure */
4516                 st->unwind = uwb->prev;
4517 #ifdef DEBUGGING
4518                 PL_regindent--;
4519 #endif
4520                 goto do_no;
4521             }
4522             /* Have more choice yet.  Reuse the same uwb.  */
4523             if ((n = (uwb->type == RE_UNWIND_BRANCH
4524                       ? NEXT_OFF(next) : ARG(next))))
4525                 next += n;
4526             else
4527                 next = NULL;    /* XXXX Needn't unwinding in this case... */
4528             uwb->next = next;
4529             next = NEXTOPER(scan);
4530             if (uwb->type == RE_UNWIND_BRANCHJ)
4531                 next = NEXTOPER(next);
4532             locinput = uwb->locinput;
4533             nextchr = uwb->nextchr;
4534 #ifdef DEBUGGING
4535             PL_regindent = uwb->regindent;
4536 #endif
4537
4538             goto reenter;
4539         }
4540         /* NOTREACHED */
4541         default:
4542             Perl_croak(aTHX_ "regexp unwind memory corruption");
4543         }
4544         /* NOTREACHED */
4545     }
4546
4547 #ifdef DEBUGGING
4548     PL_regindent--;
4549 #endif
4550     result = 0;
4551
4552     if (depth) {
4553         /* there's a previous state to backtrack to */
4554         POP_STATE;
4555         switch (st->resume_state) {
4556         case resume_TRIE1:
4557             goto resume_point_TRIE1;
4558         case resume_TRIE2:
4559             goto resume_point_TRIE2;
4560         case resume_EVAL:
4561             /* we have failed an (??{...}). Restore state to the outer re
4562              * then re-throw the failure */
4563             if (st->u.eval.toggleutf)
4564                 PL_reg_flags ^= RF_utf8;
4565             ReREFCNT_dec(rex);
4566             rex = st->u.eval.prev_rex;
4567             cur_eval = st->u.eval.prev_eval;
4568
4569             /* XXXX This is too dramatic a measure... */
4570             PL_reg_maxiter = 0;
4571
4572             PL_reginput = locinput;
4573             REGCP_UNWIND(st->u.eval.lastcp);
4574             regcppop(rex);
4575             goto do_no;
4576
4577         case resume_CURLYX:
4578             goto resume_point_CURLYX;
4579         case resume_WHILEM1:
4580             goto resume_point_WHILEM1;
4581         case resume_WHILEM2:
4582             goto resume_point_WHILEM2;
4583         case resume_WHILEM3:
4584             goto resume_point_WHILEM3;
4585         case resume_WHILEM4:
4586             goto resume_point_WHILEM4;
4587         case resume_WHILEM5:
4588             goto resume_point_WHILEM5;
4589         case resume_WHILEM6:
4590             goto resume_point_WHILEM6;
4591         case resume_CURLYM1:
4592             goto resume_point_CURLYM1;
4593         case resume_CURLYM2:
4594             goto resume_point_CURLYM2;
4595         case resume_CURLYM3:
4596             goto resume_point_CURLYM3;
4597         case resume_CURLYM4:
4598             goto resume_point_CURLYM4;
4599         case resume_IFMATCH:
4600             goto resume_point_IFMATCH;
4601         case resume_PLUS1:
4602             goto resume_point_PLUS1;
4603         case resume_PLUS2:
4604             goto resume_point_PLUS2;
4605         case resume_PLUS3:
4606             goto resume_point_PLUS3;
4607         case resume_PLUS4:
4608             goto resume_point_PLUS4;
4609         default:
4610             Perl_croak(aTHX_ "regexp resume memory corruption");
4611         }
4612     }
4613
4614 final_exit:
4615
4616     /* restore original high-water mark */
4617     PL_regmatch_slab  = orig_slab;
4618     PL_regmatch_state = orig_state;
4619
4620     /* free all slabs above current one */
4621     if (orig_slab->next) {
4622         regmatch_slab *osl, *sl = orig_slab->next;
4623         orig_slab->next = NULL;
4624         while (sl) {
4625             osl = sl;
4626             sl = sl->next;
4627             Safefree(osl);
4628         }
4629     }
4630
4631     return result;
4632
4633 }
4634
4635 /*
4636  - regrepeat - repeatedly match something simple, report how many
4637  */
4638 /*
4639  * [This routine now assumes that it will only match on things of length 1.
4640  * That was true before, but now we assume scan - reginput is the count,
4641  * rather than incrementing count on every character.  [Er, except utf8.]]
4642  */
4643 STATIC I32
4644 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max)
4645 {
4646     dVAR;
4647     register char *scan;
4648     register I32 c;
4649     register char *loceol = PL_regeol;
4650     register I32 hardcount = 0;
4651     register bool do_utf8 = PL_reg_match_utf8;
4652
4653     scan = PL_reginput;
4654     if (max == REG_INFTY)
4655         max = I32_MAX;
4656     else if (max < loceol - scan)
4657         loceol = scan + max;
4658     switch (OP(p)) {
4659     case REG_ANY:
4660         if (do_utf8) {
4661             loceol = PL_regeol;
4662             while (scan < loceol && hardcount < max && *scan != '\n') {
4663                 scan += UTF8SKIP(scan);
4664                 hardcount++;
4665             }
4666         } else {
4667             while (scan < loceol && *scan != '\n')
4668                 scan++;
4669         }
4670         break;
4671     case SANY:
4672         if (do_utf8) {
4673             loceol = PL_regeol;
4674             while (scan < loceol && hardcount < max) {
4675                 scan += UTF8SKIP(scan);
4676                 hardcount++;
4677             }
4678         }
4679         else
4680             scan = loceol;
4681         break;
4682     case CANY:
4683         scan = loceol;
4684         break;
4685     case EXACT:         /* length of string is 1 */
4686         c = (U8)*STRING(p);
4687         while (scan < loceol && UCHARAT(scan) == c)
4688             scan++;
4689         break;
4690     case EXACTF:        /* length of string is 1 */
4691         c = (U8)*STRING(p);
4692         while (scan < loceol &&
4693                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4694             scan++;
4695         break;
4696     case EXACTFL:       /* length of string is 1 */
4697         PL_reg_flags |= RF_tainted;
4698         c = (U8)*STRING(p);
4699         while (scan < loceol &&
4700                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4701             scan++;
4702         break;
4703     case ANYOF:
4704         if (do_utf8) {
4705             loceol = PL_regeol;
4706             while (hardcount < max && scan < loceol &&
4707                    reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
4708                 scan += UTF8SKIP(scan);
4709                 hardcount++;
4710             }
4711         } else {
4712             while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
4713                 scan++;
4714         }
4715         break;
4716     case ALNUM:
4717         if (do_utf8) {
4718             loceol = PL_regeol;
4719             LOAD_UTF8_CHARCLASS_ALNUM();
4720             while (hardcount < max && scan < loceol &&
4721                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4722                 scan += UTF8SKIP(scan);
4723                 hardcount++;
4724             }
4725         } else {
4726             while (scan < loceol && isALNUM(*scan))
4727                 scan++;
4728         }
4729         break;
4730     case ALNUML:
4731         PL_reg_flags |= RF_tainted;
4732         if (do_utf8) {
4733             loceol = PL_regeol;
4734             while (hardcount < max && scan < loceol &&
4735                    isALNUM_LC_utf8((U8*)scan)) {
4736                 scan += UTF8SKIP(scan);
4737                 hardcount++;
4738             }
4739         } else {
4740             while (scan < loceol && isALNUM_LC(*scan))
4741                 scan++;
4742         }
4743         break;
4744     case NALNUM:
4745         if (do_utf8) {
4746             loceol = PL_regeol;
4747             LOAD_UTF8_CHARCLASS_ALNUM();
4748             while (hardcount < max && scan < loceol &&
4749                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4750                 scan += UTF8SKIP(scan);
4751                 hardcount++;
4752             }
4753         } else {
4754             while (scan < loceol && !isALNUM(*scan))
4755                 scan++;
4756         }
4757         break;
4758     case NALNUML:
4759         PL_reg_flags |= RF_tainted;
4760         if (do_utf8) {
4761             loceol = PL_regeol;
4762             while (hardcount < max && scan < loceol &&
4763                    !isALNUM_LC_utf8((U8*)scan)) {
4764                 scan += UTF8SKIP(scan);
4765                 hardcount++;
4766             }
4767         } else {
4768             while (scan < loceol && !isALNUM_LC(*scan))
4769                 scan++;
4770         }
4771         break;
4772     case SPACE:
4773         if (do_utf8) {
4774             loceol = PL_regeol;
4775             LOAD_UTF8_CHARCLASS_SPACE();
4776             while (hardcount < max && scan < loceol &&
4777                    (*scan == ' ' ||
4778                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4779                 scan += UTF8SKIP(scan);
4780                 hardcount++;
4781             }
4782         } else {
4783             while (scan < loceol && isSPACE(*scan))
4784                 scan++;
4785         }
4786         break;
4787     case SPACEL:
4788         PL_reg_flags |= RF_tainted;
4789         if (do_utf8) {
4790             loceol = PL_regeol;
4791             while (hardcount < max && scan < loceol &&
4792                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4793                 scan += UTF8SKIP(scan);
4794                 hardcount++;
4795             }
4796         } else {
4797             while (scan < loceol && isSPACE_LC(*scan))
4798                 scan++;
4799         }
4800         break;
4801     case NSPACE:
4802         if (do_utf8) {
4803             loceol = PL_regeol;
4804             LOAD_UTF8_CHARCLASS_SPACE();
4805             while (hardcount < max && scan < loceol &&
4806                    !(*scan == ' ' ||
4807                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4808                 scan += UTF8SKIP(scan);
4809                 hardcount++;
4810             }
4811         } else {
4812             while (scan < loceol && !isSPACE(*scan))
4813                 scan++;
4814             break;
4815         }
4816     case NSPACEL:
4817         PL_reg_flags |= RF_tainted;
4818         if (do_utf8) {
4819             loceol = PL_regeol;
4820             while (hardcount < max && scan < loceol &&
4821                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4822                 scan += UTF8SKIP(scan);
4823                 hardcount++;
4824             }
4825         } else {
4826             while (scan < loceol && !isSPACE_LC(*scan))
4827                 scan++;
4828         }
4829         break;
4830     case DIGIT:
4831         if (do_utf8) {
4832             loceol = PL_regeol;
4833             LOAD_UTF8_CHARCLASS_DIGIT();
4834             while (hardcount < max && scan < loceol &&
4835                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4836                 scan += UTF8SKIP(scan);
4837                 hardcount++;
4838             }
4839         } else {
4840             while (scan < loceol && isDIGIT(*scan))
4841                 scan++;
4842         }
4843         break;
4844     case NDIGIT:
4845         if (do_utf8) {
4846             loceol = PL_regeol;
4847             LOAD_UTF8_CHARCLASS_DIGIT();
4848             while (hardcount < max && scan < loceol &&
4849                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4850                 scan += UTF8SKIP(scan);
4851                 hardcount++;
4852             }
4853         } else {
4854             while (scan < loceol && !isDIGIT(*scan))
4855                 scan++;
4856         }
4857         break;
4858     default:            /* Called on something of 0 width. */
4859         break;          /* So match right here or not at all. */
4860     }
4861
4862     if (hardcount)
4863         c = hardcount;
4864     else
4865         c = scan - PL_reginput;
4866     PL_reginput = scan;
4867
4868     DEBUG_r({
4869                 SV *re_debug_flags = NULL;
4870                 SV * const prop = sv_newmortal();
4871                 GET_RE_DEBUG_FLAGS;
4872                 DEBUG_EXECUTE_r({
4873                 regprop(prog, prop, p);
4874                 PerlIO_printf(Perl_debug_log,
4875                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
4876                               REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
4877         });
4878         });
4879
4880     return(c);
4881 }
4882
4883
4884 /*
4885 - regclass_swash - prepare the utf8 swash
4886 */
4887
4888 SV *
4889 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
4890 {
4891     dVAR;
4892     SV *sw  = NULL;
4893     SV *si  = NULL;
4894     SV *alt = NULL;
4895     const struct reg_data *data = prog ? prog->data : NULL;
4896
4897     if (data && data->count) {
4898         const U32 n = ARG(node);
4899
4900         if (data->what[n] == 's') {
4901             SV * const rv = (SV*)data->data[n];
4902             AV * const av = (AV*)SvRV((SV*)rv);
4903             SV **const ary = AvARRAY(av);
4904             SV **a, **b;
4905
4906             /* See the end of regcomp.c:S_regclass() for
4907              * documentation of these array elements. */
4908
4909             si = *ary;
4910             a  = SvROK(ary[1]) ? &ary[1] : 0;
4911             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
4912
4913             if (a)
4914                 sw = *a;
4915             else if (si && doinit) {
4916                 sw = swash_init("utf8", "", si, 1, 0);
4917                 (void)av_store(av, 1, sw);
4918             }
4919             if (b)
4920                 alt = *b;
4921         }
4922     }
4923
4924     if (listsvp)
4925         *listsvp = si;
4926     if (altsvp)
4927         *altsvp  = alt;
4928
4929     return sw;
4930 }
4931
4932 /*
4933  - reginclass - determine if a character falls into a character class
4934
4935   The n is the ANYOF regnode, the p is the target string, lenp
4936   is pointer to the maximum length of how far to go in the p
4937   (if the lenp is zero, UTF8SKIP(p) is used),
4938   do_utf8 tells whether the target string is in UTF-8.
4939
4940  */
4941
4942 STATIC bool
4943 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
4944 {
4945     dVAR;
4946     const char flags = ANYOF_FLAGS(n);
4947     bool match = FALSE;
4948     UV c = *p;
4949     STRLEN len = 0;
4950     STRLEN plen;
4951
4952     if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
4953         c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
4954                 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
4955                 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
4956         if (len == (STRLEN)-1)
4957             Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
4958     }
4959
4960     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
4961     if (do_utf8 || (flags & ANYOF_UNICODE)) {
4962         if (lenp)
4963             *lenp = 0;
4964         if (do_utf8 && !ANYOF_RUNTIME(n)) {
4965             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
4966                 match = TRUE;
4967         }
4968         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
4969             match = TRUE;
4970         if (!match) {
4971             AV *av;
4972             SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
4973
4974             if (sw) {
4975                 if (swash_fetch(sw, p, do_utf8))
4976                     match = TRUE;
4977                 else if (flags & ANYOF_FOLD) {
4978                     if (!match && lenp && av) {
4979                         I32 i;
4980                         for (i = 0; i <= av_len(av); i++) {
4981                             SV* const sv = *av_fetch(av, i, FALSE);
4982                             STRLEN len;
4983                             const char * const s = SvPV_const(sv, len);
4984
4985                             if (len <= plen && memEQ(s, (char*)p, len)) {
4986                                 *lenp = len;
4987                                 match = TRUE;
4988                                 break;
4989                             }
4990                         }
4991                     }
4992                     if (!match) {
4993                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4994                         STRLEN tmplen;
4995
4996                         to_utf8_fold(p, tmpbuf, &tmplen);
4997                         if (swash_fetch(sw, tmpbuf, do_utf8))
4998                             match = TRUE;
4999                     }
5000                 }
5001             }
5002         }
5003         if (match && lenp && *lenp == 0)
5004             *lenp = UNISKIP(NATIVE_TO_UNI(c));
5005     }
5006     if (!match && c < 256) {
5007         if (ANYOF_BITMAP_TEST(n, c))
5008             match = TRUE;
5009         else if (flags & ANYOF_FOLD) {
5010             U8 f;
5011
5012             if (flags & ANYOF_LOCALE) {
5013                 PL_reg_flags |= RF_tainted;
5014                 f = PL_fold_locale[c];
5015             }
5016             else
5017                 f = PL_fold[c];
5018             if (f != c && ANYOF_BITMAP_TEST(n, f))
5019                 match = TRUE;
5020         }
5021
5022         if (!match && (flags & ANYOF_CLASS)) {
5023             PL_reg_flags |= RF_tainted;
5024             if (
5025                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
5026                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
5027                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
5028                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
5029                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
5030                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
5031                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
5032                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5033                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
5034                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
5035                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
5036                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
5037                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
5038                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
5039                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
5040                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
5041                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
5042                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
5043                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
5044                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
5045                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
5046                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
5047                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
5048                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
5049                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
5050                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
5051                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
5052                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
5053                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
5054                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
5055                 ) /* How's that for a conditional? */
5056             {
5057                 match = TRUE;
5058             }
5059         }
5060     }
5061
5062     return (flags & ANYOF_INVERT) ? !match : match;
5063 }
5064
5065 STATIC U8 *
5066 S_reghop3(U8 *s, I32 off, U8* lim)
5067 {
5068     dVAR;
5069     if (off >= 0) {
5070         while (off-- && s < lim) {
5071             /* XXX could check well-formedness here */
5072             s += UTF8SKIP(s);
5073         }
5074     }
5075     else {
5076         while (off++) {
5077             if (s > lim) {
5078                 s--;
5079                 if (UTF8_IS_CONTINUED(*s)) {
5080                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5081                         s--;
5082                 }
5083                 /* XXX could check well-formedness here */
5084             }
5085         }
5086     }
5087     return s;
5088 }
5089
5090 STATIC U8 *
5091 S_reghopmaybe3(U8* s, I32 off, U8* lim)
5092 {
5093     dVAR;
5094     if (off >= 0) {
5095         while (off-- && s < lim) {
5096             /* XXX could check well-formedness here */
5097             s += UTF8SKIP(s);
5098         }
5099         if (off >= 0)
5100             return 0;
5101     }
5102     else {
5103         while (off++) {
5104             if (s > lim) {
5105                 s--;
5106                 if (UTF8_IS_CONTINUED(*s)) {
5107                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5108                         s--;
5109                 }
5110                 /* XXX could check well-formedness here */
5111             }
5112             else
5113                 break;
5114         }
5115         if (off <= 0)
5116             return 0;
5117     }
5118     return s;
5119 }
5120
5121 static void
5122 restore_pos(pTHX_ void *arg)
5123 {
5124     dVAR;
5125     regexp * const rex = (regexp *)arg;
5126     if (PL_reg_eval_set) {
5127         if (PL_reg_oldsaved) {
5128             rex->subbeg = PL_reg_oldsaved;
5129             rex->sublen = PL_reg_oldsavedlen;
5130 #ifdef PERL_OLD_COPY_ON_WRITE
5131             rex->saved_copy = PL_nrs;
5132 #endif
5133             RX_MATCH_COPIED_on(rex);
5134         }
5135         PL_reg_magic->mg_len = PL_reg_oldpos;
5136         PL_reg_eval_set = 0;
5137         PL_curpm = PL_reg_oldcurpm;
5138     }
5139 }
5140
5141 STATIC void
5142 S_to_utf8_substr(pTHX_ register regexp *prog)
5143 {
5144     if (prog->float_substr && !prog->float_utf8) {
5145         SV* const sv = newSVsv(prog->float_substr);
5146         prog->float_utf8 = sv;
5147         sv_utf8_upgrade(sv);
5148         if (SvTAIL(prog->float_substr))
5149             SvTAIL_on(sv);
5150         if (prog->float_substr == prog->check_substr)
5151             prog->check_utf8 = sv;
5152     }
5153     if (prog->anchored_substr && !prog->anchored_utf8) {
5154         SV* const sv = newSVsv(prog->anchored_substr);
5155         prog->anchored_utf8 = sv;
5156         sv_utf8_upgrade(sv);
5157         if (SvTAIL(prog->anchored_substr))
5158             SvTAIL_on(sv);
5159         if (prog->anchored_substr == prog->check_substr)
5160             prog->check_utf8 = sv;
5161     }
5162 }
5163
5164 STATIC void
5165 S_to_byte_substr(pTHX_ register regexp *prog)
5166 {
5167     dVAR;
5168     if (prog->float_utf8 && !prog->float_substr) {
5169         SV* sv = newSVsv(prog->float_utf8);
5170         prog->float_substr = sv;
5171         if (sv_utf8_downgrade(sv, TRUE)) {
5172             if (SvTAIL(prog->float_utf8))
5173                 SvTAIL_on(sv);
5174         } else {
5175             SvREFCNT_dec(sv);
5176             prog->float_substr = sv = &PL_sv_undef;
5177         }
5178         if (prog->float_utf8 == prog->check_utf8)
5179             prog->check_substr = sv;
5180     }
5181     if (prog->anchored_utf8 && !prog->anchored_substr) {
5182         SV* sv = newSVsv(prog->anchored_utf8);
5183         prog->anchored_substr = sv;
5184         if (sv_utf8_downgrade(sv, TRUE)) {
5185             if (SvTAIL(prog->anchored_utf8))
5186                 SvTAIL_on(sv);
5187         } else {
5188             SvREFCNT_dec(sv);
5189             prog->anchored_substr = sv = &PL_sv_undef;
5190         }
5191         if (prog->anchored_utf8 == prog->check_utf8)
5192             prog->check_substr = sv;
5193     }
5194 }
5195
5196 /*
5197  * Local variables:
5198  * c-indentation-style: bsd
5199  * c-basic-offset: 4
5200  * indent-tabs-mode: t
5201  * End:
5202  *
5203  * ex: set ts=8 sts=4 sw=4 noet:
5204  */