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