regexec.c

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