regexec.c

   1 /*    regexec.c
   2  */
   3
   4 /*
   5  *      One Ring to rule them all, One Ring to find them
   6  &
   7  *     [p.v of _The Lord of the Rings_, opening poem]
   8  *     [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
   9  *     [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
  10  */
  11
  12 /* This file contains functions for executing a regular expression.  See
  13  * also regcomp.c which funnily enough, contains functions for compiling
  14  * a regular expression.
  15  *
  16  * This file is also copied at build time to ext/re/re_exec.c, where
  17  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
  18  * This causes the main functions to be compiled under new names and with
  19  * debugging support added, which makes "use re 'debug'" work.
  20  */
  21
  22 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
  23  * confused with the original package (see point 3 below).  Thanks, Henry!
  24  */
  25
  26 /* Additional note: this code is very heavily munged from Henry's version
  27  * in places.  In some spots I've traded clarity for efficiency, so don't
  28  * blame Henry for some of the lack of readability.
  29  */
  30
  31 /* The names of the functions have been changed from regcomp and
  32  * regexec to  pregcomp and pregexec in order to avoid conflicts
  33  * with the POSIX routines of the same names.
  34 */
  35
  36 #ifdef PERL_EXT_RE_BUILD
  37 #include "re_top.h"
  38 #endif
  39
  40 /*
  41  * pregcomp and pregexec -- regsub and regerror are not used in perl
  42  *
  43  *      Copyright (c) 1986 by University of Toronto.
  44  *      Written by Henry Spencer.  Not derived from licensed software.
  45  *
  46  *      Permission is granted to anyone to use this software for any
  47  *      purpose on any computer system, and to redistribute it freely,
  48  *      subject to the following restrictions:
  49  *
  50  *      1. The author is not responsible for the consequences of use of
  51  *              this software, no matter how awful, even if they arise
  52  *              from defects in it.
  53  *
  54  *      2. The origin of this software must not be misrepresented, either
  55  *              by explicit claim or by omission.
  56  *
  57  *      3. Altered versions must be plainly marked as such, and must not
  58  *              be misrepresented as being the original software.
  59  *
  60  ****    Alterations to Henry's code are...
  61  ****
  62  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
  63  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
  64  ****    by Larry Wall and others
  65  ****
  66  ****    You may distribute under the terms of either the GNU General Public
  67  ****    License or the Artistic License, as specified in the README file.
  68  *
  69  * Beware that some of this code is subtly aware of the way operator
  70  * precedence is structured in regular expressions.  Serious changes in
  71  * regular-expression syntax might require a total rethink.
  72  */
  73 #include "EXTERN.h"
  74 #define PERL_IN_REGEXEC_C
  75 #include "perl.h"
  76
  77 #ifdef PERL_IN_XSUB_RE
  78 #  include "re_comp.h"
  79 #else
  80 #  include "regcomp.h"
  81 #endif
  82
  83 #define RF_tainted      1               /* tainted information used? */
  84 #define RF_warned       2               /* warned about big count? */
  85
  86 #define RF_utf8         8               /* Pattern contains multibyte chars? */
  87
  88 #define UTF ((PL_reg_flags & RF_utf8) != 0)
  89
  90 #define RS_init         1               /* eval environment created */
  91 #define RS_set          2               /* replsv value is set */
  92
  93 #ifndef STATIC
  94 #define STATIC  static
  95 #endif
  96
  97 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
  98
  99 /*
 100  * Forwards.
 101  */
 102
 103 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
 104 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
 105
 106 #define HOPc(pos,off) \
 107         (char *)(PL_reg_match_utf8 \
 108             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
 109             : (U8*)(pos + off))
 110 #define HOPBACKc(pos, off) \
 111         (char*)(PL_reg_match_utf8\
 112             ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
 113             : (pos - off >= PL_bostr)           \
 114                 ? (U8*)pos - off                \
 115                 : NULL)
 116
 117 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
 118 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
 119
 120 /* these are unrolled below in the CCC_TRY_XXX defined */
 121 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
 122     if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
 123 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
 124 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
 125 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
 126 #define LOAD_UTF8_CHARCLASS_MARK()  LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
 127
 128
 129 #define CCC_TRY_AFF(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC)                          \
 130         case NAMEL:                                                              \
 131             PL_reg_flags |= RF_tainted;                                                 \
 132             /* FALL THROUGH */                                                          \
 133         case NAME:                                                                     \
 134             if (!nextchr)                                                               \
 135                 sayNO;                                                                  \
 136             if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) {                                \
 137                 if (!CAT2(PL_utf8_,CLASS)) {                                            \
 138                     bool ok;                                                            \
 139                     ENTER;                                                              \
 140                     save_re_context();                                                  \
 141                     ok=CAT2(is_utf8_,CLASS)((const U8*)STR);                            \
 142                     assert(ok);                                                         \
 143                     LEAVE;                                                              \
 144                 }                                                                       \
 145                 if (!(OP(scan) == NAME                                                  \
 146                     ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)   \
 147                     : LCFUNC_utf8((U8*)locinput)))                                      \
 148                 {                                                                       \
 149                     sayNO;                                                              \
 150                 }                                                                       \
 151                 locinput += PL_utf8skip[nextchr];                                       \
 152                 nextchr = UCHARAT(locinput);                                            \
 153                 break;                                                                  \
 154             }                                                                           \
 155             if (!(OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr)))                  \
 156                 sayNO;                                                                  \
 157             nextchr = UCHARAT(++locinput);                                              \
 158             break
 159
 160 #define CCC_TRY_NEG(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC)                        \
 161         case NAMEL:                                                              \
 162             PL_reg_flags |= RF_tainted;                                                 \
 163             /* FALL THROUGH */                                                          \
 164         case NAME :                                                                     \
 165             if (!nextchr && locinput >= PL_regeol)                                      \
 166                 sayNO;                                                                  \
 167             if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) {                                \
 168                 if (!CAT2(PL_utf8_,CLASS)) {                                            \
 169                     bool ok;                                                            \
 170                     ENTER;                                                              \
 171                     save_re_context();                                                  \
 172                     ok=CAT2(is_utf8_,CLASS)((const U8*)STR);                            \
 173                     assert(ok);                                                         \
 174                     LEAVE;                                                              \
 175                 }                                                                       \
 176                 if ((OP(scan) == NAME                                                  \
 177                     ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)    \
 178                     : LCFUNC_utf8((U8*)locinput)))                                      \
 179                 {                                                                       \
 180                     sayNO;                                                              \
 181                 }                                                                       \
 182                 locinput += PL_utf8skip[nextchr];                                       \
 183                 nextchr = UCHARAT(locinput);                                            \
 184                 break;                                                                  \
 185             }                                                                           \
 186             if ((OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr)))                   \
 187                 sayNO;                                                                  \
 188             nextchr = UCHARAT(++locinput);                                              \
 189             break
 190
 191
 192 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
 193
 194 /* for use after a quantifier and before an EXACT-like node -- japhy */
 195 /* it would be nice to rework regcomp.sym to generate this stuff. sigh */
 196 #define JUMPABLE(rn) (      \
 197     OP(rn) == OPEN ||       \
 198     (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
 199     OP(rn) == EVAL ||   \
 200     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 201     OP(rn) == PLUS || OP(rn) == MINMOD || \
 202     OP(rn) == KEEPS || (PL_regkind[OP(rn)] == VERB) || \
 203     (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
 204 )
 205 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
 206
 207 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
 208
 209 #if 0
 210 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
 211    we don't need this definition. */
 212 #define IS_TEXT(rn)   ( OP(rn)==EXACT   || OP(rn)==REF   || OP(rn)==NREF   )
 213 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  || OP(rn)==REFF  || OP(rn)==NREFF  )
 214 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
 215
 216 #else
 217 /* ... so we use this as its faster. */
 218 #define IS_TEXT(rn)   ( OP(rn)==EXACT   )
 219 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  )
 220 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
 221
 222 #endif
 223
 224 /*
 225   Search for mandatory following text node; for lookahead, the text must
 226   follow but for lookbehind (rn->flags != 0) we skip to the next step.
 227 */
 228 #define FIND_NEXT_IMPT(rn) STMT_START { \
 229     while (JUMPABLE(rn)) { \
 230         const OPCODE type = OP(rn); \
 231         if (type == SUSPEND || PL_regkind[type] == CURLY) \
 232             rn = NEXTOPER(NEXTOPER(rn)); \
 233         else if (type == PLUS) \
 234             rn = NEXTOPER(rn); \
 235         else if (type == IFMATCH) \
 236             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
 237         else rn += NEXT_OFF(rn); \
 238     } \
 239 } STMT_END
 240
 241
 242 static void restore_pos(pTHX_ void *arg);
 243
 244 STATIC CHECKPOINT
 245 S_regcppush(pTHX_ I32 parenfloor)
 246 {
 247     dVAR;
 248     const int retval = PL_savestack_ix;
 249 #define REGCP_PAREN_ELEMS 4
 250     const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
 251     int p;
 252     GET_RE_DEBUG_FLAGS_DECL;
 253
 254     if (paren_elems_to_push < 0)
 255         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
 256
 257 #define REGCP_OTHER_ELEMS 7
 258     SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
 259
 260     for (p = PL_regsize; p > parenfloor; p--) {
 261 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 262         SSPUSHINT(PL_regoffs[p].end);
 263         SSPUSHINT(PL_regoffs[p].start);
 264         SSPUSHPTR(PL_reg_start_tmp[p]);
 265         SSPUSHINT(p);
 266         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
 267           "     saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
 268                       (UV)p, (IV)PL_regoffs[p].start,
 269                       (IV)(PL_reg_start_tmp[p] - PL_bostr),
 270                       (IV)PL_regoffs[p].end
 271         ));
 272     }
 273 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 274     SSPUSHPTR(PL_regoffs);
 275     SSPUSHINT(PL_regsize);
 276     SSPUSHINT(*PL_reglastparen);
 277     SSPUSHINT(*PL_reglastcloseparen);
 278     SSPUSHPTR(PL_reginput);
 279 #define REGCP_FRAME_ELEMS 2
 280 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
 281  * are needed for the regexp context stack bookkeeping. */
 282     SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 283     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
 284
 285     return retval;
 286 }
 287
 288 /* These are needed since we do not localize EVAL nodes: */
 289 #define REGCP_SET(cp)                                           \
 290     DEBUG_STATE_r(                                              \
 291             PerlIO_printf(Perl_debug_log,                       \
 292                 "  Setting an EVAL scope, savestack=%"IVdf"\n", \
 293                 (IV)PL_savestack_ix));                          \
 294     cp = PL_savestack_ix
 295
 296 #define REGCP_UNWIND(cp)                                        \
 297     DEBUG_STATE_r(                                              \
 298         if (cp != PL_savestack_ix)                              \
 299             PerlIO_printf(Perl_debug_log,                       \
 300                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 301                 (IV)(cp), (IV)PL_savestack_ix));                \
 302     regcpblow(cp)
 303
 304 STATIC char *
 305 S_regcppop(pTHX_ const regexp *rex)
 306 {
 307     dVAR;
 308     U32 i;
 309     char *input;
 310     GET_RE_DEBUG_FLAGS_DECL;
 311
 312     PERL_ARGS_ASSERT_REGCPPOP;
 313
 314     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 315     i = SSPOPINT;
 316     assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 317     i = SSPOPINT; /* Parentheses elements to pop. */
 318     input = (char *) SSPOPPTR;
 319     *PL_reglastcloseparen = SSPOPINT;
 320     *PL_reglastparen = SSPOPINT;
 321     PL_regsize = SSPOPINT;
 322     PL_regoffs=(regexp_paren_pair *) SSPOPPTR;
 323
 324
 325     /* Now restore the parentheses context. */
 326     for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 327          i > 0; i -= REGCP_PAREN_ELEMS) {
 328         I32 tmps;
 329         U32 paren = (U32)SSPOPINT;
 330         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
 331         PL_regoffs[paren].start = SSPOPINT;
 332         tmps = SSPOPINT;
 333         if (paren <= *PL_reglastparen)
 334             PL_regoffs[paren].end = tmps;
 335         DEBUG_BUFFERS_r(
 336             PerlIO_printf(Perl_debug_log,
 337                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 338                           (UV)paren, (IV)PL_regoffs[paren].start,
 339                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
 340                           (IV)PL_regoffs[paren].end,
 341                           (paren > *PL_reglastparen ? "(no)" : ""));
 342         );
 343     }
 344     DEBUG_BUFFERS_r(
 345         if (*PL_reglastparen + 1 <= rex->nparens) {
 346             PerlIO_printf(Perl_debug_log,
 347                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
 348                           (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
 349         }
 350     );
 351 #if 1
 352     /* It would seem that the similar code in regtry()
 353      * already takes care of this, and in fact it is in
 354      * a better location to since this code can #if 0-ed out
 355      * but the code in regtry() is needed or otherwise tests
 356      * requiring null fields (pat.t#187 and split.t#{13,14}
 357      * (as of patchlevel 7877)  will fail.  Then again,
 358      * this code seems to be necessary or otherwise
 359      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
 360      * --jhi updated by dapm */
 361     for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
 362         if (i > PL_regsize)
 363             PL_regoffs[i].start = -1;
 364         PL_regoffs[i].end = -1;
 365     }
 366 #endif
 367     return input;
 368 }
 369
 370 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
 371
 372 /*
 373  * pregexec and friends
 374  */
 375
 376 #ifndef PERL_IN_XSUB_RE
 377 /*
 378  - pregexec - match a regexp against a string
 379  */
 380 I32
 381 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
 382          char *strbeg, I32 minend, SV *screamer, U32 nosave)
 383 /* strend: pointer to null at end of string */
 384 /* strbeg: real beginning of string */
 385 /* minend: end of match must be >=minend after stringarg. */
 386 /* nosave: For optimizations. */
 387 {
 388     PERL_ARGS_ASSERT_PREGEXEC;
 389
 390     return
 391         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 392                       nosave ? 0 : REXEC_COPY_STR);
 393 }
 394 #endif
 395
 396 /*
 397  * Need to implement the following flags for reg_anch:
 398  *
 399  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
 400  * USE_INTUIT_ML
 401  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
 402  * INTUIT_AUTORITATIVE_ML
 403  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
 404  * INTUIT_ONCE_ML
 405  *
 406  * Another flag for this function: SECOND_TIME (so that float substrs
 407  * with giant delta may be not rechecked).
 408  */
 409
 410 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 411
 412 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
 413    Otherwise, only SvCUR(sv) is used to get strbeg. */
 414
 415 /* XXXX We assume that strpos is strbeg unless sv. */
 416
 417 /* XXXX Some places assume that there is a fixed substring.
 418         An update may be needed if optimizer marks as "INTUITable"
 419         RExen without fixed substrings.  Similarly, it is assumed that
 420         lengths of all the strings are no more than minlen, thus they
 421         cannot come from lookahead.
 422         (Or minlen should take into account lookahead.)
 423   NOTE: Some of this comment is not correct. minlen does now take account
 424   of lookahead/behind. Further research is required. -- demerphq
 425
 426 */
 427
 428 /* A failure to find a constant substring means that there is no need to make
 429    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 430    finding a substring too deep into the string means that less calls to
 431    regtry() should be needed.
 432
 433    REx compiler's optimizer found 4 possible hints:
 434         a) Anchored substring;
 435         b) Fixed substring;
 436         c) Whether we are anchored (beginning-of-line or \G);
 437         d) First node (of those at offset 0) which may distingush positions;
 438    We use a)b)d) and multiline-part of c), and try to find a position in the
 439    string which does not contradict any of them.
 440  */
 441
 442 /* Most of decisions we do here should have been done at compile time.
 443    The nodes of the REx which we used for the search should have been
 444    deleted from the finite automaton. */
 445
 446 char *
 447 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
 448                      char *strend, const U32 flags, re_scream_pos_data *data)
 449 {
 450     dVAR;
 451     struct regexp *const prog = (struct regexp *)SvANY(rx);
 452     register I32 start_shift = 0;
 453     /* Should be nonnegative! */
 454     register I32 end_shift   = 0;
 455     register char *s;
 456     register SV *check;
 457     char *strbeg;
 458     char *t;
 459     const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
 460     I32 ml_anch;
 461     register char *other_last = NULL;   /* other substr checked before this */
 462     char *check_at = NULL;              /* check substr found at this pos */
 463     const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
 464     RXi_GET_DECL(prog,progi);
 465 #ifdef DEBUGGING
 466     const char * const i_strpos = strpos;
 467 #endif
 468     GET_RE_DEBUG_FLAGS_DECL;
 469
 470     PERL_ARGS_ASSERT_RE_INTUIT_START;
 471
 472     RX_MATCH_UTF8_set(rx,do_utf8);
 473
 474     if (RX_UTF8(rx)) {
 475         PL_reg_flags |= RF_utf8;
 476     }
 477     DEBUG_EXECUTE_r(
 478         debug_start_match(rx, do_utf8, strpos, strend,
 479             sv ? "Guessing start of match in sv for"
 480                : "Guessing start of match in string for");
 481               );
 482
 483     /* CHR_DIST() would be more correct here but it makes things slow. */
 484     if (prog->minlen > strend - strpos) {
 485         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 486                               "String too short... [re_intuit_start]\n"));
 487         goto fail;
 488     }
 489
 490     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
 491     PL_regeol = strend;
 492     if (do_utf8) {
 493         if (!prog->check_utf8 && prog->check_substr)
 494             to_utf8_substr(prog);
 495         check = prog->check_utf8;
 496     } else {
 497         if (!prog->check_substr && prog->check_utf8)
 498             to_byte_substr(prog);
 499         check = prog->check_substr;
 500     }
 501     if (check == &PL_sv_undef) {
 502         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 503                 "Non-utf8 string cannot match utf8 check string\n"));
 504         goto fail;
 505     }
 506     if (prog->extflags & RXf_ANCH) {    /* Match at beg-of-str or after \n */
 507         ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
 508                      || ( (prog->extflags & RXf_ANCH_BOL)
 509                           && !multiline ) );    /* Check after \n? */
 510
 511         if (!ml_anch) {
 512           if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
 513                 && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
 514                /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
 515                && sv && !SvROK(sv)
 516                && (strpos != strbeg)) {
 517               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 518               goto fail;
 519           }
 520           if (prog->check_offset_min == prog->check_offset_max &&
 521               !(prog->extflags & RXf_CANY_SEEN)) {
 522             /* Substring at constant offset from beg-of-str... */
 523             I32 slen;
 524
 525             s = HOP3c(strpos, prog->check_offset_min, strend);
 526
 527             if (SvTAIL(check)) {
 528                 slen = SvCUR(check);    /* >= 1 */
 529
 530                 if ( strend - s > slen || strend - s < slen - 1
 531                      || (strend - s == slen && strend[-1] != '\n')) {
 532                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 533                     goto fail_finish;
 534                 }
 535                 /* Now should match s[0..slen-2] */
 536                 slen--;
 537                 if (slen && (*SvPVX_const(check) != *s
 538                              || (slen > 1
 539                                  && memNE(SvPVX_const(check), s, slen)))) {
 540                   report_neq:
 541                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 542                     goto fail_finish;
 543                 }
 544             }
 545             else if (*SvPVX_const(check) != *s
 546                      || ((slen = SvCUR(check)) > 1
 547                          && memNE(SvPVX_const(check), s, slen)))
 548                 goto report_neq;
 549             check_at = s;
 550             goto success_at_start;
 551           }
 552         }
 553         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 554         s = strpos;
 555         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 556         end_shift = prog->check_end_shift;
 557
 558         if (!ml_anch) {
 559             const I32 end = prog->check_offset_max + CHR_SVLEN(check)
 560                                          - (SvTAIL(check) != 0);
 561             const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 562
 563             if (end_shift < eshift)
 564                 end_shift = eshift;
 565         }
 566     }
 567     else {                              /* Can match at random position */
 568         ml_anch = 0;
 569         s = strpos;
 570         start_shift = prog->check_offset_min;  /* okay to underestimate on CC */
 571         end_shift = prog->check_end_shift;
 572
 573         /* end shift should be non negative here */
 574     }
 575
 576 #ifdef QDEBUGGING       /* 7/99: reports of failure (with the older version) */
 577     if (end_shift < 0)
 578         Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
 579                    (IV)end_shift, RX_PRECOMP(prog));
 580 #endif
 581
 582   restart:
 583     /* Find a possible match in the region s..strend by looking for
 584        the "check" substring in the region corrected by start/end_shift. */
 585
 586     {
 587         I32 srch_start_shift = start_shift;
 588         I32 srch_end_shift = end_shift;
 589         if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
 590             srch_end_shift -= ((strbeg - s) - srch_start_shift);
 591             srch_start_shift = strbeg - s;
 592         }
 593     DEBUG_OPTIMISE_MORE_r({
 594         PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
 595             (IV)prog->check_offset_min,
 596             (IV)srch_start_shift,
 597             (IV)srch_end_shift,
 598             (IV)prog->check_end_shift);
 599     });
 600
 601     if (flags & REXEC_SCREAM) {
 602         I32 p = -1;                     /* Internal iterator of scream. */
 603         I32 * const pp = data ? data->scream_pos : &p;
 604
 605         if (PL_screamfirst[BmRARE(check)] >= 0
 606             || ( BmRARE(check) == '\n'
 607                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
 608                  && SvTAIL(check) ))
 609             s = screaminstr(sv, check,
 610                             srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
 611         else
 612             goto fail_finish;
 613         /* we may be pointing at the wrong string */
 614         if (s && RXp_MATCH_COPIED(prog))
 615             s = strbeg + (s - SvPVX_const(sv));
 616         if (data)
 617             *data->scream_olds = s;
 618     }
 619     else {
 620         U8* start_point;
 621         U8* end_point;
 622         if (prog->extflags & RXf_CANY_SEEN) {
 623             start_point= (U8*)(s + srch_start_shift);
 624             end_point= (U8*)(strend - srch_end_shift);
 625         } else {
 626             start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
 627             end_point= HOP3(strend, -srch_end_shift, strbeg);
 628         }
 629         DEBUG_OPTIMISE_MORE_r({
 630             PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
 631                 (int)(end_point - start_point),
 632                 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
 633                 start_point);
 634         });
 635
 636         s = fbm_instr( start_point, end_point,
 637                       check, multiline ? FBMrf_MULTILINE : 0);
 638     }
 639     }
 640     /* Update the count-of-usability, remove useless subpatterns,
 641         unshift s.  */
 642
 643     DEBUG_EXECUTE_r({
 644         RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 645             SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
 646         PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
 647                           (s ? "Found" : "Did not find"),
 648             (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)
 649                 ? "anchored" : "floating"),
 650             quoted,
 651             RE_SV_TAIL(check),
 652             (s ? " at offset " : "...\n") );
 653     });
 654
 655     if (!s)
 656         goto fail_finish;
 657     /* Finish the diagnostic message */
 658     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 659
 660     /* XXX dmq: first branch is for positive lookbehind...
 661        Our check string is offset from the beginning of the pattern.
 662        So we need to do any stclass tests offset forward from that
 663        point. I think. :-(
 664      */
 665
 666
 667
 668     check_at=s;
 669
 670
 671     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 672        Start with the other substr.
 673        XXXX no SCREAM optimization yet - and a very coarse implementation
 674        XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
 675                 *always* match.  Probably should be marked during compile...
 676        Probably it is right to do no SCREAM here...
 677      */
 678
 679     if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
 680                 : (prog->float_substr && prog->anchored_substr))
 681     {
 682         /* Take into account the "other" substring. */
 683         /* XXXX May be hopelessly wrong for UTF... */
 684         if (!other_last)
 685             other_last = strpos;
 686         if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
 687           do_other_anchored:
 688             {
 689                 char * const last = HOP3c(s, -start_shift, strbeg);
 690                 char *last1, *last2;
 691                 char * const saved_s = s;
 692                 SV* must;
 693
 694                 t = s - prog->check_offset_max;
 695                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 696                     && (!do_utf8
 697                         || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
 698                             && t > strpos)))
 699                     NOOP;
 700                 else
 701                     t = strpos;
 702                 t = HOP3c(t, prog->anchored_offset, strend);
 703                 if (t < other_last)     /* These positions already checked */
 704                     t = other_last;
 705                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 706                 if (last < last1)
 707                     last1 = last;
 708                 /* XXXX It is not documented what units *_offsets are in.
 709                    We assume bytes, but this is clearly wrong.
 710                    Meaning this code needs to be carefully reviewed for errors.
 711                    dmq.
 712                   */
 713
 714                 /* On end-of-str: see comment below. */
 715                 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
 716                 if (must == &PL_sv_undef) {
 717                     s = (char*)NULL;
 718                     DEBUG_r(must = prog->anchored_utf8);        /* for debug */
 719                 }
 720                 else
 721                     s = fbm_instr(
 722                         (unsigned char*)t,
 723                         HOP3(HOP3(last1, prog->anchored_offset, strend)
 724                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
 725                         must,
 726                         multiline ? FBMrf_MULTILINE : 0
 727                     );
 728                 DEBUG_EXECUTE_r({
 729                     RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 730                         SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 731                     PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
 732                         (s ? "Found" : "Contradicts"),
 733                         quoted, RE_SV_TAIL(must));
 734                 });
 735
 736
 737                 if (!s) {
 738                     if (last1 >= last2) {
 739                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 740                                                 ", giving up...\n"));
 741                         goto fail_finish;
 742                     }
 743                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 744                         ", trying floating at offset %ld...\n",
 745                         (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
 746                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 747                     s = HOP3c(last, 1, strend);
 748                     goto restart;
 749                 }
 750                 else {
 751                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 752                           (long)(s - i_strpos)));
 753                     t = HOP3c(s, -prog->anchored_offset, strbeg);
 754                     other_last = HOP3c(s, 1, strend);
 755                     s = saved_s;
 756                     if (t == strpos)
 757                         goto try_at_start;
 758                     goto try_at_offset;
 759                 }
 760             }
 761         }
 762         else {          /* Take into account the floating substring. */
 763             char *last, *last1;
 764             char * const saved_s = s;
 765             SV* must;
 766
 767             t = HOP3c(s, -start_shift, strbeg);
 768             last1 = last =
 769                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 770             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 771                 last = HOP3c(t, prog->float_max_offset, strend);
 772             s = HOP3c(t, prog->float_min_offset, strend);
 773             if (s < other_last)
 774                 s = other_last;
 775  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 776             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
 777             /* fbm_instr() takes into account exact value of end-of-str
 778                if the check is SvTAIL(ed).  Since false positives are OK,
 779                and end-of-str is not later than strend we are OK. */
 780             if (must == &PL_sv_undef) {
 781                 s = (char*)NULL;
 782                 DEBUG_r(must = prog->float_utf8);       /* for debug message */
 783             }
 784             else
 785                 s = fbm_instr((unsigned char*)s,
 786                               (unsigned char*)last + SvCUR(must)
 787                                   - (SvTAIL(must)!=0),
 788                               must, multiline ? FBMrf_MULTILINE : 0);
 789             DEBUG_EXECUTE_r({
 790                 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 791                     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 792                 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
 793                     (s ? "Found" : "Contradicts"),
 794                     quoted, RE_SV_TAIL(must));
 795             });
 796             if (!s) {
 797                 if (last1 == last) {
 798                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 799                                             ", giving up...\n"));
 800                     goto fail_finish;
 801                 }
 802                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 803                     ", trying anchored starting at offset %ld...\n",
 804                     (long)(saved_s + 1 - i_strpos)));
 805                 other_last = last;
 806                 s = HOP3c(t, 1, strend);
 807                 goto restart;
 808             }
 809             else {
 810                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 811                       (long)(s - i_strpos)));
 812                 other_last = s; /* Fix this later. --Hugo */
 813                 s = saved_s;
 814                 if (t == strpos)
 815                     goto try_at_start;
 816                 goto try_at_offset;
 817             }
 818         }
 819     }
 820
 821
 822     t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
 823
 824     DEBUG_OPTIMISE_MORE_r(
 825         PerlIO_printf(Perl_debug_log,
 826             "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
 827             (IV)prog->check_offset_min,
 828             (IV)prog->check_offset_max,
 829             (IV)(s-strpos),
 830             (IV)(t-strpos),
 831             (IV)(t-s),
 832             (IV)(strend-strpos)
 833         )
 834     );
 835
 836     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 837         && (!do_utf8
 838             || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
 839                  && t > strpos)))
 840     {
 841         /* Fixed substring is found far enough so that the match
 842            cannot start at strpos. */
 843       try_at_offset:
 844         if (ml_anch && t[-1] != '\n') {
 845             /* Eventually fbm_*() should handle this, but often
 846                anchored_offset is not 0, so this check will not be wasted. */
 847             /* XXXX In the code below we prefer to look for "^" even in
 848                presence of anchored substrings.  And we search even
 849                beyond the found float position.  These pessimizations
 850                are historical artefacts only.  */
 851           find_anchor:
 852             while (t < strend - prog->minlen) {
 853                 if (*t == '\n') {
 854                     if (t < check_at - prog->check_offset_min) {
 855                         if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
 856                             /* Since we moved from the found position,
 857                                we definitely contradict the found anchored
 858                                substr.  Due to the above check we do not
 859                                contradict "check" substr.
 860                                Thus we can arrive here only if check substr
 861                                is float.  Redo checking for "other"=="fixed".
 862                              */
 863                             strpos = t + 1;
 864                             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
 865                                 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
 866                             goto do_other_anchored;
 867                         }
 868                         /* We don't contradict the found floating substring. */
 869                         /* XXXX Why not check for STCLASS? */
 870                         s = t + 1;
 871                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
 872                             PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
 873                         goto set_useful;
 874                     }
 875                     /* Position contradicts check-string */
 876                     /* XXXX probably better to look for check-string
 877                        than for "\n", so one should lower the limit for t? */
 878                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
 879                         PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
 880                     other_last = strpos = s = t + 1;
 881                     goto restart;
 882                 }
 883                 t++;
 884             }
 885             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
 886                         PL_colors[0], PL_colors[1]));
 887             goto fail_finish;
 888         }
 889         else {
 890             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
 891                         PL_colors[0], PL_colors[1]));
 892         }
 893         s = t;
 894       set_useful:
 895         ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr);    /* hooray/5 */
 896     }
 897     else {
 898         /* The found string does not prohibit matching at strpos,
 899            - no optimization of calling REx engine can be performed,
 900            unless it was an MBOL and we are not after MBOL,
 901            or a future STCLASS check will fail this. */
 902       try_at_start:
 903         /* Even in this situation we may use MBOL flag if strpos is offset
 904            wrt the start of the string. */
 905         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
 906             && (strpos != strbeg) && strpos[-1] != '\n'
 907             /* May be due to an implicit anchor of m{.*foo}  */
 908             && !(prog->intflags & PREGf_IMPLICIT))
 909         {
 910             t = strpos;
 911             goto find_anchor;
 912         }
 913         DEBUG_EXECUTE_r( if (ml_anch)
 914             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
 915                           (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
 916         );
 917       success_at_start:
 918         if (!(prog->intflags & PREGf_NAUGHTY)   /* XXXX If strpos moved? */
 919             && (do_utf8 ? (
 920                 prog->check_utf8                /* Could be deleted already */
 921                 && --BmUSEFUL(prog->check_utf8) < 0
 922                 && (prog->check_utf8 == prog->float_utf8)
 923             ) : (
 924                 prog->check_substr              /* Could be deleted already */
 925                 && --BmUSEFUL(prog->check_substr) < 0
 926                 && (prog->check_substr == prog->float_substr)
 927             )))
 928         {
 929             /* If flags & SOMETHING - do not do it many times on the same match */
 930             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
 931             SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
 932             if (do_utf8 ? prog->check_substr : prog->check_utf8)
 933                 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
 934             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
 935             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
 936             check = NULL;                       /* abort */
 937             s = strpos;
 938             /* XXXX This is a remnant of the old implementation.  It
 939                     looks wasteful, since now INTUIT can use many
 940                     other heuristics. */
 941             prog->extflags &= ~RXf_USE_INTUIT;
 942         }
 943         else
 944             s = strpos;
 945     }
 946
 947     /* Last resort... */
 948     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
 949     /* trie stclasses are too expensive to use here, we are better off to
 950        leave it to regmatch itself */
 951     if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
 952         /* minlen == 0 is possible if regstclass is \b or \B,
 953            and the fixed substr is ''$.
 954            Since minlen is already taken into account, s+1 is before strend;
 955            accidentally, minlen >= 1 guaranties no false positives at s + 1
 956            even for \b or \B.  But (minlen? 1 : 0) below assumes that
 957            regstclass does not come from lookahead...  */
 958         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
 959            This leaves EXACTF only, which is dealt with in find_byclass().  */
 960         const U8* const str = (U8*)STRING(progi->regstclass);
 961         const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
 962                     ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
 963                     : 1);
 964         char * endpos;
 965         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
 966             endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
 967         else if (prog->float_substr || prog->float_utf8)
 968             endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
 969         else
 970             endpos= strend;
 971
 972         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
 973                                       (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
 974
 975         t = s;
 976         s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
 977         if (!s) {
 978 #ifdef DEBUGGING
 979             const char *what = NULL;
 980 #endif
 981             if (endpos == strend) {
 982                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 983                                 "Could not match STCLASS...\n") );
 984                 goto fail;
 985             }
 986             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 987                                    "This position contradicts STCLASS...\n") );
 988             if ((prog->extflags & RXf_ANCH) && !ml_anch)
 989                 goto fail;
 990             /* Contradict one of substrings */
 991             if (prog->anchored_substr || prog->anchored_utf8) {
 992                 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
 993                     DEBUG_EXECUTE_r( what = "anchored" );
 994                   hop_and_restart:
 995                     s = HOP3c(t, 1, strend);
 996                     if (s + start_shift + end_shift > strend) {
 997                         /* XXXX Should be taken into account earlier? */
 998                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 999                                                "Could not match STCLASS...\n") );
1000                         goto fail;
1001                     }
1002                     if (!check)
1003                         goto giveup;
1004                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1005                                 "Looking for %s substr starting at offset %ld...\n",
1006                                  what, (long)(s + start_shift - i_strpos)) );
1007                     goto restart;
1008                 }
1009                 /* Have both, check_string is floating */
1010                 if (t + start_shift >= check_at) /* Contradicts floating=check */
1011                     goto retry_floating_check;
1012                 /* Recheck anchored substring, but not floating... */
1013                 s = check_at;
1014                 if (!check)
1015                     goto giveup;
1016                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1017                           "Looking for anchored substr starting at offset %ld...\n",
1018                           (long)(other_last - i_strpos)) );
1019                 goto do_other_anchored;
1020             }
1021             /* Another way we could have checked stclass at the
1022                current position only: */
1023             if (ml_anch) {
1024                 s = t = t + 1;
1025                 if (!check)
1026                     goto giveup;
1027                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1028                           "Looking for /%s^%s/m starting at offset %ld...\n",
1029                           PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
1030                 goto try_at_offset;
1031             }
1032             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))     /* Could have been deleted */
1033                 goto fail;
1034             /* Check is floating subtring. */
1035           retry_floating_check:
1036             t = check_at - start_shift;
1037             DEBUG_EXECUTE_r( what = "floating" );
1038             goto hop_and_restart;
1039         }
1040         if (t != s) {
1041             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1042                         "By STCLASS: moving %ld --> %ld\n",
1043                                   (long)(t - i_strpos), (long)(s - i_strpos))
1044                    );
1045         }
1046         else {
1047             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1048                                   "Does not contradict STCLASS...\n");
1049                    );
1050         }
1051     }
1052   giveup:
1053     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
1054                           PL_colors[4], (check ? "Guessed" : "Giving up"),
1055                           PL_colors[5], (long)(s - i_strpos)) );
1056     return s;
1057
1058   fail_finish:                          /* Substring not found */
1059     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
1060         BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1061   fail:
1062     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1063                           PL_colors[4], PL_colors[5]));
1064     return NULL;
1065 }
1066
1067 #define DECL_TRIE_TYPE(scan) \
1068     const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
1069                     trie_type = (scan->flags != EXACT) \
1070                               ? (do_utf8 ? trie_utf8_fold : (UTF ? trie_latin_utf8_fold : trie_plain)) \
1071                               : (do_utf8 ? trie_utf8 : trie_plain)
1072
1073 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len,  \
1074 uvc, charid, foldlen, foldbuf, uniflags) STMT_START {                       \
1075     UV uvc_unfolded = 0;                                                    \
1076     switch (trie_type) {                                                    \
1077     case trie_utf8_fold:                                                    \
1078         if ( foldlen>0 ) {                                                  \
1079             uvc_unfolded = uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1080             foldlen -= len;                                                 \
1081             uscan += len;                                                   \
1082             len=0;                                                          \
1083         } else {                                                            \
1084             uvc_unfolded = uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1085             uvc = to_uni_fold( uvc, foldbuf, &foldlen );                    \
1086             foldlen -= UNISKIP( uvc );                                      \
1087             uscan = foldbuf + UNISKIP( uvc );                               \
1088         }                                                                   \
1089         break;                                                              \
1090     case trie_latin_utf8_fold:                                              \
1091         if ( foldlen>0 ) {                                                  \
1092             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );     \
1093             foldlen -= len;                                                 \
1094             uscan += len;                                                   \
1095             len=0;                                                          \
1096         } else {                                                            \
1097             len = 1;                                                        \
1098             uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen );               \
1099             foldlen -= UNISKIP( uvc );                                      \
1100             uscan = foldbuf + UNISKIP( uvc );                               \
1101         }                                                                   \
1102         break;                                                              \
1103     case trie_utf8:                                                         \
1104         uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );       \
1105         break;                                                              \
1106     case trie_plain:                                                        \
1107         uvc = (UV)*uc;                                                      \
1108         len = 1;                                                            \
1109     }                                                                       \
1110                                                                             \
1111     if (uvc < 256) {                                                        \
1112         charid = trie->charmap[ uvc ];                                      \
1113     }                                                                       \
1114     else {                                                                  \
1115         charid = 0;                                                         \
1116         if (widecharmap) {                                                  \
1117             SV** const svpp = hv_fetch(widecharmap,                         \
1118                         (char*)&uvc, sizeof(UV), 0);                        \
1119             if (svpp)                                                       \
1120                 charid = (U16)SvIV(*svpp);                                  \
1121         }                                                                   \
1122     }                                                                       \
1123     if (!charid && trie_type == trie_utf8_fold && !UTF) {                   \
1124         charid = trie->charmap[uvc_unfolded];                               \
1125     }                                                                       \
1126 } STMT_END
1127
1128 #define REXEC_FBC_EXACTISH_CHECK(CoNd)                 \
1129 {                                                      \
1130     char *my_strend= (char *)strend;                   \
1131     if ( (CoNd)                                        \
1132          && (ln == len ||                              \
1133              !ibcmp_utf8(s, &my_strend, 0,  do_utf8,   \
1134                         m, NULL, ln, (bool)UTF))       \
1135          && (!reginfo || regtry(reginfo, &s)) )        \
1136         goto got_it;                                   \
1137     else {                                             \
1138          U8 foldbuf[UTF8_MAXBYTES_CASE+1];             \
1139          uvchr_to_utf8(tmpbuf, c);                     \
1140          f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);  \
1141          if ( f != c                                   \
1142               && (f == c1 || f == c2)                  \
1143               && (ln == len ||                         \
1144                 !ibcmp_utf8(s, &my_strend, 0,  do_utf8,\
1145                               m, NULL, ln, (bool)UTF)) \
1146               && (!reginfo || regtry(reginfo, &s)) )   \
1147               goto got_it;                             \
1148     }                                                  \
1149 }                                                      \
1150 s += len
1151
1152 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1153 STMT_START {                                              \
1154     while (s <= e) {                                      \
1155         if ( (CoNd)                                       \
1156              && (ln == 1 || !(OP(c) == EXACTF             \
1157                               ? ibcmp(s, m, ln)           \
1158                               : ibcmp_locale(s, m, ln)))  \
1159              && (!reginfo || regtry(reginfo, &s)) )        \
1160             goto got_it;                                  \
1161         s++;                                              \
1162     }                                                     \
1163 } STMT_END
1164
1165 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1166 STMT_START {                                          \
1167     while (s + (uskip = UTF8SKIP(s)) <= strend) {     \
1168         CoDe                                          \
1169         s += uskip;                                   \
1170     }                                                 \
1171 } STMT_END
1172
1173 #define REXEC_FBC_SCAN(CoDe)                          \
1174 STMT_START {                                          \
1175     while (s < strend) {                              \
1176         CoDe                                          \
1177         s++;                                          \
1178     }                                                 \
1179 } STMT_END
1180
1181 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1182 REXEC_FBC_UTF8_SCAN(                                  \
1183     if (CoNd) {                                       \
1184         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1185             goto got_it;                              \
1186         else                                          \
1187             tmp = doevery;                            \
1188     }                                                 \
1189     else                                              \
1190         tmp = 1;                                      \
1191 )
1192
1193 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1194 REXEC_FBC_SCAN(                                       \
1195     if (CoNd) {                                       \
1196         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1197             goto got_it;                              \
1198         else                                          \
1199             tmp = doevery;                            \
1200     }                                                 \
1201     else                                              \
1202         tmp = 1;                                      \
1203 )
1204
1205 #define REXEC_FBC_TRYIT               \
1206 if ((!reginfo || regtry(reginfo, &s))) \
1207     goto got_it
1208
1209 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd)                         \
1210     if (do_utf8) {                                             \
1211         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1212     }                                                          \
1213     else {                                                     \
1214         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1215     }                                                          \
1216     break
1217
1218 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd)      \
1219     if (do_utf8) {                                             \
1220         UtFpReLoAd;                                            \
1221         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1222     }                                                          \
1223     else {                                                     \
1224         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1225     }                                                          \
1226     break
1227
1228 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd)                   \
1229     PL_reg_flags |= RF_tainted;                                \
1230     if (do_utf8) {                                             \
1231         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1232     }                                                          \
1233     else {                                                     \
1234         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1235     }                                                          \
1236     break
1237
1238 #define DUMP_EXEC_POS(li,s,doutf8) \
1239     dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1240
1241 /* We know what class REx starts with.  Try to find this position... */
1242 /* if reginfo is NULL, its a dryrun */
1243 /* annoyingly all the vars in this routine have different names from their counterparts
1244    in regmatch. /grrr */
1245
1246 STATIC char *
1247 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1248     const char *strend, regmatch_info *reginfo)
1249 {
1250         dVAR;
1251         const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1252         char *m;
1253         STRLEN ln;
1254         STRLEN lnc;
1255         register STRLEN uskip;
1256         unsigned int c1;
1257         unsigned int c2;
1258         char *e;
1259         register I32 tmp = 1;   /* Scratch variable? */
1260         register const bool do_utf8 = PL_reg_match_utf8;
1261         RXi_GET_DECL(prog,progi);
1262
1263         PERL_ARGS_ASSERT_FIND_BYCLASS;
1264
1265         /* We know what class it must start with. */
1266         switch (OP(c)) {
1267         case ANYOF:
1268             if (do_utf8) {
1269                  REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1270                           !UTF8_IS_INVARIANT((U8)s[0]) ?
1271                           reginclass(prog, c, (U8*)s, 0, do_utf8) :
1272                           REGINCLASS(prog, c, (U8*)s));
1273             }
1274             else {
1275                  while (s < strend) {
1276                       STRLEN skip = 1;
1277
1278                       if (REGINCLASS(prog, c, (U8*)s) ||
1279                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1280                            /* The assignment of 2 is intentional:
1281                             * for the folded sharp s, the skip is 2. */
1282                            (skip = SHARP_S_SKIP))) {
1283                            if (tmp && (!reginfo || regtry(reginfo, &s)))
1284                                 goto got_it;
1285                            else
1286                                 tmp = doevery;
1287                       }
1288                       else
1289                            tmp = 1;
1290                       s += skip;
1291                  }
1292             }
1293             break;
1294         case CANY:
1295             REXEC_FBC_SCAN(
1296                 if (tmp && (!reginfo || regtry(reginfo, &s)))
1297                     goto got_it;
1298                 else
1299                     tmp = doevery;
1300             );
1301             break;
1302         case EXACTF:
1303             m   = STRING(c);
1304             ln  = STR_LEN(c);   /* length to match in octets/bytes */
1305             lnc = (I32) ln;     /* length to match in characters */
1306             if (UTF) {
1307                 STRLEN ulen1, ulen2;
1308                 U8 *sm = (U8 *) m;
1309                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1310                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1311                 /* used by commented-out code below */
1312                 /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1313
1314                 /* XXX: Since the node will be case folded at compile
1315                    time this logic is a little odd, although im not
1316                    sure that its actually wrong. --dmq */
1317
1318                 c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1319                 c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1320
1321                 /* XXX: This is kinda strange. to_utf8_XYZ returns the
1322                    codepoint of the first character in the converted
1323                    form, yet originally we did the extra step.
1324                    No tests fail by commenting this code out however
1325                    so Ive left it out. -- dmq.
1326
1327                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1328                                     0, uniflags);
1329                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1330                                     0, uniflags);
1331                 */
1332
1333                 lnc = 0;
1334                 while (sm < ((U8 *) m + ln)) {
1335                     lnc++;
1336                     sm += UTF8SKIP(sm);
1337                 }
1338             }
1339             else {
1340                 c1 = *(U8*)m;
1341                 c2 = PL_fold[c1];
1342             }
1343             goto do_exactf;
1344         case EXACTFL:
1345             m   = STRING(c);
1346             ln  = STR_LEN(c);
1347             lnc = (I32) ln;
1348             c1 = *(U8*)m;
1349             c2 = PL_fold_locale[c1];
1350           do_exactf:
1351             e = HOP3c(strend, -((I32)lnc), s);
1352
1353             if (!reginfo && e < s)
1354                 e = s;                  /* Due to minlen logic of intuit() */
1355
1356             /* The idea in the EXACTF* cases is to first find the
1357              * first character of the EXACTF* node and then, if
1358              * necessary, case-insensitively compare the full
1359              * text of the node.  The c1 and c2 are the first
1360              * characters (though in Unicode it gets a bit
1361              * more complicated because there are more cases
1362              * than just upper and lower: one needs to use
1363              * the so-called folding case for case-insensitive
1364              * matching (called "loose matching" in Unicode).
1365              * ibcmp_utf8() will do just that. */
1366
1367             if (do_utf8 || UTF) {
1368                 UV c, f;
1369                 U8 tmpbuf [UTF8_MAXBYTES+1];
1370                 STRLEN len = 1;
1371                 STRLEN foldlen;
1372                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1373                 if (c1 == c2) {
1374                     /* Upper and lower of 1st char are equal -
1375                      * probably not a "letter". */
1376                     while (s <= e) {
1377                         if (do_utf8) {
1378                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1379                                            uniflags);
1380                         } else {
1381                             c = *((U8*)s);
1382                         }
1383                         REXEC_FBC_EXACTISH_CHECK(c == c1);
1384                     }
1385                 }
1386                 else {
1387                     while (s <= e) {
1388                         if (do_utf8) {
1389                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1390                                            uniflags);
1391                         } else {
1392                             c = *((U8*)s);
1393                         }
1394
1395                         /* Handle some of the three Greek sigmas cases.
1396                          * Note that not all the possible combinations
1397                          * are handled here: some of them are handled
1398                          * by the standard folding rules, and some of
1399                          * them (the character class or ANYOF cases)
1400                          * are handled during compiletime in
1401                          * regexec.c:S_regclass(). */
1402                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1403                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1404                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1405
1406                         REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1407                     }
1408                 }
1409             }
1410             else {
1411                 /* Neither pattern nor string are UTF8 */
1412                 if (c1 == c2)
1413                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1414                 else
1415                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1416             }
1417             break;
1418         case BOUNDL:
1419             PL_reg_flags |= RF_tainted;
1420             /* FALL THROUGH */
1421         case BOUND:
1422             if (do_utf8) {
1423                 if (s == PL_bostr)
1424                     tmp = '\n';
1425                 else {
1426                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1427                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1428                 }
1429                 tmp = ((OP(c) == BOUND ?
1430                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1431                 LOAD_UTF8_CHARCLASS_ALNUM();
1432                 REXEC_FBC_UTF8_SCAN(
1433                     if (tmp == !(OP(c) == BOUND ?
1434                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1435                                  isALNUM_LC_utf8((U8*)s)))
1436                     {
1437                         tmp = !tmp;
1438                         REXEC_FBC_TRYIT;
1439                 }
1440                 );
1441             }
1442             else {
1443                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1444                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1445                 REXEC_FBC_SCAN(
1446                     if (tmp ==
1447                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1448                         tmp = !tmp;
1449                         REXEC_FBC_TRYIT;
1450                 }
1451                 );
1452             }
1453             if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1454                 goto got_it;
1455             break;
1456         case NBOUNDL:
1457             PL_reg_flags |= RF_tainted;
1458             /* FALL THROUGH */
1459         case NBOUND:
1460             if (do_utf8) {
1461                 if (s == PL_bostr)
1462                     tmp = '\n';
1463                 else {
1464                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1465                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1466                 }
1467                 tmp = ((OP(c) == NBOUND ?
1468                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1469                 LOAD_UTF8_CHARCLASS_ALNUM();
1470                 REXEC_FBC_UTF8_SCAN(
1471                     if (tmp == !(OP(c) == NBOUND ?
1472                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1473                                  isALNUM_LC_utf8((U8*)s)))
1474                         tmp = !tmp;
1475                     else REXEC_FBC_TRYIT;
1476                 );
1477             }
1478             else {
1479                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1480                 tmp = ((OP(c) == NBOUND ?
1481                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1482                 REXEC_FBC_SCAN(
1483                     if (tmp ==
1484                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1485                         tmp = !tmp;
1486                     else REXEC_FBC_TRYIT;
1487                 );
1488             }
1489             if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1490                 goto got_it;
1491             break;
1492         case ALNUM:
1493             REXEC_FBC_CSCAN_PRELOAD(
1494                 LOAD_UTF8_CHARCLASS_ALNUM(),
1495                 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1496                 isALNUM(*s)
1497             );
1498         case ALNUML:
1499             REXEC_FBC_CSCAN_TAINT(
1500                 isALNUM_LC_utf8((U8*)s),
1501                 isALNUM_LC(*s)
1502             );
1503         case NALNUM:
1504             REXEC_FBC_CSCAN_PRELOAD(
1505                 LOAD_UTF8_CHARCLASS_ALNUM(),
1506                 !swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1507                 !isALNUM(*s)
1508             );
1509         case NALNUML:
1510             REXEC_FBC_CSCAN_TAINT(
1511                 !isALNUM_LC_utf8((U8*)s),
1512                 !isALNUM_LC(*s)
1513             );
1514         case SPACE:
1515             REXEC_FBC_CSCAN_PRELOAD(
1516                 LOAD_UTF8_CHARCLASS_SPACE(),
1517                 *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8),
1518                 isSPACE(*s)
1519             );
1520         case SPACEL:
1521             REXEC_FBC_CSCAN_TAINT(
1522                 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1523                 isSPACE_LC(*s)
1524             );
1525         case NSPACE:
1526             REXEC_FBC_CSCAN_PRELOAD(
1527                 LOAD_UTF8_CHARCLASS_SPACE(),
1528                 !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)),
1529                 !isSPACE(*s)
1530             );
1531         case NSPACEL:
1532             REXEC_FBC_CSCAN_TAINT(
1533                 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1534                 !isSPACE_LC(*s)
1535             );
1536         case DIGIT:
1537             REXEC_FBC_CSCAN_PRELOAD(
1538                 LOAD_UTF8_CHARCLASS_DIGIT(),
1539                 swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1540                 isDIGIT(*s)
1541             );
1542         case DIGITL:
1543             REXEC_FBC_CSCAN_TAINT(
1544                 isDIGIT_LC_utf8((U8*)s),
1545                 isDIGIT_LC(*s)
1546             );
1547         case NDIGIT:
1548             REXEC_FBC_CSCAN_PRELOAD(
1549                 LOAD_UTF8_CHARCLASS_DIGIT(),
1550                 !swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1551                 !isDIGIT(*s)
1552             );
1553         case NDIGITL:
1554             REXEC_FBC_CSCAN_TAINT(
1555                 !isDIGIT_LC_utf8((U8*)s),
1556                 !isDIGIT_LC(*s)
1557             );
1558         case LNBREAK:
1559             REXEC_FBC_CSCAN(
1560                 is_LNBREAK_utf8(s),
1561                 is_LNBREAK_latin1(s)
1562             );
1563         case VERTWS:
1564             REXEC_FBC_CSCAN(
1565                 is_VERTWS_utf8(s),
1566                 is_VERTWS_latin1(s)
1567             );
1568         case NVERTWS:
1569             REXEC_FBC_CSCAN(
1570                 !is_VERTWS_utf8(s),
1571                 !is_VERTWS_latin1(s)
1572             );
1573         case HORIZWS:
1574             REXEC_FBC_CSCAN(
1575                 is_HORIZWS_utf8(s),
1576                 is_HORIZWS_latin1(s)
1577             );
1578         case NHORIZWS:
1579             REXEC_FBC_CSCAN(
1580                 !is_HORIZWS_utf8(s),
1581                 !is_HORIZWS_latin1(s)
1582             );
1583         case AHOCORASICKC:
1584         case AHOCORASICK:
1585             {
1586                 DECL_TRIE_TYPE(c);
1587                 /* what trie are we using right now */
1588                 reg_ac_data *aho
1589                     = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1590                 reg_trie_data *trie
1591                     = (reg_trie_data*)progi->data->data[ aho->trie ];
1592                 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1593
1594                 const char *last_start = strend - trie->minlen;
1595 #ifdef DEBUGGING
1596                 const char *real_start = s;
1597 #endif
1598                 STRLEN maxlen = trie->maxlen;
1599                 SV *sv_points;
1600                 U8 **points; /* map of where we were in the input string
1601                                 when reading a given char. For ASCII this
1602                                 is unnecessary overhead as the relationship
1603                                 is always 1:1, but for Unicode, especially
1604                                 case folded Unicode this is not true. */
1605                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1606                 U8 *bitmap=NULL;
1607
1608
1609                 GET_RE_DEBUG_FLAGS_DECL;
1610
1611                 /* We can't just allocate points here. We need to wrap it in
1612                  * an SV so it gets freed properly if there is a croak while
1613                  * running the match */
1614                 ENTER;
1615                 SAVETMPS;
1616                 sv_points=newSV(maxlen * sizeof(U8 *));
1617                 SvCUR_set(sv_points,
1618                     maxlen * sizeof(U8 *));
1619                 SvPOK_on(sv_points);
1620                 sv_2mortal(sv_points);
1621                 points=(U8**)SvPV_nolen(sv_points );
1622                 if ( trie_type != trie_utf8_fold
1623                      && (trie->bitmap || OP(c)==AHOCORASICKC) )
1624                 {
1625                     if (trie->bitmap)
1626                         bitmap=(U8*)trie->bitmap;
1627                     else
1628                         bitmap=(U8*)ANYOF_BITMAP(c);
1629                 }
1630                 /* this is the Aho-Corasick algorithm modified a touch
1631                    to include special handling for long "unknown char"
1632                    sequences. The basic idea being that we use AC as long
1633                    as we are dealing with a possible matching char, when
1634                    we encounter an unknown char (and we have not encountered
1635                    an accepting state) we scan forward until we find a legal
1636                    starting char.
1637                    AC matching is basically that of trie matching, except
1638                    that when we encounter a failing transition, we fall back
1639                    to the current states "fail state", and try the current char
1640                    again, a process we repeat until we reach the root state,
1641                    state 1, or a legal transition. If we fail on the root state
1642                    then we can either terminate if we have reached an accepting
1643                    state previously, or restart the entire process from the beginning
1644                    if we have not.
1645
1646                  */
1647                 while (s <= last_start) {
1648                     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1649                     U8 *uc = (U8*)s;
1650                     U16 charid = 0;
1651                     U32 base = 1;
1652                     U32 state = 1;
1653                     UV uvc = 0;
1654                     STRLEN len = 0;
1655                     STRLEN foldlen = 0;
1656                     U8 *uscan = (U8*)NULL;
1657                     U8 *leftmost = NULL;
1658 #ifdef DEBUGGING
1659                     U32 accepted_word= 0;
1660 #endif
1661                     U32 pointpos = 0;
1662
1663                     while ( state && uc <= (U8*)strend ) {
1664                         int failed=0;
1665                         U32 word = aho->states[ state ].wordnum;
1666
1667                         if( state==1 ) {
1668                             if ( bitmap ) {
1669                                 DEBUG_TRIE_EXECUTE_r(
1670                                     if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1671                                         dump_exec_pos( (char *)uc, c, strend, real_start,
1672                                             (char *)uc, do_utf8 );
1673                                         PerlIO_printf( Perl_debug_log,
1674                                             " Scanning for legal start char...\n");
1675                                     }
1676                                 );
1677                                 while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1678                                     uc++;
1679                                 }
1680                                 s= (char *)uc;
1681                             }
1682                             if (uc >(U8*)last_start) break;
1683                         }
1684
1685                         if ( word ) {
1686                             U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1687                             if (!leftmost || lpos < leftmost) {
1688                                 DEBUG_r(accepted_word=word);
1689                                 leftmost= lpos;
1690                             }
1691                             if (base==0) break;
1692
1693                         }
1694                         points[pointpos++ % maxlen]= uc;
1695                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1696                                              uscan, len, uvc, charid, foldlen,
1697                                              foldbuf, uniflags);
1698                         DEBUG_TRIE_EXECUTE_r({
1699                             dump_exec_pos( (char *)uc, c, strend, real_start,
1700                                 s,   do_utf8 );
1701                             PerlIO_printf(Perl_debug_log,
1702                                 " Charid:%3u CP:%4"UVxf" ",
1703                                  charid, uvc);
1704                         });
1705
1706                         do {
1707 #ifdef DEBUGGING
1708                             word = aho->states[ state ].wordnum;
1709 #endif
1710                             base = aho->states[ state ].trans.base;
1711
1712                             DEBUG_TRIE_EXECUTE_r({
1713                                 if (failed)
1714                                     dump_exec_pos( (char *)uc, c, strend, real_start,
1715                                         s,   do_utf8 );
1716                                 PerlIO_printf( Perl_debug_log,
1717                                     "%sState: %4"UVxf", word=%"UVxf,
1718                                     failed ? " Fail transition to " : "",
1719                                     (UV)state, (UV)word);
1720                             });
1721                             if ( base ) {
1722                                 U32 tmp;
1723                                 if (charid &&
1724                                      (base + charid > trie->uniquecharcount )
1725                                      && (base + charid - 1 - trie->uniquecharcount
1726                                             < trie->lasttrans)
1727                                      && trie->trans[base + charid - 1 -
1728                                             trie->uniquecharcount].check == state
1729                                      && (tmp=trie->trans[base + charid - 1 -
1730                                         trie->uniquecharcount ].next))
1731                                 {
1732                                     DEBUG_TRIE_EXECUTE_r(
1733                                         PerlIO_printf( Perl_debug_log," - legal\n"));
1734                                     state = tmp;
1735                                     break;
1736                                 }
1737                                 else {
1738                                     DEBUG_TRIE_EXECUTE_r(
1739                                         PerlIO_printf( Perl_debug_log," - fail\n"));
1740                                     failed = 1;
1741                                     state = aho->fail[state];
1742                                 }
1743                             }
1744                             else {
1745                                 /* we must be accepting here */
1746                                 DEBUG_TRIE_EXECUTE_r(
1747                                         PerlIO_printf( Perl_debug_log," - accepting\n"));
1748                                 failed = 1;
1749                                 break;
1750                             }
1751                         } while(state);
1752                         uc += len;
1753                         if (failed) {
1754                             if (leftmost)
1755                                 break;
1756                             if (!state) state = 1;
1757                         }
1758                     }
1759                     if ( aho->states[ state ].wordnum ) {
1760                         U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1761                         if (!leftmost || lpos < leftmost) {
1762                             DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1763                             leftmost = lpos;
1764                         }
1765                     }
1766                     if (leftmost) {
1767                         s = (char*)leftmost;
1768                         DEBUG_TRIE_EXECUTE_r({
1769                             PerlIO_printf(
1770                                 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1771                                 (UV)accepted_word, (IV)(s - real_start)
1772                             );
1773                         });
1774                         if (!reginfo || regtry(reginfo, &s)) {
1775                             FREETMPS;
1776                             LEAVE;
1777                             goto got_it;
1778                         }
1779                         s = HOPc(s,1);
1780                         DEBUG_TRIE_EXECUTE_r({
1781                             PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1782                         });
1783                     } else {
1784                         DEBUG_TRIE_EXECUTE_r(
1785                             PerlIO_printf( Perl_debug_log,"No match.\n"));
1786                         break;
1787                     }
1788                 }
1789                 FREETMPS;
1790                 LEAVE;
1791             }
1792             break;
1793         default:
1794             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1795             break;
1796         }
1797         return 0;
1798       got_it:
1799         return s;
1800 }
1801
1802
1803 /*
1804  - regexec_flags - match a regexp against a string
1805  */
1806 I32
1807 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
1808               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1809 /* strend: pointer to null at end of string */
1810 /* strbeg: real beginning of string */
1811 /* minend: end of match must be >=minend after stringarg. */
1812 /* data: May be used for some additional optimizations.
1813          Currently its only used, with a U32 cast, for transmitting
1814          the ganch offset when doing a /g match. This will change */
1815 /* nosave: For optimizations. */
1816 {
1817     dVAR;
1818     struct regexp *const prog = (struct regexp *)SvANY(rx);
1819     /*register*/ char *s;
1820     register regnode *c;
1821     /*register*/ char *startpos = stringarg;
1822     I32 minlen;         /* must match at least this many chars */
1823     I32 dontbother = 0; /* how many characters not to try at end */
1824     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1825     I32 scream_pos = -1;                /* Internal iterator of scream. */
1826     char *scream_olds = NULL;
1827     const bool do_utf8 = (bool)DO_UTF8(sv);
1828     I32 multiline;
1829     RXi_GET_DECL(prog,progi);
1830     regmatch_info reginfo;  /* create some info to pass to regtry etc */
1831     regexp_paren_pair *swap = NULL;
1832     GET_RE_DEBUG_FLAGS_DECL;
1833
1834     PERL_ARGS_ASSERT_REGEXEC_FLAGS;
1835     PERL_UNUSED_ARG(data);
1836
1837     /* Be paranoid... */
1838     if (prog == NULL || startpos == NULL) {
1839         Perl_croak(aTHX_ "NULL regexp parameter");
1840         return 0;
1841     }
1842
1843     multiline = prog->extflags & RXf_PMf_MULTILINE;
1844     reginfo.prog = rx;   /* Yes, sorry that this is confusing.  */
1845
1846     RX_MATCH_UTF8_set(rx, do_utf8);
1847     DEBUG_EXECUTE_r(
1848         debug_start_match(rx, do_utf8, startpos, strend,
1849         "Matching");
1850     );
1851
1852     minlen = prog->minlen;
1853
1854     if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1855         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1856                               "String too short [regexec_flags]...\n"));
1857         goto phooey;
1858     }
1859
1860
1861     /* Check validity of program. */
1862     if (UCHARAT(progi->program) != REG_MAGIC) {
1863         Perl_croak(aTHX_ "corrupted regexp program");
1864     }
1865
1866     PL_reg_flags = 0;
1867     PL_reg_eval_set = 0;
1868     PL_reg_maxiter = 0;
1869
1870     if (RX_UTF8(rx))
1871         PL_reg_flags |= RF_utf8;
1872
1873     /* Mark beginning of line for ^ and lookbehind. */
1874     reginfo.bol = startpos; /* XXX not used ??? */
1875     PL_bostr  = strbeg;
1876     reginfo.sv = sv;
1877
1878     /* Mark end of line for $ (and such) */
1879     PL_regeol = strend;
1880
1881     /* see how far we have to get to not match where we matched before */
1882     reginfo.till = startpos+minend;
1883
1884     /* If there is a "must appear" string, look for it. */
1885     s = startpos;
1886
1887     if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
1888         MAGIC *mg;
1889         if (flags & REXEC_IGNOREPOS){   /* Means: check only at start */
1890             reginfo.ganch = startpos + prog->gofs;
1891             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1892               "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
1893         } else if (sv && SvTYPE(sv) >= SVt_PVMG
1894                   && SvMAGIC(sv)
1895                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1896                   && mg->mg_len >= 0) {
1897             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
1898             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1899                 "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
1900
1901             if (prog->extflags & RXf_ANCH_GPOS) {
1902                 if (s > reginfo.ganch)
1903                     goto phooey;
1904                 s = reginfo.ganch - prog->gofs;
1905                 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1906                      "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
1907                 if (s < strbeg)
1908                     goto phooey;
1909             }
1910         }
1911         else if (data) {
1912             reginfo.ganch = strbeg + PTR2UV(data);
1913             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1914                  "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
1915
1916         } else {                                /* pos() not defined */
1917             reginfo.ganch = strbeg;
1918             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1919                  "GPOS: reginfo.ganch = strbeg\n"));
1920         }
1921     }
1922     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
1923         /* We have to be careful. If the previous successful match
1924            was from this regex we don't want a subsequent partially
1925            successful match to clobber the old results.
1926            So when we detect this possibility we add a swap buffer
1927            to the re, and switch the buffer each match. If we fail
1928            we switch it back, otherwise we leave it swapped.
1929         */
1930         swap = prog->offs;
1931         /* do we need a save destructor here for eval dies? */
1932         Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
1933     }
1934     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1935         re_scream_pos_data d;
1936
1937         d.scream_olds = &scream_olds;
1938         d.scream_pos = &scream_pos;
1939         s = re_intuit_start(rx, sv, s, strend, flags, &d);
1940         if (!s) {
1941             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1942             goto phooey;        /* not present */
1943         }
1944     }
1945
1946
1947
1948     /* Simplest case:  anchored match need be tried only once. */
1949     /*  [unless only anchor is BOL and multiline is set] */
1950     if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
1951         if (s == startpos && regtry(&reginfo, &startpos))
1952             goto got_it;
1953         else if (multiline || (prog->intflags & PREGf_IMPLICIT)
1954                  || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
1955         {
1956             char *end;
1957
1958             if (minlen)
1959                 dontbother = minlen - 1;
1960             end = HOP3c(strend, -dontbother, strbeg) - 1;
1961             /* for multiline we only have to try after newlines */
1962             if (prog->check_substr || prog->check_utf8) {
1963                 if (s == startpos)
1964                     goto after_try;
1965                 while (1) {
1966                     if (regtry(&reginfo, &s))
1967                         goto got_it;
1968                   after_try:
1969                     if (s > end)
1970                         goto phooey;
1971                     if (prog->extflags & RXf_USE_INTUIT) {
1972                         s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
1973                         if (!s)
1974                             goto phooey;
1975                     }
1976                     else
1977                         s++;
1978                 }
1979             } else {
1980                 if (s > startpos)
1981                     s--;
1982                 while (s < end) {
1983                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1984                         if (regtry(&reginfo, &s))
1985                             goto got_it;
1986                     }
1987                 }
1988             }
1989         }
1990         goto phooey;
1991     } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
1992     {
1993         /* the warning about reginfo.ganch being used without intialization
1994            is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
1995            and we only enter this block when the same bit is set. */
1996         char *tmp_s = reginfo.ganch - prog->gofs;
1997
1998         if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
1999             goto got_it;
2000         goto phooey;
2001     }
2002
2003     /* Messy cases:  unanchored match. */
2004     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2005         /* we have /x+whatever/ */
2006         /* it must be a one character string (XXXX Except UTF?) */
2007         char ch;
2008 #ifdef DEBUGGING
2009         int did_match = 0;
2010 #endif
2011         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2012             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2013         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
2014
2015         if (do_utf8) {
2016             REXEC_FBC_SCAN(
2017                 if (*s == ch) {
2018                     DEBUG_EXECUTE_r( did_match = 1 );
2019                     if (regtry(&reginfo, &s)) goto got_it;
2020                     s += UTF8SKIP(s);
2021                     while (s < strend && *s == ch)
2022                         s += UTF8SKIP(s);
2023                 }
2024             );
2025         }
2026         else {
2027             REXEC_FBC_SCAN(
2028                 if (*s == ch) {
2029                     DEBUG_EXECUTE_r( did_match = 1 );
2030                     if (regtry(&reginfo, &s)) goto got_it;
2031                     s++;
2032                     while (s < strend && *s == ch)
2033                         s++;
2034                 }
2035             );
2036         }
2037         DEBUG_EXECUTE_r(if (!did_match)
2038                 PerlIO_printf(Perl_debug_log,
2039                                   "Did not find anchored character...\n")
2040                );
2041     }
2042     else if (prog->anchored_substr != NULL
2043               || prog->anchored_utf8 != NULL
2044               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2045                   && prog->float_max_offset < strend - s)) {
2046         SV *must;
2047         I32 back_max;
2048         I32 back_min;
2049         char *last;
2050         char *last1;            /* Last position checked before */
2051 #ifdef DEBUGGING
2052         int did_match = 0;
2053 #endif
2054         if (prog->anchored_substr || prog->anchored_utf8) {
2055             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2056                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2057             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
2058             back_max = back_min = prog->anchored_offset;
2059         } else {
2060             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2061                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2062             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2063             back_max = prog->float_max_offset;
2064             back_min = prog->float_min_offset;
2065         }
2066
2067
2068         if (must == &PL_sv_undef)
2069             /* could not downgrade utf8 check substring, so must fail */
2070             goto phooey;
2071
2072         if (back_min<0) {
2073             last = strend;
2074         } else {
2075             last = HOP3c(strend,        /* Cannot start after this */
2076                   -(I32)(CHR_SVLEN(must)
2077                          - (SvTAIL(must) != 0) + back_min), strbeg);
2078         }
2079         if (s > PL_bostr)
2080             last1 = HOPc(s, -1);
2081         else
2082             last1 = s - 1;      /* bogus */
2083
2084         /* XXXX check_substr already used to find "s", can optimize if
2085            check_substr==must. */
2086         scream_pos = -1;
2087         dontbother = end_shift;
2088         strend = HOPc(strend, -dontbother);
2089         while ( (s <= last) &&
2090                 ((flags & REXEC_SCREAM)
2091                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2092                                     end_shift, &scream_pos, 0))
2093                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2094                                   (unsigned char*)strend, must,
2095                                   multiline ? FBMrf_MULTILINE : 0))) ) {
2096             /* we may be pointing at the wrong string */
2097             if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2098                 s = strbeg + (s - SvPVX_const(sv));
2099             DEBUG_EXECUTE_r( did_match = 1 );
2100             if (HOPc(s, -back_max) > last1) {
2101                 last1 = HOPc(s, -back_min);
2102                 s = HOPc(s, -back_max);
2103             }
2104             else {
2105                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2106
2107                 last1 = HOPc(s, -back_min);
2108                 s = t;
2109             }
2110             if (do_utf8) {
2111                 while (s <= last1) {
2112                     if (regtry(&reginfo, &s))
2113                         goto got_it;
2114                     s += UTF8SKIP(s);
2115                 }
2116             }
2117             else {
2118                 while (s <= last1) {
2119                     if (regtry(&reginfo, &s))
2120                         goto got_it;
2121                     s++;
2122                 }
2123             }
2124         }
2125         DEBUG_EXECUTE_r(if (!did_match) {
2126             RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
2127                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2128             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2129                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2130                                ? "anchored" : "floating"),
2131                 quoted, RE_SV_TAIL(must));
2132         });
2133         goto phooey;
2134     }
2135     else if ( (c = progi->regstclass) ) {
2136         if (minlen) {
2137             const OPCODE op = OP(progi->regstclass);
2138             /* don't bother with what can't match */
2139             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2140                 strend = HOPc(strend, -(minlen - 1));
2141         }
2142         DEBUG_EXECUTE_r({
2143             SV * const prop = sv_newmortal();
2144             regprop(prog, prop, c);
2145             {
2146                 RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
2147                     s,strend-s,60);
2148                 PerlIO_printf(Perl_debug_log,
2149                     "Matching stclass %.*s against %s (%d chars)\n",
2150                     (int)SvCUR(prop), SvPVX_const(prop),
2151                      quoted, (int)(strend - s));
2152             }
2153         });
2154         if (find_byclass(prog, c, s, strend, &reginfo))
2155             goto got_it;
2156         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2157     }
2158     else {
2159         dontbother = 0;
2160         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2161             /* Trim the end. */
2162             char *last;
2163             SV* float_real;
2164
2165             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2166                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2167             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2168
2169             if (flags & REXEC_SCREAM) {
2170                 last = screaminstr(sv, float_real, s - strbeg,
2171                                    end_shift, &scream_pos, 1); /* last one */
2172                 if (!last)
2173                     last = scream_olds; /* Only one occurrence. */
2174                 /* we may be pointing at the wrong string */
2175                 else if (RXp_MATCH_COPIED(prog))
2176                     s = strbeg + (s - SvPVX_const(sv));
2177             }
2178             else {
2179                 STRLEN len;
2180                 const char * const little = SvPV_const(float_real, len);
2181
2182                 if (SvTAIL(float_real)) {
2183                     if (memEQ(strend - len + 1, little, len - 1))
2184                         last = strend - len + 1;
2185                     else if (!multiline)
2186                         last = memEQ(strend - len, little, len)
2187                             ? strend - len : NULL;
2188                     else
2189                         goto find_last;
2190                 } else {
2191                   find_last:
2192                     if (len)
2193                         last = rninstr(s, strend, little, little + len);
2194                     else
2195                         last = strend;  /* matching "$" */
2196                 }
2197             }
2198             if (last == NULL) {
2199                 DEBUG_EXECUTE_r(
2200                     PerlIO_printf(Perl_debug_log,
2201                         "%sCan't trim the tail, match fails (should not happen)%s\n",
2202                         PL_colors[4], PL_colors[5]));
2203                 goto phooey; /* Should not happen! */
2204             }
2205             dontbother = strend - last + prog->float_min_offset;
2206         }
2207         if (minlen && (dontbother < minlen))
2208             dontbother = minlen - 1;
2209         strend -= dontbother;              /* this one's always in bytes! */
2210         /* We don't know much -- general case. */
2211         if (do_utf8) {
2212             for (;;) {
2213                 if (regtry(&reginfo, &s))
2214                     goto got_it;
2215                 if (s >= strend)
2216                     break;
2217                 s += UTF8SKIP(s);
2218             };
2219         }
2220         else {
2221             do {
2222                 if (regtry(&reginfo, &s))
2223                     goto got_it;
2224             } while (s++ < strend);
2225         }
2226     }
2227
2228     /* Failure. */
2229     goto phooey;
2230
2231 got_it:
2232     Safefree(swap);
2233     RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2234
2235     if (PL_reg_eval_set)
2236         restore_pos(aTHX_ prog);
2237     if (RXp_PAREN_NAMES(prog))
2238         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2239
2240     /* make sure $`, $&, $', and $digit will work later */
2241     if ( !(flags & REXEC_NOT_FIRST) ) {
2242         RX_MATCH_COPY_FREE(rx);
2243         if (flags & REXEC_COPY_STR) {
2244             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2245 #ifdef PERL_OLD_COPY_ON_WRITE
2246             if ((SvIsCOW(sv)
2247                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2248                 if (DEBUG_C_TEST) {
2249                     PerlIO_printf(Perl_debug_log,
2250                                   "Copy on write: regexp capture, type %d\n",
2251                                   (int) SvTYPE(sv));
2252                 }
2253                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2254                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2255                 assert (SvPOKp(prog->saved_copy));
2256             } else
2257 #endif
2258             {
2259                 RX_MATCH_COPIED_on(rx);
2260                 s = savepvn(strbeg, i);
2261                 prog->subbeg = s;
2262             }
2263             prog->sublen = i;
2264         }
2265         else {
2266             prog->subbeg = strbeg;
2267             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2268         }
2269     }
2270
2271     return 1;
2272
2273 phooey:
2274     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2275                           PL_colors[4], PL_colors[5]));
2276     if (PL_reg_eval_set)
2277         restore_pos(aTHX_ prog);
2278     if (swap) {
2279         /* we failed :-( roll it back */
2280         Safefree(prog->offs);
2281         prog->offs = swap;
2282     }
2283
2284     return 0;
2285 }
2286
2287
2288 /*
2289  - regtry - try match at specific point
2290  */
2291 STATIC I32                      /* 0 failure, 1 success */
2292 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2293 {
2294     dVAR;
2295     CHECKPOINT lastcp;
2296     REGEXP *const rx = reginfo->prog;
2297     regexp *const prog = (struct regexp *)SvANY(rx);
2298     RXi_GET_DECL(prog,progi);
2299     GET_RE_DEBUG_FLAGS_DECL;
2300
2301     PERL_ARGS_ASSERT_REGTRY;
2302
2303     reginfo->cutpoint=NULL;
2304
2305     if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2306         MAGIC *mg;
2307
2308         PL_reg_eval_set = RS_init;
2309         DEBUG_EXECUTE_r(DEBUG_s(
2310             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2311                           (IV)(PL_stack_sp - PL_stack_base));
2312             ));
2313         SAVESTACK_CXPOS();
2314         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2315         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2316         SAVETMPS;
2317         /* Apparently this is not needed, judging by wantarray. */
2318         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2319            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2320
2321         if (reginfo->sv) {
2322             /* Make $_ available to executed code. */
2323             if (reginfo->sv != DEFSV) {
2324                 SAVE_DEFSV;
2325                 DEFSV_set(reginfo->sv);
2326             }
2327
2328             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2329                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2330                 /* prepare for quick setting of pos */
2331 #ifdef PERL_OLD_COPY_ON_WRITE
2332                 if (SvIsCOW(reginfo->sv))
2333                     sv_force_normal_flags(reginfo->sv, 0);
2334 #endif
2335                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2336                                  &PL_vtbl_mglob, NULL, 0);
2337                 mg->mg_len = -1;
2338             }
2339             PL_reg_magic    = mg;
2340             PL_reg_oldpos   = mg->mg_len;
2341             SAVEDESTRUCTOR_X(restore_pos, prog);
2342         }
2343         if (!PL_reg_curpm) {
2344             Newxz(PL_reg_curpm, 1, PMOP);
2345 #ifdef USE_ITHREADS
2346             {
2347                 SV* const repointer = &PL_sv_undef;
2348                 /* this regexp is also owned by the new PL_reg_curpm, which
2349                    will try to free it.  */
2350                 av_push(PL_regex_padav, repointer);
2351                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2352                 PL_regex_pad = AvARRAY(PL_regex_padav);
2353             }
2354 #endif
2355         }
2356 #ifdef USE_ITHREADS
2357         /* It seems that non-ithreads works both with and without this code.
2358            So for efficiency reasons it seems best not to have the code
2359            compiled when it is not needed.  */
2360         /* This is safe against NULLs: */
2361         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2362         /* PM_reg_curpm owns a reference to this regexp.  */
2363         ReREFCNT_inc(rx);
2364 #endif
2365         PM_SETRE(PL_reg_curpm, rx);
2366         PL_reg_oldcurpm = PL_curpm;
2367         PL_curpm = PL_reg_curpm;
2368         if (RXp_MATCH_COPIED(prog)) {
2369             /*  Here is a serious problem: we cannot rewrite subbeg,
2370                 since it may be needed if this match fails.  Thus
2371                 $` inside (?{}) could fail... */
2372             PL_reg_oldsaved = prog->subbeg;
2373             PL_reg_oldsavedlen = prog->sublen;
2374 #ifdef PERL_OLD_COPY_ON_WRITE
2375             PL_nrs = prog->saved_copy;
2376 #endif
2377             RXp_MATCH_COPIED_off(prog);
2378         }
2379         else
2380             PL_reg_oldsaved = NULL;
2381         prog->subbeg = PL_bostr;
2382         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2383     }
2384     DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2385     prog->offs[0].start = *startpos - PL_bostr;
2386     PL_reginput = *startpos;
2387     PL_reglastparen = &prog->lastparen;
2388     PL_reglastcloseparen = &prog->lastcloseparen;
2389     prog->lastparen = 0;
2390     prog->lastcloseparen = 0;
2391     PL_regsize = 0;
2392     PL_regoffs = prog->offs;
2393     if (PL_reg_start_tmpl <= prog->nparens) {
2394         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2395         if(PL_reg_start_tmp)
2396             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2397         else
2398             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2399     }
2400
2401     /* XXXX What this code is doing here?!!!  There should be no need
2402        to do this again and again, PL_reglastparen should take care of
2403        this!  --ilya*/
2404
2405     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2406      * Actually, the code in regcppop() (which Ilya may be meaning by
2407      * PL_reglastparen), is not needed at all by the test suite
2408      * (op/regexp, op/pat, op/split), but that code is needed otherwise
2409      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2410      * Meanwhile, this code *is* needed for the
2411      * above-mentioned test suite tests to succeed.  The common theme
2412      * on those tests seems to be returning null fields from matches.
2413      * --jhi updated by dapm */
2414 #if 1
2415     if (prog->nparens) {
2416         regexp_paren_pair *pp = PL_regoffs;
2417         register I32 i;
2418         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2419             ++pp;
2420             pp->start = -1;
2421             pp->end = -1;
2422         }
2423     }
2424 #endif
2425     REGCP_SET(lastcp);
2426     if (regmatch(reginfo, progi->program + 1)) {
2427         PL_regoffs[0].end = PL_reginput - PL_bostr;
2428         return 1;
2429     }
2430     if (reginfo->cutpoint)
2431         *startpos= reginfo->cutpoint;
2432     REGCP_UNWIND(lastcp);
2433     return 0;
2434 }
2435
2436
2437 #define sayYES goto yes
2438 #define sayNO goto no
2439 #define sayNO_SILENT goto no_silent
2440
2441 /* we dont use STMT_START/END here because it leads to
2442    "unreachable code" warnings, which are bogus, but distracting. */
2443 #define CACHEsayNO \
2444     if (ST.cache_mask) \
2445        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2446     sayNO
2447
2448 /* this is used to determine how far from the left messages like
2449    'failed...' are printed. It should be set such that messages
2450    are inline with the regop output that created them.
2451 */
2452 #define REPORT_CODE_OFF 32
2453
2454
2455 /* Make sure there is a test for this +1 options in re_tests */
2456 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2457
2458 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2459 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2460
2461 #define SLAB_FIRST(s) (&(s)->states[0])
2462 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2463
2464 /* grab a new slab and return the first slot in it */
2465
2466 STATIC regmatch_state *
2467 S_push_slab(pTHX)
2468 {
2469 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2470     dMY_CXT;
2471 #endif
2472     regmatch_slab *s = PL_regmatch_slab->next;
2473     if (!s) {
2474         Newx(s, 1, regmatch_slab);
2475         s->prev = PL_regmatch_slab;
2476         s->next = NULL;
2477         PL_regmatch_slab->next = s;
2478     }
2479     PL_regmatch_slab = s;
2480     return SLAB_FIRST(s);
2481 }
2482
2483
2484 /* push a new state then goto it */
2485
2486 #define PUSH_STATE_GOTO(state, node) \
2487     scan = node; \
2488     st->resume_state = state; \
2489     goto push_state;
2490
2491 /* push a new state with success backtracking, then goto it */
2492
2493 #define PUSH_YES_STATE_GOTO(state, node) \
2494     scan = node; \
2495     st->resume_state = state; \
2496     goto push_yes_state;
2497
2498
2499
2500 /*
2501
2502 regmatch() - main matching routine
2503
2504 This is basically one big switch statement in a loop. We execute an op,
2505 set 'next' to point the next op, and continue. If we come to a point which
2506 we may need to backtrack to on failure such as (A|B|C), we push a
2507 backtrack state onto the backtrack stack. On failure, we pop the top
2508 state, and re-enter the loop at the state indicated. If there are no more
2509 states to pop, we return failure.
2510
2511 Sometimes we also need to backtrack on success; for example /A+/, where
2512 after successfully matching one A, we need to go back and try to
2513 match another one; similarly for lookahead assertions: if the assertion
2514 completes successfully, we backtrack to the state just before the assertion
2515 and then carry on.  In these cases, the pushed state is marked as
2516 'backtrack on success too'. This marking is in fact done by a chain of
2517 pointers, each pointing to the previous 'yes' state. On success, we pop to
2518 the nearest yes state, discarding any intermediate failure-only states.
2519 Sometimes a yes state is pushed just to force some cleanup code to be
2520 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2521 it to free the inner regex.
2522
2523 Note that failure backtracking rewinds the cursor position, while
2524 success backtracking leaves it alone.
2525
2526 A pattern is complete when the END op is executed, while a subpattern
2527 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2528 ops trigger the "pop to last yes state if any, otherwise return true"
2529 behaviour.
2530
2531 A common convention in this function is to use A and B to refer to the two
2532 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2533 the subpattern to be matched possibly multiple times, while B is the entire
2534 rest of the pattern. Variable and state names reflect this convention.
2535
2536 The states in the main switch are the union of ops and failure/success of
2537 substates associated with with that op.  For example, IFMATCH is the op
2538 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2539 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2540 successfully matched A and IFMATCH_A_fail is a state saying that we have
2541 just failed to match A. Resume states always come in pairs. The backtrack
2542 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2543 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2544 on success or failure.
2545
2546 The struct that holds a backtracking state is actually a big union, with
2547 one variant for each major type of op. The variable st points to the
2548 top-most backtrack struct. To make the code clearer, within each
2549 block of code we #define ST to alias the relevant union.
2550
2551 Here's a concrete example of a (vastly oversimplified) IFMATCH
2552 implementation:
2553
2554     switch (state) {
2555     ....
2556
2557 #define ST st->u.ifmatch
2558
2559     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2560         ST.foo = ...; // some state we wish to save
2561         ...
2562         // push a yes backtrack state with a resume value of
2563         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2564         // first node of A:
2565         PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2566         // NOTREACHED
2567
2568     case IFMATCH_A: // we have successfully executed A; now continue with B
2569         next = B;
2570         bar = ST.foo; // do something with the preserved value
2571         break;
2572
2573     case IFMATCH_A_fail: // A failed, so the assertion failed
2574         ...;   // do some housekeeping, then ...
2575         sayNO; // propagate the failure
2576
2577 #undef ST
2578
2579     ...
2580     }
2581
2582 For any old-timers reading this who are familiar with the old recursive
2583 approach, the code above is equivalent to:
2584
2585     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2586     {
2587         int foo = ...
2588         ...
2589         if (regmatch(A)) {
2590             next = B;
2591             bar = foo;
2592             break;
2593         }
2594         ...;   // do some housekeeping, then ...
2595         sayNO; // propagate the failure
2596     }
2597
2598 The topmost backtrack state, pointed to by st, is usually free. If you
2599 want to claim it, populate any ST.foo fields in it with values you wish to
2600 save, then do one of
2601
2602         PUSH_STATE_GOTO(resume_state, node);
2603         PUSH_YES_STATE_GOTO(resume_state, node);
2604
2605 which sets that backtrack state's resume value to 'resume_state', pushes a
2606 new free entry to the top of the backtrack stack, then goes to 'node'.
2607 On backtracking, the free slot is popped, and the saved state becomes the
2608 new free state. An ST.foo field in this new top state can be temporarily
2609 accessed to retrieve values, but once the main loop is re-entered, it
2610 becomes available for reuse.
2611
2612 Note that the depth of the backtrack stack constantly increases during the
2613 left-to-right execution of the pattern, rather than going up and down with
2614 the pattern nesting. For example the stack is at its maximum at Z at the
2615 end of the pattern, rather than at X in the following:
2616
2617     /(((X)+)+)+....(Y)+....Z/
2618
2619 The only exceptions to this are lookahead/behind assertions and the cut,
2620 (?>A), which pop all the backtrack states associated with A before
2621 continuing.
2622
2623 Bascktrack state structs are allocated in slabs of about 4K in size.
2624 PL_regmatch_state and st always point to the currently active state,
2625 and PL_regmatch_slab points to the slab currently containing
2626 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2627 allocated, and is never freed until interpreter destruction. When the slab
2628 is full, a new one is allocated and chained to the end. At exit from
2629 regmatch(), slabs allocated since entry are freed.
2630
2631 */
2632
2633
2634 #define DEBUG_STATE_pp(pp)                                  \
2635     DEBUG_STATE_r({                                         \
2636         DUMP_EXEC_POS(locinput, scan, do_utf8);             \
2637         PerlIO_printf(Perl_debug_log,                       \
2638             "    %*s"pp" %s%s%s%s%s\n",                     \
2639             depth*2, "",                                    \
2640             PL_reg_name[st->resume_state],                     \
2641             ((st==yes_state||st==mark_state) ? "[" : ""),   \
2642             ((st==yes_state) ? "Y" : ""),                   \
2643             ((st==mark_state) ? "M" : ""),                  \
2644             ((st==yes_state||st==mark_state) ? "]" : "")    \
2645         );                                                  \
2646     });
2647
2648
2649 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2650
2651 #ifdef DEBUGGING
2652
2653 STATIC void
2654 S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8,
2655     const char *start, const char *end, const char *blurb)
2656 {
2657     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2658
2659     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2660
2661     if (!PL_colorset)
2662             reginitcolors();
2663     {
2664         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2665             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
2666
2667         RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2668             start, end - start, 60);
2669
2670         PerlIO_printf(Perl_debug_log,
2671             "%s%s REx%s %s against %s\n",
2672                        PL_colors[4], blurb, PL_colors[5], s0, s1);
2673
2674         if (do_utf8||utf8_pat)
2675             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2676                 utf8_pat ? "pattern" : "",
2677                 utf8_pat && do_utf8 ? " and " : "",
2678                 do_utf8 ? "string" : ""
2679             );
2680     }
2681 }
2682
2683 STATIC void
2684 S_dump_exec_pos(pTHX_ const char *locinput,
2685                       const regnode *scan,
2686                       const char *loc_regeol,
2687                       const char *loc_bostr,
2688                       const char *loc_reg_starttry,
2689                       const bool do_utf8)
2690 {
2691     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2692     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2693     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2694     /* The part of the string before starttry has one color
2695        (pref0_len chars), between starttry and current
2696        position another one (pref_len - pref0_len chars),
2697        after the current position the third one.
2698        We assume that pref0_len <= pref_len, otherwise we
2699        decrease pref0_len.  */
2700     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2701         ? (5 + taill) - l : locinput - loc_bostr;
2702     int pref0_len;
2703
2704     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2705
2706     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2707         pref_len++;
2708     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2709     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2710         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2711               ? (5 + taill) - pref_len : loc_regeol - locinput);
2712     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2713         l--;
2714     if (pref0_len < 0)
2715         pref0_len = 0;
2716     if (pref0_len > pref_len)
2717         pref0_len = pref_len;
2718     {
2719         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2720
2721         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2722             (locinput - pref_len),pref0_len, 60, 4, 5);
2723
2724         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2725                     (locinput - pref_len + pref0_len),
2726                     pref_len - pref0_len, 60, 2, 3);
2727
2728         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2729                     locinput, loc_regeol - locinput, 10, 0, 1);
2730
2731         const STRLEN tlen=len0+len1+len2;
2732         PerlIO_printf(Perl_debug_log,
2733                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2734                     (IV)(locinput - loc_bostr),
2735                     len0, s0,
2736                     len1, s1,
2737                     (docolor ? "" : "> <"),
2738                     len2, s2,
2739                     (int)(tlen > 19 ? 0 :  19 - tlen),
2740                     "");
2741     }
2742 }
2743
2744 #endif
2745
2746 /* reg_check_named_buff_matched()
2747  * Checks to see if a named buffer has matched. The data array of
2748  * buffer numbers corresponding to the buffer is expected to reside
2749  * in the regexp->data->data array in the slot stored in the ARG() of
2750  * node involved. Note that this routine doesn't actually care about the
2751  * name, that information is not preserved from compilation to execution.
2752  * Returns the index of the leftmost defined buffer with the given name
2753  * or 0 if non of the buffers matched.
2754  */
2755 STATIC I32
2756 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2757 {
2758     I32 n;
2759     RXi_GET_DECL(rex,rexi);
2760     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
2761     I32 *nums=(I32*)SvPVX(sv_dat);
2762
2763     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
2764
2765     for ( n=0; n<SvIVX(sv_dat); n++ ) {
2766         if ((I32)*PL_reglastparen >= nums[n] &&
2767             PL_regoffs[nums[n]].end != -1)
2768         {
2769             return nums[n];
2770         }
2771     }
2772     return 0;
2773 }
2774
2775
2776 /* free all slabs above current one  - called during LEAVE_SCOPE */
2777
2778 STATIC void
2779 S_clear_backtrack_stack(pTHX_ void *p)
2780 {
2781     regmatch_slab *s = PL_regmatch_slab->next;
2782     PERL_UNUSED_ARG(p);
2783
2784     if (!s)
2785         return;
2786     PL_regmatch_slab->next = NULL;
2787     while (s) {
2788         regmatch_slab * const osl = s;
2789         s = s->next;
2790         Safefree(osl);
2791     }
2792 }
2793
2794
2795 #define SETREX(Re1,Re2) \
2796     if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2797     Re1 = (Re2)
2798
2799 STATIC I32                      /* 0 failure, 1 success */
2800 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2801 {
2802 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2803     dMY_CXT;
2804 #endif
2805     dVAR;
2806     register const bool do_utf8 = PL_reg_match_utf8;
2807     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2808     REGEXP *rex_sv = reginfo->prog;
2809     regexp *rex = (struct regexp *)SvANY(rex_sv);
2810     RXi_GET_DECL(rex,rexi);
2811     I32 oldsave;
2812     /* the current state. This is a cached copy of PL_regmatch_state */
2813     register regmatch_state *st;
2814     /* cache heavy used fields of st in registers */
2815     register regnode *scan;
2816     register regnode *next;
2817     register U32 n = 0; /* general value; init to avoid compiler warning */
2818     register I32 ln = 0; /* len or last;  init to avoid compiler warning */
2819     register char *locinput = PL_reginput;
2820     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2821
2822     bool result = 0;        /* return value of S_regmatch */
2823     int depth = 0;          /* depth of backtrack stack */
2824     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
2825     const U32 max_nochange_depth =
2826         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
2827         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
2828     regmatch_state *yes_state = NULL; /* state to pop to on success of
2829                                                             subpattern */
2830     /* mark_state piggy backs on the yes_state logic so that when we unwind
2831        the stack on success we can update the mark_state as we go */
2832     regmatch_state *mark_state = NULL; /* last mark state we have seen */
2833     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2834     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2835     U32 state_num;
2836     bool no_final = 0;      /* prevent failure from backtracking? */
2837     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
2838     char *startpoint = PL_reginput;
2839     SV *popmark = NULL;     /* are we looking for a mark? */
2840     SV *sv_commit = NULL;   /* last mark name seen in failure */
2841     SV *sv_yes_mark = NULL; /* last mark name we have seen
2842                                during a successfull match */
2843     U32 lastopen = 0;       /* last open we saw */
2844     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2845     SV* const oreplsv = GvSV(PL_replgv);
2846     /* these three flags are set by various ops to signal information to
2847      * the very next op. They have a useful lifetime of exactly one loop
2848      * iteration, and are not preserved or restored by state pushes/pops
2849      */
2850     bool sw = 0;            /* the condition value in (?(cond)a|b) */
2851     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
2852     int logical = 0;        /* the following EVAL is:
2853                                 0: (?{...})
2854                                 1: (?(?{...})X|Y)
2855                                 2: (??{...})
2856                                or the following IFMATCH/UNLESSM is:
2857                                 false: plain (?=foo)
2858                                 true:  used as a condition: (?(?=foo))
2859                             */
2860 #ifdef DEBUGGING
2861     GET_RE_DEBUG_FLAGS_DECL;
2862 #endif
2863
2864     PERL_ARGS_ASSERT_REGMATCH;
2865
2866     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
2867             PerlIO_printf(Perl_debug_log,"regmatch start\n");
2868     }));
2869     /* on first ever call to regmatch, allocate first slab */
2870     if (!PL_regmatch_slab) {
2871         Newx(PL_regmatch_slab, 1, regmatch_slab);
2872         PL_regmatch_slab->prev = NULL;
2873         PL_regmatch_slab->next = NULL;
2874         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2875     }
2876
2877     oldsave = PL_savestack_ix;
2878     SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
2879     SAVEVPTR(PL_regmatch_slab);
2880     SAVEVPTR(PL_regmatch_state);
2881
2882     /* grab next free state slot */
2883     st = ++PL_regmatch_state;
2884     if (st >  SLAB_LAST(PL_regmatch_slab))
2885         st = PL_regmatch_state = S_push_slab(aTHX);
2886
2887     /* Note that nextchr is a byte even in UTF */
2888     nextchr = UCHARAT(locinput);
2889     scan = prog;
2890     while (scan != NULL) {
2891
2892         DEBUG_EXECUTE_r( {
2893             SV * const prop = sv_newmortal();
2894             regnode *rnext=regnext(scan);
2895             DUMP_EXEC_POS( locinput, scan, do_utf8 );
2896             regprop(rex, prop, scan);
2897
2898             PerlIO_printf(Perl_debug_log,
2899                     "%3"IVdf":%*s%s(%"IVdf")\n",
2900                     (IV)(scan - rexi->program), depth*2, "",
2901                     SvPVX_const(prop),
2902                     (PL_regkind[OP(scan)] == END || !rnext) ?
2903                         0 : (IV)(rnext - rexi->program));
2904         });
2905
2906         next = scan + NEXT_OFF(scan);
2907         if (next == scan)
2908             next = NULL;
2909         state_num = OP(scan);
2910
2911       reenter_switch:
2912
2913         assert(PL_reglastparen == &rex->lastparen);
2914         assert(PL_reglastcloseparen == &rex->lastcloseparen);
2915         assert(PL_regoffs == rex->offs);
2916
2917         switch (state_num) {
2918         case BOL:
2919             if (locinput == PL_bostr)
2920             {
2921                 /* reginfo->till = reginfo->bol; */
2922                 break;
2923             }
2924             sayNO;
2925         case MBOL:
2926             if (locinput == PL_bostr ||
2927                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2928             {
2929                 break;
2930             }
2931             sayNO;
2932         case SBOL:
2933             if (locinput == PL_bostr)
2934                 break;
2935             sayNO;
2936         case GPOS:
2937             if (locinput == reginfo->ganch)
2938                 break;
2939             sayNO;
2940
2941         case KEEPS:
2942             /* update the startpoint */
2943             st->u.keeper.val = PL_regoffs[0].start;
2944             PL_reginput = locinput;
2945             PL_regoffs[0].start = locinput - PL_bostr;
2946             PUSH_STATE_GOTO(KEEPS_next, next);
2947             /*NOT-REACHED*/
2948         case KEEPS_next_fail:
2949             /* rollback the start point change */
2950             PL_regoffs[0].start = st->u.keeper.val;
2951             sayNO_SILENT;
2952             /*NOT-REACHED*/
2953         case EOL:
2954                 goto seol;
2955         case MEOL:
2956             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2957                 sayNO;
2958             break;
2959         case SEOL:
2960           seol:
2961             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2962                 sayNO;
2963             if (PL_regeol - locinput > 1)
2964                 sayNO;
2965             break;
2966         case EOS:
2967             if (PL_regeol != locinput)
2968                 sayNO;
2969             break;
2970         case SANY:
2971             if (!nextchr && locinput >= PL_regeol)
2972                 sayNO;
2973             if (do_utf8) {
2974                 locinput += PL_utf8skip[nextchr];
2975                 if (locinput > PL_regeol)
2976                     sayNO;
2977                 nextchr = UCHARAT(locinput);
2978             }
2979             else
2980                 nextchr = UCHARAT(++locinput);
2981             break;
2982         case CANY:
2983             if (!nextchr && locinput >= PL_regeol)
2984                 sayNO;
2985             nextchr = UCHARAT(++locinput);
2986             break;
2987         case REG_ANY:
2988             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2989                 sayNO;
2990             if (do_utf8) {
2991                 locinput += PL_utf8skip[nextchr];
2992                 if (locinput > PL_regeol)
2993                     sayNO;
2994                 nextchr = UCHARAT(locinput);
2995             }
2996             else
2997                 nextchr = UCHARAT(++locinput);
2998             break;
2999
3000 #undef  ST
3001 #define ST st->u.trie
3002         case TRIEC:
3003             /* In this case the charclass data is available inline so
3004                we can fail fast without a lot of extra overhead.
3005              */
3006             if (scan->flags == EXACT || !do_utf8) {
3007                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3008                     DEBUG_EXECUTE_r(
3009                         PerlIO_printf(Perl_debug_log,
3010                                   "%*s  %sfailed to match trie start class...%s\n",
3011                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3012                     );
3013                     sayNO_SILENT;
3014                     /* NOTREACHED */
3015                 }
3016             }
3017             /* FALL THROUGH */
3018         case TRIE:
3019             {
3020                 /* what type of TRIE am I? (utf8 makes this contextual) */
3021                 DECL_TRIE_TYPE(scan);
3022
3023                 /* what trie are we using right now */
3024                 reg_trie_data * const trie
3025                     = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3026                 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3027                 U32 state = trie->startstate;
3028
3029                 if (trie->bitmap && trie_type != trie_utf8_fold &&
3030                     !TRIE_BITMAP_TEST(trie,*locinput)
3031                 ) {
3032                     if (trie->states[ state ].wordnum) {
3033                          DEBUG_EXECUTE_r(
3034                             PerlIO_printf(Perl_debug_log,
3035                                           "%*s  %smatched empty string...%s\n",
3036                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3037                         );
3038                         break;
3039                     } else {
3040                         DEBUG_EXECUTE_r(
3041                             PerlIO_printf(Perl_debug_log,
3042                                           "%*s  %sfailed to match trie start class...%s\n",
3043                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3044                         );
3045                         sayNO_SILENT;
3046                    }
3047                 }
3048
3049             {
3050                 U8 *uc = ( U8* )locinput;
3051
3052                 STRLEN len = 0;
3053                 STRLEN foldlen = 0;
3054                 U8 *uscan = (U8*)NULL;
3055                 STRLEN bufflen=0;
3056                 SV *sv_accept_buff = NULL;
3057                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3058
3059                 ST.accepted = 0; /* how many accepting states we have seen */
3060                 ST.B = next;
3061                 ST.jump = trie->jump;
3062                 ST.me = scan;
3063                 /*
3064                    traverse the TRIE keeping track of all accepting states
3065                    we transition through until we get to a failing node.
3066                 */
3067
3068                 while ( state && uc <= (U8*)PL_regeol ) {
3069                     U32 base = trie->states[ state ].trans.base;
3070                     UV uvc = 0;
3071                     U16 charid;
3072                     /* We use charid to hold the wordnum as we don't use it
3073                        for charid until after we have done the wordnum logic.
3074                        We define an alias just so that the wordnum logic reads
3075                        more naturally. */
3076
3077 #define got_wordnum charid
3078                     got_wordnum = trie->states[ state ].wordnum;
3079
3080                     if ( got_wordnum ) {
3081                         if ( ! ST.accepted ) {
3082                             ENTER;
3083                             SAVETMPS; /* XXX is this necessary? dmq */
3084                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
3085                             sv_accept_buff=newSV(bufflen *
3086                                             sizeof(reg_trie_accepted) - 1);
3087                             SvCUR_set(sv_accept_buff, 0);
3088                             SvPOK_on(sv_accept_buff);
3089                             sv_2mortal(sv_accept_buff);
3090                             SAVETMPS;
3091                             ST.accept_buff =
3092                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
3093                         }
3094                         do {
3095                             if (ST.accepted >= bufflen) {
3096                                 bufflen *= 2;
3097                                 ST.accept_buff =(reg_trie_accepted*)
3098                                     SvGROW(sv_accept_buff,
3099                                         bufflen * sizeof(reg_trie_accepted));
3100                             }
3101                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
3102                                 + sizeof(reg_trie_accepted));
3103
3104
3105                             ST.accept_buff[ST.accepted].wordnum = got_wordnum;
3106                             ST.accept_buff[ST.accepted].endpos = uc;
3107                             ++ST.accepted;
3108                         } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
3109                     }
3110 #undef got_wordnum
3111
3112                     DEBUG_TRIE_EXECUTE_r({
3113                                 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
3114                                 PerlIO_printf( Perl_debug_log,
3115                                     "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
3116                                     2+depth * 2, "", PL_colors[4],
3117                                     (UV)state, (UV)ST.accepted );
3118                     });
3119
3120                     if ( base ) {
3121                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3122                                              uscan, len, uvc, charid, foldlen,
3123                                              foldbuf, uniflags);
3124
3125                         if (charid &&
3126                              (base + charid > trie->uniquecharcount )
3127                              && (base + charid - 1 - trie->uniquecharcount
3128                                     < trie->lasttrans)
3129                              && trie->trans[base + charid - 1 -
3130                                     trie->uniquecharcount].check == state)
3131                         {
3132                             state = trie->trans[base + charid - 1 -
3133                                 trie->uniquecharcount ].next;
3134                         }
3135                         else {
3136                             state = 0;
3137                         }
3138                         uc += len;
3139
3140                     }
3141                     else {
3142                         state = 0;
3143                     }
3144                     DEBUG_TRIE_EXECUTE_r(
3145                         PerlIO_printf( Perl_debug_log,
3146                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3147                             charid, uvc, (UV)state, PL_colors[5] );
3148                     );
3149                 }
3150                 if (!ST.accepted )
3151                    sayNO;
3152
3153                 DEBUG_EXECUTE_r(
3154                     PerlIO_printf( Perl_debug_log,
3155                         "%*s  %sgot %"IVdf" possible matches%s\n",
3156                         REPORT_CODE_OFF + depth * 2, "",
3157                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3158                 );
3159             }}
3160             goto trie_first_try; /* jump into the fail handler */
3161             /* NOTREACHED */
3162         case TRIE_next_fail: /* we failed - try next alterative */
3163             if ( ST.jump) {
3164                 REGCP_UNWIND(ST.cp);
3165                 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3166                     PL_regoffs[n].end = -1;
3167                 *PL_reglastparen = n;
3168             }
3169           trie_first_try:
3170             if (do_cutgroup) {
3171                 do_cutgroup = 0;
3172                 no_final = 0;
3173             }
3174
3175             if ( ST.jump) {
3176                 ST.lastparen = *PL_reglastparen;
3177                 REGCP_SET(ST.cp);
3178             }
3179             if ( ST.accepted == 1 ) {
3180                 /* only one choice left - just continue */
3181                 DEBUG_EXECUTE_r({
3182                     AV *const trie_words
3183                         = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3184                     SV ** const tmp = av_fetch( trie_words,
3185                         ST.accept_buff[ 0 ].wordnum-1, 0 );
3186                     SV *sv= tmp ? sv_newmortal() : NULL;
3187
3188                     PerlIO_printf( Perl_debug_log,
3189                         "%*s  %sonly one match left: #%d <%s>%s\n",
3190                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3191                         ST.accept_buff[ 0 ].wordnum,
3192                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3193                                 PL_colors[0], PL_colors[1],
3194                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3195                             )
3196                         : "not compiled under -Dr",
3197                         PL_colors[5] );
3198                 });
3199                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3200                 /* in this case we free tmps/leave before we call regmatch
3201                    as we wont be using accept_buff again. */
3202
3203                 locinput = PL_reginput;
3204                 nextchr = UCHARAT(locinput);
3205                 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
3206                     scan = ST.B;
3207                 else
3208                     scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3209                 if (!has_cutgroup) {
3210                     FREETMPS;
3211                     LEAVE;
3212                 } else {
3213                     ST.accepted--;
3214                     PUSH_YES_STATE_GOTO(TRIE_next, scan);
3215                 }
3216
3217                 continue; /* execute rest of RE */
3218             }
3219
3220             if ( !ST.accepted-- ) {
3221                 DEBUG_EXECUTE_r({
3222                     PerlIO_printf( Perl_debug_log,
3223                         "%*s  %sTRIE failed...%s\n",
3224                         REPORT_CODE_OFF+depth*2, "",
3225                         PL_colors[4],
3226                         PL_colors[5] );
3227                 });
3228                 FREETMPS;
3229                 LEAVE;
3230                 sayNO_SILENT;
3231                 /*NOTREACHED*/
3232             }
3233
3234             /*
3235                There are at least two accepting states left.  Presumably
3236                the number of accepting states is going to be low,
3237                typically two. So we simply scan through to find the one
3238                with lowest wordnum.  Once we find it, we swap the last
3239                state into its place and decrement the size. We then try to
3240                match the rest of the pattern at the point where the word
3241                ends. If we succeed, control just continues along the
3242                regex; if we fail we return here to try the next accepting
3243                state
3244              */
3245
3246             {
3247                 U32 best = 0;
3248                 U32 cur;
3249                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3250                     DEBUG_TRIE_EXECUTE_r(
3251                         PerlIO_printf( Perl_debug_log,
3252                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3253                             REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3254                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3255                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3256                     );
3257
3258                     if (ST.accept_buff[cur].wordnum <
3259                             ST.accept_buff[best].wordnum)
3260                         best = cur;
3261                 }
3262
3263                 DEBUG_EXECUTE_r({
3264                     AV *const trie_words
3265                         = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3266                     SV ** const tmp = av_fetch( trie_words,
3267                         ST.accept_buff[ best ].wordnum - 1, 0 );
3268                     regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
3269                                     ST.B :
3270                                     ST.me + ST.jump[ST.accept_buff[best].wordnum];
3271                     SV *sv= tmp ? sv_newmortal() : NULL;
3272
3273                     PerlIO_printf( Perl_debug_log,
3274                         "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3275                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3276                         ST.accept_buff[best].wordnum,
3277                         tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3278                                 PL_colors[0], PL_colors[1],
3279                                 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3280                             ) : "not compiled under -Dr",
3281                             REG_NODE_NUM(nextop),
3282                         PL_colors[5] );
3283                 });
3284
3285                 if ( best<ST.accepted ) {
3286                     reg_trie_accepted tmp = ST.accept_buff[ best ];
3287                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3288                     ST.accept_buff[ ST.accepted ] = tmp;
3289                     best = ST.accepted;
3290                 }
3291                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3292                 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3293                     scan = ST.B;
3294                 } else {
3295                     scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3296                 }
3297                 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3298                 /* NOTREACHED */
3299             }
3300             /* NOTREACHED */
3301         case TRIE_next:
3302             /* we dont want to throw this away, see bug 57042*/
3303             if (oreplsv != GvSV(PL_replgv))
3304                 sv_setsv(oreplsv, GvSV(PL_replgv));
3305             FREETMPS;
3306             LEAVE;
3307             sayYES;
3308 #undef  ST
3309
3310         case EXACT: {
3311             char *s = STRING(scan);
3312             ln = STR_LEN(scan);
3313             if (do_utf8 != UTF) {
3314                 /* The target and the pattern have differing utf8ness. */
3315                 char *l = locinput;
3316                 const char * const e = s + ln;
3317
3318                 if (do_utf8) {
3319                     /* The target is utf8, the pattern is not utf8. */
3320                     while (s < e) {
3321                         STRLEN ulen;
3322                         if (l >= PL_regeol)
3323                              sayNO;
3324                         if (NATIVE_TO_UNI(*(U8*)s) !=
3325                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3326                                             uniflags))
3327                              sayNO;
3328                         l += ulen;
3329                         s ++;
3330                     }
3331                 }
3332                 else {
3333                     /* The target is not utf8, the pattern is utf8. */
3334                     while (s < e) {
3335                         STRLEN ulen;
3336                         if (l >= PL_regeol)
3337                             sayNO;
3338                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3339                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3340                                            uniflags))
3341                             sayNO;
3342                         s += ulen;
3343                         l ++;
3344                     }
3345                 }
3346                 locinput = l;
3347                 nextchr = UCHARAT(locinput);
3348                 break;
3349             }
3350             /* The target and the pattern have the same utf8ness. */
3351             /* Inline the first character, for speed. */
3352             if (UCHARAT(s) != nextchr)
3353                 sayNO;
3354             if (PL_regeol - locinput < ln)
3355                 sayNO;
3356             if (ln > 1 && memNE(s, locinput, ln))
3357                 sayNO;
3358             locinput += ln;
3359             nextchr = UCHARAT(locinput);
3360             break;
3361             }
3362         case EXACTFL:
3363             PL_reg_flags |= RF_tainted;
3364             /* FALL THROUGH */
3365         case EXACTF: {
3366             char * const s = STRING(scan);
3367             ln = STR_LEN(scan);
3368
3369             if (do_utf8 || UTF) {
3370               /* Either target or the pattern are utf8. */
3371                 const char * const l = locinput;
3372                 char *e = PL_regeol;
3373
3374                 if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
3375                                l, &e, 0,  do_utf8)) {
3376                      /* One more case for the sharp s:
3377                       * pack("U0U*", 0xDF) =~ /ss/i,
3378                       * the 0xC3 0x9F are the UTF-8
3379                       * byte sequence for the U+00DF. */
3380
3381                      if (!(do_utf8 &&
3382                            toLOWER(s[0]) == 's' &&
3383                            ln >= 2 &&
3384                            toLOWER(s[1]) == 's' &&
3385                            (U8)l[0] == 0xC3 &&
3386                            e - l >= 2 &&
3387                            (U8)l[1] == 0x9F))
3388                           sayNO;
3389                 }
3390                 locinput = e;
3391                 nextchr = UCHARAT(locinput);
3392                 break;
3393             }
3394
3395             /* Neither the target and the pattern are utf8. */
3396
3397             /* Inline the first character, for speed. */
3398             if (UCHARAT(s) != nextchr &&
3399                 UCHARAT(s) != ((OP(scan) == EXACTF)
3400                                ? PL_fold : PL_fold_locale)[nextchr])
3401                 sayNO;
3402             if (PL_regeol - locinput < ln)
3403                 sayNO;
3404             if (ln > 1 && (OP(scan) == EXACTF
3405                            ? ibcmp(s, locinput, ln)
3406                            : ibcmp_locale(s, locinput, ln)))
3407                 sayNO;
3408             locinput += ln;
3409             nextchr = UCHARAT(locinput);
3410             break;
3411             }
3412         case BOUNDL:
3413         case NBOUNDL:
3414             PL_reg_flags |= RF_tainted;
3415             /* FALL THROUGH */
3416         case BOUND:
3417         case NBOUND:
3418             /* was last char in word? */
3419             if (do_utf8) {
3420                 if (locinput == PL_bostr)
3421                     ln = '\n';
3422                 else {
3423                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3424
3425                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3426                 }
3427                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3428                     ln = isALNUM_uni(ln);
3429                     LOAD_UTF8_CHARCLASS_ALNUM();
3430                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3431                 }
3432                 else {
3433                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3434                     n = isALNUM_LC_utf8((U8*)locinput);
3435                 }
3436             }
3437             else {
3438                 ln = (locinput != PL_bostr) ?
3439                     UCHARAT(locinput - 1) : '\n';
3440                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3441                     ln = isALNUM(ln);
3442                     n = isALNUM(nextchr);
3443                 }
3444                 else {
3445                     ln = isALNUM_LC(ln);
3446                     n = isALNUM_LC(nextchr);
3447                 }
3448             }
3449             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3450                                     OP(scan) == BOUNDL))
3451                     sayNO;
3452             break;
3453         case ANYOF:
3454             if (do_utf8) {
3455                 STRLEN inclasslen = PL_regeol - locinput;
3456
3457                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3458                     goto anyof_fail;
3459                 if (locinput >= PL_regeol)
3460                     sayNO;
3461                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3462                 nextchr = UCHARAT(locinput);
3463                 break;
3464             }
3465             else {
3466                 if (nextchr < 0)
3467                     nextchr = UCHARAT(locinput);
3468                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3469                     goto anyof_fail;
3470                 if (!nextchr && locinput >= PL_regeol)
3471                     sayNO;
3472                 nextchr = UCHARAT(++locinput);
3473                 break;
3474             }
3475         anyof_fail:
3476             /* If we might have the case of the German sharp s
3477              * in a casefolding Unicode character class. */
3478
3479             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3480                  locinput += SHARP_S_SKIP;
3481                  nextchr = UCHARAT(locinput);
3482             }
3483             else
3484                  sayNO;
3485             break;
3486         /* Special char classes - The defines start on line 129 or so */
3487         CCC_TRY_AFF( ALNUM,  ALNUML, alnum, "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3488         CCC_TRY_NEG(NALNUM, NALNUML, alnum, "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3489
3490         CCC_TRY_AFF( SPACE,  SPACEL, space, " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3491         CCC_TRY_NEG(NSPACE, NSPACEL, space, " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3492
3493         CCC_TRY_AFF( DIGIT,  DIGITL, digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3494         CCC_TRY_NEG(NDIGIT, NDIGITL, digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3495
3496         case CLUMP:
3497             if (locinput >= PL_regeol)
3498                 sayNO;
3499             if  (do_utf8) {
3500                 LOAD_UTF8_CHARCLASS_MARK();
3501                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3502                     sayNO;
3503                 locinput += PL_utf8skip[nextchr];
3504                 while (locinput < PL_regeol &&
3505                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3506                     locinput += UTF8SKIP(locinput);
3507                 if (locinput > PL_regeol)
3508                     sayNO;
3509             }
3510             else
3511                locinput++;
3512             nextchr = UCHARAT(locinput);
3513             break;
3514
3515         case NREFFL:
3516         {
3517             char *s;
3518             char type;
3519             PL_reg_flags |= RF_tainted;
3520             /* FALL THROUGH */
3521         case NREF:
3522         case NREFF:
3523             type = OP(scan);
3524             n = reg_check_named_buff_matched(rex,scan);
3525
3526             if ( n ) {
3527                 type = REF + ( type - NREF );
3528                 goto do_ref;
3529             } else {
3530                 sayNO;
3531             }
3532             /* unreached */
3533         case REFFL:
3534             PL_reg_flags |= RF_tainted;
3535             /* FALL THROUGH */
3536         case REF:
3537         case REFF:
3538             n = ARG(scan);  /* which paren pair */
3539             type = OP(scan);
3540           do_ref:
3541             ln = PL_regoffs[n].start;
3542             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3543             if (*PL_reglastparen < n || ln == -1)
3544                 sayNO;                  /* Do not match unless seen CLOSEn. */
3545             if (ln == PL_regoffs[n].end)
3546                 break;
3547
3548             s = PL_bostr + ln;
3549             if (do_utf8 && type != REF) {       /* REF can do byte comparison */
3550                 char *l = locinput;
3551                 const char *e = PL_bostr + PL_regoffs[n].end;
3552                 /*
3553                  * Note that we can't do the "other character" lookup trick as
3554                  * in the 8-bit case (no pun intended) because in Unicode we
3555                  * have to map both upper and title case to lower case.
3556                  */
3557                 if (type == REFF) {
3558                     while (s < e) {
3559                         STRLEN ulen1, ulen2;
3560                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3561                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3562
3563                         if (l >= PL_regeol)
3564                             sayNO;
3565                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3566                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3567                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3568                             sayNO;
3569                         s += ulen1;
3570                         l += ulen2;
3571                     }
3572                 }
3573                 locinput = l;
3574                 nextchr = UCHARAT(locinput);
3575                 break;
3576             }
3577
3578             /* Inline the first character, for speed. */
3579             if (UCHARAT(s) != nextchr &&
3580                 (type == REF ||
3581                  (UCHARAT(s) != (type == REFF
3582                                   ? PL_fold : PL_fold_locale)[nextchr])))
3583                 sayNO;
3584             ln = PL_regoffs[n].end - ln;
3585             if (locinput + ln > PL_regeol)
3586                 sayNO;
3587             if (ln > 1 && (type == REF
3588                            ? memNE(s, locinput, ln)
3589                            : (type == REFF
3590                               ? ibcmp(s, locinput, ln)
3591                               : ibcmp_locale(s, locinput, ln))))
3592                 sayNO;
3593             locinput += ln;
3594             nextchr = UCHARAT(locinput);
3595             break;
3596         }
3597         case NOTHING:
3598         case TAIL:
3599             break;
3600         case BACK:
3601             break;
3602
3603 #undef  ST
3604 #define ST st->u.eval
3605         {
3606             SV *ret;
3607             REGEXP *re_sv;
3608             regexp *re;
3609             regexp_internal *rei;
3610             regnode *startpoint;
3611
3612         case GOSTART:
3613         case GOSUB: /*    /(...(?1))/   /(...(?&foo))/   */
3614             if (cur_eval && cur_eval->locinput==locinput) {
3615                 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3616                     Perl_croak(aTHX_ "Infinite recursion in regex");
3617                 if ( ++nochange_depth > max_nochange_depth )
3618                     Perl_croak(aTHX_
3619                         "Pattern subroutine nesting without pos change"
3620                         " exceeded limit in regex");
3621             } else {
3622                 nochange_depth = 0;
3623             }
3624             re_sv = rex_sv;
3625             re = rex;
3626             rei = rexi;
3627             (void)ReREFCNT_inc(rex_sv);
3628             if (OP(scan)==GOSUB) {
3629                 startpoint = scan + ARG2L(scan);
3630                 ST.close_paren = ARG(scan);
3631             } else {
3632                 startpoint = rei->program+1;
3633                 ST.close_paren = 0;
3634             }
3635             goto eval_recurse_doit;
3636             /* NOTREACHED */
3637         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3638             if (cur_eval && cur_eval->locinput==locinput) {
3639                 if ( ++nochange_depth > max_nochange_depth )
3640                     Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3641             } else {
3642                 nochange_depth = 0;
3643             }
3644             {
3645                 /* execute the code in the {...} */
3646                 dSP;
3647                 SV ** const before = SP;
3648                 OP_4tree * const oop = PL_op;
3649                 COP * const ocurcop = PL_curcop;
3650                 PAD *old_comppad;
3651                 char *saved_regeol = PL_regeol;
3652
3653                 n = ARG(scan);
3654                 PL_op = (OP_4tree*)rexi->data->data[n];
3655                 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3656                     "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3657                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3658                 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3659
3660                 if (sv_yes_mark) {
3661                     SV *sv_mrk = get_sv("REGMARK", 1);
3662                     sv_setsv(sv_mrk, sv_yes_mark);
3663                 }
3664
3665                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3666                 SPAGAIN;
3667                 if (SP == before)
3668                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3669                 else {
3670                     ret = POPs;
3671                     PUTBACK;
3672                 }
3673
3674                 PL_op = oop;
3675                 PAD_RESTORE_LOCAL(old_comppad);
3676                 PL_curcop = ocurcop;
3677                 PL_regeol = saved_regeol;
3678                 if (!logical) {
3679                     /* /(?{...})/ */
3680                     sv_setsv(save_scalar(PL_replgv), ret);
3681                     break;
3682                 }
3683             }
3684             if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3685                 logical = 0;
3686                 {
3687                     /* extract RE object from returned value; compiling if
3688                      * necessary */
3689                     MAGIC *mg = NULL;
3690                     REGEXP *rx = NULL;
3691
3692                     if (SvROK(ret)) {
3693                         SV *const sv = SvRV(ret);
3694
3695                         if (SvTYPE(sv) == SVt_REGEXP) {
3696                             rx = (REGEXP*) sv;
3697                         } else if (SvSMAGICAL(sv)) {
3698                             mg = mg_find(sv, PERL_MAGIC_qr);
3699                             assert(mg);
3700                         }
3701                     } else if (SvTYPE(ret) == SVt_REGEXP) {
3702                         rx = (REGEXP*) ret;
3703                     } else if (SvSMAGICAL(ret)) {
3704                         if (SvGMAGICAL(ret)) {
3705                             /* I don't believe that there is ever qr magic
3706                                here.  */
3707                             assert(!mg_find(ret, PERL_MAGIC_qr));
3708                             sv_unmagic(ret, PERL_MAGIC_qr);
3709                         }
3710                         else {
3711                             mg = mg_find(ret, PERL_MAGIC_qr);
3712                             /* testing suggests mg only ends up non-NULL for
3713                                scalars who were upgraded and compiled in the
3714                                else block below. In turn, this is only
3715                                triggered in the "postponed utf8 string" tests
3716                                in t/op/pat.t  */
3717                         }
3718                     }
3719
3720                     if (mg) {
3721                         rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
3722                         assert(rx);
3723                     }
3724                     if (rx) {
3725                         rx = reg_temp_copy(rx);
3726                     }
3727                     else {
3728                         U32 pm_flags = 0;
3729                         const I32 osize = PL_regsize;
3730
3731                         if (DO_UTF8(ret)) {
3732                             assert (SvUTF8(ret));
3733                         } else if (SvUTF8(ret)) {
3734                             /* Not doing UTF-8, despite what the SV says. Is
3735                                this only if we're trapped in use 'bytes'?  */
3736                             /* Make a copy of the octet sequence, but without
3737                                the flag on, as the compiler now honours the
3738                                SvUTF8 flag on ret.  */
3739                             STRLEN len;
3740                             const char *const p = SvPV(ret, len);
3741                             ret = newSVpvn_flags(p, len, SVs_TEMP);
3742                         }
3743                         rx = CALLREGCOMP(ret, pm_flags);
3744                         if (!(SvFLAGS(ret)
3745                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3746                                  | SVs_GMG))) {
3747                             /* This isn't a first class regexp. Instead, it's
3748                                caching a regexp onto an existing, Perl visible
3749                                scalar.  */
3750                             sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
3751                         }
3752                         PL_regsize = osize;
3753                     }
3754                     re_sv = rx;
3755                     re = (struct regexp *)SvANY(rx);
3756                 }
3757                 RXp_MATCH_COPIED_off(re);
3758                 re->subbeg = rex->subbeg;
3759                 re->sublen = rex->sublen;
3760                 rei = RXi_GET(re);
3761                 DEBUG_EXECUTE_r(
3762                     debug_start_match(re_sv, do_utf8, locinput, PL_regeol,
3763                         "Matching embedded");
3764                 );
3765                 startpoint = rei->program + 1;
3766                 ST.close_paren = 0; /* only used for GOSUB */
3767                 /* borrowed from regtry */
3768                 if (PL_reg_start_tmpl <= re->nparens) {
3769                     PL_reg_start_tmpl = re->nparens*3/2 + 3;
3770                     if(PL_reg_start_tmp)
3771                         Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3772                     else
3773                         Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3774                 }
3775
3776         eval_recurse_doit: /* Share code with GOSUB below this line */
3777                 /* run the pattern returned from (??{...}) */
3778                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3779                 REGCP_SET(ST.lastcp);
3780
3781                 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
3782
3783                 /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
3784                 PL_reglastparen = &re->lastparen;
3785                 PL_reglastcloseparen = &re->lastcloseparen;
3786                 re->lastparen = 0;
3787                 re->lastcloseparen = 0;
3788
3789                 PL_reginput = locinput;
3790                 PL_regsize = 0;
3791
3792                 /* XXXX This is too dramatic a measure... */
3793                 PL_reg_maxiter = 0;
3794
3795                 ST.toggle_reg_flags = PL_reg_flags;
3796                 if (RX_UTF8(re_sv))
3797                     PL_reg_flags |= RF_utf8;
3798                 else
3799                     PL_reg_flags &= ~RF_utf8;
3800                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3801
3802                 ST.prev_rex = rex_sv;
3803                 ST.prev_curlyx = cur_curlyx;
3804                 SETREX(rex_sv,re_sv);
3805                 rex = re;
3806                 rexi = rei;
3807                 cur_curlyx = NULL;
3808                 ST.B = next;
3809                 ST.prev_eval = cur_eval;
3810                 cur_eval = st;
3811                 /* now continue from first node in postoned RE */
3812                 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
3813                 /* NOTREACHED */
3814             }
3815             /* logical is 1,   /(?(?{...})X|Y)/ */
3816             sw = (bool)SvTRUE(ret);
3817             logical = 0;
3818             break;
3819         }
3820
3821         case EVAL_AB: /* cleanup after a successful (??{A})B */
3822             /* note: this is called twice; first after popping B, then A */
3823             PL_reg_flags ^= ST.toggle_reg_flags;
3824             ReREFCNT_dec(rex_sv);
3825             SETREX(rex_sv,ST.prev_rex);
3826             rex = (struct regexp *)SvANY(rex_sv);
3827             rexi = RXi_GET(rex);
3828             regcpblow(ST.cp);
3829             cur_eval = ST.prev_eval;
3830             cur_curlyx = ST.prev_curlyx;
3831
3832             /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
3833             PL_reglastparen = &rex->lastparen;
3834             PL_reglastcloseparen = &rex->lastcloseparen;
3835             /* also update PL_regoffs */
3836             PL_regoffs = rex->offs;
3837
3838             /* XXXX This is too dramatic a measure... */
3839             PL_reg_maxiter = 0;
3840             if ( nochange_depth )
3841                 nochange_depth--;
3842             sayYES;
3843
3844
3845         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3846             /* note: this is called twice; first after popping B, then A */
3847             PL_reg_flags ^= ST.toggle_reg_flags;