regexec.c

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