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