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