regexec.c

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