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