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