regexec.c

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