regexec.c

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