regexec.c

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