src/5013005/regexec.c

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