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) ((char *)(PL_reg_match_utf8 \
 103             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
 104             : (U8*)(pos + off)))
 105 #define HOPBACKc(pos, off) ((char*)     \
 106     ((PL_reg_match_utf8)                \
 107         ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
 108     : (pos - off >= PL_bostr)           \
 109         ? (U8*)(pos - off)              \
 110     : (U8*)NULL)                        \
 111 )
 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 /* for use after a quantifier and before an EXACT-like node -- japhy */
 124 #define JUMPABLE(rn) ( \
 125     OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
 126     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 127     OP(rn) == PLUS || OP(rn) == MINMOD || \
 128     (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \
 129 )
 130
 131 #define HAS_TEXT(rn) ( \
 132     PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \
 133 )
 134
 135 /*
 136   Search for mandatory following text node; for lookahead, the text must
 137   follow but for lookbehind (rn->flags != 0) we skip to the next step.
 138 */
 139 #define FIND_NEXT_IMPT(rn) STMT_START { \
 140     while (JUMPABLE(rn)) \
 141         if (OP(rn) == SUSPEND || PL_regkind[(U8)OP(rn)] == CURLY) \
 142             rn = NEXTOPER(NEXTOPER(rn)); \
 143         else if (OP(rn) == PLUS) \
 144             rn = NEXTOPER(rn); \
 145         else if (OP(rn) == IFMATCH) \
 146             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
 147         else rn += NEXT_OFF(rn); \
 148 } STMT_END
 149
 150 static void restore_pos(pTHX_ void *arg);
 151
 152 STATIC CHECKPOINT
 153 S_regcppush(pTHX_ I32 parenfloor)
 154 {
 155     dVAR;
 156     const int retval = PL_savestack_ix;
 157 #define REGCP_PAREN_ELEMS 4
 158     const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
 159     int p;
 160
 161     if (paren_elems_to_push < 0)
 162         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
 163
 164 #define REGCP_OTHER_ELEMS 6
 165     SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
 166     for (p = PL_regsize; p > parenfloor; p--) {
 167 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 168         SSPUSHINT(PL_regendp[p]);
 169         SSPUSHINT(PL_regstartp[p]);
 170         SSPUSHPTR(PL_reg_start_tmp[p]);
 171         SSPUSHINT(p);
 172     }
 173 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 174     SSPUSHINT(PL_regsize);
 175     SSPUSHINT(*PL_reglastparen);
 176     SSPUSHINT(*PL_reglastcloseparen);
 177     SSPUSHPTR(PL_reginput);
 178 #define REGCP_FRAME_ELEMS 2
 179 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
 180  * are needed for the regexp context stack bookkeeping. */
 181     SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 182     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
 183
 184     return retval;
 185 }
 186
 187 /* These are needed since we do not localize EVAL nodes: */
 188 #  define REGCP_SET(cp)  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,          \
 189                              "  Setting an EVAL scope, savestack=%"IVdf"\n",    \
 190                              (IV)PL_savestack_ix)); cp = PL_savestack_ix
 191
 192 #  define REGCP_UNWIND(cp)  DEBUG_EXECUTE_r(cp != PL_savestack_ix ?             \
 193                                 PerlIO_printf(Perl_debug_log,           \
 194                                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 195                                 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
 196
 197 STATIC char *
 198 S_regcppop(pTHX_ const regexp *rex)
 199 {
 200     dVAR;
 201     I32 i;
 202     char *input;
 203
 204     GET_RE_DEBUG_FLAGS_DECL;
 205
 206     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 207     i = SSPOPINT;
 208     assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 209     i = SSPOPINT; /* Parentheses elements to pop. */
 210     input = (char *) SSPOPPTR;
 211     *PL_reglastcloseparen = SSPOPINT;
 212     *PL_reglastparen = SSPOPINT;
 213     PL_regsize = SSPOPINT;
 214
 215     /* Now restore the parentheses context. */
 216     for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 217          i > 0; i -= REGCP_PAREN_ELEMS) {
 218         I32 tmps;
 219         U32 paren = (U32)SSPOPINT;
 220         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
 221         PL_regstartp[paren] = SSPOPINT;
 222         tmps = SSPOPINT;
 223         if (paren <= *PL_reglastparen)
 224             PL_regendp[paren] = tmps;
 225         DEBUG_EXECUTE_r(
 226             PerlIO_printf(Perl_debug_log,
 227                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 228                           (UV)paren, (IV)PL_regstartp[paren],
 229                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
 230                           (IV)PL_regendp[paren],
 231                           (paren > *PL_reglastparen ? "(no)" : ""));
 232         );
 233     }
 234     DEBUG_EXECUTE_r(
 235         if (*PL_reglastparen + 1 <= rex->nparens) {
 236             PerlIO_printf(Perl_debug_log,
 237                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
 238                           (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
 239         }
 240     );
 241 #if 1
 242     /* It would seem that the similar code in regtry()
 243      * already takes care of this, and in fact it is in
 244      * a better location to since this code can #if 0-ed out
 245      * but the code in regtry() is needed or otherwise tests
 246      * requiring null fields (pat.t#187 and split.t#{13,14}
 247      * (as of patchlevel 7877)  will fail.  Then again,
 248      * this code seems to be necessary or otherwise
 249      * building DynaLoader will fail:
 250      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
 251      * --jhi */
 252     for (i = *PL_reglastparen + 1; (U32)i <= rex->nparens; i++) {
 253         if (i > PL_regsize)
 254             PL_regstartp[i] = -1;
 255         PL_regendp[i] = -1;
 256     }
 257 #endif
 258     return input;
 259 }
 260
 261 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
 262
 263 #define TRYPAREN(paren, n, input, where) {                      \
 264     if (paren) {                                                \
 265         if (n) {                                                \
 266             PL_regstartp[paren] = HOPc(input, -1) - PL_bostr;   \
 267             PL_regendp[paren] = input - PL_bostr;               \
 268         }                                                       \
 269         else                                                    \
 270             PL_regendp[paren] = -1;                             \
 271     }                                                           \
 272     REGMATCH(next, where);                                      \
 273     if (result)                                                 \
 274         sayYES;                                                 \
 275     if (paren && n)                                             \
 276         PL_regendp[paren] = -1;                                 \
 277 }
 278
 279
 280 /*
 281  * pregexec and friends
 282  */
 283
 284 #ifndef PERL_IN_XSUB_RE
 285 /*
 286  - pregexec - match a regexp against a string
 287  */
 288 I32
 289 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
 290          char *strbeg, I32 minend, SV *screamer, U32 nosave)
 291 /* strend: pointer to null at end of string */
 292 /* strbeg: real beginning of string */
 293 /* minend: end of match must be >=minend after stringarg. */
 294 /* nosave: For optimizations. */
 295 {
 296     return
 297         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 298                       nosave ? 0 : REXEC_COPY_STR);
 299 }
 300 #endif
 301
 302 /*
 303  * Need to implement the following flags for reg_anch:
 304  *
 305  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
 306  * USE_INTUIT_ML
 307  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
 308  * INTUIT_AUTORITATIVE_ML
 309  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
 310  * INTUIT_ONCE_ML
 311  *
 312  * Another flag for this function: SECOND_TIME (so that float substrs
 313  * with giant delta may be not rechecked).
 314  */
 315
 316 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 317
 318 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
 319    Otherwise, only SvCUR(sv) is used to get strbeg. */
 320
 321 /* XXXX We assume that strpos is strbeg unless sv. */
 322
 323 /* XXXX Some places assume that there is a fixed substring.
 324         An update may be needed if optimizer marks as "INTUITable"
 325         RExen without fixed substrings.  Similarly, it is assumed that
 326         lengths of all the strings are no more than minlen, thus they
 327         cannot come from lookahead.
 328         (Or minlen should take into account lookahead.) */
 329
 330 /* A failure to find a constant substring means that there is no need to make
 331    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 332    finding a substring too deep into the string means that less calls to
 333    regtry() should be needed.
 334
 335    REx compiler's optimizer found 4 possible hints:
 336         a) Anchored substring;
 337         b) Fixed substring;
 338         c) Whether we are anchored (beginning-of-line or \G);
 339         d) First node (of those at offset 0) which may distingush positions;
 340    We use a)b)d) and multiline-part of c), and try to find a position in the
 341    string which does not contradict any of them.
 342  */
 343
 344 /* Most of decisions we do here should have been done at compile time.
 345    The nodes of the REx which we used for the search should have been
 346    deleted from the finite automaton. */
 347
 348 char *
 349 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
 350                      char *strend, U32 flags, re_scream_pos_data *data)
 351 {
 352     dVAR;
 353     register I32 start_shift = 0;
 354     /* Should be nonnegative! */
 355     register I32 end_shift   = 0;
 356     register char *s;
 357     register SV *check;
 358     char *strbeg;
 359     char *t;
 360     const int do_utf8 = sv ? SvUTF8(sv) : 0;    /* if no sv we have to assume bytes */
 361     I32 ml_anch;
 362     register char *other_last = NULL;   /* other substr checked before this */
 363     char *check_at = NULL;              /* check substr found at this pos */
 364     const I32 multiline = prog->reganch & PMf_MULTILINE;
 365 #ifdef DEBUGGING
 366     const char * const i_strpos = strpos;
 367     SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
 368 #endif
 369
 370     GET_RE_DEBUG_FLAGS_DECL;
 371
 372     RX_MATCH_UTF8_set(prog,do_utf8);
 373
 374     if (prog->reganch & ROPT_UTF8) {
 375         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 376                               "UTF-8 regex...\n"));
 377         PL_reg_flags |= RF_utf8;
 378     }
 379
 380     DEBUG_EXECUTE_r({
 381          const char *s   = PL_reg_match_utf8 ?
 382                          sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
 383                          strpos;
 384          const int   len = PL_reg_match_utf8 ?
 385                          (int)strlen(s) : strend - strpos;
 386          if (!PL_colorset)
 387               reginitcolors();
 388          if (PL_reg_match_utf8)
 389              DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 390                                    "UTF-8 target...\n"));
 391          PerlIO_printf(Perl_debug_log,
 392                        "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n",
 393                        PL_colors[4], PL_colors[5], PL_colors[0],
 394                        prog->precomp,
 395                        PL_colors[1],
 396                        (strlen(prog->precomp) > 60 ? "..." : ""),
 397                        PL_colors[0],
 398                        (int)(len > 60 ? 60 : len),
 399                        s, PL_colors[1],
 400                        (len > 60 ? "..." : "")
 401               );
 402     });
 403
 404     /* CHR_DIST() would be more correct here but it makes things slow. */
 405     if (prog->minlen > strend - strpos) {
 406         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 407                               "String too short... [re_intuit_start]\n"));
 408         goto fail;
 409     }
 410     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
 411     PL_regeol = strend;
 412     if (do_utf8) {
 413         if (!prog->check_utf8 && prog->check_substr)
 414             to_utf8_substr(prog);
 415         check = prog->check_utf8;
 416     } else {
 417         if (!prog->check_substr && prog->check_utf8)
 418             to_byte_substr(prog);
 419         check = prog->check_substr;
 420     }
 421    if (check == &PL_sv_undef) {
 422         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 423                 "Non-utf string cannot match utf check string\n"));
 424         goto fail;
 425     }
 426     if (prog->reganch & ROPT_ANCH) {    /* Match at beg-of-str or after \n */
 427         ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
 428                      || ( (prog->reganch & ROPT_ANCH_BOL)
 429                           && !multiline ) );    /* Check after \n? */
 430
 431         if (!ml_anch) {
 432           if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
 433                                   | ROPT_IMPLICIT)) /* not a real BOL */
 434                /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
 435                && sv && !SvROK(sv)
 436                && (strpos != strbeg)) {
 437               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 438               goto fail;
 439           }
 440           if (prog->check_offset_min == prog->check_offset_max &&
 441               !(prog->reganch & ROPT_CANY_SEEN)) {
 442             /* Substring at constant offset from beg-of-str... */
 443             I32 slen;
 444
 445             s = HOP3c(strpos, prog->check_offset_min, strend);
 446             if (SvTAIL(check)) {
 447                 slen = SvCUR(check);    /* >= 1 */
 448
 449                 if ( strend - s > slen || strend - s < slen - 1
 450                      || (strend - s == slen && strend[-1] != '\n')) {
 451                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 452                     goto fail_finish;
 453                 }
 454                 /* Now should match s[0..slen-2] */
 455                 slen--;
 456                 if (slen && (*SvPVX_const(check) != *s
 457                              || (slen > 1
 458                                  && memNE(SvPVX_const(check), s, slen)))) {
 459                   report_neq:
 460                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 461                     goto fail_finish;
 462                 }
 463             }
 464             else if (*SvPVX_const(check) != *s
 465                      || ((slen = SvCUR(check)) > 1
 466                          && memNE(SvPVX_const(check), s, slen)))
 467                 goto report_neq;
 468             check_at = s;
 469             goto success_at_start;
 470           }
 471         }
 472         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 473         s = strpos;
 474         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 475         end_shift = prog->minlen - start_shift -
 476             CHR_SVLEN(check) + (SvTAIL(check) != 0);
 477         if (!ml_anch) {
 478             const I32 end = prog->check_offset_max + CHR_SVLEN(check)
 479                                          - (SvTAIL(check) != 0);
 480             const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 481
 482             if (end_shift < eshift)
 483                 end_shift = eshift;
 484         }
 485     }
 486     else {                              /* Can match at random position */
 487         ml_anch = 0;
 488         s = strpos;
 489         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 490         /* Should be nonnegative! */
 491         end_shift = prog->minlen - start_shift -
 492             CHR_SVLEN(check) + (SvTAIL(check) != 0);
 493     }
 494
 495 #ifdef DEBUGGING        /* 7/99: reports of failure (with the older version) */
 496     if (end_shift < 0)
 497         Perl_croak(aTHX_ "panic: end_shift");
 498 #endif
 499
 500   restart:
 501     /* Find a possible match in the region s..strend by looking for
 502        the "check" substring in the region corrected by start/end_shift. */
 503     if (flags & REXEC_SCREAM) {
 504         I32 p = -1;                     /* Internal iterator of scream. */
 505         I32 * const pp = data ? data->scream_pos : &p;
 506
 507         if (PL_screamfirst[BmRARE(check)] >= 0
 508             || ( BmRARE(check) == '\n'
 509                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
 510                  && SvTAIL(check) ))
 511             s = screaminstr(sv, check,
 512                             start_shift + (s - strbeg), end_shift, pp, 0);
 513         else
 514             goto fail_finish;
 515         /* we may be pointing at the wrong string */
 516         if (s && RX_MATCH_COPIED(prog))
 517             s = strbeg + (s - SvPVX_const(sv));
 518         if (data)
 519             *data->scream_olds = s;
 520     }
 521     else if (prog->reganch & ROPT_CANY_SEEN)
 522         s = fbm_instr((U8*)(s + start_shift),
 523                       (U8*)(strend - end_shift),
 524                       check, multiline ? FBMrf_MULTILINE : 0);
 525     else
 526         s = fbm_instr(HOP3(s, start_shift, strend),
 527                       HOP3(strend, -end_shift, strbeg),
 528                       check, multiline ? FBMrf_MULTILINE : 0);
 529
 530     /* Update the count-of-usability, remove useless subpatterns,
 531         unshift s.  */
 532
 533     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s",
 534                           (s ? "Found" : "Did not find"),
 535                           (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
 536                           PL_colors[0],
 537                           (int)(SvCUR(check) - (SvTAIL(check)!=0)),
 538                           SvPVX_const(check),
 539                           PL_colors[1], (SvTAIL(check) ? "$" : ""),
 540                           (s ? " at offset " : "...\n") ) );
 541
 542     if (!s)
 543         goto fail_finish;
 544
 545     check_at = s;
 546
 547     /* Finish the diagnostic message */
 548     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 549
 550     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 551        Start with the other substr.
 552        XXXX no SCREAM optimization yet - and a very coarse implementation
 553        XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
 554                 *always* match.  Probably should be marked during compile...
 555        Probably it is right to do no SCREAM here...
 556      */
 557
 558     if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
 559         /* Take into account the "other" substring. */
 560         /* XXXX May be hopelessly wrong for UTF... */
 561         if (!other_last)
 562             other_last = strpos;
 563         if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
 564           do_other_anchored:
 565             {
 566                 char * const last = HOP3c(s, -start_shift, strbeg);
 567                 char *last1, *last2;
 568                 char *s1 = s;
 569                 SV* must;
 570
 571                 t = s - prog->check_offset_max;
 572                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 573                     && (!do_utf8
 574                         || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
 575                             && t > strpos)))
 576                     NOOP;
 577                 else
 578                     t = strpos;
 579                 t = HOP3c(t, prog->anchored_offset, strend);
 580                 if (t < other_last)     /* These positions already checked */
 581                     t = other_last;
 582                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 583                 if (last < last1)
 584                     last1 = last;
 585  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 586                 /* On end-of-str: see comment below. */
 587                 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
 588                 if (must == &PL_sv_undef) {
 589                     s = (char*)NULL;
 590                     DEBUG_EXECUTE_r(must = prog->anchored_utf8);        /* for debug */
 591                 }
 592                 else
 593                     s = fbm_instr(
 594                         (unsigned char*)t,
 595                         HOP3(HOP3(last1, prog->anchored_offset, strend)
 596                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
 597                         must,
 598                         multiline ? FBMrf_MULTILINE : 0
 599                     );
 600                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 601                         "%s anchored substr \"%s%.*s%s\"%s",
 602                         (s ? "Found" : "Contradicts"),
 603                         PL_colors[0],
 604                           (int)(SvCUR(must)
 605                           - (SvTAIL(must)!=0)),
 606                           SvPVX_const(must),
 607                           PL_colors[1], (SvTAIL(must) ? "$" : "")));
 608                 if (!s) {
 609                     if (last1 >= last2) {
 610                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 611                                                 ", giving up...\n"));
 612                         goto fail_finish;
 613                     }
 614                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 615                         ", trying floating at offset %ld...\n",
 616                         (long)(HOP3c(s1, 1, strend) - i_strpos)));
 617                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 618                     s = HOP3c(last, 1, strend);
 619                     goto restart;
 620                 }
 621                 else {
 622                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 623                           (long)(s - i_strpos)));
 624                     t = HOP3c(s, -prog->anchored_offset, strbeg);
 625                     other_last = HOP3c(s, 1, strend);
 626                     s = s1;
 627                     if (t == strpos)
 628                         goto try_at_start;
 629                     goto try_at_offset;
 630                 }
 631             }
 632         }
 633         else {          /* Take into account the floating substring. */
 634             char *last, *last1;
 635             char *s1 = s;
 636             SV* must;
 637
 638             t = HOP3c(s, -start_shift, strbeg);
 639             last1 = last =
 640                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 641             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 642                 last = HOP3c(t, prog->float_max_offset, strend);
 643             s = HOP3c(t, prog->float_min_offset, strend);
 644             if (s < other_last)
 645                 s = other_last;
 646  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 647             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
 648             /* fbm_instr() takes into account exact value of end-of-str
 649                if the check is SvTAIL(ed).  Since false positives are OK,
 650                and end-of-str is not later than strend we are OK. */
 651             if (must == &PL_sv_undef) {
 652                 s = (char*)NULL;
 653                 DEBUG_EXECUTE_r(must = prog->float_utf8);       /* for debug message */
 654             }
 655             else
 656                 s = fbm_instr((unsigned char*)s,
 657                               (unsigned char*)last + SvCUR(must)
 658                                   - (SvTAIL(must)!=0),
 659                               must, multiline ? FBMrf_MULTILINE : 0);
 660             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
 661                     (s ? "Found" : "Contradicts"),
 662                     PL_colors[0],
 663                       (int)(SvCUR(must) - (SvTAIL(must)!=0)),
 664                       SvPVX_const(must),
 665                       PL_colors[1], (SvTAIL(must) ? "$" : "")));
 666             if (!s) {
 667                 if (last1 == last) {
 668                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 669                                             ", giving up...\n"));
 670                     goto fail_finish;
 671                 }
 672                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 673                     ", trying anchored starting at offset %ld...\n",
 674                     (long)(s1 + 1 - i_strpos)));
 675                 other_last = last;
 676                 s = HOP3c(t, 1, strend);
 677                 goto restart;
 678             }
 679             else {
 680                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 681                       (long)(s - i_strpos)));
 682                 other_last = s; /* Fix this later. --Hugo */
 683                 s = s1;
 684                 if (t == strpos)
 685                     goto try_at_start;
 686                 goto try_at_offset;
 687             }
 688         }
 689     }
 690
 691     t = s - prog->check_offset_max;
 692     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 693         && (!do_utf8
 694             || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*)strpos))
 695                  && t > strpos))) {
 696         /* Fixed substring is found far enough so that the match
 697            cannot start at strpos. */
 698       try_at_offset:
 699         if (ml_anch && t[-1] != '\n') {
 700             /* Eventually fbm_*() should handle this, but often
 701                anchored_offset is not 0, so this check will not be wasted. */
 702             /* XXXX In the code below we prefer to look for "^" even in
 703                presence of anchored substrings.  And we search even
 704                beyond the found float position.  These pessimizations
 705                are historical artefacts only.  */
 706           find_anchor:
 707             while (t < strend - prog->minlen) {
 708                 if (*t == '\n') {
 709                     if (t < check_at - prog->check_offset_min) {
 710                         if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
 711                             /* Since we moved from the found position,
 712                                we definitely contradict the found anchored
 713                                substr.  Due to the above check we do not
 714                                contradict "check" substr.
 715                                Thus we can arrive here only if check substr
 716                                is float.  Redo checking for "other"=="fixed".
 717                              */
 718                             strpos = t + 1;
 719                             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
 720                                 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
 721                             goto do_other_anchored;
 722                         }
 723                         /* We don't contradict the found floating substring. */
 724                         /* XXXX Why not check for STCLASS? */
 725                         s = t + 1;
 726                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
 727                             PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
 728                         goto set_useful;
 729                     }
 730                     /* Position contradicts check-string */
 731                     /* XXXX probably better to look for check-string
 732                        than for "\n", so one should lower the limit for t? */
 733                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
 734                         PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
 735                     other_last = strpos = s = t + 1;
 736                     goto restart;
 737                 }
 738                 t++;
 739             }
 740             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
 741                         PL_colors[0], PL_colors[1]));
 742             goto fail_finish;
 743         }
 744         else {
 745             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
 746                         PL_colors[0], PL_colors[1]));
 747         }
 748         s = t;
 749       set_useful:
 750         ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr);    /* hooray/5 */
 751     }
 752     else {
 753         /* The found string does not prohibit matching at strpos,
 754            - no optimization of calling REx engine can be performed,
 755            unless it was an MBOL and we are not after MBOL,
 756            or a future STCLASS check will fail this. */
 757       try_at_start:
 758         /* Even in this situation we may use MBOL flag if strpos is offset
 759            wrt the start of the string. */
 760         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
 761             && (strpos != strbeg) && strpos[-1] != '\n'
 762             /* May be due to an implicit anchor of m{.*foo}  */
 763             && !(prog->reganch & ROPT_IMPLICIT))
 764         {
 765             t = strpos;
 766             goto find_anchor;
 767         }
 768         DEBUG_EXECUTE_r( if (ml_anch)
 769             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
 770                         (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
 771         );
 772       success_at_start:
 773         if (!(prog->reganch & ROPT_NAUGHTY)     /* XXXX If strpos moved? */
 774             && (do_utf8 ? (
 775                 prog->check_utf8                /* Could be deleted already */
 776                 && --BmUSEFUL(prog->check_utf8) < 0
 777                 && (prog->check_utf8 == prog->float_utf8)
 778             ) : (
 779                 prog->check_substr              /* Could be deleted already */
 780                 && --BmUSEFUL(prog->check_substr) < 0
 781                 && (prog->check_substr == prog->float_substr)
 782             )))
 783         {
 784             /* If flags & SOMETHING - do not do it many times on the same match */
 785             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
 786             SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
 787             if (do_utf8 ? prog->check_substr : prog->check_utf8)
 788                 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
 789             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
 790             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
 791             check = NULL;                       /* abort */
 792             s = strpos;
 793             /* XXXX This is a remnant of the old implementation.  It
 794                     looks wasteful, since now INTUIT can use many
 795                     other heuristics. */
 796             prog->reganch &= ~RE_USE_INTUIT;
 797         }
 798         else
 799             s = strpos;
 800     }
 801
 802     /* Last resort... */
 803     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
 804     if (prog->regstclass) {
 805         /* minlen == 0 is possible if regstclass is \b or \B,
 806            and the fixed substr is ''$.
 807            Since minlen is already taken into account, s+1 is before strend;
 808            accidentally, minlen >= 1 guaranties no false positives at s + 1
 809            even for \b or \B.  But (minlen? 1 : 0) below assumes that
 810            regstclass does not come from lookahead...  */
 811         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
 812            This leaves EXACTF only, which is dealt with in find_byclass().  */
 813         const U8* const str = (U8*)STRING(prog->regstclass);
 814         const int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT
 815                     ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
 816                     : 1);
 817         const char * const endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
 818                 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
 819                 : (prog->float_substr || prog->float_utf8
 820                    ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
 821                            cl_l, strend)
 822                    : strend);
 823
 824         t = s;
 825         s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
 826         if (!s) {
 827 #ifdef DEBUGGING
 828             const char *what = NULL;
 829 #endif
 830             if (endpos == strend) {
 831                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 832                                 "Could not match STCLASS...\n") );
 833                 goto fail;
 834             }
 835             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 836                                    "This position contradicts STCLASS...\n") );
 837             if ((prog->reganch & ROPT_ANCH) && !ml_anch)
 838                 goto fail;
 839             /* Contradict one of substrings */
 840             if (prog->anchored_substr || prog->anchored_utf8) {
 841                 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
 842                     DEBUG_EXECUTE_r( what = "anchored" );
 843                   hop_and_restart:
 844                     s = HOP3c(t, 1, strend);
 845                     if (s + start_shift + end_shift > strend) {
 846                         /* XXXX Should be taken into account earlier? */
 847                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 848                                                "Could not match STCLASS...\n") );
 849                         goto fail;
 850                     }
 851                     if (!check)
 852                         goto giveup;
 853                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 854                                 "Looking for %s substr starting at offset %ld...\n",
 855                                  what, (long)(s + start_shift - i_strpos)) );
 856                     goto restart;
 857                 }
 858                 /* Have both, check_string is floating */
 859                 if (t + start_shift >= check_at) /* Contradicts floating=check */
 860                     goto retry_floating_check;
 861                 /* Recheck anchored substring, but not floating... */
 862                 s = check_at;
 863                 if (!check)
 864                     goto giveup;
 865                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 866                           "Looking for anchored substr starting at offset %ld...\n",
 867                           (long)(other_last - i_strpos)) );
 868                 goto do_other_anchored;
 869             }
 870             /* Another way we could have checked stclass at the
 871                current position only: */
 872             if (ml_anch) {
 873                 s = t = t + 1;
 874                 if (!check)
 875                     goto giveup;
 876                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 877                           "Looking for /%s^%s/m starting at offset %ld...\n",
 878                           PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
 879                 goto try_at_offset;
 880             }
 881             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))     /* Could have been deleted */
 882                 goto fail;
 883             /* Check is floating subtring. */
 884           retry_floating_check:
 885             t = check_at - start_shift;
 886             DEBUG_EXECUTE_r( what = "floating" );
 887             goto hop_and_restart;
 888         }
 889         if (t != s) {
 890             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 891                         "By STCLASS: moving %ld --> %ld\n",
 892                                   (long)(t - i_strpos), (long)(s - i_strpos))
 893                    );
 894         }
 895         else {
 896             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 897                                   "Does not contradict STCLASS...\n");
 898                    );
 899         }
 900     }
 901   giveup:
 902     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
 903                           PL_colors[4], (check ? "Guessed" : "Giving up"),
 904                           PL_colors[5], (long)(s - i_strpos)) );
 905     return s;
 906
 907   fail_finish:                          /* Substring not found */
 908     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
 909         BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
 910   fail:
 911     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
 912                           PL_colors[4], PL_colors[5]));
 913     return NULL;
 914 }
 915
 916 /* We know what class REx starts with.  Try to find this position... */
 917 /* if reginfo is NULL, its a dryrun */
 918
 919 STATIC char *
 920 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char
 921 *strend, const regmatch_info *reginfo)
 922 {
 923         dVAR;
 924         const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
 925         char *m;
 926         STRLEN ln;
 927         STRLEN lnc;
 928         register STRLEN uskip;
 929         unsigned int c1;
 930         unsigned int c2;
 931         char *e;
 932         register I32 tmp = 1;   /* Scratch variable? */
 933         register const bool do_utf8 = PL_reg_match_utf8;
 934
 935         /* We know what class it must start with. */
 936         switch (OP(c)) {
 937         case ANYOF:
 938             if (do_utf8) {
 939                  while (s + (uskip = UTF8SKIP(s)) <= strend) {
 940                       if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
 941                           !UTF8_IS_INVARIANT((U8)s[0]) ?
 942                           reginclass(prog, c, (U8*)s, 0, do_utf8) :
 943                           REGINCLASS(prog, c, (U8*)s)) {
 944                            if (tmp && (!reginfo || regtry(reginfo, s)))
 945                                 goto got_it;
 946                            else
 947                                 tmp = doevery;
 948                       }
 949                       else
 950                            tmp = 1;
 951                       s += uskip;
 952                  }
 953             }
 954             else {
 955                  while (s < strend) {
 956                       STRLEN skip = 1;
 957
 958                       if (REGINCLASS(prog, c, (U8*)s) ||
 959                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
 960                            /* The assignment of 2 is intentional:
 961                             * for the folded sharp s, the skip is 2. */
 962                            (skip = SHARP_S_SKIP))) {
 963                            if (tmp && (!reginfo || regtry(reginfo, s)))
 964                                 goto got_it;
 965                            else
 966                                 tmp = doevery;
 967                       }
 968                       else
 969                            tmp = 1;
 970                       s += skip;
 971                  }
 972             }
 973             break;
 974         case CANY:
 975             while (s < strend) {
 976                 if (tmp && (!reginfo || regtry(reginfo, s)))
 977                     goto got_it;
 978                 else
 979                     tmp = doevery;
 980                 s++;
 981             }
 982             break;
 983         case EXACTF:
 984             m   = STRING(c);
 985             ln  = STR_LEN(c);   /* length to match in octets/bytes */
 986             lnc = (I32) ln;     /* length to match in characters */
 987             if (UTF) {
 988                 STRLEN ulen1, ulen2;
 989                 U8 *sm = (U8 *) m;
 990                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
 991                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
 992                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
 993
 994                 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
 995                 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
 996
 997                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
 998                                     0, uniflags);
 999                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1000                                     0, uniflags);
1001                 lnc = 0;
1002                 while (sm < ((U8 *) m + ln)) {
1003                     lnc++;
1004                     sm += UTF8SKIP(sm);
1005                 }
1006             }
1007             else {
1008                 c1 = *(U8*)m;
1009                 c2 = PL_fold[c1];
1010             }
1011             goto do_exactf;
1012         case EXACTFL:
1013             m   = STRING(c);
1014             ln  = STR_LEN(c);
1015             lnc = (I32) ln;
1016             c1 = *(U8*)m;
1017             c2 = PL_fold_locale[c1];
1018           do_exactf:
1019             e = HOP3c(strend, -((I32)lnc), s);
1020
1021             if (!reginfo && e < s)
1022                 e = s;                  /* Due to minlen logic of intuit() */
1023
1024             /* The idea in the EXACTF* cases is to first find the
1025              * first character of the EXACTF* node and then, if
1026              * necessary, case-insensitively compare the full
1027              * text of the node.  The c1 and c2 are the first
1028              * characters (though in Unicode it gets a bit
1029              * more complicated because there are more cases
1030              * than just upper and lower: one needs to use
1031              * the so-called folding case for case-insensitive
1032              * matching (called "loose matching" in Unicode).
1033              * ibcmp_utf8() will do just that. */
1034
1035             if (do_utf8) {
1036                 UV c, f;
1037                 U8 tmpbuf [UTF8_MAXBYTES+1];
1038                 STRLEN len, foldlen;
1039                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1040                 if (c1 == c2) {
1041                     /* Upper and lower of 1st char are equal -
1042                      * probably not a "letter". */
1043                     while (s <= e) {
1044                         c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1045                                            uniflags);
1046                         if ( c == c1
1047                              && (ln == len ||
1048                                  ibcmp_utf8(s, (char **)0, 0,  do_utf8,
1049                                             m, (char **)0, ln, (bool)UTF))
1050                              && (!reginfo || regtry(reginfo, s)) )
1051                             goto got_it;
1052                         else {
1053                              U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1054                              uvchr_to_utf8(tmpbuf, c);
1055                              f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1056                              if ( f != c
1057                                   && (f == c1 || f == c2)
1058                                   && (ln == foldlen ||
1059                                       !ibcmp_utf8((char *) foldbuf,
1060                                                   (char **)0, foldlen, do_utf8,
1061                                                   m,
1062                                                   (char **)0, ln, (bool)UTF))
1063                                   && (!reginfo || regtry(reginfo, s)) )
1064                                   goto got_it;
1065                         }
1066                         s += len;
1067                     }
1068                 }
1069                 else {
1070                     while (s <= e) {
1071                       c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1072                                            uniflags);
1073
1074                         /* Handle some of the three Greek sigmas cases.
1075                          * Note that not all the possible combinations
1076                          * are handled here: some of them are handled
1077                          * by the standard folding rules, and some of
1078                          * them (the character class or ANYOF cases)
1079                          * are handled during compiletime in
1080                          * regexec.c:S_regclass(). */
1081                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1082                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1083                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1084
1085                         if ( (c == c1 || c == c2)
1086                              && (ln == len ||
1087                                  ibcmp_utf8(s, (char **)0, 0,  do_utf8,
1088                                             m, (char **)0, ln, (bool)UTF))
1089                              && (!reginfo || regtry(reginfo, s)) )
1090                             goto got_it;
1091                         else {
1092                              U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1093                              uvchr_to_utf8(tmpbuf, c);
1094                              f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1095                              if ( f != c
1096                                   && (f == c1 || f == c2)
1097                                   && (ln == foldlen ||
1098                                       !ibcmp_utf8((char *) foldbuf,
1099                                                   (char **)0, foldlen, do_utf8,
1100                                                   m,
1101                                                   (char **)0, ln, (bool)UTF))
1102                                   && (!reginfo || regtry(reginfo, s)) )
1103                                   goto got_it;
1104                         }
1105                         s += len;
1106                     }
1107                 }
1108             }
1109             else {
1110                 if (c1 == c2)
1111                     while (s <= e) {
1112                         if ( *(U8*)s == c1
1113                              && (ln == 1 || !(OP(c) == EXACTF
1114                                               ? ibcmp(s, m, ln)
1115                                               : ibcmp_locale(s, m, ln)))
1116                              && (!reginfo || regtry(reginfo, s)) )
1117                             goto got_it;
1118                         s++;
1119                     }
1120                 else
1121                     while (s <= e) {
1122                         if ( (*(U8*)s == c1 || *(U8*)s == c2)
1123                              && (ln == 1 || !(OP(c) == EXACTF
1124                                               ? ibcmp(s, m, ln)
1125                                               : ibcmp_locale(s, m, ln)))
1126                              && (!reginfo || regtry(reginfo, s)) )
1127                             goto got_it;
1128                         s++;
1129                     }
1130             }
1131             break;
1132         case BOUNDL:
1133             PL_reg_flags |= RF_tainted;
1134             /* FALL THROUGH */
1135         case BOUND:
1136             if (do_utf8) {
1137                 if (s == PL_bostr)
1138                     tmp = '\n';
1139                 else {
1140                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1141                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1142                 }
1143                 tmp = ((OP(c) == BOUND ?
1144                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1145                 LOAD_UTF8_CHARCLASS_ALNUM();
1146                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1147                     if (tmp == !(OP(c) == BOUND ?
1148                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1149                                  isALNUM_LC_utf8((U8*)s)))
1150                     {
1151                         tmp = !tmp;
1152                         if ((!reginfo || regtry(reginfo, s)))
1153                             goto got_it;
1154                     }
1155                     s += uskip;
1156                 }
1157             }
1158             else {
1159                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1160                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1161                 while (s < strend) {
1162                     if (tmp ==
1163                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1164                         tmp = !tmp;
1165                         if ((!reginfo || regtry(reginfo, s)))
1166                             goto got_it;
1167                     }
1168                     s++;
1169                 }
1170             }
1171             if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, s)))
1172                 goto got_it;
1173             break;
1174         case NBOUNDL:
1175             PL_reg_flags |= RF_tainted;
1176             /* FALL THROUGH */
1177         case NBOUND:
1178             if (do_utf8) {
1179                 if (s == PL_bostr)
1180                     tmp = '\n';
1181                 else {
1182                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1183                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1184                 }
1185                 tmp = ((OP(c) == NBOUND ?
1186                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1187                 LOAD_UTF8_CHARCLASS_ALNUM();
1188                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1189                     if (tmp == !(OP(c) == NBOUND ?
1190                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1191                                  isALNUM_LC_utf8((U8*)s)))
1192                         tmp = !tmp;
1193                     else if ((!reginfo || regtry(reginfo, s)))
1194                         goto got_it;
1195                     s += uskip;
1196                 }
1197             }
1198             else {
1199                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1200                 tmp = ((OP(c) == NBOUND ?
1201                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1202                 while (s < strend) {
1203                     if (tmp ==
1204                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1205                         tmp = !tmp;
1206                     else if ((!reginfo || regtry(reginfo, s)))
1207                         goto got_it;
1208                     s++;
1209                 }
1210             }
1211             if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, s)))
1212                 goto got_it;
1213             break;
1214         case ALNUM:
1215             if (do_utf8) {
1216                 LOAD_UTF8_CHARCLASS_ALNUM();
1217                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1218                     if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1219                         if (tmp && (!reginfo || regtry(reginfo, s)))
1220                             goto got_it;
1221                         else
1222                             tmp = doevery;
1223                     }
1224                     else
1225                         tmp = 1;
1226                     s += uskip;
1227                 }
1228             }
1229             else {
1230                 while (s < strend) {
1231                     if (isALNUM(*s)) {
1232                         if (tmp && (!reginfo || regtry(reginfo, s)))
1233                             goto got_it;
1234                         else
1235                             tmp = doevery;
1236                     }
1237                     else
1238                         tmp = 1;
1239                     s++;
1240                 }
1241             }
1242             break;
1243         case ALNUML:
1244             PL_reg_flags |= RF_tainted;
1245             if (do_utf8) {
1246                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1247                     if (isALNUM_LC_utf8((U8*)s)) {
1248                         if (tmp && (!reginfo || regtry(reginfo, s)))
1249                             goto got_it;
1250                         else
1251                             tmp = doevery;
1252                     }
1253                     else
1254                         tmp = 1;
1255                     s += uskip;
1256                 }
1257             }
1258             else {
1259                 while (s < strend) {
1260                     if (isALNUM_LC(*s)) {
1261                         if (tmp && (!reginfo || regtry(reginfo, s)))
1262                             goto got_it;
1263                         else
1264                             tmp = doevery;
1265                     }
1266                     else
1267                         tmp = 1;
1268                     s++;
1269                 }
1270             }
1271             break;
1272         case NALNUM:
1273             if (do_utf8) {
1274                 LOAD_UTF8_CHARCLASS_ALNUM();
1275                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1276                     if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1277                         if (tmp && (!reginfo || regtry(reginfo, s)))
1278                             goto got_it;
1279                         else
1280                             tmp = doevery;
1281                     }
1282                     else
1283                         tmp = 1;
1284                     s += uskip;
1285                 }
1286             }
1287             else {
1288                 while (s < strend) {
1289                     if (!isALNUM(*s)) {
1290                         if (tmp && (!reginfo || regtry(reginfo, s)))
1291                             goto got_it;
1292                         else
1293                             tmp = doevery;
1294                     }
1295                     else
1296                         tmp = 1;
1297                     s++;
1298                 }
1299             }
1300             break;
1301         case NALNUML:
1302             PL_reg_flags |= RF_tainted;
1303             if (do_utf8) {
1304                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1305                     if (!isALNUM_LC_utf8((U8*)s)) {
1306                         if (tmp && (!reginfo || regtry(reginfo, s)))
1307                             goto got_it;
1308                         else
1309                             tmp = doevery;
1310                     }
1311                     else
1312                         tmp = 1;
1313                     s += uskip;
1314                 }
1315             }
1316             else {
1317                 while (s < strend) {
1318                     if (!isALNUM_LC(*s)) {
1319                         if (tmp && (!reginfo || regtry(reginfo, s)))
1320                             goto got_it;
1321                         else
1322                             tmp = doevery;
1323                     }
1324                     else
1325                         tmp = 1;
1326                     s++;
1327                 }
1328             }
1329             break;
1330         case SPACE:
1331             if (do_utf8) {
1332                 LOAD_UTF8_CHARCLASS_SPACE();
1333                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1334                     if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1335                         if (tmp && (!reginfo || regtry(reginfo, s)))
1336                             goto got_it;
1337                         else
1338                             tmp = doevery;
1339                     }
1340                     else
1341                         tmp = 1;
1342                     s += uskip;
1343                 }
1344             }
1345             else {
1346                 while (s < strend) {
1347                     if (isSPACE(*s)) {
1348                         if (tmp && (!reginfo || regtry(reginfo, s)))
1349                             goto got_it;
1350                         else
1351                             tmp = doevery;
1352                     }
1353                     else
1354                         tmp = 1;
1355                     s++;
1356                 }
1357             }
1358             break;
1359         case SPACEL:
1360             PL_reg_flags |= RF_tainted;
1361             if (do_utf8) {
1362                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1363                     if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1364                         if (tmp && (!reginfo || regtry(reginfo, s)))
1365                             goto got_it;
1366                         else
1367                             tmp = doevery;
1368                     }
1369                     else
1370                         tmp = 1;
1371                     s += uskip;
1372                 }
1373             }
1374             else {
1375                 while (s < strend) {
1376                     if (isSPACE_LC(*s)) {
1377                         if (tmp && (!reginfo || regtry(reginfo, s)))
1378                             goto got_it;
1379                         else
1380                             tmp = doevery;
1381                     }
1382                     else
1383                         tmp = 1;
1384                     s++;
1385                 }
1386             }
1387             break;
1388         case NSPACE:
1389             if (do_utf8) {
1390                 LOAD_UTF8_CHARCLASS_SPACE();
1391                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1392                     if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1393                         if (tmp && (!reginfo || regtry(reginfo, s)))
1394                             goto got_it;
1395                         else
1396                             tmp = doevery;
1397                     }
1398                     else
1399                         tmp = 1;
1400                     s += uskip;
1401                 }
1402             }
1403             else {
1404                 while (s < strend) {
1405                     if (!isSPACE(*s)) {
1406                         if (tmp && (!reginfo || regtry(reginfo, s)))
1407                             goto got_it;
1408                         else
1409                             tmp = doevery;
1410                     }
1411                     else
1412                         tmp = 1;
1413                     s++;
1414                 }
1415             }
1416             break;
1417         case NSPACEL:
1418             PL_reg_flags |= RF_tainted;
1419             if (do_utf8) {
1420                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1421                     if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1422                         if (tmp && (!reginfo || regtry(reginfo, s)))
1423                             goto got_it;
1424                         else
1425                             tmp = doevery;
1426                     }
1427                     else
1428                         tmp = 1;
1429                     s += uskip;
1430                 }
1431             }
1432             else {
1433                 while (s < strend) {
1434                     if (!isSPACE_LC(*s)) {
1435                         if (tmp && (!reginfo || regtry(reginfo, s)))
1436                             goto got_it;
1437                         else
1438                             tmp = doevery;
1439                     }
1440                     else
1441                         tmp = 1;
1442                     s++;
1443                 }
1444             }
1445             break;
1446         case DIGIT:
1447             if (do_utf8) {
1448                 LOAD_UTF8_CHARCLASS_DIGIT();
1449                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1450                     if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1451                         if (tmp && (!reginfo || regtry(reginfo, s)))
1452                             goto got_it;
1453                         else
1454                             tmp = doevery;
1455                     }
1456                     else
1457                         tmp = 1;
1458                     s += uskip;
1459                 }
1460             }
1461             else {
1462                 while (s < strend) {
1463                     if (isDIGIT(*s)) {
1464                         if (tmp && (!reginfo || regtry(reginfo, s)))
1465                             goto got_it;
1466                         else
1467                             tmp = doevery;
1468                     }
1469                     else
1470                         tmp = 1;
1471                     s++;
1472                 }
1473             }
1474             break;
1475         case DIGITL:
1476             PL_reg_flags |= RF_tainted;
1477             if (do_utf8) {
1478                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1479                     if (isDIGIT_LC_utf8((U8*)s)) {
1480                         if (tmp && (!reginfo || regtry(reginfo, s)))
1481                             goto got_it;
1482                         else
1483                             tmp = doevery;
1484                     }
1485                     else
1486                         tmp = 1;
1487                     s += uskip;
1488                 }
1489             }
1490             else {
1491                 while (s < strend) {
1492                     if (isDIGIT_LC(*s)) {
1493                         if (tmp && (!reginfo || regtry(reginfo, s)))
1494                             goto got_it;
1495                         else
1496                             tmp = doevery;
1497                     }
1498                     else
1499                         tmp = 1;
1500                     s++;
1501                 }
1502             }
1503             break;
1504         case NDIGIT:
1505             if (do_utf8) {
1506                 LOAD_UTF8_CHARCLASS_DIGIT();
1507                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1508                     if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1509                         if (tmp && (!reginfo || regtry(reginfo, s)))
1510                             goto got_it;
1511                         else
1512                             tmp = doevery;
1513                     }
1514                     else
1515                         tmp = 1;
1516                     s += uskip;
1517                 }
1518             }
1519             else {
1520                 while (s < strend) {
1521                     if (!isDIGIT(*s)) {
1522                         if (tmp && (!reginfo || regtry(reginfo, s)))
1523                             goto got_it;
1524                         else
1525                             tmp = doevery;
1526                     }
1527                     else
1528                         tmp = 1;
1529                     s++;
1530                 }
1531             }
1532             break;
1533         case NDIGITL:
1534             PL_reg_flags |= RF_tainted;
1535             if (do_utf8) {
1536                 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1537                     if (!isDIGIT_LC_utf8((U8*)s)) {
1538                         if (tmp && (!reginfo || regtry(reginfo, s)))
1539                             goto got_it;
1540                         else
1541                             tmp = doevery;
1542                     }
1543                     else
1544                         tmp = 1;
1545                     s += uskip;
1546                 }
1547             }
1548             else {
1549                 while (s < strend) {
1550                     if (!isDIGIT_LC(*s)) {
1551                         if (tmp && (!reginfo || regtry(reginfo, s)))
1552                             goto got_it;
1553                         else
1554                             tmp = doevery;
1555                     }
1556                     else
1557                         tmp = 1;
1558                     s++;
1559                 }
1560             }
1561             break;
1562         default:
1563             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1564             break;
1565         }
1566         return 0;
1567       got_it:
1568         return s;
1569 }
1570
1571 /*
1572  - regexec_flags - match a regexp against a string
1573  */
1574 I32
1575 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1576               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1577 /* strend: pointer to null at end of string */
1578 /* strbeg: real beginning of string */
1579 /* minend: end of match must be >=minend after stringarg. */
1580 /* data: May be used for some additional optimizations. */
1581 /* nosave: For optimizations. */
1582 {
1583     dVAR;
1584     register char *s;
1585     register regnode *c;
1586     register char *startpos = stringarg;
1587     I32 minlen;         /* must match at least this many chars */
1588     I32 dontbother = 0; /* how many characters not to try at end */
1589     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1590     I32 scream_pos = -1;                /* Internal iterator of scream. */
1591     char *scream_olds = NULL;
1592     SV* oreplsv = GvSV(PL_replgv);
1593     const bool do_utf8 = DO_UTF8(sv);
1594     I32 multiline;
1595 #ifdef DEBUGGING
1596     SV* dsv0;
1597     SV* dsv1;
1598 #endif
1599     regmatch_info reginfo;  /* create some info to pass to regtry etc */
1600
1601     GET_RE_DEBUG_FLAGS_DECL;
1602
1603     PERL_UNUSED_ARG(data);
1604
1605     /* Be paranoid... */
1606     if (prog == NULL || startpos == NULL) {
1607         Perl_croak(aTHX_ "NULL regexp parameter");
1608         return 0;
1609     }
1610
1611     multiline = prog->reganch & PMf_MULTILINE;
1612     reginfo.prog = prog;
1613
1614 #ifdef DEBUGGING
1615     dsv0 = PERL_DEBUG_PAD_ZERO(0);
1616     dsv1 = PERL_DEBUG_PAD_ZERO(1);
1617 #endif
1618
1619     RX_MATCH_UTF8_set(prog, do_utf8);
1620
1621     minlen = prog->minlen;
1622     if (strend - startpos < minlen) {
1623         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1624                               "String too short [regexec_flags]...\n"));
1625         goto phooey;
1626     }
1627
1628     /* Check validity of program. */
1629     if (UCHARAT(prog->program) != REG_MAGIC) {
1630         Perl_croak(aTHX_ "corrupted regexp program");
1631     }
1632
1633     PL_reg_flags = 0;
1634     PL_reg_eval_set = 0;
1635     PL_reg_maxiter = 0;
1636
1637     if (prog->reganch & ROPT_UTF8)
1638         PL_reg_flags |= RF_utf8;
1639
1640     /* Mark beginning of line for ^ and lookbehind. */
1641     reginfo.bol = startpos; /* XXX not used ??? */
1642     PL_bostr  = strbeg;
1643     reginfo.sv = sv;
1644
1645     /* Mark end of line for $ (and such) */
1646     PL_regeol = strend;
1647
1648     /* see how far we have to get to not match where we matched before */
1649     reginfo.till = startpos+minend;
1650
1651     /* If there is a "must appear" string, look for it. */
1652     s = startpos;
1653
1654     if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to set reginfo->ganch */
1655         MAGIC *mg;
1656
1657         if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
1658             reginfo.ganch = startpos;
1659         else if (sv && SvTYPE(sv) >= SVt_PVMG
1660                   && SvMAGIC(sv)
1661                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1662                   && mg->mg_len >= 0) {
1663             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
1664             if (prog->reganch & ROPT_ANCH_GPOS) {
1665                 if (s > reginfo.ganch)
1666                     goto phooey;
1667                 s = reginfo.ganch;
1668             }
1669         }
1670         else                            /* pos() not defined */
1671             reginfo.ganch = strbeg;
1672     }
1673
1674     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1675         re_scream_pos_data d;
1676
1677         d.scream_olds = &scream_olds;
1678         d.scream_pos = &scream_pos;
1679         s = re_intuit_start(prog, sv, s, strend, flags, &d);
1680         if (!s) {
1681             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1682             goto phooey;        /* not present */
1683         }
1684     }
1685
1686     DEBUG_EXECUTE_r({
1687         const char * const s0   = UTF
1688             ? pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
1689                           UNI_DISPLAY_REGEX)
1690             : prog->precomp;
1691         const int len0 = UTF ? (int)SvCUR(dsv0) : prog->prelen;
1692         const char * const s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60,
1693                                                UNI_DISPLAY_REGEX) : startpos;
1694         const int len1 = do_utf8 ? (int)SvCUR(dsv1) : strend - startpos;
1695          if (!PL_colorset)
1696              reginitcolors();
1697          PerlIO_printf(Perl_debug_log,
1698                        "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n",
1699                        PL_colors[4], PL_colors[5], PL_colors[0],
1700                        len0, len0, s0,
1701                        PL_colors[1],
1702                        len0 > 60 ? "..." : "",
1703                        PL_colors[0],
1704                        (int)(len1 > 60 ? 60 : len1),
1705                        s1, PL_colors[1],
1706                        (len1 > 60 ? "..." : "")
1707               );
1708     });
1709
1710     /* Simplest case:  anchored match need be tried only once. */
1711     /*  [unless only anchor is BOL and multiline is set] */
1712     if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1713         if (s == startpos && regtry(&reginfo, startpos))
1714             goto got_it;
1715         else if (multiline || (prog->reganch & ROPT_IMPLICIT)
1716                  || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1717         {
1718             char *end;
1719
1720             if (minlen)
1721                 dontbother = minlen - 1;
1722             end = HOP3c(strend, -dontbother, strbeg) - 1;
1723             /* for multiline we only have to try after newlines */
1724             if (prog->check_substr || prog->check_utf8) {
1725                 if (s == startpos)
1726                     goto after_try;
1727                 while (1) {
1728                     if (regtry(&reginfo, s))
1729                         goto got_it;
1730                   after_try:
1731                     if (s >= end)
1732                         goto phooey;
1733                     if (prog->reganch & RE_USE_INTUIT) {
1734                         s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1735                         if (!s)
1736                             goto phooey;
1737                     }
1738                     else
1739                         s++;
1740                 }
1741             } else {
1742                 if (s > startpos)
1743                     s--;
1744                 while (s < end) {
1745                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1746                         if (regtry(&reginfo, s))
1747                             goto got_it;
1748                     }
1749                 }
1750             }
1751         }
1752         goto phooey;
1753     } else if (prog->reganch & ROPT_ANCH_GPOS) {
1754         if (regtry(&reginfo, reginfo.ganch))
1755             goto got_it;
1756         goto phooey;
1757     }
1758
1759     /* Messy cases:  unanchored match. */
1760     if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1761         /* we have /x+whatever/ */
1762         /* it must be a one character string (XXXX Except UTF?) */
1763         char ch;
1764 #ifdef DEBUGGING
1765         int did_match = 0;
1766 #endif
1767         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1768             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1769         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1770
1771         if (do_utf8) {
1772             while (s < strend) {
1773                 if (*s == ch) {
1774                     DEBUG_EXECUTE_r( did_match = 1 );
1775                     if (regtry(&reginfo, s)) goto got_it;
1776                     s += UTF8SKIP(s);
1777                     while (s < strend && *s == ch)
1778                         s += UTF8SKIP(s);
1779                 }
1780                 s += UTF8SKIP(s);
1781             }
1782         }
1783         else {
1784             while (s < strend) {
1785                 if (*s == ch) {
1786                     DEBUG_EXECUTE_r( did_match = 1 );
1787                     if (regtry(&reginfo, s)) goto got_it;
1788                     s++;
1789                     while (s < strend && *s == ch)
1790                         s++;
1791                 }
1792                 s++;
1793             }
1794         }
1795         DEBUG_EXECUTE_r(if (!did_match)
1796                 PerlIO_printf(Perl_debug_log,
1797                                   "Did not find anchored character...\n")
1798                );
1799     }
1800     else if (prog->anchored_substr != NULL
1801               || prog->anchored_utf8 != NULL
1802               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1803                   && prog->float_max_offset < strend - s)) {
1804         SV *must;
1805         I32 back_max;
1806         I32 back_min;
1807         char *last;
1808         char *last1;            /* Last position checked before */
1809 #ifdef DEBUGGING
1810         int did_match = 0;
1811 #endif
1812         if (prog->anchored_substr || prog->anchored_utf8) {
1813             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1814                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1815             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1816             back_max = back_min = prog->anchored_offset;
1817         } else {
1818             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1819                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1820             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1821             back_max = prog->float_max_offset;
1822             back_min = prog->float_min_offset;
1823         }
1824         if (must == &PL_sv_undef)
1825             /* could not downgrade utf8 check substring, so must fail */
1826             goto phooey;
1827
1828         last = HOP3c(strend,    /* Cannot start after this */
1829                           -(I32)(CHR_SVLEN(must)
1830                                  - (SvTAIL(must) != 0) + back_min), strbeg);
1831
1832         if (s > PL_bostr)
1833             last1 = HOPc(s, -1);
1834         else
1835             last1 = s - 1;      /* bogus */
1836
1837         /* XXXX check_substr already used to find "s", can optimize if
1838            check_substr==must. */
1839         scream_pos = -1;
1840         dontbother = end_shift;
1841         strend = HOPc(strend, -dontbother);
1842         while ( (s <= last) &&
1843                 ((flags & REXEC_SCREAM)
1844                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
1845                                     end_shift, &scream_pos, 0))
1846                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
1847                                   (unsigned char*)strend, must,
1848                                   multiline ? FBMrf_MULTILINE : 0))) ) {
1849             /* we may be pointing at the wrong string */
1850             if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
1851                 s = strbeg + (s - SvPVX_const(sv));
1852             DEBUG_EXECUTE_r( did_match = 1 );
1853             if (HOPc(s, -back_max) > last1) {
1854                 last1 = HOPc(s, -back_min);
1855                 s = HOPc(s, -back_max);
1856             }
1857             else {
1858                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1859
1860                 last1 = HOPc(s, -back_min);
1861                 s = t;
1862             }
1863             if (do_utf8) {
1864                 while (s <= last1) {
1865                     if (regtry(&reginfo, s))
1866                         goto got_it;
1867                     s += UTF8SKIP(s);
1868                 }
1869             }
1870             else {
1871                 while (s <= last1) {
1872                     if (regtry(&reginfo, s))
1873                         goto got_it;
1874                     s++;
1875                 }
1876             }
1877         }
1878         DEBUG_EXECUTE_r(if (!did_match)
1879                     PerlIO_printf(Perl_debug_log,
1880                                   "Did not find %s substr \"%s%.*s%s\"%s...\n",
1881                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
1882                                ? "anchored" : "floating"),
1883                               PL_colors[0],
1884                               (int)(SvCUR(must) - (SvTAIL(must)!=0)),
1885                               SvPVX_const(must),
1886                                   PL_colors[1], (SvTAIL(must) ? "$" : ""))
1887                );
1888         goto phooey;
1889     }
1890     else if ((c = prog->regstclass)) {
1891         if (minlen) {
1892             I32 op = (U8)OP(prog->regstclass);
1893             /* don't bother with what can't match */
1894             if (PL_regkind[op] != EXACT && op != CANY)
1895                 strend = HOPc(strend, -(minlen - 1));
1896         }
1897         DEBUG_EXECUTE_r({
1898             SV *prop = sv_newmortal();
1899             const char *s0;
1900             const char *s1;
1901             int len0;
1902             int len1;
1903
1904             regprop(prog, prop, c);
1905             s0 = UTF ?
1906               pv_uni_display(dsv0, (U8*)SvPVX_const(prop), SvCUR(prop), 60,
1907                              UNI_DISPLAY_REGEX) :
1908               SvPVX_const(prop);
1909             len0 = UTF ? SvCUR(dsv0) : SvCUR(prop);
1910             s1 = UTF ?
1911               sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
1912             len1 = UTF ? (int)SvCUR(dsv1) : strend - s;
1913             PerlIO_printf(Perl_debug_log,
1914                           "Matching stclass \"%*.*s\" against \"%*.*s\"\n",
1915                           len0, len0, s0,
1916                           len1, len1, s1);
1917         });
1918         if (find_byclass(prog, c, s, strend, &reginfo))
1919             goto got_it;
1920         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
1921     }
1922     else {
1923         dontbother = 0;
1924         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
1925             /* Trim the end. */
1926             char *last;
1927             SV* float_real;
1928
1929             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1930                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1931             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
1932
1933             if (flags & REXEC_SCREAM) {
1934                 last = screaminstr(sv, float_real, s - strbeg,
1935                                    end_shift, &scream_pos, 1); /* last one */
1936                 if (!last)
1937                     last = scream_olds; /* Only one occurrence. */
1938                 /* we may be pointing at the wrong string */
1939                 else if (RX_MATCH_COPIED(prog))
1940                     s = strbeg + (s - SvPVX_const(sv));
1941             }
1942             else {
1943                 STRLEN len;
1944                 const char * const little = SvPV_const(float_real, len);
1945
1946                 if (SvTAIL(float_real)) {
1947                     if (memEQ(strend - len + 1, little, len - 1))
1948                         last = strend - len + 1;
1949                     else if (!multiline)
1950                         last = memEQ(strend - len, little, len)
1951                             ? strend - len : NULL;
1952                     else
1953                         goto find_last;
1954                 } else {
1955                   find_last:
1956                     if (len)
1957                         last = rninstr(s, strend, little, little + len);
1958                     else
1959                         last = strend;  /* matching "$" */
1960                 }
1961             }
1962             if (last == NULL) {
1963                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1964                                       "%sCan't trim the tail, match fails (should not happen)%s\n",
1965                                       PL_colors[4], PL_colors[5]));
1966                 goto phooey; /* Should not happen! */
1967             }
1968             dontbother = strend - last + prog->float_min_offset;
1969         }
1970         if (minlen && (dontbother < minlen))
1971             dontbother = minlen - 1;
1972         strend -= dontbother;              /* this one's always in bytes! */
1973         /* We don't know much -- general case. */
1974         if (do_utf8) {
1975             for (;;) {
1976                 if (regtry(&reginfo, s))
1977                     goto got_it;
1978                 if (s >= strend)
1979                     break;
1980                 s += UTF8SKIP(s);
1981             };
1982         }
1983         else {
1984             do {
1985                 if (regtry(&reginfo, s))
1986                     goto got_it;
1987             } while (s++ < strend);
1988         }
1989     }
1990
1991     /* Failure. */
1992     goto phooey;
1993
1994 got_it:
1995     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
1996
1997     if (PL_reg_eval_set) {
1998         /* Preserve the current value of $^R */
1999         if (oreplsv != GvSV(PL_replgv))
2000             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2001                                                   restored, the value remains
2002                                                   the same. */
2003         restore_pos(aTHX_ prog);
2004     }
2005
2006     /* make sure $`, $&, $', and $digit will work later */
2007     if ( !(flags & REXEC_NOT_FIRST) ) {
2008         RX_MATCH_COPY_FREE(prog);
2009         if (flags & REXEC_COPY_STR) {
2010             I32 i = PL_regeol - startpos + (stringarg - strbeg);
2011 #ifdef PERL_OLD_COPY_ON_WRITE
2012             if ((SvIsCOW(sv)
2013                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2014                 if (DEBUG_C_TEST) {
2015                     PerlIO_printf(Perl_debug_log,
2016                                   "Copy on write: regexp capture, type %d\n",
2017                                   (int) SvTYPE(sv));
2018                 }
2019                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2020                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2021                 assert (SvPOKp(prog->saved_copy));
2022             } else
2023 #endif
2024             {
2025                 RX_MATCH_COPIED_on(prog);
2026                 s = savepvn(strbeg, i);
2027                 prog->subbeg = s;
2028             }
2029             prog->sublen = i;
2030         }
2031         else {
2032             prog->subbeg = strbeg;
2033             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2034         }
2035     }
2036
2037     return 1;
2038
2039 phooey:
2040     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2041                           PL_colors[4], PL_colors[5]));
2042     if (PL_reg_eval_set)
2043         restore_pos(aTHX_ prog);
2044     return 0;
2045 }
2046
2047 /*
2048  - regtry - try match at specific point
2049  */
2050 STATIC I32                      /* 0 failure, 1 success */
2051 S_regtry(pTHX_ const regmatch_info *reginfo, char *startpos)
2052 {
2053     dVAR;
2054     register I32 *sp;
2055     register I32 *ep;
2056     CHECKPOINT lastcp;
2057     regexp *prog = reginfo->prog;
2058     GET_RE_DEBUG_FLAGS_DECL;
2059
2060 #ifdef DEBUGGING
2061     PL_regindent = 0;   /* XXXX Not good when matches are reenterable... */
2062 #endif
2063     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2064         MAGIC *mg;
2065
2066         PL_reg_eval_set = RS_init;
2067         DEBUG_EXECUTE_r(DEBUG_s(
2068             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2069                           (IV)(PL_stack_sp - PL_stack_base));
2070             ));
2071         SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2072         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2073         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2074         SAVETMPS;
2075         /* Apparently this is not needed, judging by wantarray. */
2076         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2077            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2078
2079         if (reginfo->sv) {
2080             /* Make $_ available to executed code. */
2081             if (reginfo->sv != DEFSV) {
2082                 SAVE_DEFSV;
2083                 DEFSV = reginfo->sv;
2084             }
2085
2086             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2087                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2088                 /* prepare for quick setting of pos */
2089 #ifdef PERL_OLD_COPY_ON_WRITE
2090                 if (SvIsCOW(sv))
2091                     sv_force_normal_flags(sv, 0);
2092 #endif
2093                 mg = sv_magicext(reginfo->sv, (SV*)0, PERL_MAGIC_regex_global,
2094                                  &PL_vtbl_mglob, NULL, 0);
2095                 mg->mg_len = -1;
2096             }
2097             PL_reg_magic    = mg;
2098             PL_reg_oldpos   = mg->mg_len;
2099             SAVEDESTRUCTOR_X(restore_pos, prog);
2100         }
2101         if (!PL_reg_curpm) {
2102             Newxz(PL_reg_curpm, 1, PMOP);
2103 #ifdef USE_ITHREADS
2104             {
2105                 SV* repointer = newSViv(0);
2106                 /* so we know which PL_regex_padav element is PL_reg_curpm */
2107                 SvFLAGS(repointer) |= SVf_BREAK;
2108                 av_push(PL_regex_padav,repointer);
2109                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2110                 PL_regex_pad = AvARRAY(PL_regex_padav);
2111             }
2112 #endif
2113         }
2114         PM_SETRE(PL_reg_curpm, prog);
2115         PL_reg_oldcurpm = PL_curpm;
2116         PL_curpm = PL_reg_curpm;
2117         if (RX_MATCH_COPIED(prog)) {
2118             /*  Here is a serious problem: we cannot rewrite subbeg,
2119                 since it may be needed if this match fails.  Thus
2120                 $` inside (?{}) could fail... */
2121             PL_reg_oldsaved = prog->subbeg;
2122             PL_reg_oldsavedlen = prog->sublen;
2123 #ifdef PERL_OLD_COPY_ON_WRITE
2124             PL_nrs = prog->saved_copy;
2125 #endif
2126             RX_MATCH_COPIED_off(prog);
2127         }
2128         else
2129             PL_reg_oldsaved = NULL;
2130         prog->subbeg = PL_bostr;
2131         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2132     }
2133     prog->startp[0] = startpos - PL_bostr;
2134     PL_reginput = startpos;
2135     PL_regstartp = prog->startp;
2136     PL_regendp = prog->endp;
2137     PL_reglastparen = &prog->lastparen;
2138     PL_reglastcloseparen = &prog->lastcloseparen;
2139     prog->lastparen = 0;
2140     prog->lastcloseparen = 0;
2141     PL_regsize = 0;
2142     DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
2143     if (PL_reg_start_tmpl <= prog->nparens) {
2144         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2145         if(PL_reg_start_tmp)
2146             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2147         else
2148             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2149     }
2150
2151     /* XXXX What this code is doing here?!!!  There should be no need
2152        to do this again and again, PL_reglastparen should take care of
2153        this!  --ilya*/
2154
2155     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2156      * Actually, the code in regcppop() (which Ilya may be meaning by
2157      * PL_reglastparen), is not needed at all by the test suite
2158      * (op/regexp, op/pat, op/split), but that code is needed, oddly
2159      * enough, for building DynaLoader, or otherwise this
2160      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2161      * will happen.  Meanwhile, this code *is* needed for the
2162      * above-mentioned test suite tests to succeed.  The common theme
2163      * on those tests seems to be returning null fields from matches.
2164      * --jhi */
2165 #if 1
2166     sp = prog->startp;
2167     ep = prog->endp;
2168     if (prog->nparens) {
2169         register I32 i;
2170         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2171             *++sp = -1;
2172             *++ep = -1;
2173         }
2174     }
2175 #endif
2176     REGCP_SET(lastcp);
2177     if (regmatch(reginfo, prog->program + 1)) {
2178         prog->endp[0] = PL_reginput - PL_bostr;
2179         return 1;
2180     }
2181     REGCP_UNWIND(lastcp);
2182     return 0;
2183 }
2184
2185 #define RE_UNWIND_BRANCH        1
2186 #define RE_UNWIND_BRANCHJ       2
2187
2188 union re_unwind_t;
2189
2190 typedef struct {                /* XX: makes sense to enlarge it... */
2191     I32 type;
2192     I32 prev;
2193     CHECKPOINT lastcp;
2194 } re_unwind_generic_t;
2195
2196 typedef struct {
2197     I32 type;
2198     I32 prev;
2199     CHECKPOINT lastcp;
2200     I32 lastparen;
2201     regnode *next;
2202     char *locinput;
2203     I32 nextchr;
2204     int minmod;
2205 #ifdef DEBUGGING
2206     int regindent;
2207 #endif
2208 } re_unwind_branch_t;
2209
2210 typedef union re_unwind_t {
2211     I32 type;
2212     re_unwind_generic_t generic;
2213     re_unwind_branch_t branch;
2214 } re_unwind_t;
2215
2216 #define sayYES goto yes
2217 #define sayNO goto no
2218 #define sayNO_ANYOF goto no_anyof
2219 #define sayYES_FINAL goto yes_final
2220 #define sayNO_FINAL  goto no_final
2221 #define sayNO_SILENT goto do_no
2222 #define saySAME(x) if (x) goto yes; else goto no
2223
2224 #define POSCACHE_SUCCESS 0      /* caching success rather than failure */
2225 #define POSCACHE_SEEN 1         /* we know what we're caching */
2226 #define POSCACHE_START 2        /* the real cache: this bit maps to pos 0 */
2227
2228 #define CACHEsayYES STMT_START { \
2229     if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2230         if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2231             PL_reg_poscache[0] |= (1<<POSCACHE_SUCCESS) | (1<<POSCACHE_SEEN); \
2232             PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2233         } \
2234         else if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS)) { \
2235             PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2236         } \
2237         else { \
2238             /* cache records failure, but this is success */ \
2239             DEBUG_r( \
2240                 PerlIO_printf(Perl_debug_log, \
2241                     "%*s  (remove success from failure cache)\n", \
2242                     REPORT_CODE_OFF+PL_regindent*2, "") \
2243             ); \
2244             PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2245         } \
2246     } \
2247     sayYES; \
2248 } STMT_END
2249
2250 #define CACHEsayNO STMT_START { \
2251     if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2252         if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2253             PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2254             PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2255         } \
2256         else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2257             PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2258         } \
2259         else { \
2260             /* cache records success, but this is failure */ \
2261             DEBUG_r( \
2262                 PerlIO_printf(Perl_debug_log, \
2263                     "%*s  (remove failure from success cache)\n", \
2264                     REPORT_CODE_OFF+PL_regindent*2, "") \
2265             ); \
2266             PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2267         } \
2268     } \
2269     sayNO; \
2270 } STMT_END
2271
2272 /* this is used to determine how far from the left messages like
2273    'failed...' are printed. Currently 29 makes these messages line
2274    up with the opcode they refer to. Earlier perls used 25 which
2275    left these messages outdented making reviewing a debug output
2276    quite difficult.
2277 */
2278 #define REPORT_CODE_OFF 29
2279
2280
2281 /* Make sure there is a test for this +1 options in re_tests */
2282 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2283
2284 /* this value indiciates that the c1/c2 "next char" test should be skipped */
2285 #define CHRTEST_VOID -1000
2286
2287 #define SLAB_FIRST(s) (&(s)->states[0])
2288 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2289
2290 /* grab a new slab and return the first slot in it */
2291
2292 STATIC regmatch_state *
2293 S_push_slab(pTHX)
2294 {
2295 #if PERL_VERSION < 9
2296     dMY_CXT;
2297 #endif
2298     regmatch_slab *s = PL_regmatch_slab->next;
2299     if (!s) {
2300         Newx(s, 1, regmatch_slab);
2301         s->prev = PL_regmatch_slab;
2302         s->next = NULL;
2303         PL_regmatch_slab->next = s;
2304     }
2305     PL_regmatch_slab = s;
2306     return SLAB_FIRST(s);
2307 }
2308
2309 /* simulate a recursive call to regmatch */
2310
2311 #define REGMATCH(ns, where) \
2312     st->scan = scan; \
2313     scan = (ns); \
2314     st->resume_state = resume_##where; \
2315     goto start_recurse; \
2316     resume_point_##where:
2317
2318
2319 /* push a new regex state. Set newst to point to it */
2320
2321 #define PUSH_STATE(newst, resume) \
2322     depth++;    \
2323     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "PUSH STATE(%d)\n", depth)); \
2324     st->scan = scan;    \
2325     st->next = next;    \
2326     st->n = n;  \
2327     st->locinput = locinput;    \
2328     st->resume_state = resume;  \
2329     newst = st+1;   \
2330     if (newst >  SLAB_LAST(PL_regmatch_slab)) \
2331         newst = S_push_slab(aTHX);  \
2332     PL_regmatch_state = newst;  \
2333     newst->cc = 0;  \
2334     newst->minmod = 0;  \
2335     newst->sw = 0;  \
2336     newst->logical = 0; \
2337     newst->unwind = 0;  \
2338     locinput = PL_reginput; \
2339     nextchr = UCHARAT(locinput);
2340
2341 #define POP_STATE \
2342     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth)); \
2343     depth--; \
2344     st--; \
2345     if (st < SLAB_FIRST(PL_regmatch_slab)) { \
2346         PL_regmatch_slab = PL_regmatch_slab->prev; \
2347         st = SLAB_LAST(PL_regmatch_slab); \
2348     } \
2349     PL_regmatch_state = st; \
2350     scan        = st->scan; \
2351     next        = st->next; \
2352     n           = st->n; \
2353     locinput    = st->locinput; \
2354     nextchr = UCHARAT(locinput);
2355
2356 /*
2357  - regmatch - main matching routine
2358  *
2359  * Conceptually the strategy is simple:  check to see whether the current
2360  * node matches, call self recursively to see whether the rest matches,
2361  * and then act accordingly.  In practice we make some effort to avoid
2362  * recursion, in particular by going through "ordinary" nodes (that don't
2363  * need to know whether the rest of the match failed) by a loop instead of
2364  * by recursion.
2365  */
2366 /* [lwall] I've hoisted the register declarations to the outer block in order to
2367  * maybe save a little bit of pushing and popping on the stack.  It also takes
2368  * advantage of machines that use a register save mask on subroutine entry.
2369  *
2370  * This function used to be heavily recursive, but since this had the
2371  * effect of blowing the CPU stack on complex regexes, it has been
2372  * restructured to be iterative, and to save state onto the heap rather
2373  * than the stack. Essentially whereever regmatch() used to be called, it
2374  * pushes the current state, notes where to return, then jumps back into
2375  * the main loop.
2376  *
2377  * Originally the structure of this function used to look something like
2378
2379     S_regmatch() {
2380         int a = 1, b = 2;
2381         ...
2382         while (scan != NULL) {
2383             a++; // do stuff with a and b
2384             ...
2385             switch (OP(scan)) {
2386                 case FOO: {
2387                     int local = 3;
2388                     ...
2389                     if (regmatch(...))  // recurse
2390                         goto yes;
2391                 }
2392                 ...
2393             }
2394         }
2395         yes:
2396         return 1;
2397     }
2398
2399  * Now it looks something like this:
2400
2401     typedef struct {
2402         int a, b, local;
2403         int resume_state;
2404     } regmatch_state;
2405
2406     S_regmatch() {
2407         regmatch_state *st = new();
2408         int depth=0;
2409         st->a++; // do stuff with a and b
2410         ...
2411         while (scan != NULL) {
2412             ...
2413             switch (OP(scan)) {
2414                 case FOO: {
2415                     st->local = 3;
2416                     ...
2417                     st->scan = scan;
2418                     scan = ...;
2419                     st->resume_state = resume_FOO;
2420                     goto start_recurse; // recurse
2421
2422                     resume_point_FOO:
2423                     if (result)
2424                         goto yes;
2425                 }
2426                 ...
2427             }
2428           start_recurse:
2429             st = new(); push a new state
2430             st->a = 1; st->b = 2;
2431             depth++;
2432         }
2433       yes:
2434         result = 1;
2435         if (depth--) {
2436             st = pop();
2437             switch (resume_state) {
2438             case resume_FOO:
2439                 goto resume_point_FOO;
2440             ...
2441             }
2442         }
2443         return result
2444     }
2445
2446  * WARNING: this means that any line in this function that contains a
2447  * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2448  * regmatch() using gotos instead. Thus the values of any local variables
2449  * not saved in the regmatch_state structure will have been lost when
2450  * execution resumes on the next line .
2451  *
2452  * States (ie the st pointer) are allocated in slabs of about 4K in size.
2453  * PL_regmatch_state always points to the currently active state, and
2454  * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2455  * The first time regmatch is called, the first slab is allocated, and is
2456  * never freed until interpreter desctruction. When the slab is full,
2457  * a new one is allocated chained to the end. At exit from regmatch, slabs
2458  * allocated since entry are freed.
2459  */
2460
2461
2462 STATIC I32                      /* 0 failure, 1 success */
2463 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2464 {
2465 #if PERL_VERSION < 9
2466     dMY_CXT;
2467 #endif
2468     dVAR;
2469     register const bool do_utf8 = PL_reg_match_utf8;
2470     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2471
2472     regexp *rex = reginfo->prog;
2473
2474     regmatch_slab  *orig_slab;
2475     regmatch_state *orig_state;
2476
2477     /* the current state. This is a cached copy of PL_regmatch_state */
2478     register regmatch_state *st;
2479
2480     /* cache heavy used fields of st in registers */
2481     register regnode *scan;
2482     register regnode *next;
2483     register I32 n = 0; /* initialize to shut up compiler warning */
2484     register char *locinput = PL_reginput;
2485
2486     /* these variables are NOT saved during a recusive RFEGMATCH: */
2487     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2488     bool result;            /* return value of S_regmatch */
2489     regnode *inner;         /* Next node in internal branch. */
2490     int depth = 0;          /* depth of recursion */
2491     regmatch_state *newst;  /* when pushing a state, this is the new one */
2492     regmatch_state *yes_state = NULL; /* state to pop to on success of
2493                                                             subpattern */
2494
2495 #ifdef DEBUGGING
2496     SV *re_debug_flags = NULL;
2497     GET_RE_DEBUG_FLAGS;
2498     PL_regindent++;
2499 #endif
2500
2501     /* on first ever call to regmatch, allocate first slab */
2502     if (!PL_regmatch_slab) {
2503         Newx(PL_regmatch_slab, 1, regmatch_slab);
2504         PL_regmatch_slab->prev = NULL;
2505         PL_regmatch_slab->next = NULL;
2506         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2507     }
2508
2509     /* remember current high-water mark for exit */
2510     /* XXX this should be done with SAVE* instead */
2511     orig_slab  = PL_regmatch_slab;
2512     orig_state = PL_regmatch_state;
2513
2514     /* grab next free state slot */
2515     st = ++PL_regmatch_state;
2516     if (st >  SLAB_LAST(PL_regmatch_slab))
2517         st = PL_regmatch_state = S_push_slab(aTHX);
2518
2519     st->minmod = 0;
2520     st->sw = 0;
2521     st->logical = 0;
2522     st->unwind = 0;
2523     st->cc = NULL;
2524     /* Note that nextchr is a byte even in UTF */
2525     nextchr = UCHARAT(locinput);
2526     scan = prog;
2527     while (scan != NULL) {
2528
2529         DEBUG_EXECUTE_r( {
2530             SV * const prop = sv_newmortal();
2531             const int docolor = *PL_colors[0];
2532             const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2533             int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2534             /* The part of the string before starttry has one color
2535                (pref0_len chars), between starttry and current
2536                position another one (pref_len - pref0_len chars),
2537                after the current position the third one.
2538                We assume that pref0_len <= pref_len, otherwise we
2539                decrease pref0_len.  */
2540             int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2541                 ? (5 + taill) - l : locinput - PL_bostr;
2542             int pref0_len;
2543
2544             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2545                 pref_len++;
2546             pref0_len = pref_len  - (locinput - PL_reg_starttry);
2547             if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2548                 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2549                       ? (5 + taill) - pref_len : PL_regeol - locinput);
2550             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2551                 l--;
2552             if (pref0_len < 0)
2553                 pref0_len = 0;
2554             if (pref0_len > pref_len)
2555                 pref0_len = pref_len;
2556             regprop(rex, prop, scan);
2557             {
2558               const char * const s0 =
2559                 do_utf8 && OP(scan) != CANY ?
2560                 pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
2561                                pref0_len, 60, UNI_DISPLAY_REGEX) :
2562                 locinput - pref_len;
2563               const int len0 = do_utf8 ? (int)strlen(s0) : pref0_len;
2564               const char * const s1 = do_utf8 && OP(scan) != CANY ?
2565                 pv_uni_display(PERL_DEBUG_PAD(1),
2566                                (U8*)(locinput - pref_len + pref0_len),
2567                                pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2568                 locinput - pref_len + pref0_len;
2569               const int len1 = do_utf8 ? (int)strlen(s1) : pref_len - pref0_len;
2570               const char * const s2 = do_utf8 && OP(scan) != CANY ?
2571                 pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
2572                                PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2573                 locinput;
2574               const int len2 = do_utf8 ? (int)strlen(s2) : l;
2575               PerlIO_printf(Perl_debug_log,
2576                             "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2577                             (IV)(locinput - PL_bostr),
2578                             PL_colors[4],
2579                             len0, s0,
2580                             PL_colors[5],
2581                             PL_colors[2],
2582                             len1, s1,
2583                             PL_colors[3],
2584                             (docolor ? "" : "> <"),
2585                             PL_colors[0],
2586                             len2, s2,
2587                             PL_colors[1],
2588                             15 - l - pref_len + 1,
2589                             "",
2590                             (IV)(scan - rex->program), PL_regindent*2, "",
2591                             SvPVX_const(prop));
2592             }
2593         });
2594
2595         next = scan + NEXT_OFF(scan);
2596         if (next == scan)
2597             next = NULL;
2598
2599         switch (OP(scan)) {
2600         case BOL:
2601             if (locinput == PL_bostr)
2602             {
2603                 /* reginfo->till = reginfo->bol; */
2604                 break;
2605             }
2606             sayNO;
2607         case MBOL:
2608             if (locinput == PL_bostr ||
2609                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2610             {
2611                 break;
2612             }
2613             sayNO;
2614         case SBOL:
2615             if (locinput == PL_bostr)
2616                 break;
2617             sayNO;
2618         case GPOS:
2619             if (locinput == reginfo->ganch)
2620                 break;
2621             sayNO;
2622         case EOL:
2623                 goto seol;
2624         case MEOL:
2625             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2626                 sayNO;
2627             break;
2628         case SEOL:
2629           seol:
2630             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2631                 sayNO;
2632             if (PL_regeol - locinput > 1)
2633                 sayNO;
2634             break;
2635         case EOS:
2636             if (PL_regeol != locinput)
2637                 sayNO;
2638             break;
2639         case SANY:
2640             if (!nextchr && locinput >= PL_regeol)
2641                 sayNO;
2642             if (do_utf8) {
2643                 locinput += PL_utf8skip[nextchr];
2644                 if (locinput > PL_regeol)
2645                     sayNO;
2646                 nextchr = UCHARAT(locinput);
2647             }
2648             else
2649                 nextchr = UCHARAT(++locinput);
2650             break;
2651         case CANY:
2652             if (!nextchr && locinput >= PL_regeol)
2653                 sayNO;
2654             nextchr = UCHARAT(++locinput);
2655             break;
2656         case REG_ANY:
2657             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2658                 sayNO;
2659             if (do_utf8) {
2660                 locinput += PL_utf8skip[nextchr];
2661                 if (locinput > PL_regeol)
2662                     sayNO;
2663                 nextchr = UCHARAT(locinput);
2664             }
2665             else
2666                 nextchr = UCHARAT(++locinput);
2667             break;
2668
2669
2670
2671         /*
2672            traverse the TRIE keeping track of all accepting states
2673            we transition through until we get to a failing node.
2674
2675
2676         */
2677         case TRIE:
2678         case TRIEF:
2679         case TRIEFL:
2680             {
2681                 U8 *uc = ( U8* )locinput;
2682                 U32 state = 1;
2683                 U16 charid = 0;
2684                 U32 base = 0;
2685                 UV uvc = 0;
2686                 STRLEN len = 0;
2687                 STRLEN foldlen = 0;
2688                 U8 *uscan = (U8*)NULL;
2689                 STRLEN bufflen=0;
2690                 SV *sv_accept_buff = NULL;
2691                 const enum { trie_plain, trie_utf8, trie_uft8_fold }
2692                     trie_type = do_utf8 ?
2693                           (OP(scan) == TRIE ? trie_utf8 : trie_uft8_fold)
2694                         : trie_plain;
2695
2696                 /* what trie are we using right now */
2697                 reg_trie_data *trie
2698                     = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2699                 st->u.trie.accepted = 0; /* how many accepting states we have seen */
2700                 result = 0;
2701
2702                 while ( state && uc <= (U8*)PL_regeol ) {
2703
2704                     if (trie->states[ state ].wordnum) {
2705                         if (!st->u.trie.accepted ) {
2706                             ENTER;
2707                             SAVETMPS;
2708                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2709                             sv_accept_buff=newSV(bufflen *
2710                                             sizeof(reg_trie_accepted) - 1);
2711                             SvCUR_set(sv_accept_buff,
2712                                                 sizeof(reg_trie_accepted));
2713                             SvPOK_on(sv_accept_buff);
2714                             sv_2mortal(sv_accept_buff);
2715                             st->u.trie.accept_buff =
2716                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2717                         }
2718                         else {
2719                             if (st->u.trie.accepted >= bufflen) {
2720                                 bufflen *= 2;
2721                                 st->u.trie.accept_buff =(reg_trie_accepted*)
2722                                     SvGROW(sv_accept_buff,
2723                                         bufflen * sizeof(reg_trie_accepted));
2724                             }
2725                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2726                                 + sizeof(reg_trie_accepted));
2727                         }
2728                         st->u.trie.accept_buff[st->u.trie.accepted].wordnum = trie->states[state].wordnum;
2729                         st->u.trie.accept_buff[st->u.trie.accepted].endpos = uc;
2730                         ++st->u.trie.accepted;
2731                     }
2732
2733                     base = trie->states[ state ].trans.base;
2734
2735                     DEBUG_TRIE_EXECUTE_r(
2736                                 PerlIO_printf( Perl_debug_log,
2737                                     "%*s  %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2738                                     REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2739                                     (UV)state, (UV)base, (UV)st->u.trie.accepted );
2740                     );
2741
2742                     if ( base ) {
2743                         switch (trie_type) {
2744                         case trie_uft8_fold:
2745                             if ( foldlen>0 ) {
2746                                 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2747                                 foldlen -= len;
2748                                 uscan += len;
2749                                 len=0;
2750                             } else {
2751                                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2752                                 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2753                                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2754                                 foldlen -= UNISKIP( uvc );
2755                                 uscan = foldbuf + UNISKIP( uvc );
2756                             }
2757                             break;
2758                         case trie_utf8:
2759                             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
2760                                                             &len, uniflags );
2761                             break;
2762                         case trie_plain:
2763                             uvc = (UV)*uc;
2764                             len = 1;
2765                         }
2766
2767                         if (uvc < 256) {
2768                             charid = trie->charmap[ uvc ];
2769                         }
2770                         else {
2771                             charid = 0;
2772                             if (trie->widecharmap) {
2773                                 SV** svpp = (SV**)NULL;
2774                                 svpp = hv_fetch(trie->widecharmap,
2775                                             (char*)&uvc, sizeof(UV), 0);
2776                                 if (svpp)
2777                                     charid = (U16)SvIV(*svpp);
2778                             }
2779                         }
2780
2781                         if (charid &&
2782                              (base + charid > trie->uniquecharcount )
2783                              && (base + charid - 1 - trie->uniquecharcount
2784                                     < trie->lasttrans)
2785                              && trie->trans[base + charid - 1 -
2786                                     trie->uniquecharcount].check == state)
2787                         {
2788                             state = trie->trans[base + charid - 1 -
2789                                 trie->uniquecharcount ].next;
2790                         }
2791                         else {
2792                             state = 0;
2793                         }
2794                         uc += len;
2795
2796                     }
2797                     else {
2798                         state = 0;
2799                     }
2800                     DEBUG_TRIE_EXECUTE_r(
2801                         PerlIO_printf( Perl_debug_log,
2802                             "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
2803                             charid, uvc, (UV)state, PL_colors[5] );
2804                     );
2805                 }
2806                 if (!st->u.trie.accepted )
2807                    sayNO;
2808
2809             /*
2810                There was at least one accepting state that we
2811                transitioned through. Presumably the number of accepting
2812                states is going to be low, typically one or two. So we
2813                simply scan through to find the one with lowest wordnum.
2814                Once we find it, we swap the last state into its place
2815                and decrement the size. We then try to match the rest of
2816                the pattern at the point where the word ends, if we
2817                succeed then we end the loop, otherwise the loop
2818                eventually terminates once all of the accepting states
2819                have been tried.
2820             */
2821
2822                 if ( st->u.trie.accepted == 1 ) {
2823                     DEBUG_EXECUTE_r({
2824                         SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ 0 ].wordnum-1, 0 );
2825                         PerlIO_printf( Perl_debug_log,
2826                             "%*s  %sonly one match : #%d <%s>%s\n",
2827                             REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2828                             st->u.trie.accept_buff[ 0 ].wordnum,
2829                             tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2830                             PL_colors[5] );
2831                     });
2832                     PL_reginput = (char *)st->u.trie.accept_buff[ 0 ].endpos;
2833                     /* in this case we free tmps/leave before we call regmatch
2834                        as we wont be using accept_buff again. */
2835                     FREETMPS;
2836                     LEAVE;
2837                     REGMATCH(scan + NEXT_OFF(scan), TRIE1);
2838                     /*** all unsaved local vars undefined at this point */
2839                 } else {
2840                     DEBUG_EXECUTE_r(
2841                         PerlIO_printf( Perl_debug_log,"%*s  %sgot %"IVdf" possible matches%s\n",
2842                             REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], (IV)st->u.trie.accepted,
2843                             PL_colors[5] );
2844                     );
2845                     while ( !result && st->u.trie.accepted-- ) {
2846                         U32 best = 0;
2847                         U32 cur;
2848                         for( cur = 1 ; cur <= st->u.trie.accepted ; cur++ ) {
2849                             DEBUG_TRIE_EXECUTE_r(
2850                                 PerlIO_printf( Perl_debug_log,
2851                                     "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
2852                                     REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2853                                     (IV)best, st->u.trie.accept_buff[ best ].wordnum, (IV)cur,
2854                                     st->u.trie.accept_buff[ cur ].wordnum, PL_colors[5] );
2855                             );
2856
2857                             if (st->u.trie.accept_buff[cur].wordnum <
2858                                     st->u.trie.accept_buff[best].wordnum)
2859                                 best = cur;
2860                         }
2861                         DEBUG_EXECUTE_r({
2862                             reg_trie_data * const trie = (reg_trie_data*)
2863                                             rex->data->data[ARG(scan)];
2864                             SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ best ].wordnum - 1, 0 );
2865                             PerlIO_printf( Perl_debug_log, "%*s  %strying alternation #%d <%s> at 0x%p%s\n",
2866                                 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2867                                 st->u.trie.accept_buff[best].wordnum,
2868                                 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", (void*)scan,
2869                                 PL_colors[5] );
2870                         });
2871                         if ( best<st->u.trie.accepted ) {
2872                             reg_trie_accepted tmp = st->u.trie.accept_buff[ best ];
2873                             st->u.trie.accept_buff[ best ] = st->u.trie.accept_buff[ st->u.trie.accepted ];
2874                             st->u.trie.accept_buff[ st->u.trie.accepted ] = tmp;
2875                             best = st->u.trie.accepted;
2876                         }
2877                         PL_reginput = (char *)st->u.trie.accept_buff[ best ].endpos;
2878
2879                         /*
2880                            as far as I can tell we only need the SAVETMPS/FREETMPS
2881                            for re's with EVAL in them but I'm leaving them in for
2882                            all until I can be sure.
2883                          */
2884                         SAVETMPS;
2885                         REGMATCH(scan + NEXT_OFF(scan), TRIE2);
2886                         /*** all unsaved local vars undefined at this point */
2887                         FREETMPS;
2888                     }
2889                     FREETMPS;
2890                     LEAVE;
2891                 }
2892
2893                 if (result) {
2894                     sayYES;
2895                 } else {
2896                     sayNO;
2897                 }
2898             }
2899             /* unreached codepoint */
2900         case EXACT: {
2901             char *s = STRING(scan);
2902             st->ln = STR_LEN(scan);
2903             if (do_utf8 != UTF) {
2904                 /* The target and the pattern have differing utf8ness. */
2905                 char *l = locinput;
2906                 const char *e = s + st->ln;
2907
2908                 if (do_utf8) {
2909                     /* The target is utf8, the pattern is not utf8. */
2910                     while (s < e) {
2911                         STRLEN ulen;
2912                         if (l >= PL_regeol)
2913                              sayNO;
2914                         if (NATIVE_TO_UNI(*(U8*)s) !=
2915                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
2916                                             uniflags))
2917                              sayNO;
2918                         l += ulen;
2919                         s ++;
2920                     }
2921                 }
2922                 else {
2923                     /* The target is not utf8, the pattern is utf8. */
2924                     while (s < e) {
2925                         STRLEN ulen;
2926                         if (l >= PL_regeol)
2927                             sayNO;
2928                         if (NATIVE_TO_UNI(*((U8*)l)) !=
2929                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
2930                                            uniflags))
2931                             sayNO;
2932                         s += ulen;
2933                         l ++;
2934                     }
2935                 }
2936                 locinput = l;
2937                 nextchr = UCHARAT(locinput);
2938                 break;
2939             }
2940             /* The target and the pattern have the same utf8ness. */
2941             /* Inline the first character, for speed. */
2942             if (UCHARAT(s) != nextchr)
2943                 sayNO;
2944             if (PL_regeol - locinput < st->ln)
2945                 sayNO;
2946             if (st->ln > 1 && memNE(s, locinput, st->ln))
2947                 sayNO;
2948             locinput += st->ln;
2949             nextchr = UCHARAT(locinput);
2950             break;
2951             }
2952         case EXACTFL:
2953             PL_reg_flags |= RF_tainted;
2954             /* FALL THROUGH */
2955         case EXACTF: {
2956             char *s = STRING(scan);
2957             st->ln = STR_LEN(scan);
2958
2959             if (do_utf8 || UTF) {
2960               /* Either target or the pattern are utf8. */
2961                 char *l = locinput;
2962                 char *e = PL_regeol;
2963
2964                 if (ibcmp_utf8(s, 0,  st->ln, (bool)UTF,
2965                                l, &e, 0,  do_utf8)) {
2966                      /* One more case for the sharp s:
2967                       * pack("U0U*", 0xDF) =~ /ss/i,
2968                       * the 0xC3 0x9F are the UTF-8
2969                       * byte sequence for the U+00DF. */
2970                      if (!(do_utf8 &&
2971                            toLOWER(s[0]) == 's' &&
2972                            st->ln >= 2 &&
2973                            toLOWER(s[1]) == 's' &&
2974                            (U8)l[0] == 0xC3 &&
2975                            e - l >= 2 &&
2976                            (U8)l[1] == 0x9F))
2977                           sayNO;
2978                 }
2979                 locinput = e;
2980                 nextchr = UCHARAT(locinput);
2981                 break;
2982             }
2983
2984             /* Neither the target and the pattern are utf8. */
2985
2986             /* Inline the first character, for speed. */
2987             if (UCHARAT(s) != nextchr &&
2988                 UCHARAT(s) != ((OP(scan) == EXACTF)
2989                                ? PL_fold : PL_fold_locale)[nextchr])
2990                 sayNO;
2991             if (PL_regeol - locinput < st->ln)
2992                 sayNO;
2993             if (st->ln > 1 && (OP(scan) == EXACTF
2994                            ? ibcmp(s, locinput, st->ln)
2995                            : ibcmp_locale(s, locinput, st->ln)))
2996                 sayNO;
2997             locinput += st->ln;
2998             nextchr = UCHARAT(locinput);
2999             break;
3000             }
3001         case ANYOF:
3002             if (do_utf8) {
3003                 STRLEN inclasslen = PL_regeol - locinput;
3004
3005                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3006                     sayNO_ANYOF;
3007                 if (locinput >= PL_regeol)
3008                     sayNO;
3009                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3010                 nextchr = UCHARAT(locinput);
3011                 break;
3012             }
3013             else {
3014                 if (nextchr < 0)
3015                     nextchr = UCHARAT(locinput);
3016                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3017                     sayNO_ANYOF;
3018                 if (!nextchr && locinput >= PL_regeol)
3019                     sayNO;
3020                 nextchr = UCHARAT(++locinput);
3021                 break;
3022             }
3023         no_anyof:
3024             /* If we might have the case of the German sharp s
3025              * in a casefolding Unicode character class. */
3026
3027             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3028                  locinput += SHARP_S_SKIP;
3029                  nextchr = UCHARAT(locinput);
3030             }
3031             else
3032                  sayNO;
3033             break;
3034         case ALNUML:
3035             PL_reg_flags |= RF_tainted;
3036             /* FALL THROUGH */
3037         case ALNUM:
3038             if (!nextchr)
3039                 sayNO;
3040             if (do_utf8) {
3041                 LOAD_UTF8_CHARCLASS_ALNUM();
3042                 if (!(OP(scan) == ALNUM
3043                       ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3044                       : isALNUM_LC_utf8((U8*)locinput)))
3045                 {
3046                     sayNO;
3047                 }
3048                 locinput += PL_utf8skip[nextchr];
3049                 nextchr = UCHARAT(locinput);
3050                 break;
3051             }
3052             if (!(OP(scan) == ALNUM
3053                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3054                 sayNO;
3055             nextchr = UCHARAT(++locinput);
3056             break;
3057         case NALNUML:
3058             PL_reg_flags |= RF_tainted;
3059             /* FALL THROUGH */
3060         case NALNUM:
3061             if (!nextchr && locinput >= PL_regeol)
3062                 sayNO;
3063             if (do_utf8) {
3064                 LOAD_UTF8_CHARCLASS_ALNUM();
3065                 if (OP(scan) == NALNUM
3066                     ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3067                     : isALNUM_LC_utf8((U8*)locinput))
3068                 {
3069                     sayNO;
3070                 }
3071                 locinput += PL_utf8skip[nextchr];
3072                 nextchr = UCHARAT(locinput);
3073                 break;
3074             }
3075             if (OP(scan) == NALNUM
3076                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3077                 sayNO;
3078             nextchr = UCHARAT(++locinput);
3079             break;
3080         case BOUNDL:
3081         case NBOUNDL:
3082             PL_reg_flags |= RF_tainted;
3083             /* FALL THROUGH */
3084         case BOUND:
3085         case NBOUND:
3086             /* was last char in word? */
3087             if (do_utf8) {
3088                 if (locinput == PL_bostr)
3089                     st->ln = '\n';
3090                 else {
3091                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3092
3093                     st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3094                 }
3095                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3096                     st->ln = isALNUM_uni(st->ln);
3097                     LOAD_UTF8_CHARCLASS_ALNUM();
3098                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3099                 }
3100                 else {
3101                     st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3102                     n = isALNUM_LC_utf8((U8*)locinput);
3103                 }
3104             }
3105             else {
3106                 st->ln = (locinput != PL_bostr) ?
3107                     UCHARAT(locinput - 1) : '\n';
3108                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3109                     st->ln = isALNUM(st->ln);
3110                     n = isALNUM(nextchr);
3111                 }
3112                 else {
3113                     st->ln = isALNUM_LC(st->ln);
3114                     n = isALNUM_LC(nextchr);
3115                 }
3116             }
3117             if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3118                                     OP(scan) == BOUNDL))
3119                     sayNO;
3120             break;
3121         case SPACEL:
3122             PL_reg_flags |= RF_tainted;
3123             /* FALL THROUGH */
3124         case SPACE:
3125             if (!nextchr)
3126                 sayNO;
3127             if (do_utf8) {
3128                 if (UTF8_IS_CONTINUED(nextchr)) {
3129                     LOAD_UTF8_CHARCLASS_SPACE();
3130                     if (!(OP(scan) == SPACE
3131                           ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3132                           : isSPACE_LC_utf8((U8*)locinput)))
3133                     {
3134                         sayNO;
3135                     }
3136                     locinput += PL_utf8skip[nextchr];
3137                     nextchr = UCHARAT(locinput);
3138                     break;
3139                 }
3140                 if (!(OP(scan) == SPACE
3141                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3142                     sayNO;
3143                 nextchr = UCHARAT(++locinput);
3144             }
3145             else {
3146                 if (!(OP(scan) == SPACE
3147                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3148                     sayNO;
3149                 nextchr = UCHARAT(++locinput);
3150             }
3151             break;
3152         case NSPACEL:
3153             PL_reg_flags |= RF_tainted;
3154             /* FALL THROUGH */
3155         case NSPACE:
3156             if (!nextchr && locinput >= PL_regeol)
3157                 sayNO;
3158             if (do_utf8) {
3159                 LOAD_UTF8_CHARCLASS_SPACE();
3160                 if (OP(scan) == NSPACE
3161                     ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3162                     : isSPACE_LC_utf8((U8*)locinput))
3163                 {
3164                     sayNO;
3165                 }
3166                 locinput += PL_utf8skip[nextchr];
3167                 nextchr = UCHARAT(locinput);
3168                 break;
3169             }
3170             if (OP(scan) == NSPACE
3171                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3172                 sayNO;
3173             nextchr = UCHARAT(++locinput);
3174             break;
3175         case DIGITL:
3176             PL_reg_flags |= RF_tainted;
3177             /* FALL THROUGH */
3178         case DIGIT:
3179             if (!nextchr)
3180                 sayNO;
3181             if (do_utf8) {
3182                 LOAD_UTF8_CHARCLASS_DIGIT();
3183                 if (!(OP(scan) == DIGIT
3184                       ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3185                       : isDIGIT_LC_utf8((U8*)locinput)))
3186                 {
3187                     sayNO;
3188                 }
3189                 locinput += PL_utf8skip[nextchr];
3190                 nextchr = UCHARAT(locinput);
3191                 break;
3192             }
3193             if (!(OP(scan) == DIGIT
3194                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3195                 sayNO;
3196             nextchr = UCHARAT(++locinput);
3197             break;
3198         case NDIGITL:
3199             PL_reg_flags |= RF_tainted;
3200             /* FALL THROUGH */
3201         case NDIGIT:
3202             if (!nextchr && locinput >= PL_regeol)
3203                 sayNO;
3204             if (do_utf8) {
3205                 LOAD_UTF8_CHARCLASS_DIGIT();
3206                 if (OP(scan) == NDIGIT
3207                     ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3208                     : isDIGIT_LC_utf8((U8*)locinput))
3209                 {
3210                     sayNO;
3211                 }
3212                 locinput += PL_utf8skip[nextchr];
3213                 nextchr = UCHARAT(locinput);
3214                 break;
3215             }
3216             if (OP(scan) == NDIGIT
3217                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3218                 sayNO;
3219             nextchr = UCHARAT(++locinput);
3220             break;
3221         case CLUMP:
3222             if (locinput >= PL_regeol)
3223                 sayNO;
3224             if  (do_utf8) {
3225                 LOAD_UTF8_CHARCLASS_MARK();
3226                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3227                     sayNO;
3228                 locinput += PL_utf8skip[nextchr];
3229                 while (locinput < PL_regeol &&
3230                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3231                     locinput += UTF8SKIP(locinput);
3232                 if (locinput > PL_regeol)
3233                     sayNO;
3234             }
3235             else
3236                locinput++;
3237             nextchr = UCHARAT(locinput);
3238             break;
3239         case REFFL:
3240             PL_reg_flags |= RF_tainted;
3241             /* FALL THROUGH */
3242         case REF:
3243         case REFF: {
3244             char *s;
3245             n = ARG(scan);  /* which paren pair */
3246             st->ln = PL_regstartp[n];
3247             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3248             if ((I32)*PL_reglastparen < n || st->ln == -1)
3249                 sayNO;                  /* Do not match unless seen CLOSEn. */
3250             if (st->ln == PL_regendp[n])
3251                 break;
3252
3253             s = PL_bostr + st->ln;
3254             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
3255                 char *l = locinput;
3256                 const char *e = PL_bostr + PL_regendp[n];
3257                 /*
3258                  * Note that we can't do the "other character" lookup trick as
3259                  * in the 8-bit case (no pun intended) because in Unicode we
3260                  * have to map both upper and title case to lower case.
3261                  */
3262                 if (OP(scan) == REFF) {
3263                     while (s < e) {
3264                         STRLEN ulen1, ulen2;
3265                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3266                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3267
3268                         if (l >= PL_regeol)
3269                             sayNO;
3270                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3271                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3272                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3273                             sayNO;
3274                         s += ulen1;
3275                         l += ulen2;
3276                     }
3277                 }
3278                 locinput = l;
3279                 nextchr = UCHARAT(locinput);
3280                 break;
3281             }
3282
3283             /* Inline the first character, for speed. */
3284             if (UCHARAT(s) != nextchr &&
3285                 (OP(scan) == REF ||
3286                  (UCHARAT(s) != ((OP(scan) == REFF
3287                                   ? PL_fold : PL_fold_locale)[nextchr]))))
3288                 sayNO;
3289             st->ln = PL_regendp[n] - st->ln;
3290             if (locinput + st->ln > PL_regeol)
3291                 sayNO;
3292             if (st->ln > 1 && (OP(scan) == REF
3293                            ? memNE(s, locinput, st->ln)
3294                            : (OP(scan) == REFF
3295                               ? ibcmp(s, locinput, st->ln)
3296                               : ibcmp_locale(s, locinput, st->ln))))
3297                 sayNO;
3298             locinput += st->ln;
3299             nextchr = UCHARAT(locinput);
3300             break;
3301             }
3302
3303         case NOTHING:
3304         case TAIL:
3305             break;
3306         case BACK:
3307             break;
3308         case EVAL:
3309         {
3310             SV *ret;
3311             {
3312                 /* execute the code in the {...} */
3313                 dSP;
3314                 SV ** const before = SP;
3315                 OP_4tree * const oop = PL_op;
3316                 COP * const ocurcop = PL_curcop;
3317                 PAD *old_comppad;
3318
3319                 n = ARG(scan);
3320                 PL_op = (OP_4tree*)rex->data->data[n];
3321                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3322                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3323                 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3324
3325                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3326                 SPAGAIN;
3327                 if (SP == before)
3328                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3329                 else {
3330                     ret = POPs;
3331                     PUTBACK;
3332                 }
3333
3334                 PL_op = oop;
3335                 PAD_RESTORE_LOCAL(old_comppad);
3336                 PL_curcop = ocurcop;
3337                 if (!st->logical) {
3338                     /* /(?{...})/ */
3339                     sv_setsv(save_scalar(PL_replgv), ret);
3340                     break;
3341                 }
3342             }
3343             if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3344                 regexp *re;
3345                 {
3346                     /* extract RE object from returned value; compiling if
3347                      * necessary */
3348
3349                     MAGIC *mg = NULL;
3350                     SV *sv;
3351                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3352                         mg = mg_find(sv, PERL_MAGIC_qr);
3353                     else if (SvSMAGICAL(ret)) {
3354                         if (SvGMAGICAL(ret))
3355                             sv_unmagic(ret, PERL_MAGIC_qr);
3356                         else
3357                             mg = mg_find(ret, PERL_MAGIC_qr);
3358                     }
3359
3360                     if (mg) {
3361                         re = (regexp *)mg->mg_obj;
3362                         (void)ReREFCNT_inc(re);
3363                     }
3364                     else {
3365                         STRLEN len;
3366                         const char * const t = SvPV_const(ret, len);
3367                         PMOP pm;
3368                         const I32 osize = PL_regsize;
3369
3370                         Zero(&pm, 1, PMOP);
3371                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3372                         re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3373                         if (!(SvFLAGS(ret)
3374                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3375                                 | SVs_GMG)))
3376                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3377                                         PERL_MAGIC_qr,0,0);
3378                         PL_regsize = osize;
3379                     }
3380                 }
3381
3382                 /* run the pattern returned from (??{...}) */
3383
3384                 DEBUG_EXECUTE_r(
3385                     PerlIO_printf(Perl_debug_log,
3386                                   "Entering embedded \"%s%.60s%s%s\"\n",
3387                                   PL_colors[0],
3388                                   re->precomp,
3389                                   PL_colors[1],
3390                                   (strlen(re->precomp) > 60 ? "..." : ""))
3391                     );
3392
3393                 st->u.eval.cp = regcppush(0);   /* Save *all* the positions. */
3394                 REGCP_SET(st->u.eval.lastcp);
3395                 *PL_reglastparen = 0;
3396                 *PL_reglastcloseparen = 0;
3397                 PL_reginput = locinput;
3398
3399                 /* XXXX This is too dramatic a measure... */
3400                 PL_reg_maxiter = 0;
3401
3402                 st->logical = 0;
3403                 st->u.eval.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3404                             ((re->reganch & ROPT_UTF8) != 0);
3405                 if (st->u.eval.toggleutf) PL_reg_flags ^= RF_utf8;
3406                 st->u.eval.prev_rex = rex;
3407                 rex = re;
3408
3409                 /* resume to current state on success */
3410                 st->u.yes.prev_yes_state = yes_state;
3411                 yes_state = st;
3412                 PUSH_STATE(newst, resume_EVAL);
3413                 st = newst;
3414
3415                 /* now continue  from first node in postoned RE */
3416                 next = re->program + 1;
3417                 break;
3418                 /* NOTREACHED */
3419             }
3420             /* /(?(?{...})X|Y)/ */
3421             st->sw = SvTRUE(ret);
3422             st->logical = 0;
3423             break;
3424         }
3425         case OPEN:
3426             n = ARG(scan);  /* which paren pair */
3427             PL_reg_start_tmp[n] = locinput;
3428             if (n > PL_regsize)
3429                 PL_regsize = n;
3430             break;
3431         case CLOSE:
3432             n = ARG(scan);  /* which paren pair */
3433             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3434             PL_regendp[n] = locinput - PL_bostr;
3435             if (n > (I32)*PL_reglastparen)
3436                 *PL_reglastparen = n;
3437             *PL_reglastcloseparen = n;
3438             break;
3439         case GROUPP:
3440             n = ARG(scan);  /* which paren pair */
3441             st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3442             break;
3443         case IFTHEN:
3444             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3445             if (st->sw)
3446                 next = NEXTOPER(NEXTOPER(scan));
3447             else {
3448                 next = scan + ARG(scan);
3449                 if (OP(next) == IFTHEN) /* Fake one. */
3450                     next = NEXTOPER(NEXTOPER(next));
3451             }
3452             break;
3453         case LOGICAL:
3454             st->logical = scan->flags;
3455             break;
3456 /*******************************************************************
3457  cc points to the regmatch_state associated with the most recent CURLYX.
3458  This struct contains info about the innermost (...)* loop (an
3459  "infoblock"), and a pointer to the next outer cc.
3460
3461  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3462
3463    1) After matching Y, regnode for CURLYX is processed;
3464
3465    2) This regnode populates cc, and calls regmatch() recursively
3466       with the starting point at WHILEM node;
3467
3468    3) Each hit of WHILEM node tries to match A and Z (in the order
3469       depending on the current iteration, min/max of {min,max} and
3470       greediness).  The information about where are nodes for "A"
3471       and "Z" is read from cc, as is info on how many times "A"
3472       was already matched, and greediness.
3473
3474    4) After A matches, the same WHILEM node is hit again.
3475
3476    5) Each time WHILEM is hit, cc is the infoblock created by CURLYX
3477       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
3478       resets cc, since this Y(A)*Z can be a part of some other loop:
3479       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
3480       of the external loop.
3481
3482  Currently present infoblocks form a tree with a stem formed by st->cc
3483  and whatever it mentions via ->next, and additional attached trees
3484  corresponding to temporarily unset infoblocks as in "5" above.
3485
3486  In the following picture, infoblocks for outer loop of
3487  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
3488  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
3489  infoblocks are drawn below the "reset" infoblock.
3490
3491  In fact in the picture below we do not show failed matches for Z and T
3492  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
3493  more obvious *why* one needs to *temporary* unset infoblocks.]
3494
3495   Matched       REx position    InfoBlocks      Comment
3496                 (Y(A)*?Z)*?T    x
3497                 Y(A)*?Z)*?T     x <- O
3498   Y             (A)*?Z)*?T      x <- O
3499   Y             A)*?Z)*?T       x <- O <- I
3500   YA            )*?Z)*?T        x <- O <- I
3501   YA            A)*?Z)*?T       x <- O <- I
3502   YAA           )*?Z)*?T        x <- O <- I
3503   YAA           Z)*?T           x <- O          # Temporary unset I
3504                                      I
3505
3506   YAAZ          Y(A)*?Z)*?T     x <- O
3507                                      I
3508
3509   YAAZY         (A)*?Z)*?T      x <- O
3510                                      I
3511
3512   YAAZY         A)*?Z)*?T       x <- O <- I
3513                                      I
3514
3515   YAAZYA        )*?Z)*?T        x <- O <- I
3516                                      I
3517
3518   YAAZYA        Z)*?T           x <- O          # Temporary unset I
3519                                      I,I
3520
3521   YAAZYAZ       )*?T            x <- O
3522                                      I,I
3523
3524   YAAZYAZ       T               x               # Temporary unset O
3525                                 O
3526                                 I,I
3527
3528   YAAZYAZT                      x
3529                                 O
3530                                 I,I
3531  *******************************************************************/
3532
3533         case CURLYX: {
3534                 /* No need to save/restore up to this paren */
3535                 I32 parenfloor = scan->flags;
3536
3537                 /* Dave says:
3538
3539                    CURLYX and WHILEM are always paired: they're the moral
3540                    equivalent of pp_enteriter anbd pp_iter.
3541
3542                    The only time next could be null is if the node tree is
3543                    corrupt. This was mentioned on p5p a few days ago.
3544
3545                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3546                    So we'll assert that this is true:
3547                 */
3548                 assert(next);
3549                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3550                     next += ARG(next);
3551                 /* XXXX Probably it is better to teach regpush to support
3552                    parenfloor > PL_regsize... */
3553                 if (parenfloor > (I32)*PL_reglastparen)
3554                     parenfloor = *PL_reglastparen; /* Pessimization... */
3555
3556                 st->u.curlyx.cp = PL_savestack_ix;
3557                 st->u.curlyx.outercc = st->cc;
3558                 st->cc = st;
3559                 /* these fields contain the state of the current curly.
3560                  * they are accessed by subsequent WHILEMs;
3561                  * cur and lastloc are also updated by WHILEM */
3562                 st->u.curlyx.parenfloor = parenfloor;
3563                 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3564                 st->u.curlyx.min = ARG1(scan);
3565                 st->u.curlyx.max  = ARG2(scan);
3566                 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3567                 st->u.curlyx.lastloc = 0;
3568                 /* st->next and st->minmod are also read by WHILEM */
3569
3570                 PL_reginput = locinput;
3571                 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3572                 /*** all unsaved local vars undefined at this point */
3573                 regcpblow(st->u.curlyx.cp);
3574                 st->cc = st->u.curlyx.outercc;
3575                 saySAME(result);
3576             }
3577             /* NOTREACHED */
3578         case WHILEM: {
3579                 /*
3580                  * This is really hard to understand, because after we match
3581                  * what we're trying to match, we must make sure the rest of
3582                  * the REx is going to match for sure, and to do that we have
3583                  * to go back UP the parse tree by recursing ever deeper.  And
3584                  * if it fails, we have to reset our parent's current state
3585                  * that we can try again after backing off.
3586                  */
3587
3588                 /* Dave says:
3589
3590                    st->cc gets initialised by CURLYX ready for use by WHILEM.
3591                    So again, unless somethings been corrupted, st->cc cannot
3592                    be null at that point in WHILEM.
3593
3594                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3595                    So we'll assert that this is true:
3596                 */
3597                 assert(st->cc);
3598                 st->u.whilem.lastloc = st->cc->u.curlyx.lastloc; /* Detection of 0-len. */
3599                 st->u.whilem.cache_offset = 0;
3600                 st->u.whilem.cache_bit = 0;
3601
3602                 n = st->cc->u.curlyx.cur + 1; /* how many we know we matched */
3603                 PL_reginput = locinput;
3604
3605                 DEBUG_EXECUTE_r(
3606                     PerlIO_printf(Perl_debug_log,
3607                                   "%*s  %ld out of %ld..%ld  cc=%"UVxf"\n",
3608                                   REPORT_CODE_OFF+PL_regindent*2, "",
3609                                   (long)n, (long)st->cc->u.curlyx.min,
3610                                   (long)st->cc->u.curlyx.max, PTR2UV(st->cc))
3611                     );
3612
3613                 /* If degenerate scan matches "", assume scan done. */
3614
3615                 if (locinput == st->cc->u.curlyx.lastloc && n >= st->cc->u.curlyx.min) {
3616                     st->u.whilem.savecc = st->cc;
3617                     st->cc = st->cc->u.curlyx.outercc;
3618                     if (st->cc)
3619                         st->ln = st->cc->u.curlyx.cur;
3620                     DEBUG_EXECUTE_r(
3621                         PerlIO_printf(Perl_debug_log,
3622                            "%*s  empty match detected, try continuation...\n",
3623                            REPORT_CODE_OFF+PL_regindent*2, "")
3624                         );
3625                     REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3626                     /*** all unsaved local vars undefined at this point */
3627                     st->cc = st->u.whilem.savecc;
3628                     if (result)
3629                         sayYES;
3630                     if (st->cc->u.curlyx.outercc)
3631                         st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3632                     sayNO;
3633                 }
3634
3635                 /* First just match a string of min scans. */
3636
3637                 if (n < st->cc->u.curlyx.min) {
3638                     st->cc->u.curlyx.cur = n;
3639                     st->cc->u.curlyx.lastloc = locinput;
3640                     REGMATCH(st->cc->u.curlyx.scan, WHILEM2);
3641                     /*** all unsaved local vars undefined at this point */
3642                     if (result)
3643                         sayYES;
3644                     st->cc->u.curlyx.cur = n - 1;
3645                     st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3646                     sayNO;
3647                 }
3648
3649                 if (scan->flags) {
3650                     /* Check whether we already were at this position.
3651                         Postpone detection until we know the match is not
3652                         *that* much linear. */
3653                 if (!PL_reg_maxiter) {
3654                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3655                     PL_reg_leftiter = PL_reg_maxiter;
3656                 }
3657                 if (PL_reg_leftiter-- == 0) {
3658                     const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8;
3659                     if (PL_reg_poscache) {
3660                         if ((I32)PL_reg_poscache_size < size) {
3661                             Renew(PL_reg_poscache, size, char);
3662                             PL_reg_poscache_size = size;
3663                         }
3664                         Zero(PL_reg_poscache, size, char);
3665                     }
3666                     else {
3667                         PL_reg_poscache_size = size;
3668                         Newxz(PL_reg_poscache, size, char);
3669                     }
3670                     DEBUG_EXECUTE_r(
3671                         PerlIO_printf(Perl_debug_log,
3672               "%sDetected a super-linear match, switching on caching%s...\n",
3673                                       PL_colors[4], PL_colors[5])
3674                         );
3675                 }
3676                 if (PL_reg_leftiter < 0) {
3677                     st->u.whilem.cache_offset = locinput - PL_bostr;
3678
3679                     st->u.whilem.cache_offset = (scan->flags & 0xf) - 1 + POSCACHE_START
3680                             + st->u.whilem.cache_offset * (scan->flags>>4);
3681                     st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
3682                     st->u.whilem.cache_offset /= 8;
3683                     if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
3684                     DEBUG_EXECUTE_r(
3685                         PerlIO_printf(Perl_debug_log,
3686                                       "%*s  already tried at this position...\n",
3687                                       REPORT_CODE_OFF+PL_regindent*2, "")
3688                         );
3689                         if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))
3690                             /* cache records success */
3691                             sayYES;
3692                         else
3693                             /* cache records failure */
3694                             sayNO_SILENT;
3695                     }
3696                 }
3697                 }
3698
3699                 /* Prefer next over scan for minimal matching. */
3700
3701                 if (st->cc->minmod) {
3702                     st->u.whilem.savecc = st->cc;
3703                     st->cc = st->cc->u.curlyx.outercc;
3704                     if (st->cc)
3705                         st->ln = st->cc->u.curlyx.cur;
3706                     st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
3707                     REGCP_SET(st->u.whilem.lastcp);
3708                     REGMATCH(st->u.whilem.savecc->next, WHILEM3);
3709                     /*** all unsaved local vars undefined at this point */
3710                     st->cc = st->u.whilem.savecc;
3711                     if (result) {
3712                         regcpblow(st->u.whilem.cp);
3713                         CACHEsayYES;    /* All done. */
3714                     }
3715                     REGCP_UNWIND(st->u.whilem.lastcp);
3716                     regcppop(rex);
3717                     if (st->cc->u.curlyx.outercc)
3718                         st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3719
3720                     if (n >= st->cc->u.curlyx.max) { /* Maximum greed exceeded? */
3721                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3722                             && !(PL_reg_flags & RF_warned)) {
3723                             PL_reg_flags |= RF_warned;
3724                             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3725                                  "Complex regular subexpression recursion",
3726                                  REG_INFTY - 1);
3727                         }
3728                         CACHEsayNO;
3729                     }
3730
3731                     DEBUG_EXECUTE_r(
3732                         PerlIO_printf(Perl_debug_log,
3733                                       "%*s  trying longer...\n",
3734                                       REPORT_CODE_OFF+PL_regindent*2, "")
3735                         );
3736                     /* Try scanning more and see if it helps. */
3737                     PL_reginput = locinput;
3738                     st->cc->u.curlyx.cur = n;
3739                     st->cc->u.curlyx.lastloc = locinput;
3740                     st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3741                     REGCP_SET(st->u.whilem.lastcp);
3742                     REGMATCH(st->cc->u.curlyx.scan, WHILEM4);
3743                     /*** all unsaved local vars undefined at this point */
3744                     if (result) {
3745                         regcpblow(st->u.whilem.cp);
3746                         CACHEsayYES;
3747                     }
3748                     REGCP_UNWIND(st->u.whilem.lastcp);
3749                     regcppop(rex);
3750                     st->cc->u.curlyx.cur = n - 1;
3751                     st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3752                     CACHEsayNO;
3753                 }
3754
3755                 /* Prefer scan over next for maximal matching. */
3756
3757                 if (n < st->cc->u.curlyx.max) { /* More greed allowed? */
3758                     st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3759                     st->cc->u.curlyx.cur = n;
3760                     st->cc->u.curlyx.lastloc = locinput;
3761                     REGCP_SET(st->u.whilem.lastcp);
3762                     REGMATCH(st->cc->u.curlyx.scan, WHILEM5);
3763                     /*** all unsaved local vars undefined at this point */
3764                     if (result) {
3765                         regcpblow(st->u.whilem.cp);
3766                         CACHEsayYES;
3767                     }
3768                     REGCP_UNWIND(st->u.whilem.lastcp);
3769                     regcppop(rex);      /* Restore some previous $<digit>s? */
3770                     PL_reginput = locinput;
3771                     DEBUG_EXECUTE_r(
3772                         PerlIO_printf(Perl_debug_log,
3773                                       "%*s  failed, try continuation...\n",
3774                                       REPORT_CODE_OFF+PL_regindent*2, "")
3775                         );
3776                 }
3777                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3778                         && !(PL_reg_flags & RF_warned)) {
3779                     PL_reg_flags |= RF_warned;
3780                     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3781                          "Complex regular subexpression recursion",
3782                          REG_INFTY - 1);
3783                 }
3784
3785                 /* Failed deeper matches of scan, so see if this one works. */
3786                 st->u.whilem.savecc = st->cc;
3787                 st->cc = st->cc->u.curlyx.outercc;
3788                 if (st->cc)
3789                     st->ln = st->cc->u.curlyx.cur;
3790                 REGMATCH(st->u.whilem.savecc->next, WHILEM6);
3791                 /*** all unsaved local vars undefined at this point */
3792                 st->cc = st->u.whilem.savecc;
3793                 if (result)
3794                     CACHEsayYES;
3795                 if (st->cc->u.curlyx.outercc)
3796                     st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3797                 st->cc->u.curlyx.cur = n - 1;
3798                 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3799                 CACHEsayNO;
3800             }
3801             /* NOTREACHED */
3802         case BRANCHJ:
3803             next = scan + ARG(scan);
3804             if (next == scan)
3805                 next = NULL;
3806             inner = NEXTOPER(NEXTOPER(scan));
3807             goto do_branch;
3808         case BRANCH:
3809             inner = NEXTOPER(scan);
3810           do_branch:
3811             {
3812                 I32 type;
3813                 type = OP(scan);
3814                 if (!next || OP(next) != type)  /* No choice. */
3815                     next = inner;       /* Avoid recursion. */
3816                 else {
3817                     const I32 lastparen = *PL_reglastparen;
3818                     /* Put unwinding data on stack */
3819                     const I32 unwind1 = SSNEWt(1,re_unwind_branch_t);
3820                     re_unwind_branch_t * const uw = SSPTRt(unwind1,re_unwind_branch_t);
3821
3822                     uw->prev = st->unwind;
3823                     st->unwind = unwind1;
3824                     uw->type = ((type == BRANCH)
3825                                 ? RE_UNWIND_BRANCH
3826                                 : RE_UNWIND_BRANCHJ);
3827                     uw->lastparen = lastparen;
3828                     uw->next = next;
3829                     uw->locinput = locinput;
3830                     uw->nextchr = nextchr;
3831                     uw->minmod = st->minmod;
3832 #ifdef DEBUGGING
3833                     uw->regindent = ++PL_regindent;
3834 #endif
3835
3836                     REGCP_SET(uw->lastcp);
3837
3838                     /* Now go into the first branch */
3839                     next = inner;
3840                 }
3841             }
3842             break;
3843         case MINMOD:
3844             st->minmod = 1;
3845             break;
3846         case CURLYM:
3847         {
3848             st->u.curlym.l = st->u.curlym.matches = 0;
3849
3850             /* We suppose that the next guy does not need
3851                backtracking: in particular, it is of constant non-zero length,
3852                and has no parenths to influence future backrefs. */
3853             st->ln = ARG1(scan);  /* min to match */
3854             n  = ARG2(scan);  /* max to match */
3855             st->u.curlym.paren = scan->flags;
3856             if (st->u.curlym.paren) {
3857                 if (st->u.curlym.paren > PL_regsize)
3858                     PL_regsize = st->u.curlym.paren;
3859                 if (st->u.curlym.paren > (I32)*PL_reglastparen)
3860                     *PL_reglastparen = st->u.curlym.paren;
3861             }
3862             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3863             if (st->u.curlym.paren)
3864                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3865             PL_reginput = locinput;
3866             st->u.curlym.maxwanted = st->minmod ? st->ln : n;
3867             while (PL_reginput < PL_regeol && st->u.curlym.matches < st->u.curlym.maxwanted) {
3868                 /* resume to current state on success */
3869                 st->u.yes.prev_yes_state = yes_state;
3870                 yes_state = st;
3871                 REGMATCH(scan, CURLYM1);
3872                 yes_state = st->u.yes.prev_yes_state;
3873                 /*** all unsaved local vars undefined at this point */
3874                 if (!result)
3875                     break;
3876                 /* on first match, determine length, u.curlym.l */
3877                 if (!st->u.curlym.matches++) {
3878                     if (PL_reg_match_utf8) {
3879                         char *s = locinput;
3880                         while (s < PL_reginput) {
3881                             st->u.curlym.l++;
3882                             s += UTF8SKIP(s);
3883                         }
3884                     }
3885                     else {
3886                         st->u.curlym.l = PL_reginput - locinput;
3887                     }
3888                     if (st->u.curlym.l == 0) {
3889                         st->u.curlym.matches = st->u.curlym.maxwanted;
3890                         break;
3891                     }
3892                 }
3893                 locinput = PL_reginput;
3894             }
3895
3896             PL_reginput = locinput;
3897             if (st->u.curlym.matches < st->ln) {
3898                 st->minmod = 0;
3899                 sayNO;
3900             }
3901
3902             DEBUG_EXECUTE_r(
3903                 PerlIO_printf(Perl_debug_log,
3904                           "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3905                           (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3906                           (IV) st->u.curlym.matches, (IV)st->u.curlym.l)
3907             );
3908
3909             /* calculate c1 and c1 for possible match of 1st char
3910              * following curly */
3911             st->u.curlym.c1 = st->u.curlym.c2 = CHRTEST_VOID;
3912             if (HAS_TEXT(next) || JUMPABLE(next)) {
3913                 regnode *text_node = next;
3914                 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3915                 if (HAS_TEXT(text_node)
3916                     && PL_regkind[(U8)OP(text_node)] != REF)
3917                 {
3918                     st->u.curlym.c1 = (U8)*STRING(text_node);
3919                     st->u.curlym.c2 =
3920                         (OP(text_node) == EXACTF || OP(text_node) == REFF)
3921                         ? PL_fold[st->u.curlym.c1]
3922                         : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3923                             ? PL_fold_locale[st->u.curlym.c1]
3924                             : st->u.curlym.c1;
3925                 }
3926             }
3927
3928             REGCP_SET(st->u.curlym.lastcp);
3929
3930             st->u.curlym.minmod = st->minmod;
3931             st->minmod = 0;
3932             while (st->u.curlym.matches >= st->ln
3933                 && (st->u.curlym.matches <= n
3934                     /* for REG_INFTY, ln could overflow to negative */
3935                     || (n == REG_INFTY && st->u.curlym.matches >= 0)))
3936             {
3937                 /* If it could work, try it. */
3938                 if (st->u.curlym.c1 == CHRTEST_VOID ||
3939                     UCHARAT(PL_reginput) == st->u.curlym.c1 ||
3940                     UCHARAT(PL_reginput) == st->u.curlym.c2)
3941                 {
3942                     DEBUG_EXECUTE_r(
3943                         PerlIO_printf(Perl_debug_log,
3944                             "%*s  trying tail with matches=%"IVdf"...\n",
3945                             (int)(REPORT_CODE_OFF+PL_regindent*2),
3946                             "", (IV)st->u.curlym.matches)
3947                         );
3948                     if (st->u.curlym.paren) {
3949                         if (st->u.curlym.matches) {
3950                             PL_regstartp[st->u.curlym.paren]
3951                                 = HOPc(PL_reginput, -st->u.curlym.l) - PL_bostr;
3952                             PL_regendp[st->u.curlym.paren] = PL_reginput - PL_bostr;
3953                         }
3954                         else
3955                             PL_regendp[st->u.curlym.paren] = -1;
3956                     }
3957                     /* resume to current state on success */
3958                     st->u.yes.prev_yes_state = yes_state;
3959                     yes_state = st;
3960                     REGMATCH(next, CURLYM2);
3961                     yes_state = st->u.yes.prev_yes_state;
3962                     /*** all unsaved local vars undefined at this point */
3963                     if (result)
3964                         /* XXX tmp sayYES; */
3965                         sayYES_FINAL;
3966                     REGCP_UNWIND(st->u.curlym.lastcp);
3967                 }
3968                 /* Couldn't or didn't -- move forward/backward. */
3969                 if (st->u.curlym.minmod) {
3970                     PL_reginput = locinput;
3971                     /* resume to current state on success */
3972                     st->u.yes.prev_yes_state = yes_state;
3973                     yes_state = st;
3974                     REGMATCH(scan, CURLYM3);
3975                     yes_state = st->u.yes.prev_yes_state;
3976                     /*** all unsaved local vars undefined at this point */
3977                     if (result) {
3978                         st->u.curlym.matches++;
3979                         locinput = PL_reginput;
3980                     }
3981                     else
3982                         sayNO;
3983                 }
3984                 else {
3985                     st->u.curlym.matches--;
3986                     locinput = HOPc(locinput, -st->u.curlym.l);
3987                     PL_reginput = locinput;
3988                 }
3989             }
3990             sayNO;
3991             /* NOTREACHED */
3992             break;
3993         }
3994         case CURLYN:
3995             st->u.plus.paren = scan->flags;     /* Which paren to set */
3996             if (st->u.plus.paren > PL_regsize)
3997                 PL_regsize = st->u.plus.paren;
3998             if (st->u.plus.paren > (I32)*PL_reglastparen)
3999                 *PL_reglastparen = st->u.plus.paren;
4000             st->ln = ARG1(scan);  /* min to match */
4001             n  = ARG2(scan);  /* max to match */
4002             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4003             goto repeat;
4004         case CURLY:
4005             st->u.plus.paren = 0;
4006             st->ln = ARG1(scan);  /* min to match */
4007             n  = ARG2(scan);  /* max to match */
4008             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4009             goto repeat;
4010         case STAR:
4011             st->ln = 0;
4012             n = REG_INFTY;
4013             scan = NEXTOPER(scan);
4014             st->u.plus.paren = 0;
4015             goto repeat;
4016         case PLUS:
4017             st->ln = 1;
4018             n = REG_INFTY;
4019             scan = NEXTOPER(scan);
4020             st->u.plus.paren = 0;
4021           repeat:
4022             /*
4023             * Lookahead to avoid useless match attempts
4024             * when we know what character comes next.
4025             */
4026
4027             /*
4028             * Used to only do .*x and .*?x, but now it allows
4029             * for )'s, ('s and (?{ ... })'s to be in the way
4030             * of the quantifier and the EXACT-like node.  -- japhy
4031             */
4032
4033             if (HAS_TEXT(next) || JUMPABLE(next)) {
4034                 U8 *s;
4035                 regnode *text_node = next;
4036
4037                 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
4038
4039                 if (! HAS_TEXT(text_node))
4040                     st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4041                 else {
4042                     if (PL_regkind[(U8)OP(text_node)] == REF) {
4043                         st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4044                         goto assume_ok_easy;
4045                     }
4046                     else { s = (U8*)STRING(text_node); }
4047
4048                     if (!UTF) {
4049                         st->u.plus.c2 = st->u.plus.c1 = *s;
4050                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4051                             st->u.plus.c2 = PL_fold[st->u.plus.c1];
4052                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4053                             st->u.plus.c2 = PL_fold_locale[st->u.plus.c1];
4054                     }
4055                     else { /* UTF */
4056                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4057                              STRLEN ulen1, ulen2;
4058                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4059                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4060
4061                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4062                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4063
4064                              st->u.plus.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4065                                                  uniflags);
4066                              st->u.plus.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4067                                                  uniflags);
4068                         }
4069                         else {
4070                             st->u.plus.c2 = st->u.plus.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4071                                                      uniflags);
4072                         }
4073                     }
4074                 }
4075             }
4076             else
4077                 st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4078         assume_ok_easy:
4079             PL_reginput = locinput;
4080             if (st->minmod) {
4081                 st->minmod = 0;
4082                 if (st->ln && regrepeat(rex, scan, st->ln) < st->ln)
4083                     sayNO;
4084                 locinput = PL_reginput;
4085                 REGCP_SET(st->u.plus.lastcp);
4086                 if (st->u.plus.c1 != CHRTEST_VOID) {
4087                     st->u.plus.old = locinput;
4088                     st->u.plus.count = 0;
4089
4090                     if  (n == REG_INFTY) {
4091                         st->u.plus.e = PL_regeol - 1;
4092                         if (do_utf8)
4093                             while (UTF8_IS_CONTINUATION(*(U8*)st->u.plus.e))
4094                                 st->u.plus.e--;
4095                     }
4096                     else if (do_utf8) {
4097                         int m = n - st->ln;
4098                         for (st->u.plus.e = locinput;
4099                              m >0 && st->u.plus.e + UTF8SKIP(st->u.plus.e) <= PL_regeol; m--)
4100                             st->u.plus.e += UTF8SKIP(st->u.plus.e);
4101                     }
4102                     else {
4103                         st->u.plus.e = locinput + n - st->ln;
4104                         if (st->u.plus.e >= PL_regeol)
4105                             st->u.plus.e = PL_regeol - 1;
4106                     }
4107                     while (1) {
4108                         /* Find place 'next' could work */
4109                         if (!do_utf8) {
4110                             if (st->u.plus.c1 == st->u.plus.c2) {
4111                                 while (locinput <= st->u.plus.e &&
4112                                        UCHARAT(locinput) != st->u.plus.c1)
4113                                     locinput++;
4114                             } else {
4115                                 while (locinput <= st->u.plus.e
4116                                        && UCHARAT(locinput) != st->u.plus.c1
4117                                        && UCHARAT(locinput) != st->u.plus.c2)
4118                                     locinput++;
4119                             }
4120                             st->u.plus.count = locinput - st->u.plus.old;
4121                         }
4122                         else {
4123                             if (st->u.plus.c1 == st->u.plus.c2) {
4124                                 STRLEN len;
4125                                 /* count initialised to
4126                                  * utf8_distance(old, locinput) */
4127                                 while (locinput <= st->u.plus.e &&
4128                                        utf8n_to_uvchr((U8*)locinput,
4129                                                       UTF8_MAXBYTES, &len,
4130                                                       uniflags) != (UV)st->u.plus.c1) {
4131                                     locinput += len;
4132                                     st->u.plus.count++;
4133                                 }
4134                             } else {
4135                                 /* count initialised to
4136                                  * utf8_distance(old, locinput) */
4137                                 while (locinput <= st->u.plus.e) {
4138                                     STRLEN len;
4139                                     const UV c = utf8n_to_uvchr((U8*)locinput,
4140                                                           UTF8_MAXBYTES, &len,
4141                                                           uniflags);
4142                                     if (c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4143                                         break;
4144                                     locinput += len;
4145                                     st->u.plus.count++;
4146                                 }
4147                             }
4148                         }
4149                         if (locinput > st->u.plus.e)
4150                             sayNO;
4151                         /* PL_reginput == old now */
4152                         if (locinput != st->u.plus.old) {
4153                             st->ln = 1; /* Did some */
4154                             if (regrepeat(rex, scan, st->u.plus.count) < st->u.plus.count)
4155                                 sayNO;
4156                         }
4157                         /* PL_reginput == locinput now */
4158                         TRYPAREN(st->u.plus.paren, st->ln, locinput, PLUS1);
4159                         /*** all unsaved local vars undefined at this point */
4160                         PL_reginput = locinput; /* Could be reset... */
4161                         REGCP_UNWIND(st->u.plus.lastcp);
4162                         /* Couldn't or didn't -- move forward. */
4163                         st->u.plus.old = locinput;
4164                         if (do_utf8)
4165                             locinput += UTF8SKIP(locinput);
4166                         else
4167                             locinput++;
4168                         st->u.plus.count = 1;
4169                     }
4170                 }
4171                 else
4172                 while (n >= st->ln || (n == REG_INFTY && st->ln > 0)) { /* ln overflow ? */
4173                     UV c;
4174                     if (st->u.plus.c1 != CHRTEST_VOID) {
4175                         if (do_utf8)
4176                             c = utf8n_to_uvchr((U8*)PL_reginput,
4177                                                UTF8_MAXBYTES, 0,
4178                                                uniflags);
4179                         else
4180                             c = UCHARAT(PL_reginput);
4181                         /* If it could work, try it. */
4182                         if (c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4183                         {
4184                             TRYPAREN(st->u.plus.paren, st->ln, PL_reginput, PLUS2);
4185                             /*** all unsaved local vars undefined at this point */
4186                             REGCP_UNWIND(st->u.plus.lastcp);
4187                         }
4188                     }
4189                     /* If it could work, try it. */
4190                     else if (st->u.plus.c1 == CHRTEST_VOID)
4191                     {
4192                         TRYPAREN(st->u.plus.paren, st->ln, PL_reginput, PLUS3);
4193                         /*** all unsaved local vars undefined at this point */
4194                         REGCP_UNWIND(st->u.plus.lastcp);
4195                     }
4196                     /* Couldn't or didn't -- move forward. */
4197                     PL_reginput = locinput;
4198                     if (regrepeat(rex, scan, 1)) {
4199                         st->ln++;
4200                         locinput = PL_reginput;
4201                     }
4202                     else
4203                         sayNO;
4204                 }
4205             }
4206             else {
4207                 n = regrepeat(rex, scan, n);
4208                 locinput = PL_reginput;
4209                 if (st->ln < n && PL_regkind[(U8)OP(next)] == EOL &&
4210                     (OP(next) != MEOL ||
4211                         OP(next) == SEOL || OP(next) == EOS))
4212                 {
4213                     st->ln = n;                 /* why back off? */
4214                     /* ...because $ and \Z can match before *and* after
4215                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4216                        We should back off by one in this case. */
4217                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
4218                         st->ln--;
4219                 }
4220                 REGCP_SET(st->u.plus.lastcp);
4221                 {
4222                     UV c = 0;
4223                     while (n >= st->ln) {
4224                         if (st->u.plus.c1 != CHRTEST_VOID) {
4225                             if (do_utf8)
4226                                 c = utf8n_to_uvchr((U8*)PL_reginput,
4227                                                    UTF8_MAXBYTES, 0,
4228                                                    uniflags);
4229                             else
4230                                 c = UCHARAT(PL_reginput);
4231                         }
4232                         /* If it could work, try it. */
4233                         if (st->u.plus.c1 == CHRTEST_VOID || c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4234                             {
4235                                 TRYPAREN(st->u.plus.paren, n, PL_reginput, PLUS4);
4236                                 /*** all unsaved local vars undefined at this point */
4237                                 REGCP_UNWIND(st->u.plus.lastcp);
4238                             }
4239                         /* Couldn't or didn't -- back up. */
4240                         n--;
4241                         PL_reginput = locinput = HOPc(locinput, -1);
4242                     }
4243                 }
4244             }
4245             sayNO;
4246             break;
4247         case END:
4248             if (locinput < reginfo->till) {
4249                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4250                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4251                                       PL_colors[4],
4252                                       (long)(locinput - PL_reg_starttry),
4253                                       (long)(reginfo->till - PL_reg_starttry),
4254                                       PL_colors[5]));
4255                 sayNO_FINAL;            /* Cannot match: too short. */
4256             }
4257             PL_reginput = locinput;     /* put where regtry can find it */
4258             sayYES_FINAL;               /* Success! */
4259
4260         case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4261             DEBUG_EXECUTE_r(
4262             PerlIO_printf(Perl_debug_log,
4263                 "%*s  %ssubpattern success...%s\n",
4264                 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5]));
4265             PL_reginput = locinput;     /* put where regtry can find it */
4266             sayYES_FINAL;               /* Success! */
4267
4268         case SUSPEND:   /* (?>FOO) */
4269             st->u.ifmatch.wanted = 1;
4270             PL_reginput = locinput;
4271             goto do_ifmatch;
4272
4273         case UNLESSM:   /* -ve lookaround: (?!FOO), or with flags, (?<!foo) */
4274             st->u.ifmatch.wanted = 0;
4275             goto ifmatch_trivial_fail_test;
4276
4277         case IFMATCH:   /* +ve lookaround: (?=FOO), or with flags, (?<=foo) */
4278             st->u.ifmatch.wanted = 1;
4279           ifmatch_trivial_fail_test:
4280             if (scan->flags) {
4281                 char * const s = HOPBACKc(locinput, scan->flags);
4282                 if (!s) {
4283                     /* trivial fail */
4284                     if (st->logical) {
4285                         st->logical = 0;
4286                         st->sw = 1 - st->u.ifmatch.wanted;
4287                     }
4288                     else if (st->u.ifmatch.wanted)
4289                         sayNO;
4290                     next = scan + ARG(scan);
4291                     if (next == scan)
4292                         next = NULL;
4293                     break;
4294                 }
4295                 PL_reginput = s;
4296             }
4297             else
4298                 PL_reginput = locinput;
4299
4300           do_ifmatch:
4301             /* resume to current state on success */
4302             st->u.yes.prev_yes_state = yes_state;
4303             yes_state = st;
4304             PUSH_STATE(newst, resume_IFMATCH);
4305             st = newst;
4306             next = NEXTOPER(NEXTOPER(scan));
4307             break;
4308
4309         case LONGJMP:
4310             next = scan + ARG(scan);
4311             if (next == scan)
4312                 next = NULL;
4313             break;
4314         default:
4315             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4316                           PTR2UV(scan), OP(scan));
4317             Perl_croak(aTHX_ "regexp memory corruption");
4318         }
4319
4320       reenter:
4321         scan = next;
4322         continue;
4323         /* NOTREACHED */
4324
4325         /* simulate recursively calling regmatch(), but without actually
4326          * recursing - ie save the current state on the heap rather than on
4327          * the stack, then re-enter the loop. This avoids complex regexes
4328          * blowing the processor stack */
4329
4330       start_recurse:
4331         {
4332             /* push new state */
4333             regmatch_state *oldst = st;
4334
4335             depth++;
4336
4337             /* grab the next free state slot */
4338             st++;
4339             if (st >  SLAB_LAST(PL_regmatch_slab))
4340                 st = S_push_slab(aTHX);
4341             PL_regmatch_state = st;
4342
4343             oldst->next = next;
4344             oldst->n = n;
4345             oldst->locinput = locinput;
4346
4347             st->cc = oldst->cc;
4348             locinput = PL_reginput;
4349             nextchr = UCHARAT(locinput);
4350             st->minmod = 0;
4351             st->sw = 0;
4352             st->logical = 0;
4353             st->unwind = 0;
4354 #ifdef DEBUGGING
4355             PL_regindent++;
4356 #endif
4357         }
4358     }
4359
4360
4361
4362     /*
4363     * We get here only if there's trouble -- normally "case END" is
4364     * the terminating point.
4365     */
4366     Perl_croak(aTHX_ "corrupted regexp pointers");
4367     /*NOTREACHED*/
4368     sayNO;
4369
4370 yes_final:
4371
4372     if (yes_state) {
4373         /* we have successfully completed a subexpression, but we must now
4374          * pop to the state marked by yes_state and continue from there */
4375
4376         /*XXX tmp for CURLYM*/
4377         regmatch_slab * const oslab = PL_regmatch_slab;
4378         regmatch_state * const ost = st;
4379         regmatch_state * const oys = yes_state;
4380         int odepth = depth;
4381
4382         assert(st != yes_state);
4383         while (yes_state < SLAB_FIRST(PL_regmatch_slab)
4384             || yes_state > SLAB_LAST(PL_regmatch_slab))
4385         {
4386             /* not in this slab, pop slab */
4387             depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
4388             PL_regmatch_slab = PL_regmatch_slab->prev;
4389             st = SLAB_LAST(PL_regmatch_slab);
4390         }
4391         depth -= (st - yes_state);
4392         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE TO (%d)\n", depth));
4393         st = yes_state;
4394         yes_state = st->u.yes.prev_yes_state;
4395         PL_regmatch_state = st;
4396
4397         switch (st->resume_state) {
4398         case resume_EVAL:
4399             if (st->u.eval.toggleutf)
4400                 PL_reg_flags ^= RF_utf8;
4401             ReREFCNT_dec(rex);
4402             rex = st->u.eval.prev_rex;
4403             /* XXXX This is too dramatic a measure... */
4404             PL_reg_maxiter = 0;
4405             /* Restore parens of the caller without popping the
4406              * savestack */
4407             {
4408                 const I32 tmp = PL_savestack_ix;
4409                 PL_savestack_ix = st->u.eval.lastcp;
4410                 regcppop(rex);
4411                 PL_savestack_ix = tmp;
4412             }
4413             PL_reginput = locinput;
4414              /* continue at the node following the (??{...}) */
4415             next        = st->next;
4416             goto reenter;
4417
4418         case resume_IFMATCH:
4419             if (st->logical) {
4420                 st->logical = 0;
4421                 st->sw = st->u.ifmatch.wanted;
4422             }
4423             else if (!st->u.ifmatch.wanted)
4424                 sayNO;
4425
4426             if (OP(st->scan) == SUSPEND)
4427                 locinput = PL_reginput;
4428             else {
4429                 locinput = PL_reginput = st->locinput;
4430                 nextchr = UCHARAT(locinput);
4431             }
4432             next = st->scan + ARG(st->scan);
4433             if (next == st->scan)
4434                 next = NULL;
4435             goto reenter;
4436
4437         /* XXX tmp  don't handle yes_state yet */
4438         case resume_CURLYM1:
4439         case resume_CURLYM2:
4440         case resume_CURLYM3:
4441             PL_regmatch_slab =oslab;
4442             st = ost;
4443             PL_regmatch_state = st;
4444             depth = odepth;
4445             yes_state = oys;
4446             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "XXX revering a CURLYM\n"));
4447             goto yes;
4448
4449         default:
4450             Perl_croak(aTHX_ "unexpected yes reume state");
4451         }
4452     }
4453
4454     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4455                           PL_colors[4], PL_colors[5]));
4456 yes:
4457 #ifdef DEBUGGING
4458     PL_regindent--;
4459 #endif
4460
4461     result = 1;
4462     /* XXX this is duplicate(ish) code to that in the do_no section.
4463      * eventually a yes should just pop the stack back to the current
4464      * yes_state */
4465     if (depth) {
4466         /* restore previous state and re-enter */
4467         POP_STATE;
4468
4469         switch (st->resume_state) {
4470         case resume_TRIE1:
4471             goto resume_point_TRIE1;
4472         case resume_TRIE2:
4473             goto resume_point_TRIE2;
4474         case resume_CURLYX:
4475             goto resume_point_CURLYX;
4476         case resume_WHILEM1:
4477             goto resume_point_WHILEM1;
4478         case resume_WHILEM2:
4479             goto resume_point_WHILEM2;
4480         case resume_WHILEM3:
4481             goto resume_point_WHILEM3;
4482         case resume_WHILEM4:
4483             goto resume_point_WHILEM4;
4484         case resume_WHILEM5:
4485             goto resume_point_WHILEM5;
4486         case resume_WHILEM6:
4487             goto resume_point_WHILEM6;
4488         case resume_CURLYM1:
4489             goto resume_point_CURLYM1;
4490         case resume_CURLYM2:
4491             goto resume_point_CURLYM2;
4492         case resume_CURLYM3:
4493             goto resume_point_CURLYM3;
4494         case resume_PLUS1:
4495             goto resume_point_PLUS1;
4496         case resume_PLUS2:
4497             goto resume_point_PLUS2;
4498         case resume_PLUS3:
4499             goto resume_point_PLUS3;
4500         case resume_PLUS4:
4501             goto resume_point_PLUS4;
4502
4503         case resume_IFMATCH:
4504         case resume_EVAL:
4505         default:
4506             Perl_croak(aTHX_ "regexp resume memory corruption");
4507         }
4508     }
4509     goto final_exit;
4510
4511 no:
4512     DEBUG_EXECUTE_r(
4513         PerlIO_printf(Perl_debug_log,
4514                       "%*s  %sfailed...%s\n",
4515                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4516         );
4517     goto do_no;
4518 no_final:
4519 do_no:
4520     if (st->unwind) {
4521         re_unwind_t * const uw = SSPTRt(st->unwind,re_unwind_t);
4522
4523         switch (uw->type) {
4524         case RE_UNWIND_BRANCH:
4525         case RE_UNWIND_BRANCHJ:
4526         {
4527             re_unwind_branch_t * const uwb = &(uw->branch);
4528             const I32 lastparen = uwb->lastparen;
4529
4530             REGCP_UNWIND(uwb->lastcp);
4531             for (n = *PL_reglastparen; n > lastparen; n--)
4532                 PL_regendp[n] = -1;
4533             *PL_reglastparen = n;
4534             scan = next = uwb->next;
4535             st->minmod = uwb->minmod;
4536             if ( !scan ||
4537                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
4538                               ? BRANCH : BRANCHJ) ) {           /* Failure */
4539                 st->unwind = uwb->prev;
4540 #ifdef DEBUGGING
4541                 PL_regindent--;
4542 #endif
4543                 goto do_no;
4544             }
4545             /* Have more choice yet.  Reuse the same uwb.  */
4546             if ((n = (uwb->type == RE_UNWIND_BRANCH
4547                       ? NEXT_OFF(next) : ARG(next))))
4548                 next += n;
4549             else
4550                 next = NULL;    /* XXXX Needn't unwinding in this case... */
4551             uwb->next = next;
4552             next = NEXTOPER(scan);
4553             if (uwb->type == RE_UNWIND_BRANCHJ)
4554                 next = NEXTOPER(next);
4555             locinput = uwb->locinput;
4556             nextchr = uwb->nextchr;
4557 #ifdef DEBUGGING
4558             PL_regindent = uwb->regindent;
4559 #endif
4560
4561             goto reenter;
4562         }
4563         /* NOTREACHED */
4564         default:
4565             Perl_croak(aTHX_ "regexp unwind memory corruption");
4566         }
4567         /* NOTREACHED */
4568     }
4569
4570 #ifdef DEBUGGING
4571     PL_regindent--;
4572 #endif
4573     result = 0;
4574
4575     if (depth) {
4576         /* there's a previous state to backtrack to */
4577         POP_STATE;
4578         switch (st->resume_state) {
4579         case resume_TRIE1:
4580             goto resume_point_TRIE1;
4581         case resume_TRIE2:
4582             goto resume_point_TRIE2;
4583         case resume_EVAL:
4584             /* we have failed an (??{...}). Restore state to the outer re
4585              * then re-throw the failure */
4586             if (st->u.eval.toggleutf)
4587                 PL_reg_flags ^= RF_utf8;
4588             ReREFCNT_dec(rex);
4589             rex = st->u.eval.prev_rex;
4590             yes_state = st->u.yes.prev_yes_state;
4591
4592             /* XXXX This is too dramatic a measure... */
4593             PL_reg_maxiter = 0;
4594
4595             PL_reginput = locinput;
4596             REGCP_UNWIND(st->u.eval.lastcp);
4597             regcppop(rex);
4598             goto do_no;
4599
4600         case resume_CURLYX:
4601             goto resume_point_CURLYX;
4602         case resume_WHILEM1:
4603             goto resume_point_WHILEM1;
4604         case resume_WHILEM2:
4605             goto resume_point_WHILEM2;
4606         case resume_WHILEM3:
4607             goto resume_point_WHILEM3;
4608         case resume_WHILEM4:
4609             goto resume_point_WHILEM4;
4610         case resume_WHILEM5:
4611             goto resume_point_WHILEM5;
4612         case resume_WHILEM6:
4613             goto resume_point_WHILEM6;
4614         case resume_CURLYM1:
4615             goto resume_point_CURLYM1;
4616         case resume_CURLYM2:
4617             goto resume_point_CURLYM2;
4618         case resume_CURLYM3:
4619             goto resume_point_CURLYM3;
4620         case resume_IFMATCH:
4621             yes_state = st->u.yes.prev_yes_state;
4622             if (st->logical) {
4623                 st->logical = 0;
4624                 st->sw = !st->u.ifmatch.wanted;
4625             }
4626             else if (st->u.ifmatch.wanted)
4627                 sayNO;
4628
4629             assert(OP(scan) != SUSPEND); /* XXX DAPM tmp */
4630             locinput = PL_reginput = st->locinput;
4631             nextchr = UCHARAT(locinput);
4632             next = scan + ARG(scan);
4633             if (next == scan)
4634                 next = NULL;
4635             goto reenter;
4636
4637         case resume_PLUS1:
4638             goto resume_point_PLUS1;
4639         case resume_PLUS2:
4640             goto resume_point_PLUS2;
4641         case resume_PLUS3:
4642             goto resume_point_PLUS3;
4643         case resume_PLUS4:
4644             goto resume_point_PLUS4;
4645         default:
4646             Perl_croak(aTHX_ "regexp resume memory corruption");
4647         }
4648     }
4649
4650 final_exit:
4651
4652     /* restore original high-water mark */
4653     PL_regmatch_slab  = orig_slab;
4654     PL_regmatch_state = orig_state;
4655
4656     /* free all slabs above current one */
4657     if (orig_slab->next) {
4658         regmatch_slab *sl = orig_slab->next;
4659         orig_slab->next = NULL;
4660         while (sl) {
4661             regmatch_slab * const osl = sl;
4662             sl = sl->next;
4663             Safefree(osl);
4664         }
4665     }
4666
4667     return result;
4668
4669 }
4670
4671 /*
4672  - regrepeat - repeatedly match something simple, report how many
4673  */
4674 /*
4675  * [This routine now assumes that it will only match on things of length 1.
4676  * That was true before, but now we assume scan - reginput is the count,
4677  * rather than incrementing count on every character.  [Er, except utf8.]]
4678  */
4679 STATIC I32
4680 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max)
4681 {
4682     dVAR;
4683     register char *scan;
4684     register I32 c;
4685     register char *loceol = PL_regeol;
4686     register I32 hardcount = 0;
4687     register bool do_utf8 = PL_reg_match_utf8;
4688
4689     scan = PL_reginput;
4690     if (max == REG_INFTY)
4691         max = I32_MAX;
4692     else if (max < loceol - scan)
4693         loceol = scan + max;
4694     switch (OP(p)) {
4695     case REG_ANY:
4696         if (do_utf8) {
4697             loceol = PL_regeol;
4698             while (scan < loceol && hardcount < max && *scan != '\n') {
4699                 scan += UTF8SKIP(scan);
4700                 hardcount++;
4701             }
4702         } else {
4703             while (scan < loceol && *scan != '\n')
4704                 scan++;
4705         }
4706         break;
4707     case SANY:
4708         if (do_utf8) {
4709             loceol = PL_regeol;
4710             while (scan < loceol && hardcount < max) {
4711                 scan += UTF8SKIP(scan);
4712                 hardcount++;
4713             }
4714         }
4715         else
4716             scan = loceol;
4717         break;
4718     case CANY:
4719         scan = loceol;
4720         break;
4721     case EXACT:         /* length of string is 1 */
4722         c = (U8)*STRING(p);
4723         while (scan < loceol && UCHARAT(scan) == c)
4724             scan++;
4725         break;
4726     case EXACTF:        /* length of string is 1 */
4727         c = (U8)*STRING(p);
4728         while (scan < loceol &&
4729                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4730             scan++;
4731         break;
4732     case EXACTFL:       /* length of string is 1 */
4733         PL_reg_flags |= RF_tainted;
4734         c = (U8)*STRING(p);
4735         while (scan < loceol &&
4736                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4737             scan++;
4738         break;
4739     case ANYOF:
4740         if (do_utf8) {
4741             loceol = PL_regeol;
4742             while (hardcount < max && scan < loceol &&
4743                    reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
4744                 scan += UTF8SKIP(scan);
4745                 hardcount++;
4746             }
4747         } else {
4748             while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
4749                 scan++;
4750         }
4751         break;
4752     case ALNUM:
4753         if (do_utf8) {
4754             loceol = PL_regeol;
4755             LOAD_UTF8_CHARCLASS_ALNUM();
4756             while (hardcount < max && scan < loceol &&
4757                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4758                 scan += UTF8SKIP(scan);
4759                 hardcount++;
4760             }
4761         } else {
4762             while (scan < loceol && isALNUM(*scan))
4763                 scan++;
4764         }
4765         break;
4766     case ALNUML:
4767         PL_reg_flags |= RF_tainted;
4768         if (do_utf8) {
4769             loceol = PL_regeol;
4770             while (hardcount < max && scan < loceol &&
4771                    isALNUM_LC_utf8((U8*)scan)) {
4772                 scan += UTF8SKIP(scan);
4773                 hardcount++;
4774             }
4775         } else {
4776             while (scan < loceol && isALNUM_LC(*scan))
4777                 scan++;
4778         }
4779         break;
4780     case NALNUM:
4781         if (do_utf8) {
4782             loceol = PL_regeol;
4783             LOAD_UTF8_CHARCLASS_ALNUM();
4784             while (hardcount < max && scan < loceol &&
4785                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4786                 scan += UTF8SKIP(scan);
4787                 hardcount++;
4788             }
4789         } else {
4790             while (scan < loceol && !isALNUM(*scan))
4791                 scan++;
4792         }
4793         break;
4794     case NALNUML:
4795         PL_reg_flags |= RF_tainted;
4796         if (do_utf8) {
4797             loceol = PL_regeol;
4798             while (hardcount < max && scan < loceol &&
4799                    !isALNUM_LC_utf8((U8*)scan)) {
4800                 scan += UTF8SKIP(scan);
4801                 hardcount++;
4802             }
4803         } else {
4804             while (scan < loceol && !isALNUM_LC(*scan))
4805                 scan++;
4806         }
4807         break;
4808     case SPACE:
4809         if (do_utf8) {
4810             loceol = PL_regeol;
4811             LOAD_UTF8_CHARCLASS_SPACE();
4812             while (hardcount < max && scan < loceol &&
4813                    (*scan == ' ' ||
4814                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4815                 scan += UTF8SKIP(scan);
4816                 hardcount++;
4817             }
4818         } else {
4819             while (scan < loceol && isSPACE(*scan))
4820                 scan++;
4821         }
4822         break;
4823     case SPACEL:
4824         PL_reg_flags |= RF_tainted;
4825         if (do_utf8) {
4826             loceol = PL_regeol;
4827             while (hardcount < max && scan < loceol &&
4828                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4829                 scan += UTF8SKIP(scan);
4830                 hardcount++;
4831             }
4832         } else {
4833             while (scan < loceol && isSPACE_LC(*scan))
4834                 scan++;
4835         }
4836         break;
4837     case NSPACE:
4838         if (do_utf8) {
4839             loceol = PL_regeol;
4840             LOAD_UTF8_CHARCLASS_SPACE();
4841             while (hardcount < max && scan < loceol &&
4842                    !(*scan == ' ' ||
4843                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4844                 scan += UTF8SKIP(scan);
4845                 hardcount++;
4846             }
4847         } else {
4848             while (scan < loceol && !isSPACE(*scan))
4849                 scan++;
4850             break;
4851         }
4852     case NSPACEL:
4853         PL_reg_flags |= RF_tainted;
4854         if (do_utf8) {
4855             loceol = PL_regeol;
4856             while (hardcount < max && scan < loceol &&
4857                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4858                 scan += UTF8SKIP(scan);
4859                 hardcount++;
4860             }
4861         } else {
4862             while (scan < loceol && !isSPACE_LC(*scan))
4863                 scan++;
4864         }
4865         break;
4866     case DIGIT:
4867         if (do_utf8) {
4868             loceol = PL_regeol;
4869             LOAD_UTF8_CHARCLASS_DIGIT();
4870             while (hardcount < max && scan < loceol &&
4871                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4872                 scan += UTF8SKIP(scan);
4873                 hardcount++;
4874             }
4875         } else {
4876             while (scan < loceol && isDIGIT(*scan))
4877                 scan++;
4878         }
4879         break;
4880     case NDIGIT:
4881         if (do_utf8) {
4882             loceol = PL_regeol;
4883             LOAD_UTF8_CHARCLASS_DIGIT();
4884             while (hardcount < max && scan < loceol &&
4885                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4886                 scan += UTF8SKIP(scan);
4887                 hardcount++;
4888             }
4889         } else {
4890             while (scan < loceol && !isDIGIT(*scan))
4891                 scan++;
4892         }
4893         break;
4894     default:            /* Called on something of 0 width. */
4895         break;          /* So match right here or not at all. */
4896     }
4897
4898     if (hardcount)
4899         c = hardcount;
4900     else
4901         c = scan - PL_reginput;
4902     PL_reginput = scan;
4903
4904     DEBUG_r({
4905                 SV *re_debug_flags = NULL;
4906                 SV * const prop = sv_newmortal();
4907                 GET_RE_DEBUG_FLAGS;
4908                 DEBUG_EXECUTE_r({
4909                 regprop(prog, prop, p);
4910                 PerlIO_printf(Perl_debug_log,
4911                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
4912                               REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
4913         });
4914         });
4915
4916     return(c);
4917 }
4918
4919
4920 #ifndef PERL_IN_XSUB_RE
4921 /*
4922 - regclass_swash - prepare the utf8 swash
4923 */
4924
4925 SV *
4926 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
4927 {
4928     dVAR;
4929     SV *sw  = NULL;
4930     SV *si  = NULL;
4931     SV *alt = NULL;
4932     const struct reg_data *data = prog ? prog->data : NULL;
4933
4934     if (data && data->count) {
4935         const U32 n = ARG(node);
4936
4937         if (data->what[n] == 's') {
4938             SV * const rv = (SV*)data->data[n];
4939             AV * const av = (AV*)SvRV((SV*)rv);
4940             SV **const ary = AvARRAY(av);
4941             SV **a, **b;
4942
4943             /* See the end of regcomp.c:S_regclass() for
4944              * documentation of these array elements. */
4945
4946             si = *ary;
4947             a  = SvROK(ary[1]) ? &ary[1] : 0;
4948             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
4949
4950             if (a)
4951                 sw = *a;
4952             else if (si && doinit) {
4953                 sw = swash_init("utf8", "", si, 1, 0);
4954                 (void)av_store(av, 1, sw);
4955             }
4956             if (b)
4957                 alt = *b;
4958         }
4959     }
4960
4961     if (listsvp)
4962         *listsvp = si;
4963     if (altsvp)
4964         *altsvp  = alt;
4965
4966     return sw;
4967 }
4968 #endif
4969
4970 /*
4971  - reginclass - determine if a character falls into a character class
4972
4973   The n is the ANYOF regnode, the p is the target string, lenp
4974   is pointer to the maximum length of how far to go in the p
4975   (if the lenp is zero, UTF8SKIP(p) is used),
4976   do_utf8 tells whether the target string is in UTF-8.
4977
4978  */
4979
4980 STATIC bool
4981 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
4982 {
4983     dVAR;
4984     const char flags = ANYOF_FLAGS(n);
4985     bool match = FALSE;
4986     UV c = *p;
4987     STRLEN len = 0;
4988     STRLEN plen;
4989
4990     if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
4991         c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
4992                 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
4993                 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
4994         if (len == (STRLEN)-1)
4995             Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
4996     }
4997
4998     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
4999     if (do_utf8 || (flags & ANYOF_UNICODE)) {
5000         if (lenp)
5001             *lenp = 0;
5002         if (do_utf8 && !ANYOF_RUNTIME(n)) {
5003             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5004                 match = TRUE;
5005         }
5006         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5007             match = TRUE;
5008         if (!match) {
5009             AV *av;
5010             SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5011
5012             if (sw) {
5013                 if (swash_fetch(sw, p, do_utf8))
5014                     match = TRUE;
5015                 else if (flags & ANYOF_FOLD) {
5016                     if (!match && lenp && av) {
5017                         I32 i;
5018                         for (i = 0; i <= av_len(av); i++) {
5019                             SV* const sv = *av_fetch(av, i, FALSE);
5020                             STRLEN len;
5021                             const char * const s = SvPV_const(sv, len);
5022
5023                             if (len <= plen && memEQ(s, (char*)p, len)) {
5024                                 *lenp = len;
5025                                 match = TRUE;
5026                                 break;
5027                             }
5028                         }
5029                     }
5030                     if (!match) {
5031                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5032                         STRLEN tmplen;
5033
5034                         to_utf8_fold(p, tmpbuf, &tmplen);
5035                         if (swash_fetch(sw, tmpbuf, do_utf8))
5036                             match = TRUE;
5037                     }
5038                 }
5039             }
5040         }
5041         if (match && lenp && *lenp == 0)
5042             *lenp = UNISKIP(NATIVE_TO_UNI(c));
5043     }
5044     if (!match && c < 256) {
5045         if (ANYOF_BITMAP_TEST(n, c))
5046             match = TRUE;
5047         else if (flags & ANYOF_FOLD) {
5048             U8 f;
5049
5050             if (flags & ANYOF_LOCALE) {
5051                 PL_reg_flags |= RF_tainted;
5052                 f = PL_fold_locale[c];
5053             }
5054             else
5055                 f = PL_fold[c];
5056             if (f != c && ANYOF_BITMAP_TEST(n, f))
5057                 match = TRUE;
5058         }
5059
5060         if (!match && (flags & ANYOF_CLASS)) {
5061             PL_reg_flags |= RF_tainted;
5062             if (
5063                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
5064                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
5065                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
5066                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
5067                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
5068                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
5069                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
5070                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5071                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
5072                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
5073                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
5074                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
5075                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
5076                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
5077                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
5078                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
5079                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
5080                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
5081                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
5082                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
5083                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
5084                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
5085                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
5086                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
5087                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
5088                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
5089                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
5090                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
5091                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
5092                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
5093                 ) /* How's that for a conditional? */
5094             {
5095                 match = TRUE;
5096             }
5097         }
5098     }
5099
5100     return (flags & ANYOF_INVERT) ? !match : match;
5101 }
5102
5103 STATIC U8 *
5104 S_reghop3(U8 *s, I32 off, const U8* lim)
5105 {
5106     dVAR;
5107     if (off >= 0) {
5108         while (off-- && s < lim) {
5109             /* XXX could check well-formedness here */
5110             s += UTF8SKIP(s);
5111         }
5112     }
5113     else {
5114         while (off++) {
5115             if (s > lim) {
5116                 s--;
5117                 if (UTF8_IS_CONTINUED(*s)) {
5118                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5119                         s--;
5120                 }
5121                 /* XXX could check well-formedness here */
5122             }
5123         }
5124     }
5125     return s;
5126 }
5127
5128 STATIC U8 *
5129 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5130 {
5131     dVAR;
5132     if (off >= 0) {
5133         while (off-- && s < lim) {
5134             /* XXX could check well-formedness here */
5135             s += UTF8SKIP(s);
5136         }
5137         if (off >= 0)
5138             return 0;
5139     }
5140     else {
5141         while (off++) {
5142             if (s > lim) {
5143                 s--;
5144                 if (UTF8_IS_CONTINUED(*s)) {
5145                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5146                         s--;
5147                 }
5148                 /* XXX could check well-formedness here */
5149             }
5150             else
5151                 break;
5152         }
5153         if (off <= 0)
5154             return 0;
5155     }
5156     return s;
5157 }
5158
5159 static void
5160 restore_pos(pTHX_ void *arg)
5161 {
5162     dVAR;
5163     regexp * const rex = (regexp *)arg;
5164     if (PL_reg_eval_set) {
5165         if (PL_reg_oldsaved) {
5166             rex->subbeg = PL_reg_oldsaved;
5167             rex->sublen = PL_reg_oldsavedlen;
5168 #ifdef PERL_OLD_COPY_ON_WRITE
5169             rex->saved_copy = PL_nrs;
5170 #endif
5171             RX_MATCH_COPIED_on(rex);
5172         }
5173         PL_reg_magic->mg_len = PL_reg_oldpos;
5174         PL_reg_eval_set = 0;
5175         PL_curpm = PL_reg_oldcurpm;
5176     }
5177 }
5178
5179 STATIC void
5180 S_to_utf8_substr(pTHX_ register regexp *prog)
5181 {
5182     if (prog->float_substr && !prog->float_utf8) {
5183         SV* const sv = newSVsv(prog->float_substr);
5184         prog->float_utf8 = sv;
5185         sv_utf8_upgrade(sv);
5186         if (SvTAIL(prog->float_substr))
5187             SvTAIL_on(sv);
5188         if (prog->float_substr == prog->check_substr)
5189             prog->check_utf8 = sv;
5190     }
5191     if (prog->anchored_substr && !prog->anchored_utf8) {
5192         SV* const sv = newSVsv(prog->anchored_substr);
5193         prog->anchored_utf8 = sv;
5194         sv_utf8_upgrade(sv);
5195         if (SvTAIL(prog->anchored_substr))
5196             SvTAIL_on(sv);
5197         if (prog->anchored_substr == prog->check_substr)
5198             prog->check_utf8 = sv;
5199     }
5200 }
5201
5202 STATIC void
5203 S_to_byte_substr(pTHX_ register regexp *prog)
5204 {
5205     dVAR;
5206     if (prog->float_utf8 && !prog->float_substr) {
5207         SV* sv = newSVsv(prog->float_utf8);
5208         prog->float_substr = sv;
5209         if (sv_utf8_downgrade(sv, TRUE)) {
5210             if (SvTAIL(prog->float_utf8))
5211                 SvTAIL_on(sv);
5212         } else {
5213             SvREFCNT_dec(sv);
5214             prog->float_substr = sv = &PL_sv_undef;
5215         }
5216         if (prog->float_utf8 == prog->check_utf8)
5217             prog->check_substr = sv;
5218     }
5219     if (prog->anchored_utf8 && !prog->anchored_substr) {
5220         SV* sv = newSVsv(prog->anchored_utf8);
5221         prog->anchored_substr = sv;
5222         if (sv_utf8_downgrade(sv, TRUE)) {
5223             if (SvTAIL(prog->anchored_utf8))
5224                 SvTAIL_on(sv);
5225         } else {
5226             SvREFCNT_dec(sv);
5227             prog->anchored_substr = sv = &PL_sv_undef;
5228         }
5229         if (prog->anchored_utf8 == prog->check_utf8)
5230             prog->check_substr = sv;
5231     }
5232 }
5233
5234 /*
5235  * Local variables:
5236  * c-indentation-style: bsd
5237  * c-basic-offset: 4
5238  * indent-tabs-mode: t
5239  * End:
5240  *
5241  * ex: set ts=8 sts=4 sw=4 noet:
5242  */