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