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