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