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, by Larry Wall and others
  60  ****
  61  ****    You may distribute under the terms of either the GNU General Public
  62  ****    License or the Artistic License, as specified in the README file.
  63  *
  64  * Beware that some of this code is subtly aware of the way operator
  65  * precedence is structured in regular expressions.  Serious changes in
  66  * regular-expression syntax might require a total rethink.
  67  */
  68 #include "EXTERN.h"
  69 #define PERL_IN_REGEXEC_C
  70 #include "perl.h"
  71
  72 #ifdef PERL_IN_XSUB_RE
  73 #  include "re_comp.h"
  74 #else
  75 #  include "regcomp.h"
  76 #endif
  77
  78 #define RF_tainted      1               /* tainted information used? */
  79 #define RF_warned       2               /* warned about big count? */
  80
  81 #define RF_utf8         8               /* Pattern contains multibyte chars? */
  82
  83 #define UTF ((PL_reg_flags & RF_utf8) != 0)
  84
  85 #define RS_init         1               /* eval environment created */
  86 #define RS_set          2               /* replsv value is set */
  87
  88 #ifndef STATIC
  89 #define STATIC  static
  90 #endif
  91
  92 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
  93
  94 /*
  95  * Forwards.
  96  */
  97
  98 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
  99 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
 100
 101 #define HOPc(pos,off) \
 102         (char *)(PL_reg_match_utf8 \
 103             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
 104             : (U8*)(pos + off))
 105 #define HOPBACKc(pos, off) \
 106         (char*)(PL_reg_match_utf8\
 107             ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
 108             : (pos - off >= PL_bostr)           \
 109                 ? (U8*)pos - off                \
 110                 : NULL)
 111
 112 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
 113 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
 114
 115 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
 116     if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
 117 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
 118 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
 119 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
 120 #define LOAD_UTF8_CHARCLASS_MARK()  LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
 121
 122 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
 123
 124 /* for use after a quantifier and before an EXACT-like node -- japhy */
 125 #define JUMPABLE(rn) ( \
 126     OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
 127     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 128     OP(rn) == PLUS || OP(rn) == MINMOD || \
 129     (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
 130 )
 131
 132 #define HAS_TEXT(rn) ( \
 133     PL_regkind[OP(rn)] == EXACT || PL_regkind[OP(rn)] == REF \
 134 )
 135
 136 /*
 137   Search for mandatory following text node; for lookahead, the text must
 138   follow but for lookbehind (rn->flags != 0) we skip to the next step.
 139 */
 140 #define FIND_NEXT_IMPT(rn) STMT_START { \
 141     while (JUMPABLE(rn)) { \
 142         const OPCODE type = OP(rn); \
 143         if (type == SUSPEND || PL_regkind[type] == CURLY) \
 144             rn = NEXTOPER(NEXTOPER(rn)); \
 145         else if (type == PLUS) \
 146             rn = NEXTOPER(rn); \
 147         else if (type == IFMATCH) \
 148             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
 149         else rn += NEXT_OFF(rn); \
 150     } \
 151 } STMT_END
 152
 153 static void restore_pos(pTHX_ void *arg);
 154
 155 STATIC CHECKPOINT
 156 S_regcppush(pTHX_ I32 parenfloor)
 157 {
 158     dVAR;
 159     const int retval = PL_savestack_ix;
 160 #define REGCP_PAREN_ELEMS 4
 161     const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
 162     int p;
 163     GET_RE_DEBUG_FLAGS_DECL;
 164
 165     if (paren_elems_to_push < 0)
 166         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
 167
 168 #define REGCP_OTHER_ELEMS 6
 169     SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
 170     for (p = PL_regsize; p > parenfloor; p--) {
 171 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 172         SSPUSHINT(PL_regendp[p]);
 173         SSPUSHINT(PL_regstartp[p]);
 174         SSPUSHPTR(PL_reg_start_tmp[p]);
 175         SSPUSHINT(p);
 176         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 177           "     saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
 178                       (UV)p, (IV)PL_regstartp[p],
 179                       (IV)(PL_reg_start_tmp[p] - PL_bostr),
 180                       (IV)PL_regendp[p]
 181         ));
 182     }
 183 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 184     SSPUSHINT(PL_regsize);
 185     SSPUSHINT(*PL_reglastparen);
 186     SSPUSHINT(*PL_reglastcloseparen);
 187     SSPUSHPTR(PL_reginput);
 188 #define REGCP_FRAME_ELEMS 2
 189 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
 190  * are needed for the regexp context stack bookkeeping. */
 191     SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 192     SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
 193
 194     return retval;
 195 }
 196
 197 /* These are needed since we do not localize EVAL nodes: */
 198 #define REGCP_SET(cp)                                           \
 199     DEBUG_STATE_r(                                              \
 200             PerlIO_printf(Perl_debug_log,                       \
 201                 "  Setting an EVAL scope, savestack=%"IVdf"\n", \
 202                 (IV)PL_savestack_ix));                          \
 203     cp = PL_savestack_ix
 204
 205 #define REGCP_UNWIND(cp)                                        \
 206     DEBUG_STATE_r(                                              \
 207         if (cp != PL_savestack_ix)                              \
 208             PerlIO_printf(Perl_debug_log,                       \
 209                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 210                 (IV)(cp), (IV)PL_savestack_ix));                \
 211     regcpblow(cp)
 212
 213 STATIC char *
 214 S_regcppop(pTHX_ const regexp *rex)
 215 {
 216     dVAR;
 217     I32 i;
 218     char *input;
 219
 220     GET_RE_DEBUG_FLAGS_DECL;
 221
 222     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 223     i = SSPOPINT;
 224     assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 225     i = SSPOPINT; /* Parentheses elements to pop. */
 226     input = (char *) SSPOPPTR;
 227     *PL_reglastcloseparen = SSPOPINT;
 228     *PL_reglastparen = SSPOPINT;
 229     PL_regsize = SSPOPINT;
 230
 231     /* Now restore the parentheses context. */
 232     for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 233          i > 0; i -= REGCP_PAREN_ELEMS) {
 234         I32 tmps;
 235         U32 paren = (U32)SSPOPINT;
 236         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
 237         PL_regstartp[paren] = SSPOPINT;
 238         tmps = SSPOPINT;
 239         if (paren <= *PL_reglastparen)
 240             PL_regendp[paren] = tmps;
 241         DEBUG_EXECUTE_r(
 242             PerlIO_printf(Perl_debug_log,
 243                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 244                           (UV)paren, (IV)PL_regstartp[paren],
 245                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
 246                           (IV)PL_regendp[paren],
 247                           (paren > *PL_reglastparen ? "(no)" : ""));
 248         );
 249     }
 250     DEBUG_EXECUTE_r(
 251         if (*PL_reglastparen + 1 <= rex->nparens) {
 252             PerlIO_printf(Perl_debug_log,
 253                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
 254                           (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
 255         }
 256     );
 257 #if 1
 258     /* It would seem that the similar code in regtry()
 259      * already takes care of this, and in fact it is in
 260      * a better location to since this code can #if 0-ed out
 261      * but the code in regtry() is needed or otherwise tests
 262      * requiring null fields (pat.t#187 and split.t#{13,14}
 263      * (as of patchlevel 7877)  will fail.  Then again,
 264      * this code seems to be necessary or otherwise
 265      * building DynaLoader will fail:
 266      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
 267      * --jhi */
 268     for (i = *PL_reglastparen + 1; (U32)i <= rex->nparens; i++) {
 269         if (i > PL_regsize)
 270             PL_regstartp[i] = -1;
 271         PL_regendp[i] = -1;
 272     }
 273 #endif
 274     return input;
 275 }
 276
 277 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
 278
 279 /*
 280  * pregexec and friends
 281  */
 282
 283 #ifndef PERL_IN_XSUB_RE
 284 /*
 285  - pregexec - match a regexp against a string
 286  */
 287 I32
 288 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
 289          char *strbeg, I32 minend, SV *screamer, U32 nosave)
 290 /* strend: pointer to null at end of string */
 291 /* strbeg: real beginning of string */
 292 /* minend: end of match must be >=minend after stringarg. */
 293 /* nosave: For optimizations. */
 294 {
 295     return
 296         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 297                       nosave ? 0 : REXEC_COPY_STR);
 298 }
 299 #endif
 300
 301 /*
 302  * Need to implement the following flags for reg_anch:
 303  *
 304  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
 305  * USE_INTUIT_ML
 306  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
 307  * INTUIT_AUTORITATIVE_ML
 308  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
 309  * INTUIT_ONCE_ML
 310  *
 311  * Another flag for this function: SECOND_TIME (so that float substrs
 312  * with giant delta may be not rechecked).
 313  */
 314
 315 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 316
 317 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
 318    Otherwise, only SvCUR(sv) is used to get strbeg. */
 319
 320 /* XXXX We assume that strpos is strbeg unless sv. */
 321
 322 /* XXXX Some places assume that there is a fixed substring.
 323         An update may be needed if optimizer marks as "INTUITable"
 324         RExen without fixed substrings.  Similarly, it is assumed that
 325         lengths of all the strings are no more than minlen, thus they
 326         cannot come from lookahead.
 327         (Or minlen should take into account lookahead.) */
 328
 329 /* A failure to find a constant substring means that there is no need to make
 330    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 331    finding a substring too deep into the string means that less calls to
 332    regtry() should be needed.
 333
 334    REx compiler's optimizer found 4 possible hints:
 335         a) Anchored substring;
 336         b) Fixed substring;
 337         c) Whether we are anchored (beginning-of-line or \G);
 338         d) First node (of those at offset 0) which may distingush positions;
 339    We use a)b)d) and multiline-part of c), and try to find a position in the
 340    string which does not contradict any of them.
 341  */
 342
 343 /* Most of decisions we do here should have been done at compile time.
 344    The nodes of the REx which we used for the search should have been
 345    deleted from the finite automaton. */
 346
 347 char *
 348 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
 349                      char *strend, U32 flags, re_scream_pos_data *data)
 350 {
 351     dVAR;
 352     register I32 start_shift = 0;
 353     /* Should be nonnegative! */
 354     register I32 end_shift   = 0;
 355     register char *s;
 356     register SV *check;
 357     char *strbeg;
 358     char *t;
 359     const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
 360     I32 ml_anch;
 361     register char *other_last = NULL;   /* other substr checked before this */
 362     char *check_at = NULL;              /* check substr found at this pos */
 363     const I32 multiline = prog->reganch & PMf_MULTILINE;
 364 #ifdef DEBUGGING
 365     const char * const i_strpos = strpos;
 366 #endif
 367
 368     GET_RE_DEBUG_FLAGS_DECL;
 369
 370     RX_MATCH_UTF8_set(prog,do_utf8);
 371
 372     if (prog->reganch & ROPT_UTF8) {
 373         PL_reg_flags |= RF_utf8;
 374     }
 375     DEBUG_EXECUTE_r(
 376         debug_start_match(prog, do_utf8, strpos, strend,
 377             sv ? "Guessing start of match in sv for"
 378                : "Guessing start of match in string for");
 379               );
 380
 381     /* CHR_DIST() would be more correct here but it makes things slow. */
 382     if (prog->minlen > strend - strpos) {
 383         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 384                               "String too short... [re_intuit_start]\n"));
 385         goto fail;
 386     }
 387
 388     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
 389     PL_regeol = strend;
 390     if (do_utf8) {
 391         if (!prog->check_utf8 && prog->check_substr)
 392             to_utf8_substr(prog);
 393         check = prog->check_utf8;
 394     } else {
 395         if (!prog->check_substr && prog->check_utf8)
 396             to_byte_substr(prog);
 397         check = prog->check_substr;
 398     }
 399     if (check == &PL_sv_undef) {
 400         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 401                 "Non-utf8 string cannot match utf8 check string\n"));
 402         goto fail;
 403     }
 404     if (prog->reganch & ROPT_ANCH) {    /* Match at beg-of-str or after \n */
 405         ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
 406                      || ( (prog->reganch & ROPT_ANCH_BOL)
 407                           && !multiline ) );    /* Check after \n? */
 408
 409         if (!ml_anch) {
 410           if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
 411                                   | ROPT_IMPLICIT)) /* not a real BOL */
 412                /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
 413                && sv && !SvROK(sv)
 414                && (strpos != strbeg)) {
 415               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 416               goto fail;
 417           }
 418           if (prog->check_offset_min == prog->check_offset_max &&
 419               !(prog->reganch & ROPT_CANY_SEEN)) {
 420             /* Substring at constant offset from beg-of-str... */
 421             I32 slen;
 422
 423             s = HOP3c(strpos, prog->check_offset_min, strend);
 424
 425             if (SvTAIL(check)) {
 426                 slen = SvCUR(check);    /* >= 1 */
 427
 428                 if ( strend - s > slen || strend - s < slen - 1
 429                      || (strend - s == slen && strend[-1] != '\n')) {
 430                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 431                     goto fail_finish;
 432                 }
 433                 /* Now should match s[0..slen-2] */
 434                 slen--;
 435                 if (slen && (*SvPVX_const(check) != *s
 436                              || (slen > 1
 437                                  && memNE(SvPVX_const(check), s, slen)))) {
 438                   report_neq:
 439                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 440                     goto fail_finish;
 441                 }
 442             }
 443             else if (*SvPVX_const(check) != *s
 444                      || ((slen = SvCUR(check)) > 1
 445                          && memNE(SvPVX_const(check), s, slen)))
 446                 goto report_neq;
 447             check_at = s;
 448             goto success_at_start;
 449           }
 450         }
 451         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 452         s = strpos;
 453         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 454         end_shift = prog->check_end_shift;
 455
 456         if (!ml_anch) {
 457             const I32 end = prog->check_offset_max + CHR_SVLEN(check)
 458                                          - (SvTAIL(check) != 0);
 459             const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 460
 461             if (end_shift < eshift)
 462                 end_shift = eshift;
 463         }
 464     }
 465     else {                              /* Can match at random position */
 466         ml_anch = 0;
 467         s = strpos;
 468         start_shift = prog->check_offset_min;  /* okay to underestimate on CC */
 469         end_shift = prog->check_end_shift;
 470
 471         /* end shift should be non negative here */
 472     }
 473
 474 #ifdef DEBUGGING        /* 7/99: reports of failure (with the older version) */
 475     if (end_shift < 0)
 476         Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
 477                    (IV)end_shift, prog->precomp);
 478 #endif
 479
 480   restart:
 481     /* Find a possible match in the region s..strend by looking for
 482        the "check" substring in the region corrected by start/end_shift. */
 483
 484     {
 485         I32 srch_start_shift = start_shift;
 486         I32 srch_end_shift = end_shift;
 487         if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
 488             srch_end_shift -= ((strbeg - s) - srch_start_shift);
 489             srch_start_shift = strbeg - s;
 490         }
 491     DEBUG_OPTIMISE_r({
 492         PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
 493             (IV)prog->check_offset_min,
 494             (IV)srch_start_shift,
 495             (IV)srch_end_shift,
 496             (IV)prog->check_end_shift);
 497     });
 498
 499     if (flags & REXEC_SCREAM) {
 500         I32 p = -1;                     /* Internal iterator of scream. */
 501         I32 * const pp = data ? data->scream_pos : &p;
 502
 503         if (PL_screamfirst[BmRARE(check)] >= 0
 504             || ( BmRARE(check) == '\n'
 505                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
 506                  && SvTAIL(check) ))
 507             s = screaminstr(sv, check,
 508                             srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
 509         else
 510             goto fail_finish;
 511         /* we may be pointing at the wrong string */
 512         if (s && RX_MATCH_COPIED(prog))
 513             s = strbeg + (s - SvPVX_const(sv));
 514         if (data)
 515             *data->scream_olds = s;
 516     }
 517     else {
 518         U8* start_point;
 519         U8* end_point;
 520         if (prog->reganch & ROPT_CANY_SEEN) {
 521             start_point= (U8*)(s + srch_start_shift);
 522             end_point= (U8*)(strend - srch_end_shift);
 523         } else {
 524             start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
 525             end_point= HOP3(strend, -srch_end_shift, strbeg);
 526         }
 527         DEBUG_OPTIMISE_r({
 528             PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
 529                 (int)(end_point - start_point),
 530                 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
 531                 start_point);
 532         });
 533
 534         s = fbm_instr( start_point, end_point,
 535                       check, multiline ? FBMrf_MULTILINE : 0);
 536     }
 537     }
 538     /* Update the count-of-usability, remove useless subpatterns,
 539         unshift s.  */
 540
 541     DEBUG_EXECUTE_r({
 542         RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 543             SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
 544         PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
 545                           (s ? "Found" : "Did not find"),
 546             (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)
 547                 ? "anchored" : "floating"),
 548             quoted,
 549             RE_SV_TAIL(check),
 550             (s ? " at offset " : "...\n") );
 551     });
 552
 553     if (!s)
 554         goto fail_finish;
 555     /* Finish the diagnostic message */
 556     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 557
 558     /* XXX dmq: first branch is for positive lookbehind...
 559        Our check string is offset from the beginning of the pattern.
 560        So we need to do any stclass tests offset forward from that
 561        point. I think. :-(
 562      */
 563
 564
 565
 566     check_at=s;
 567
 568
 569     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 570        Start with the other substr.
 571        XXXX no SCREAM optimization yet - and a very coarse implementation
 572        XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
 573                 *always* match.  Probably should be marked during compile...
 574        Probably it is right to do no SCREAM here...
 575      */
 576
 577     if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
 578                 : (prog->float_substr && prog->anchored_substr))
 579     {
 580         /* Take into account the "other" substring. */
 581         /* XXXX May be hopelessly wrong for UTF... */
 582         if (!other_last)
 583             other_last = strpos;
 584         if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
 585           do_other_anchored:
 586             {
 587                 char * const last = HOP3c(s, -start_shift, strbeg);
 588                 char *last1, *last2;
 589                 char * const saved_s = s;
 590                 SV* must;
 591
 592                 t = s - prog->check_offset_max;
 593                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 594                     && (!do_utf8
 595                         || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
 596                             && t > strpos)))
 597                     NOOP;
 598                 else
 599                     t = strpos;
 600                 t = HOP3c(t, prog->anchored_offset, strend);
 601                 if (t < other_last)     /* These positions already checked */
 602                     t = other_last;
 603                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 604                 if (last < last1)
 605                     last1 = last;
 606                 /* XXXX It is not documented what units *_offsets are in.
 607                    We assume bytes, but this is clearly wrong.
 608                    Meaning this code needs to be carefully reviewed for errors.
 609                    dmq.
 610                   */
 611
 612                 /* On end-of-str: see comment below. */
 613                 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
 614                 if (must == &PL_sv_undef) {
 615                     s = (char*)NULL;
 616                     DEBUG_r(must = prog->anchored_utf8);        /* for debug */
 617                 }
 618                 else
 619                     s = fbm_instr(
 620                         (unsigned char*)t,
 621                         HOP3(HOP3(last1, prog->anchored_offset, strend)
 622                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
 623                         must,
 624                         multiline ? FBMrf_MULTILINE : 0
 625                     );
 626                 DEBUG_EXECUTE_r({
 627                     RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 628                         SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 629                     PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
 630                         (s ? "Found" : "Contradicts"),
 631                         quoted, RE_SV_TAIL(must));
 632                 });
 633
 634
 635                 if (!s) {
 636                     if (last1 >= last2) {
 637                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 638                                                 ", giving up...\n"));
 639                         goto fail_finish;
 640                     }
 641                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 642                         ", trying floating at offset %ld...\n",
 643                         (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
 644                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 645                     s = HOP3c(last, 1, strend);
 646                     goto restart;
 647                 }
 648                 else {
 649                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 650                           (long)(s - i_strpos)));
 651                     t = HOP3c(s, -prog->anchored_offset, strbeg);
 652                     other_last = HOP3c(s, 1, strend);
 653                     s = saved_s;
 654                     if (t == strpos)
 655                         goto try_at_start;
 656                     goto try_at_offset;
 657                 }
 658             }
 659         }
 660         else {          /* Take into account the floating substring. */
 661             char *last, *last1;
 662             char * const saved_s = s;
 663             SV* must;
 664
 665             t = HOP3c(s, -start_shift, strbeg);
 666             last1 = last =
 667                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 668             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 669                 last = HOP3c(t, prog->float_max_offset, strend);
 670             s = HOP3c(t, prog->float_min_offset, strend);
 671             if (s < other_last)
 672                 s = other_last;
 673  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 674             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
 675             /* fbm_instr() takes into account exact value of end-of-str
 676                if the check is SvTAIL(ed).  Since false positives are OK,
 677                and end-of-str is not later than strend we are OK. */
 678             if (must == &PL_sv_undef) {
 679                 s = (char*)NULL;
 680                 DEBUG_r(must = prog->float_utf8);       /* for debug message */
 681             }
 682             else
 683                 s = fbm_instr((unsigned char*)s,
 684                               (unsigned char*)last + SvCUR(must)
 685                                   - (SvTAIL(must)!=0),
 686                               must, multiline ? FBMrf_MULTILINE : 0);
 687             DEBUG_EXECUTE_r({
 688                 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 689                     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 690                 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
 691                     (s ? "Found" : "Contradicts"),
 692                     quoted, RE_SV_TAIL(must));
 693             });
 694             if (!s) {
 695                 if (last1 == last) {
 696                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 697                                             ", giving up...\n"));
 698                     goto fail_finish;
 699                 }
 700                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 701                     ", trying anchored starting at offset %ld...\n",
 702                     (long)(saved_s + 1 - i_strpos)));
 703                 other_last = last;
 704                 s = HOP3c(t, 1, strend);
 705                 goto restart;
 706             }
 707             else {
 708                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 709                       (long)(s - i_strpos)));
 710                 other_last = s; /* Fix this later. --Hugo */
 711                 s = saved_s;
 712                 if (t == strpos)
 713                     goto try_at_start;
 714                 goto try_at_offset;
 715             }
 716         }
 717     }
 718
 719
 720     t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
 721
 722     DEBUG_OPTIMISE_r(
 723         PerlIO_printf(Perl_debug_log,
 724             "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
 725             (IV)prog->check_offset_min,
 726             (IV)prog->check_offset_max,
 727             (IV)(s-strpos),
 728             (IV)(t-strpos),
 729             (IV)(t-s),
 730             (IV)(strend-strpos)
 731         )
 732     );
 733
 734     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 735         && (!do_utf8
 736             || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
 737                  && t > strpos)))
 738     {
 739         /* Fixed substring is found far enough so that the match
 740            cannot start at strpos. */
 741       try_at_offset:
 742         if (ml_anch && t[-1] != '\n') {
 743             /* Eventually fbm_*() should handle this, but often
 744                anchored_offset is not 0, so this check will not be wasted. */
 745             /* XXXX In the code below we prefer to look for "^" even in
 746                presence of anchored substrings.  And we search even
 747                beyond the found float position.  These pessimizations
 748                are historical artefacts only.  */
 749           find_anchor:
 750             while (t < strend - prog->minlen) {
 751                 if (*t == '\n') {
 752                     if (t < check_at - prog->check_offset_min) {
 753                         if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
 754                             /* Since we moved from the found position,
 755                                we definitely contradict the found anchored
 756                                substr.  Due to the above check we do not
 757                                contradict "check" substr.
 758                                Thus we can arrive here only if check substr
 759                                is float.  Redo checking for "other"=="fixed".
 760                              */
 761                             strpos = t + 1;
 762                             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
 763                                 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
 764                             goto do_other_anchored;
 765                         }
 766                         /* We don't contradict the found floating substring. */
 767                         /* XXXX Why not check for STCLASS? */
 768                         s = t + 1;
 769                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
 770                             PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
 771                         goto set_useful;
 772                     }
 773                     /* Position contradicts check-string */
 774                     /* XXXX probably better to look for check-string
 775                        than for "\n", so one should lower the limit for t? */
 776                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
 777                         PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
 778                     other_last = strpos = s = t + 1;
 779                     goto restart;
 780                 }
 781                 t++;
 782             }
 783             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
 784                         PL_colors[0], PL_colors[1]));
 785             goto fail_finish;
 786         }
 787         else {
 788             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
 789                         PL_colors[0], PL_colors[1]));
 790         }
 791         s = t;
 792       set_useful:
 793         ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr);    /* hooray/5 */
 794     }
 795     else {
 796         /* The found string does not prohibit matching at strpos,
 797            - no optimization of calling REx engine can be performed,
 798            unless it was an MBOL and we are not after MBOL,
 799            or a future STCLASS check will fail this. */
 800       try_at_start:
 801         /* Even in this situation we may use MBOL flag if strpos is offset
 802            wrt the start of the string. */
 803         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
 804             && (strpos != strbeg) && strpos[-1] != '\n'
 805             /* May be due to an implicit anchor of m{.*foo}  */
 806             && !(prog->reganch & ROPT_IMPLICIT))
 807         {
 808             t = strpos;
 809             goto find_anchor;
 810         }
 811         DEBUG_EXECUTE_r( if (ml_anch)
 812             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
 813                         (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
 814         );
 815       success_at_start:
 816         if (!(prog->reganch & ROPT_NAUGHTY)     /* XXXX If strpos moved? */
 817             && (do_utf8 ? (
 818                 prog->check_utf8                /* Could be deleted already */
 819                 && --BmUSEFUL(prog->check_utf8) < 0
 820                 && (prog->check_utf8 == prog->float_utf8)
 821             ) : (
 822                 prog->check_substr              /* Could be deleted already */
 823                 && --BmUSEFUL(prog->check_substr) < 0
 824                 && (prog->check_substr == prog->float_substr)
 825             )))
 826         {
 827             /* If flags & SOMETHING - do not do it many times on the same match */
 828             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
 829             SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
 830             if (do_utf8 ? prog->check_substr : prog->check_utf8)
 831                 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
 832             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
 833             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
 834             check = NULL;                       /* abort */
 835             s = strpos;
 836             /* XXXX This is a remnant of the old implementation.  It
 837                     looks wasteful, since now INTUIT can use many
 838                     other heuristics. */
 839             prog->reganch &= ~RE_USE_INTUIT;
 840         }
 841         else
 842             s = strpos;
 843     }
 844
 845     /* Last resort... */
 846     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
 847     /* trie stclasses are too expensive to use here, we are better off to
 848        leave it to regmatch itself */
 849     if (prog->regstclass && PL_regkind[OP(prog->regstclass)]!=TRIE) {
 850         /* minlen == 0 is possible if regstclass is \b or \B,
 851            and the fixed substr is ''$.
 852            Since minlen is already taken into account, s+1 is before strend;
 853            accidentally, minlen >= 1 guaranties no false positives at s + 1
 854            even for \b or \B.  But (minlen? 1 : 0) below assumes that
 855            regstclass does not come from lookahead...  */
 856         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
 857            This leaves EXACTF only, which is dealt with in find_byclass().  */
 858         const U8* const str = (U8*)STRING(prog->regstclass);
 859         const int cl_l = (PL_regkind[OP(prog->regstclass)] == EXACT
 860                     ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
 861                     : 1);
 862         char * endpos;
 863         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
 864             endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
 865         else if (prog->float_substr || prog->float_utf8)
 866             endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
 867         else
 868             endpos= strend;
 869
 870         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %d s: %d endpos: %d\n",
 871                                       (IV)start_shift, check_at - strbeg, s - strbeg, endpos - strbeg));
 872
 873         t = s;
 874         s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
 875         if (!s) {
 876 #ifdef DEBUGGING
 877             const char *what = NULL;
 878 #endif
 879             if (endpos == strend) {
 880                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 881                                 "Could not match STCLASS...\n") );
 882                 goto fail;
 883             }
 884             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 885                                    "This position contradicts STCLASS...\n") );
 886             if ((prog->reganch & ROPT_ANCH) && !ml_anch)
 887                 goto fail;
 888             /* Contradict one of substrings */
 889             if (prog->anchored_substr || prog->anchored_utf8) {
 890                 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
 891                     DEBUG_EXECUTE_r( what = "anchored" );
 892                   hop_and_restart:
 893                     s = HOP3c(t, 1, strend);
 894                     if (s + start_shift + end_shift > strend) {
 895                         /* XXXX Should be taken into account earlier? */
 896                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 897                                                "Could not match STCLASS...\n") );
 898                         goto fail;
 899                     }
 900                     if (!check)
 901                         goto giveup;
 902                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 903                                 "Looking for %s substr starting at offset %ld...\n",
 904                                  what, (long)(s + start_shift - i_strpos)) );
 905                     goto restart;
 906                 }
 907                 /* Have both, check_string is floating */
 908                 if (t + start_shift >= check_at) /* Contradicts floating=check */
 909                     goto retry_floating_check;
 910                 /* Recheck anchored substring, but not floating... */
 911                 s = check_at;
 912                 if (!check)
 913                     goto giveup;
 914                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 915                           "Looking for anchored substr starting at offset %ld...\n",
 916                           (long)(other_last - i_strpos)) );
 917                 goto do_other_anchored;
 918             }
 919             /* Another way we could have checked stclass at the
 920                current position only: */
 921             if (ml_anch) {
 922                 s = t = t + 1;
 923                 if (!check)
 924                     goto giveup;
 925                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
 926                           "Looking for /%s^%s/m starting at offset %ld...\n",
 927                           PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
 928                 goto try_at_offset;
 929             }
 930             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))     /* Could have been deleted */
 931                 goto fail;
 932             /* Check is floating subtring. */
 933           retry_floating_check:
 934             t = check_at - start_shift;
 935             DEBUG_EXECUTE_r( what = "floating" );
 936             goto hop_and_restart;
 937         }
 938         if (t != s) {
 939             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 940                         "By STCLASS: moving %ld --> %ld\n",
 941                                   (long)(t - i_strpos), (long)(s - i_strpos))
 942                    );
 943         }
 944         else {
 945             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 946                                   "Does not contradict STCLASS...\n");
 947                    );
 948         }
 949     }
 950   giveup:
 951     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
 952                           PL_colors[4], (check ? "Guessed" : "Giving up"),
 953                           PL_colors[5], (long)(s - i_strpos)) );
 954     return s;
 955
 956   fail_finish:                          /* Substring not found */
 957     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
 958         BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
 959   fail:
 960     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
 961                           PL_colors[4], PL_colors[5]));
 962     return NULL;
 963 }
 964
 965
 966
 967 #define REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len, uvc, charid,  \
 968 foldlen, foldbuf, uniflags) STMT_START {                                    \
 969     switch (trie_type) {                                                    \
 970     case trie_utf8_fold:                                                    \
 971         if ( foldlen>0 ) {                                                  \
 972             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );     \
 973             foldlen -= len;                                                 \
 974             uscan += len;                                                   \
 975             len=0;                                                          \
 976         } else {                                                            \
 977             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );   \
 978             uvc = to_uni_fold( uvc, foldbuf, &foldlen );                    \
 979             foldlen -= UNISKIP( uvc );                                      \
 980             uscan = foldbuf + UNISKIP( uvc );                               \
 981         }                                                                   \
 982         break;                                                              \
 983     case trie_utf8:                                                         \
 984         uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );       \
 985         break;                                                              \
 986     case trie_plain:                                                        \
 987         uvc = (UV)*uc;                                                      \
 988         len = 1;                                                            \
 989     }                                                                       \
 990                                                                             \
 991     if (uvc < 256) {                                                        \
 992         charid = trie->charmap[ uvc ];                                      \
 993     }                                                                       \
 994     else {                                                                  \
 995         charid = 0;                                                         \
 996         if (trie->widecharmap) {                                            \
 997             SV** const svpp = hv_fetch(trie->widecharmap,                   \
 998                         (char*)&uvc, sizeof(UV), 0);                        \
 999             if (svpp)                                                       \
1000                 charid = (U16)SvIV(*svpp);                                  \
1001         }                                                                   \
1002     }                                                                       \
1003 } STMT_END
1004
1005 #define REXEC_FBC_EXACTISH_CHECK(CoNd)                  \
1006     if ( (CoNd)                                        \
1007          && (ln == len ||                              \
1008              ibcmp_utf8(s, NULL, 0,  do_utf8,          \
1009                         m, NULL, ln, (bool)UTF))       \
1010          && (!reginfo || regtry(reginfo, s)) )         \
1011         goto got_it;                                   \
1012     else {                                             \
1013          U8 foldbuf[UTF8_MAXBYTES_CASE+1];             \
1014          uvchr_to_utf8(tmpbuf, c);                     \
1015          f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);  \
1016          if ( f != c                                   \
1017               && (f == c1 || f == c2)                  \
1018               && (ln == foldlen ||                     \
1019                   !ibcmp_utf8((char *) foldbuf,        \
1020                               NULL, foldlen, do_utf8,  \
1021                               m,                       \
1022                               NULL, ln, (bool)UTF))    \
1023               && (!reginfo || regtry(reginfo, s)) )    \
1024               goto got_it;                             \
1025     }                                                  \
1026     s += len
1027
1028 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1029 STMT_START {                                              \
1030     while (s <= e) {                                      \
1031         if ( (CoNd)                                       \
1032              && (ln == 1 || !(OP(c) == EXACTF             \
1033                               ? ibcmp(s, m, ln)           \
1034                               : ibcmp_locale(s, m, ln)))  \
1035              && (!reginfo || regtry(reginfo, s)) )        \
1036             goto got_it;                                  \
1037         s++;                                              \
1038     }                                                     \
1039 } STMT_END
1040
1041 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1042 STMT_START {                                          \
1043     while (s + (uskip = UTF8SKIP(s)) <= strend) {     \
1044         CoDe                                          \
1045         s += uskip;                                   \
1046     }                                                 \
1047 } STMT_END
1048
1049 #define REXEC_FBC_SCAN(CoDe)                          \
1050 STMT_START {                                          \
1051     while (s < strend) {                              \
1052         CoDe                                          \
1053         s++;                                          \
1054     }                                                 \
1055 } STMT_END
1056
1057 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1058 REXEC_FBC_UTF8_SCAN(                                  \
1059     if (CoNd) {                                       \
1060         if (tmp && (!reginfo || regtry(reginfo, s)))  \
1061             goto got_it;                              \
1062         else                                          \
1063             tmp = doevery;                            \
1064     }                                                 \
1065     else                                              \
1066         tmp = 1;                                      \
1067 )
1068
1069 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1070 REXEC_FBC_SCAN(                                       \
1071     if (CoNd) {                                       \
1072         if (tmp && (!reginfo || regtry(reginfo, s)))  \
1073             goto got_it;                              \
1074         else                                          \
1075             tmp = doevery;                            \
1076     }                                                 \
1077     else                                              \
1078         tmp = 1;                                      \
1079 )
1080
1081 #define REXEC_FBC_TRYIT               \
1082 if ((!reginfo || regtry(reginfo, s))) \
1083     goto got_it
1084
1085 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd)      \
1086     if (do_utf8) {                                             \
1087         UtFpReLoAd;                                            \
1088         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1089     }                                                          \
1090     else {                                                     \
1091         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1092     }                                                          \
1093     break
1094
1095 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd)                   \
1096     PL_reg_flags |= RF_tainted;                                \
1097     if (do_utf8) {                                             \
1098         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1099     }                                                          \
1100     else {                                                     \
1101         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1102     }                                                          \
1103     break
1104
1105 #define DUMP_EXEC_POS(li,s,doutf8) \
1106     dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1107
1108 /* We know what class REx starts with.  Try to find this position... */
1109 /* if reginfo is NULL, its a dryrun */
1110 /* annoyingly all the vars in this routine have different names from their counterparts
1111    in regmatch. /grrr */
1112
1113 STATIC char *
1114 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1115     const char *strend, const regmatch_info *reginfo)
1116 {
1117         dVAR;
1118         const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
1119         char *m;
1120         STRLEN ln;
1121         STRLEN lnc;
1122         register STRLEN uskip;
1123         unsigned int c1;
1124         unsigned int c2;
1125         char *e;
1126         register I32 tmp = 1;   /* Scratch variable? */
1127         register const bool do_utf8 = PL_reg_match_utf8;
1128
1129         /* We know what class it must start with. */
1130         switch (OP(c)) {
1131         case ANYOF:
1132             if (do_utf8) {
1133                  REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1134                           !UTF8_IS_INVARIANT((U8)s[0]) ?
1135                           reginclass(prog, c, (U8*)s, 0, do_utf8) :
1136                           REGINCLASS(prog, c, (U8*)s));
1137             }
1138             else {
1139                  while (s < strend) {
1140                       STRLEN skip = 1;
1141
1142                       if (REGINCLASS(prog, c, (U8*)s) ||
1143                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1144                            /* The assignment of 2 is intentional:
1145                             * for the folded sharp s, the skip is 2. */
1146                            (skip = SHARP_S_SKIP))) {
1147                            if (tmp && (!reginfo || regtry(reginfo, s)))
1148                                 goto got_it;
1149                            else
1150                                 tmp = doevery;
1151                       }
1152                       else
1153                            tmp = 1;
1154                       s += skip;
1155                  }
1156             }
1157             break;
1158         case CANY:
1159             REXEC_FBC_SCAN(
1160                 if (tmp && (!reginfo || regtry(reginfo, s)))
1161                     goto got_it;
1162                 else
1163                     tmp = doevery;
1164             );
1165             break;
1166         case EXACTF:
1167             m   = STRING(c);
1168             ln  = STR_LEN(c);   /* length to match in octets/bytes */
1169             lnc = (I32) ln;     /* length to match in characters */
1170             if (UTF) {
1171                 STRLEN ulen1, ulen2;
1172                 U8 *sm = (U8 *) m;
1173                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1174                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1175                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1176
1177                 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1178                 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1179
1180                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1181                                     0, uniflags);
1182                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1183                                     0, uniflags);
1184                 lnc = 0;
1185                 while (sm < ((U8 *) m + ln)) {
1186                     lnc++;
1187                     sm += UTF8SKIP(sm);
1188                 }
1189             }
1190             else {
1191                 c1 = *(U8*)m;
1192                 c2 = PL_fold[c1];
1193             }
1194             goto do_exactf;
1195         case EXACTFL:
1196             m   = STRING(c);
1197             ln  = STR_LEN(c);
1198             lnc = (I32) ln;
1199             c1 = *(U8*)m;
1200             c2 = PL_fold_locale[c1];
1201           do_exactf:
1202             e = HOP3c(strend, -((I32)lnc), s);
1203
1204             if (!reginfo && e < s)
1205                 e = s;                  /* Due to minlen logic of intuit() */
1206
1207             /* The idea in the EXACTF* cases is to first find the
1208              * first character of the EXACTF* node and then, if
1209              * necessary, case-insensitively compare the full
1210              * text of the node.  The c1 and c2 are the first
1211              * characters (though in Unicode it gets a bit
1212              * more complicated because there are more cases
1213              * than just upper and lower: one needs to use
1214              * the so-called folding case for case-insensitive
1215              * matching (called "loose matching" in Unicode).
1216              * ibcmp_utf8() will do just that. */
1217
1218             if (do_utf8) {
1219                 UV c, f;
1220                 U8 tmpbuf [UTF8_MAXBYTES+1];
1221                 STRLEN len, foldlen;
1222                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1223                 if (c1 == c2) {
1224                     /* Upper and lower of 1st char are equal -
1225                      * probably not a "letter". */
1226                     while (s <= e) {
1227                         c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1228                                            uniflags);
1229                         REXEC_FBC_EXACTISH_CHECK(c == c1);
1230                     }
1231                 }
1232                 else {
1233                     while (s <= e) {
1234                       c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1235                                            uniflags);
1236
1237                         /* Handle some of the three Greek sigmas cases.
1238                          * Note that not all the possible combinations
1239                          * are handled here: some of them are handled
1240                          * by the standard folding rules, and some of
1241                          * them (the character class or ANYOF cases)
1242                          * are handled during compiletime in
1243                          * regexec.c:S_regclass(). */
1244                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1245                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1246                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1247
1248                         REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1249                     }
1250                 }
1251             }
1252             else {
1253                 if (c1 == c2)
1254                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1255                 else
1256                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1257             }
1258             break;
1259         case BOUNDL:
1260             PL_reg_flags |= RF_tainted;
1261             /* FALL THROUGH */
1262         case BOUND:
1263             if (do_utf8) {
1264                 if (s == PL_bostr)
1265                     tmp = '\n';
1266                 else {
1267                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1268                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1269                 }
1270                 tmp = ((OP(c) == BOUND ?
1271                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1272                 LOAD_UTF8_CHARCLASS_ALNUM();
1273                 REXEC_FBC_UTF8_SCAN(
1274                     if (tmp == !(OP(c) == BOUND ?
1275                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1276                                  isALNUM_LC_utf8((U8*)s)))
1277                     {
1278                         tmp = !tmp;
1279                         REXEC_FBC_TRYIT;
1280                 }
1281                 );
1282             }
1283             else {
1284                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1285                 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1286                 REXEC_FBC_SCAN(
1287                     if (tmp ==
1288                         !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1289                         tmp = !tmp;
1290                         REXEC_FBC_TRYIT;
1291                 }
1292                 );
1293             }
1294             if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, s)))
1295                 goto got_it;
1296             break;
1297         case NBOUNDL:
1298             PL_reg_flags |= RF_tainted;
1299             /* FALL THROUGH */
1300         case NBOUND:
1301             if (do_utf8) {
1302                 if (s == PL_bostr)
1303                     tmp = '\n';
1304                 else {
1305                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1306                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1307                 }
1308                 tmp = ((OP(c) == NBOUND ?
1309                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1310                 LOAD_UTF8_CHARCLASS_ALNUM();
1311                 REXEC_FBC_UTF8_SCAN(
1312                     if (tmp == !(OP(c) == NBOUND ?
1313                                  (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1314                                  isALNUM_LC_utf8((U8*)s)))
1315                         tmp = !tmp;
1316                     else REXEC_FBC_TRYIT;
1317                 );
1318             }
1319             else {
1320                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1321                 tmp = ((OP(c) == NBOUND ?
1322                         isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1323                 REXEC_FBC_SCAN(
1324                     if (tmp ==
1325                         !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1326                         tmp = !tmp;
1327                     else REXEC_FBC_TRYIT;
1328                 );
1329             }
1330             if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, s)))
1331                 goto got_it;
1332             break;
1333         case ALNUM:
1334             REXEC_FBC_CSCAN_PRELOAD(
1335                 LOAD_UTF8_CHARCLASS_ALNUM(),
1336                 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1337                 isALNUM(*s)
1338             );
1339         case ALNUML:
1340             REXEC_FBC_CSCAN_TAINT(
1341                 isALNUM_LC_utf8((U8*)s),
1342                 isALNUM_LC(*s)
1343             );
1344         case NALNUM:
1345             REXEC_FBC_CSCAN_PRELOAD(
1346                 LOAD_UTF8_CHARCLASS_ALNUM(),
1347                 !swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1348                 !isALNUM(*s)
1349             );
1350         case NALNUML:
1351             REXEC_FBC_CSCAN_TAINT(
1352                 !isALNUM_LC_utf8((U8*)s),
1353                 !isALNUM_LC(*s)
1354             );
1355         case SPACE:
1356             REXEC_FBC_CSCAN_PRELOAD(
1357                 LOAD_UTF8_CHARCLASS_SPACE(),
1358                 *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8),
1359                 isSPACE(*s)
1360             );
1361         case SPACEL:
1362             REXEC_FBC_CSCAN_TAINT(
1363                 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1364                 isSPACE_LC(*s)
1365             );
1366         case NSPACE:
1367             REXEC_FBC_CSCAN_PRELOAD(
1368                 LOAD_UTF8_CHARCLASS_SPACE(),
1369                 !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)),
1370                 !isSPACE(*s)
1371             );
1372         case NSPACEL:
1373             REXEC_FBC_CSCAN_TAINT(
1374                 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1375                 !isSPACE_LC(*s)
1376             );
1377         case DIGIT:
1378             REXEC_FBC_CSCAN_PRELOAD(
1379                 LOAD_UTF8_CHARCLASS_DIGIT(),
1380                 swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1381                 isDIGIT(*s)
1382             );
1383         case DIGITL:
1384             REXEC_FBC_CSCAN_TAINT(
1385                 isDIGIT_LC_utf8((U8*)s),
1386                 isDIGIT_LC(*s)
1387             );
1388         case NDIGIT:
1389             REXEC_FBC_CSCAN_PRELOAD(
1390                 LOAD_UTF8_CHARCLASS_DIGIT(),
1391                 !swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1392                 !isDIGIT(*s)
1393             );
1394         case NDIGITL:
1395             REXEC_FBC_CSCAN_TAINT(
1396                 !isDIGIT_LC_utf8((U8*)s),
1397                 !isDIGIT_LC(*s)
1398             );
1399         case AHOCORASICKC:
1400         case AHOCORASICK:
1401             {
1402                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
1403                     trie_type = do_utf8 ?
1404                           (c->flags == EXACT ? trie_utf8 : trie_utf8_fold)
1405                         : trie_plain;
1406                 /* what trie are we using right now */
1407                 reg_ac_data *aho
1408                     = (reg_ac_data*)prog->data->data[ ARG( c ) ];
1409                 reg_trie_data *trie=aho->trie;
1410
1411                 const char *last_start = strend - trie->minlen;
1412 #ifdef DEBUGGING
1413                 const char *real_start = s;
1414 #endif
1415                 STRLEN maxlen = trie->maxlen;
1416                 SV *sv_points;
1417                 U8 **points; /* map of where we were in the input string
1418                                 when reading a given char. For ASCII this
1419                                 is unnecessary overhead as the relationship
1420                                 is always 1:1, but for unicode, especially
1421                                 case folded unicode this is not true. */
1422                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1423                 U8 *bitmap=NULL;
1424
1425
1426                 GET_RE_DEBUG_FLAGS_DECL;
1427
1428                 /* We can't just allocate points here. We need to wrap it in
1429                  * an SV so it gets freed properly if there is a croak while
1430                  * running the match */
1431                 ENTER;
1432                 SAVETMPS;
1433                 sv_points=newSV(maxlen * sizeof(U8 *));
1434                 SvCUR_set(sv_points,
1435                     maxlen * sizeof(U8 *));
1436                 SvPOK_on(sv_points);
1437                 sv_2mortal(sv_points);
1438                 points=(U8**)SvPV_nolen(sv_points );
1439                 if ( trie_type != trie_utf8_fold
1440                      && (trie->bitmap || OP(c)==AHOCORASICKC) )
1441                 {
1442                     if (trie->bitmap)
1443                         bitmap=(U8*)trie->bitmap;
1444                     else
1445                         bitmap=(U8*)ANYOF_BITMAP(c);
1446                 }
1447                 /* this is the Aho-Corasick algorithm modified a touch
1448                    to include special handling for long "unknown char"
1449                    sequences. The basic idea being that we use AC as long
1450                    as we are dealing with a possible matching char, when
1451                    we encounter an unknown char (and we have not encountered
1452                    an accepting state) we scan forward until we find a legal
1453                    starting char.
1454                    AC matching is basically that of trie matching, except
1455                    that when we encounter a failing transition, we fall back
1456                    to the current states "fail state", and try the current char
1457                    again, a process we repeat until we reach the root state,
1458                    state 1, or a legal transition. If we fail on the root state
1459                    then we can either terminate if we have reached an accepting
1460                    state previously, or restart the entire process from the beginning
1461                    if we have not.
1462
1463                  */
1464                 while (s <= last_start) {
1465                     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1466                     U8 *uc = (U8*)s;
1467                     U16 charid = 0;
1468                     U32 base = 1;
1469                     U32 state = 1;
1470                     UV uvc = 0;
1471                     STRLEN len = 0;
1472                     STRLEN foldlen = 0;
1473                     U8 *uscan = (U8*)NULL;
1474                     U8 *leftmost = NULL;
1475 #ifdef DEBUGGING
1476                     U32 accepted_word= 0;
1477 #endif
1478                     U32 pointpos = 0;
1479
1480                     while ( state && uc <= (U8*)strend ) {
1481                         int failed=0;
1482                         U32 word = aho->states[ state ].wordnum;
1483
1484                         if( state==1 ) {
1485                             if ( bitmap ) {
1486                                 DEBUG_TRIE_EXECUTE_r(
1487                                     if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1488                                         dump_exec_pos( (char *)uc, c, strend, real_start,
1489                                             (char *)uc, do_utf8 );
1490                                         PerlIO_printf( Perl_debug_log,
1491                                             " Scanning for legal start char...\n");
1492                                     }
1493                                 );
1494                                 while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1495                                     uc++;
1496                                 }
1497                                 s= (char *)uc;
1498                             }
1499                             if (uc >(U8*)last_start) break;
1500                         }
1501
1502                         if ( word ) {
1503                             U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1504                             if (!leftmost || lpos < leftmost) {
1505                                 DEBUG_r(accepted_word=word);
1506                                 leftmost= lpos;
1507                             }
1508                             if (base==0) break;
1509
1510                         }
1511                         points[pointpos++ % maxlen]= uc;
1512                         REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
1513                             uvc, charid, foldlen, foldbuf, uniflags);
1514                         DEBUG_TRIE_EXECUTE_r({
1515                             dump_exec_pos( (char *)uc, c, strend, real_start,
1516                                 s,   do_utf8 );
1517                             PerlIO_printf(Perl_debug_log,
1518                                 " Charid:%3u CP:%4"UVxf" ",
1519                                  charid, uvc);
1520                         });
1521
1522                         do {
1523 #ifdef DEBUGGING
1524                             word = aho->states[ state ].wordnum;
1525 #endif
1526                             base = aho->states[ state ].trans.base;
1527
1528                             DEBUG_TRIE_EXECUTE_r({
1529                                 if (failed)
1530                                     dump_exec_pos( (char *)uc, c, strend, real_start,
1531                                         s,   do_utf8 );
1532                                 PerlIO_printf( Perl_debug_log,
1533                                     "%sState: %4"UVxf", word=%"UVxf,
1534                                     failed ? " Fail transition to " : "",
1535                                     (UV)state, (UV)word);
1536                             });
1537                             if ( base ) {
1538                                 U32 tmp;
1539                                 if (charid &&
1540                                      (base + charid > trie->uniquecharcount )
1541                                      && (base + charid - 1 - trie->uniquecharcount
1542                                             < trie->lasttrans)
1543                                      && trie->trans[base + charid - 1 -
1544                                             trie->uniquecharcount].check == state
1545                                      && (tmp=trie->trans[base + charid - 1 -
1546                                         trie->uniquecharcount ].next))
1547                                 {
1548                                     DEBUG_TRIE_EXECUTE_r(
1549                                         PerlIO_printf( Perl_debug_log," - legal\n"));
1550                                     state = tmp;
1551                                     break;
1552                                 }
1553                                 else {
1554                                     DEBUG_TRIE_EXECUTE_r(
1555                                         PerlIO_printf( Perl_debug_log," - fail\n"));
1556                                     failed = 1;
1557                                     state = aho->fail[state];
1558                                 }
1559                             }
1560                             else {
1561                                 /* we must be accepting here */
1562                                 DEBUG_TRIE_EXECUTE_r(
1563                                         PerlIO_printf( Perl_debug_log," - accepting\n"));
1564                                 failed = 1;
1565                                 break;
1566                             }
1567                         } while(state);
1568                         uc += len;
1569                         if (failed) {
1570                             if (leftmost)
1571                                 break;
1572                             if (!state) state = 1;
1573                         }
1574                     }
1575                     if ( aho->states[ state ].wordnum ) {
1576                         U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1577                         if (!leftmost || lpos < leftmost) {
1578                             DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1579                             leftmost = lpos;
1580                         }
1581                     }
1582                     if (leftmost) {
1583                         s = (char*)leftmost;
1584                         DEBUG_TRIE_EXECUTE_r({
1585                             PerlIO_printf(
1586                                 Perl_debug_log,"Matches word #%"UVxf" at position %d. Trying full pattern...\n",
1587                                 (UV)accepted_word, s - real_start
1588                             );
1589                         });
1590                         if (!reginfo || regtry(reginfo, s)) {
1591                             FREETMPS;
1592                             LEAVE;
1593                             goto got_it;
1594                         }
1595                         s = HOPc(s,1);
1596                         DEBUG_TRIE_EXECUTE_r({
1597                             PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1598                         });
1599                     } else {
1600                         DEBUG_TRIE_EXECUTE_r(
1601                             PerlIO_printf( Perl_debug_log,"No match.\n"));
1602                         break;
1603                     }
1604                 }
1605                 FREETMPS;
1606                 LEAVE;
1607             }
1608             break;
1609         default:
1610             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1611             break;
1612         }
1613         return 0;
1614       got_it:
1615         return s;
1616 }
1617
1618 /*
1619  - regexec_flags - match a regexp against a string
1620  */
1621 I32
1622 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1623               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1624 /* strend: pointer to null at end of string */
1625 /* strbeg: real beginning of string */
1626 /* minend: end of match must be >=minend after stringarg. */
1627 /* data: May be used for some additional optimizations. */
1628 /* nosave: For optimizations. */
1629 {
1630     dVAR;
1631     register char *s;
1632     register regnode *c;
1633     register char *startpos = stringarg;
1634     I32 minlen;         /* must match at least this many chars */
1635     I32 dontbother = 0; /* how many characters not to try at end */
1636     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1637     I32 scream_pos = -1;                /* Internal iterator of scream. */
1638     char *scream_olds = NULL;
1639     SV* const oreplsv = GvSV(PL_replgv);
1640     const bool do_utf8 = DO_UTF8(sv);
1641     I32 multiline;
1642
1643     regmatch_info reginfo;  /* create some info to pass to regtry etc */
1644
1645     GET_RE_DEBUG_FLAGS_DECL;
1646
1647     PERL_UNUSED_ARG(data);
1648
1649     /* Be paranoid... */
1650     if (prog == NULL || startpos == NULL) {
1651         Perl_croak(aTHX_ "NULL regexp parameter");
1652         return 0;
1653     }
1654
1655     multiline = prog->reganch & PMf_MULTILINE;
1656     reginfo.prog = prog;
1657
1658     RX_MATCH_UTF8_set(prog, do_utf8);
1659     DEBUG_EXECUTE_r(
1660         debug_start_match(prog, do_utf8, startpos, strend,
1661         "Matching");
1662     );
1663
1664     minlen = prog->minlen;
1665
1666     if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1667         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1668                               "String too short [regexec_flags]...\n"));
1669         goto phooey;
1670     }
1671
1672
1673     /* Check validity of program. */
1674     if (UCHARAT(prog->program) != REG_MAGIC) {
1675         Perl_croak(aTHX_ "corrupted regexp program");
1676     }
1677
1678     PL_reg_flags = 0;
1679     PL_reg_eval_set = 0;
1680     PL_reg_maxiter = 0;
1681
1682     if (prog->reganch & ROPT_UTF8)
1683         PL_reg_flags |= RF_utf8;
1684
1685     /* Mark beginning of line for ^ and lookbehind. */
1686     reginfo.bol = startpos; /* XXX not used ??? */
1687     PL_bostr  = strbeg;
1688     reginfo.sv = sv;
1689
1690     /* Mark end of line for $ (and such) */
1691     PL_regeol = strend;
1692
1693     /* see how far we have to get to not match where we matched before */
1694     reginfo.till = startpos+minend;
1695
1696     /* If there is a "must appear" string, look for it. */
1697     s = startpos;
1698
1699     if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to set reginfo->ganch */
1700         MAGIC *mg;
1701
1702         if (flags & REXEC_IGNOREPOS)    /* Means: check only at start */
1703             reginfo.ganch = startpos;
1704         else if (sv && SvTYPE(sv) >= SVt_PVMG
1705                   && SvMAGIC(sv)
1706                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1707                   && mg->mg_len >= 0) {
1708             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
1709             if (prog->reganch & ROPT_ANCH_GPOS) {
1710                 if (s > reginfo.ganch)
1711                     goto phooey;
1712                 s = reginfo.ganch;
1713             }
1714         }
1715         else                            /* pos() not defined */
1716             reginfo.ganch = strbeg;
1717     }
1718
1719     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1720         re_scream_pos_data d;
1721
1722         d.scream_olds = &scream_olds;
1723         d.scream_pos = &scream_pos;
1724         s = re_intuit_start(prog, sv, s, strend, flags, &d);
1725         if (!s) {
1726             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1727             goto phooey;        /* not present */
1728         }
1729     }
1730
1731
1732
1733     /* Simplest case:  anchored match need be tried only once. */
1734     /*  [unless only anchor is BOL and multiline is set] */
1735     if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1736         if (s == startpos && regtry(&reginfo, startpos))
1737             goto got_it;
1738         else if (multiline || (prog->reganch & ROPT_IMPLICIT)
1739                  || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1740         {
1741             char *end;
1742
1743             if (minlen)
1744                 dontbother = minlen - 1;
1745             end = HOP3c(strend, -dontbother, strbeg) - 1;
1746             /* for multiline we only have to try after newlines */
1747             if (prog->check_substr || prog->check_utf8) {
1748                 if (s == startpos)
1749                     goto after_try;
1750                 while (1) {
1751                     if (regtry(&reginfo, s))
1752                         goto got_it;
1753                   after_try:
1754                     if (s >= end)
1755                         goto phooey;
1756                     if (prog->reganch & RE_USE_INTUIT) {
1757                         s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1758                         if (!s)
1759                             goto phooey;
1760                     }
1761                     else
1762                         s++;
1763                 }
1764             } else {
1765                 if (s > startpos)
1766                     s--;
1767                 while (s < end) {
1768                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
1769                         if (regtry(&reginfo, s))
1770                             goto got_it;
1771                     }
1772                 }
1773             }
1774         }
1775         goto phooey;
1776     } else if (prog->reganch & ROPT_ANCH_GPOS) {
1777         if (regtry(&reginfo, reginfo.ganch))
1778             goto got_it;
1779         goto phooey;
1780     }
1781
1782     /* Messy cases:  unanchored match. */
1783     if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1784         /* we have /x+whatever/ */
1785         /* it must be a one character string (XXXX Except UTF?) */
1786         char ch;
1787 #ifdef DEBUGGING
1788         int did_match = 0;
1789 #endif
1790         if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1791             do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1792         ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1793
1794         if (do_utf8) {
1795             REXEC_FBC_SCAN(
1796                 if (*s == ch) {
1797                     DEBUG_EXECUTE_r( did_match = 1 );
1798                     if (regtry(&reginfo, s)) goto got_it;
1799                     s += UTF8SKIP(s);
1800                     while (s < strend && *s == ch)
1801                         s += UTF8SKIP(s);
1802                 }
1803             );
1804         }
1805         else {
1806             REXEC_FBC_SCAN(
1807                 if (*s == ch) {
1808                     DEBUG_EXECUTE_r( did_match = 1 );
1809                     if (regtry(&reginfo, s)) goto got_it;
1810                     s++;
1811                     while (s < strend && *s == ch)
1812                         s++;
1813                 }
1814             );
1815         }
1816         DEBUG_EXECUTE_r(if (!did_match)
1817                 PerlIO_printf(Perl_debug_log,
1818                                   "Did not find anchored character...\n")
1819                );
1820     }
1821     else if (prog->anchored_substr != NULL
1822               || prog->anchored_utf8 != NULL
1823               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1824                   && prog->float_max_offset < strend - s)) {
1825         SV *must;
1826         I32 back_max;
1827         I32 back_min;
1828         char *last;
1829         char *last1;            /* Last position checked before */
1830 #ifdef DEBUGGING
1831         int did_match = 0;
1832 #endif
1833         if (prog->anchored_substr || prog->anchored_utf8) {
1834             if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1835                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1836             must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1837             back_max = back_min = prog->anchored_offset;
1838         } else {
1839             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1840                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1841             must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1842             back_max = prog->float_max_offset;
1843             back_min = prog->float_min_offset;
1844         }
1845
1846
1847         if (must == &PL_sv_undef)
1848             /* could not downgrade utf8 check substring, so must fail */
1849             goto phooey;
1850
1851         if (back_min<0) {
1852             last = strend;
1853         } else {
1854             last = HOP3c(strend,        /* Cannot start after this */
1855                   -(I32)(CHR_SVLEN(must)
1856                          - (SvTAIL(must) != 0) + back_min), strbeg);
1857         }
1858         if (s > PL_bostr)
1859             last1 = HOPc(s, -1);
1860         else
1861             last1 = s - 1;      /* bogus */
1862
1863         /* XXXX check_substr already used to find "s", can optimize if
1864            check_substr==must. */
1865         scream_pos = -1;
1866         dontbother = end_shift;
1867         strend = HOPc(strend, -dontbother);
1868         while ( (s <= last) &&
1869                 ((flags & REXEC_SCREAM)
1870                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
1871                                     end_shift, &scream_pos, 0))
1872                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
1873                                   (unsigned char*)strend, must,
1874                                   multiline ? FBMrf_MULTILINE : 0))) ) {
1875             /* we may be pointing at the wrong string */
1876             if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
1877                 s = strbeg + (s - SvPVX_const(sv));
1878             DEBUG_EXECUTE_r( did_match = 1 );
1879             if (HOPc(s, -back_max) > last1) {
1880                 last1 = HOPc(s, -back_min);
1881                 s = HOPc(s, -back_max);
1882             }
1883             else {
1884                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1885
1886                 last1 = HOPc(s, -back_min);
1887                 s = t;
1888             }
1889             if (do_utf8) {
1890                 while (s <= last1) {
1891                     if (regtry(&reginfo, s))
1892                         goto got_it;
1893                     s += UTF8SKIP(s);
1894                 }
1895             }
1896             else {
1897                 while (s <= last1) {
1898                     if (regtry(&reginfo, s))
1899                         goto got_it;
1900                     s++;
1901                 }
1902             }
1903         }
1904         DEBUG_EXECUTE_r(if (!did_match) {
1905             RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
1906                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1907             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
1908                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
1909                                ? "anchored" : "floating"),
1910                 quoted, RE_SV_TAIL(must));
1911         });
1912         goto phooey;
1913     }
1914     else if ( (c = prog->regstclass) ) {
1915         if (minlen) {
1916             const OPCODE op = OP(prog->regstclass);
1917             /* don't bother with what can't match */
1918             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
1919                 strend = HOPc(strend, -(minlen - 1));
1920         }
1921         DEBUG_EXECUTE_r({
1922             SV * const prop = sv_newmortal();
1923             regprop(prog, prop, c);
1924             {
1925                 RE_PV_QUOTED_DECL(quoted,UTF,PERL_DEBUG_PAD_ZERO(1),
1926                     s,strend-s,60);
1927                 PerlIO_printf(Perl_debug_log,
1928                     "Matching stclass %.*s against %s (%d chars)\n",
1929                     (int)SvCUR(prop), SvPVX_const(prop),
1930                      quoted, (int)(strend - s));
1931             }
1932         });
1933         if (find_byclass(prog, c, s, strend, &reginfo))
1934             goto got_it;
1935         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
1936     }
1937     else {
1938         dontbother = 0;
1939         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
1940             /* Trim the end. */
1941             char *last;
1942             SV* float_real;
1943
1944             if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1945                 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1946             float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
1947
1948             if (flags & REXEC_SCREAM) {
1949                 last = screaminstr(sv, float_real, s - strbeg,
1950                                    end_shift, &scream_pos, 1); /* last one */
1951                 if (!last)
1952                     last = scream_olds; /* Only one occurrence. */
1953                 /* we may be pointing at the wrong string */
1954                 else if (RX_MATCH_COPIED(prog))
1955                     s = strbeg + (s - SvPVX_const(sv));
1956             }
1957             else {
1958                 STRLEN len;
1959                 const char * const little = SvPV_const(float_real, len);
1960
1961                 if (SvTAIL(float_real)) {
1962                     if (memEQ(strend - len + 1, little, len - 1))
1963                         last = strend - len + 1;
1964                     else if (!multiline)
1965                         last = memEQ(strend - len, little, len)
1966                             ? strend - len : NULL;
1967                     else
1968                         goto find_last;
1969                 } else {
1970                   find_last:
1971                     if (len)
1972                         last = rninstr(s, strend, little, little + len);
1973                     else
1974                         last = strend;  /* matching "$" */
1975                 }
1976             }
1977             if (last == NULL) {
1978                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1979                                       "%sCan't trim the tail, match fails (should not happen)%s\n",
1980                                       PL_colors[4], PL_colors[5]));
1981                 goto phooey; /* Should not happen! */
1982             }
1983             dontbother = strend - last + prog->float_min_offset;
1984         }
1985         if (minlen && (dontbother < minlen))
1986             dontbother = minlen - 1;
1987         strend -= dontbother;              /* this one's always in bytes! */
1988         /* We don't know much -- general case. */
1989         if (do_utf8) {
1990             for (;;) {
1991                 if (regtry(&reginfo, s))
1992                     goto got_it;
1993                 if (s >= strend)
1994                     break;
1995                 s += UTF8SKIP(s);
1996             };
1997         }
1998         else {
1999             do {
2000                 if (regtry(&reginfo, s))
2001                     goto got_it;
2002             } while (s++ < strend);
2003         }
2004     }
2005
2006     /* Failure. */
2007     goto phooey;
2008
2009 got_it:
2010     RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2011
2012     if (PL_reg_eval_set) {
2013         /* Preserve the current value of $^R */
2014         if (oreplsv != GvSV(PL_replgv))
2015             sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2016                                                   restored, the value remains
2017                                                   the same. */
2018         restore_pos(aTHX_ prog);
2019     }
2020
2021     /* make sure $`, $&, $', and $digit will work later */
2022     if ( !(flags & REXEC_NOT_FIRST) ) {
2023         RX_MATCH_COPY_FREE(prog);
2024         if (flags & REXEC_COPY_STR) {
2025             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2026 #ifdef PERL_OLD_COPY_ON_WRITE
2027             if ((SvIsCOW(sv)
2028                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2029                 if (DEBUG_C_TEST) {
2030                     PerlIO_printf(Perl_debug_log,
2031                                   "Copy on write: regexp capture, type %d\n",
2032                                   (int) SvTYPE(sv));
2033                 }
2034                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2035                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2036                 assert (SvPOKp(prog->saved_copy));
2037             } else
2038 #endif
2039             {
2040                 RX_MATCH_COPIED_on(prog);
2041                 s = savepvn(strbeg, i);
2042                 prog->subbeg = s;
2043             }
2044             prog->sublen = i;
2045         }
2046         else {
2047             prog->subbeg = strbeg;
2048             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2049         }
2050     }
2051
2052     return 1;
2053
2054 phooey:
2055     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2056                           PL_colors[4], PL_colors[5]));
2057     if (PL_reg_eval_set)
2058         restore_pos(aTHX_ prog);
2059     return 0;
2060 }
2061
2062 /*
2063  - regtry - try match at specific point
2064  */
2065 STATIC I32                      /* 0 failure, 1 success */
2066 S_regtry(pTHX_ const regmatch_info *reginfo, char *startpos)
2067 {
2068     dVAR;
2069     register I32 *sp;
2070     register I32 *ep;
2071     CHECKPOINT lastcp;
2072     regexp *prog = reginfo->prog;
2073     GET_RE_DEBUG_FLAGS_DECL;
2074
2075     if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2076         MAGIC *mg;
2077
2078         PL_reg_eval_set = RS_init;
2079         DEBUG_EXECUTE_r(DEBUG_s(
2080             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2081                           (IV)(PL_stack_sp - PL_stack_base));
2082             ));
2083         SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2084         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2085         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2086         SAVETMPS;
2087         /* Apparently this is not needed, judging by wantarray. */
2088         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2089            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2090
2091         if (reginfo->sv) {
2092             /* Make $_ available to executed code. */
2093             if (reginfo->sv != DEFSV) {
2094                 SAVE_DEFSV;
2095                 DEFSV = reginfo->sv;
2096             }
2097
2098             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2099                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2100                 /* prepare for quick setting of pos */
2101 #ifdef PERL_OLD_COPY_ON_WRITE
2102                 if (SvIsCOW(sv))
2103                     sv_force_normal_flags(sv, 0);
2104 #endif
2105                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2106                                  &PL_vtbl_mglob, NULL, 0);
2107                 mg->mg_len = -1;
2108             }
2109             PL_reg_magic    = mg;
2110             PL_reg_oldpos   = mg->mg_len;
2111             SAVEDESTRUCTOR_X(restore_pos, prog);
2112         }
2113         if (!PL_reg_curpm) {
2114             Newxz(PL_reg_curpm, 1, PMOP);
2115 #ifdef USE_ITHREADS
2116             {
2117                 SV* const repointer = newSViv(0);
2118                 /* so we know which PL_regex_padav element is PL_reg_curpm */
2119                 SvFLAGS(repointer) |= SVf_BREAK;
2120                 av_push(PL_regex_padav,repointer);
2121                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2122                 PL_regex_pad = AvARRAY(PL_regex_padav);
2123             }
2124 #endif
2125         }
2126         PM_SETRE(PL_reg_curpm, prog);
2127         PL_reg_oldcurpm = PL_curpm;
2128         PL_curpm = PL_reg_curpm;
2129         if (RX_MATCH_COPIED(prog)) {
2130             /*  Here is a serious problem: we cannot rewrite subbeg,
2131                 since it may be needed if this match fails.  Thus
2132                 $` inside (?{}) could fail... */
2133             PL_reg_oldsaved = prog->subbeg;
2134             PL_reg_oldsavedlen = prog->sublen;
2135 #ifdef PERL_OLD_COPY_ON_WRITE
2136             PL_nrs = prog->saved_copy;
2137 #endif
2138             RX_MATCH_COPIED_off(prog);
2139         }
2140         else
2141             PL_reg_oldsaved = NULL;
2142         prog->subbeg = PL_bostr;
2143         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2144     }
2145     prog->startp[0] = startpos - PL_bostr;
2146     PL_reginput = startpos;
2147     PL_regstartp = prog->startp;
2148     PL_regendp = prog->endp;
2149     PL_reglastparen = &prog->lastparen;
2150     PL_reglastcloseparen = &prog->lastcloseparen;
2151     prog->lastparen = 0;
2152     prog->lastcloseparen = 0;
2153     PL_regsize = 0;
2154     DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
2155     if (PL_reg_start_tmpl <= prog->nparens) {
2156         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2157         if(PL_reg_start_tmp)
2158             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2159         else
2160             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2161     }
2162
2163     /* XXXX What this code is doing here?!!!  There should be no need
2164        to do this again and again, PL_reglastparen should take care of
2165        this!  --ilya*/
2166
2167     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2168      * Actually, the code in regcppop() (which Ilya may be meaning by
2169      * PL_reglastparen), is not needed at all by the test suite
2170      * (op/regexp, op/pat, op/split), but that code is needed, oddly
2171      * enough, for building DynaLoader, or otherwise this
2172      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2173      * will happen.  Meanwhile, this code *is* needed for the
2174      * above-mentioned test suite tests to succeed.  The common theme
2175      * on those tests seems to be returning null fields from matches.
2176      * --jhi */
2177 #if 1
2178     sp = prog->startp;
2179     ep = prog->endp;
2180     if (prog->nparens) {
2181         register I32 i;
2182         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2183             *++sp = -1;
2184             *++ep = -1;
2185         }
2186     }
2187 #endif
2188     REGCP_SET(lastcp);
2189     if (regmatch(reginfo, prog->program + 1)) {
2190         prog->endp[0] = PL_reginput - PL_bostr;
2191         return 1;
2192     }
2193     REGCP_UNWIND(lastcp);
2194     return 0;
2195 }
2196
2197
2198 #define sayYES goto yes
2199 #define sayNO goto no
2200 #define sayNO_ANYOF goto no_anyof
2201 #define sayYES_FINAL goto yes_final
2202 #define sayNO_FINAL  goto no_final
2203 #define sayNO_SILENT goto do_no
2204 #define saySAME(x) if (x) goto yes; else goto no
2205
2206 #define CACHEsayNO STMT_START { \
2207     if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) \
2208        PL_reg_poscache[st->u.whilem.cache_offset] |= \
2209             (1<<st->u.whilem.cache_bit); \
2210     sayNO; \
2211 } STMT_END
2212
2213
2214 /* this is used to determine how far from the left messages like
2215    'failed...' are printed. Currently 29 makes these messages line
2216    up with the opcode they refer to. Earlier perls used 25 which
2217    left these messages outdented making reviewing a debug output
2218    quite difficult.
2219 */
2220 #define REPORT_CODE_OFF 29
2221
2222
2223 /* Make sure there is a test for this +1 options in re_tests */
2224 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2225
2226 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2227 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2228
2229 #define SLAB_FIRST(s) (&(s)->states[0])
2230 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2231
2232 /* grab a new slab and return the first slot in it */
2233
2234 STATIC regmatch_state *
2235 S_push_slab(pTHX)
2236 {
2237 #if PERL_VERSION < 9
2238     dMY_CXT;
2239 #endif
2240     regmatch_slab *s = PL_regmatch_slab->next;
2241     if (!s) {
2242         Newx(s, 1, regmatch_slab);
2243         s->prev = PL_regmatch_slab;
2244         s->next = NULL;
2245         PL_regmatch_slab->next = s;
2246     }
2247     PL_regmatch_slab = s;
2248     return SLAB_FIRST(s);
2249 }
2250
2251 /* simulate a recursive call to regmatch */
2252
2253 #define REGMATCH(ns, where) \
2254     st->scan = scan; \
2255     scan = (ns); \
2256     st->resume_state = resume_##where; \
2257     goto start_recurse; \
2258     resume_point_##where:
2259
2260 /* push a new state then goto it */
2261
2262 #define PUSH_STATE_GOTO(state, node) \
2263     scan = node; \
2264     st->resume_state = state; \
2265     goto push_state;
2266
2267 /* push a new state with success backtracking, then goto it */
2268
2269 #define PUSH_YES_STATE_GOTO(state, node) \
2270     scan = node; \
2271     st->resume_state = state; \
2272     goto push_yes_state;
2273
2274
2275
2276 /*
2277  - regmatch - main matching routine
2278  *
2279  * Conceptually the strategy is simple:  check to see whether the current
2280  * node matches, call self recursively to see whether the rest matches,
2281  * and then act accordingly.  In practice we make some effort to avoid
2282  * recursion, in particular by going through "ordinary" nodes (that don't
2283  * need to know whether the rest of the match failed) by a loop instead of
2284  * by recursion.
2285  */
2286 /* [lwall] I've hoisted the register declarations to the outer block in order to
2287  * maybe save a little bit of pushing and popping on the stack.  It also takes
2288  * advantage of machines that use a register save mask on subroutine entry.
2289  *
2290  * This function used to be heavily recursive, but since this had the
2291  * effect of blowing the CPU stack on complex regexes, it has been
2292  * restructured to be iterative, and to save state onto the heap rather
2293  * than the stack. Essentially whereever regmatch() used to be called, it
2294  * pushes the current state, notes where to return, then jumps back into
2295  * the main loop.
2296  *
2297  * Originally the structure of this function used to look something like
2298
2299     S_regmatch() {
2300         int a = 1, b = 2;
2301         ...
2302         while (scan != NULL) {
2303             a++; // do stuff with a and b
2304             ...
2305             switch (OP(scan)) {
2306                 case FOO: {
2307                     int local = 3;
2308                     ...
2309                     if (regmatch(...))  // recurse
2310                         goto yes;
2311                 }
2312                 ...
2313             }
2314         }
2315         yes:
2316         return 1;
2317     }
2318
2319  * Now it looks something like this:
2320
2321     typedef struct {
2322         int a, b, local;
2323         int resume_state;
2324     } regmatch_state;
2325
2326     S_regmatch() {
2327         regmatch_state *st = new();
2328         int depth=0;
2329         st->a++; // do stuff with a and b
2330         ...
2331         while (scan != NULL) {
2332             ...
2333             switch (OP(scan)) {
2334                 case FOO: {
2335                     st->local = 3;
2336                     ...
2337                     st->scan = scan;
2338                     scan = ...;
2339                     st->resume_state = resume_FOO;
2340                     goto start_recurse; // recurse
2341
2342                     resume_point_FOO:
2343                     if (result)
2344                         goto yes;
2345                 }
2346                 ...
2347             }
2348           start_recurse:
2349             st = new(); push a new state
2350             st->a = 1; st->b = 2;
2351             depth++;
2352         }
2353       yes:
2354         result = 1;
2355         if (depth--) {
2356             st = pop();
2357             switch (resume_state) {
2358             case resume_FOO:
2359                 goto resume_point_FOO;
2360             ...
2361             }
2362         }
2363         return result
2364     }
2365
2366  * WARNING: this means that any line in this function that contains a
2367  * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2368  * regmatch() using gotos instead. Thus the values of any local variables
2369  * not saved in the regmatch_state structure will have been lost when
2370  * execution resumes on the next line .
2371  *
2372  * States (ie the st pointer) are allocated in slabs of about 4K in size.
2373  * PL_regmatch_state always points to the currently active state, and
2374  * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2375  * The first time regmatch is called, the first slab is allocated, and is
2376  * never freed until interpreter desctruction. When the slab is full,
2377  * a new one is allocated chained to the end. At exit from regmatch, slabs
2378  * allocated since entry are freed.
2379  */
2380
2381 /* *** every FOO_fail should = FOO+1 */
2382 #define TRIE_next              (REGNODE_MAX+1)
2383 #define TRIE_next_fail         (REGNODE_MAX+2)
2384 #define EVAL_AB                (REGNODE_MAX+3)
2385 #define EVAL_AB_fail           (REGNODE_MAX+4)
2386 #define resume_CURLYX          (REGNODE_MAX+5)
2387 #define resume_WHILEM1         (REGNODE_MAX+6)
2388 #define resume_WHILEM2         (REGNODE_MAX+7)
2389 #define resume_WHILEM3         (REGNODE_MAX+8)
2390 #define resume_WHILEM4         (REGNODE_MAX+9)
2391 #define resume_WHILEM5         (REGNODE_MAX+10)
2392 #define resume_WHILEM6         (REGNODE_MAX+11)
2393 #define BRANCH_next            (REGNODE_MAX+12)
2394 #define BRANCH_next_fail       (REGNODE_MAX+13)
2395 #define CURLYM_A               (REGNODE_MAX+14)
2396 #define CURLYM_A_fail          (REGNODE_MAX+15)
2397 #define CURLYM_B               (REGNODE_MAX+16)
2398 #define CURLYM_B_fail          (REGNODE_MAX+17)
2399 #define IFMATCH_A              (REGNODE_MAX+18)
2400 #define IFMATCH_A_fail         (REGNODE_MAX+19)
2401 #define CURLY_B_min_known      (REGNODE_MAX+20)
2402 #define CURLY_B_min_known_fail (REGNODE_MAX+21)
2403 #define CURLY_B_min            (REGNODE_MAX+22)
2404 #define CURLY_B_min_fail       (REGNODE_MAX+23)
2405 #define CURLY_B_max            (REGNODE_MAX+24)
2406 #define CURLY_B_max_fail       (REGNODE_MAX+25)
2407
2408 #define DEBUG_STATE_pp(pp)                                  \
2409     DEBUG_STATE_r(                                          \
2410         DUMP_EXEC_POS(locinput, scan, do_utf8);             \
2411         PerlIO_printf(Perl_debug_log,                       \
2412             "    %*s"pp" %s\n",                             \
2413             depth*2, "",                                    \
2414             state_names[st->resume_state-REGNODE_MAX-1] )   \
2415     );
2416
2417
2418 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2419
2420 #ifdef DEBUGGING
2421 static const char * const state_names[] = {
2422    "TRIE_next",
2423    "TRIE_next_fail",
2424    "EVAL_AB",
2425    "EVAL_AB_fail",
2426    "resume_CURLYX",
2427    "resume_WHILEM1",
2428    "resume_WHILEM2",
2429    "resume_WHILEM3",
2430    "resume_WHILEM4",
2431    "resume_WHILEM5",
2432    "resume_WHILEM6",
2433    "BRANCH_next",
2434    "BRANCH_next_fail",
2435    "CURLYM_A",
2436    "CURLYM_A_fail",
2437    "CURLYM_B",
2438    "CURLYM_B_fail",
2439    "IFMATCH_A",
2440    "IFMATCH_A_fail",
2441    "CURLY_B_min_known",
2442    "CURLY_B_min_known_fail",
2443    "CURLY_B_min",
2444    "CURLY_B_min_fail",
2445    "CURLY_B_max",
2446    "CURLY_B_max_fail"
2447 };
2448
2449 STATIC void
2450 S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
2451     const char *start, const char *end, const char *blurb)
2452 {
2453     const bool utf8_pat= prog->reganch & ROPT_UTF8 ? 1 : 0;
2454     if (!PL_colorset)
2455             reginitcolors();
2456     {
2457         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2458             prog->precomp, prog->prelen, 60);
2459
2460         RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2461             start, end - start, 60);
2462
2463         PerlIO_printf(Perl_debug_log,
2464             "%s%s REx%s %s against %s\n",
2465                        PL_colors[4], blurb, PL_colors[5], s0, s1);
2466
2467         if (do_utf8||utf8_pat)
2468             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2469                 utf8_pat ? "pattern" : "",
2470                 utf8_pat && do_utf8 ? " and " : "",
2471                 do_utf8 ? "string" : ""
2472             );
2473     }
2474 }
2475
2476 STATIC void
2477 S_dump_exec_pos(pTHX_ const char *locinput,
2478                       const regnode *scan,
2479                       const char *loc_regeol,
2480                       const char *loc_bostr,
2481                       const char *loc_reg_starttry,
2482                       const bool do_utf8)
2483 {
2484     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2485     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2486     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2487     /* The part of the string before starttry has one color
2488        (pref0_len chars), between starttry and current
2489        position another one (pref_len - pref0_len chars),
2490        after the current position the third one.
2491        We assume that pref0_len <= pref_len, otherwise we
2492        decrease pref0_len.  */
2493     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2494         ? (5 + taill) - l : locinput - loc_bostr;
2495     int pref0_len;
2496
2497     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2498         pref_len++;
2499     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2500     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2501         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2502               ? (5 + taill) - pref_len : loc_regeol - locinput);
2503     while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2504         l--;
2505     if (pref0_len < 0)
2506         pref0_len = 0;
2507     if (pref0_len > pref_len)
2508         pref0_len = pref_len;
2509     {
2510         const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2511
2512         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2513             (locinput - pref_len),pref0_len, 60, 4, 5);
2514
2515         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2516                     (locinput - pref_len + pref0_len),
2517                     pref_len - pref0_len, 60, 2, 3);
2518
2519         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2520                     locinput, loc_regeol - locinput, 10, 0, 1);
2521
2522         const STRLEN tlen=len0+len1+len2;
2523         PerlIO_printf(Perl_debug_log,
2524                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2525                     (IV)(locinput - loc_bostr),
2526                     len0, s0,
2527                     len1, s1,
2528                     (docolor ? "" : "> <"),
2529                     len2, s2,
2530                     tlen > 19 ? 0 :  19 - tlen,
2531                     "");
2532     }
2533 }
2534
2535 #endif
2536
2537 STATIC I32                      /* 0 failure, 1 success */
2538 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2539 {
2540 #if PERL_VERSION < 9
2541     dMY_CXT;
2542 #endif
2543     dVAR;
2544     register const bool do_utf8 = PL_reg_match_utf8;
2545     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2546
2547     regexp *rex = reginfo->prog;
2548
2549     regmatch_slab  *orig_slab;
2550     regmatch_state *orig_state;
2551
2552     /* the current state. This is a cached copy of PL_regmatch_state */
2553     register regmatch_state *st;
2554
2555     /* cache heavy used fields of st in registers */
2556     register regnode *scan;
2557     register regnode *next;
2558     register I32 n = 0; /* initialize to shut up compiler warning */
2559     register char *locinput = PL_reginput;
2560
2561     /* these variables are NOT saved during a recusive RFEGMATCH: */
2562     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2563     bool result = 0;        /* return value of S_regmatch */
2564     int depth = 0;          /* depth of recursion */
2565     regmatch_state *yes_state = NULL; /* state to pop to on success of
2566                                                             subpattern */
2567     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2568     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2569     U32 state_num;
2570
2571     I32 parenfloor = 0;
2572
2573 #ifdef DEBUGGING
2574     GET_RE_DEBUG_FLAGS_DECL;
2575 #endif
2576
2577     /* on first ever call to regmatch, allocate first slab */
2578     if (!PL_regmatch_slab) {
2579         Newx(PL_regmatch_slab, 1, regmatch_slab);
2580         PL_regmatch_slab->prev = NULL;
2581         PL_regmatch_slab->next = NULL;
2582         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2583     }
2584
2585     /* remember current high-water mark for exit */
2586     /* XXX this should be done with SAVE* instead */
2587     orig_slab  = PL_regmatch_slab;
2588     orig_state = PL_regmatch_state;
2589
2590     /* grab next free state slot */
2591     st = ++PL_regmatch_state;
2592     if (st >  SLAB_LAST(PL_regmatch_slab))
2593         st = PL_regmatch_state = S_push_slab(aTHX);
2594
2595     st->minmod = 0;
2596     st->sw = 0;
2597     st->logical = 0;
2598     cur_curlyx = NULL;
2599
2600     /* Note that nextchr is a byte even in UTF */
2601     nextchr = UCHARAT(locinput);
2602     scan = prog;
2603     while (scan != NULL) {
2604
2605         DEBUG_EXECUTE_r( {
2606             SV * const prop = sv_newmortal();
2607             regnode *rnext=regnext(scan);
2608             DUMP_EXEC_POS( locinput, scan, do_utf8 );
2609             regprop(rex, prop, scan);
2610
2611             PerlIO_printf(Perl_debug_log,
2612                     "%3"IVdf":%*s%s(%"IVdf")\n",
2613                     (IV)(scan - rex->program), depth*2, "",
2614                     SvPVX_const(prop),
2615                     (PL_regkind[OP(scan)] == END || !rnext) ?
2616                         0 : (IV)(rnext - rex->program));
2617         });
2618
2619         next = scan + NEXT_OFF(scan);
2620         if (next == scan)
2621             next = NULL;
2622         state_num = OP(scan);
2623
2624       reenter_switch:
2625         switch (state_num) {
2626         case BOL:
2627             if (locinput == PL_bostr)
2628             {
2629                 /* reginfo->till = reginfo->bol; */
2630                 break;
2631             }
2632             sayNO;
2633         case MBOL:
2634             if (locinput == PL_bostr ||
2635                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2636             {
2637                 break;
2638             }
2639             sayNO;
2640         case SBOL:
2641             if (locinput == PL_bostr)
2642                 break;
2643             sayNO;
2644         case GPOS:
2645             if (locinput == reginfo->ganch)
2646                 break;
2647             sayNO;
2648         case EOL:
2649                 goto seol;
2650         case MEOL:
2651             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2652                 sayNO;
2653             break;
2654         case SEOL:
2655           seol:
2656             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2657                 sayNO;
2658             if (PL_regeol - locinput > 1)
2659                 sayNO;
2660             break;
2661         case EOS:
2662             if (PL_regeol != locinput)
2663                 sayNO;
2664             break;
2665         case SANY:
2666             if (!nextchr && locinput >= PL_regeol)
2667                 sayNO;
2668             if (do_utf8) {
2669                 locinput += PL_utf8skip[nextchr];
2670                 if (locinput > PL_regeol)
2671                     sayNO;
2672                 nextchr = UCHARAT(locinput);
2673             }
2674             else
2675                 nextchr = UCHARAT(++locinput);
2676             break;
2677         case CANY:
2678             if (!nextchr && locinput >= PL_regeol)
2679                 sayNO;
2680             nextchr = UCHARAT(++locinput);
2681             break;
2682         case REG_ANY:
2683             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2684                 sayNO;
2685             if (do_utf8) {
2686                 locinput += PL_utf8skip[nextchr];
2687                 if (locinput > PL_regeol)
2688                     sayNO;
2689                 nextchr = UCHARAT(locinput);
2690             }
2691             else
2692                 nextchr = UCHARAT(++locinput);
2693             break;
2694
2695 #undef  ST
2696 #define ST st->u.trie
2697         case TRIEC:
2698             /* In this case the charclass data is available inline so
2699                we can fail fast without a lot of extra overhead.
2700              */
2701             if (scan->flags == EXACT || !do_utf8) {
2702                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
2703                     DEBUG_EXECUTE_r(
2704                         PerlIO_printf(Perl_debug_log,
2705                                   "%*s  %sfailed to match trie start class...%s\n",
2706                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2707                     );
2708                     sayNO_SILENT;
2709                     /* NOTREACHED */
2710                 }
2711             }
2712             /* FALL THROUGH */
2713         case TRIE:
2714             {
2715                 /* what type of TRIE am I? (utf8 makes this contextual) */
2716                 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2717                     trie_type = do_utf8 ?
2718                           (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2719                         : trie_plain;
2720
2721                 /* what trie are we using right now */
2722                 reg_trie_data * const trie
2723                     = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2724                 U32 state = trie->startstate;
2725
2726                 if (trie->bitmap && trie_type != trie_utf8_fold &&
2727                     !TRIE_BITMAP_TEST(trie,*locinput)
2728                 ) {
2729                     if (trie->states[ state ].wordnum) {
2730                          DEBUG_EXECUTE_r(
2731                             PerlIO_printf(Perl_debug_log,
2732                                           "%*s  %smatched empty string...%s\n",
2733                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2734                         );
2735                         break;
2736                     } else {
2737                         DEBUG_EXECUTE_r(
2738                             PerlIO_printf(Perl_debug_log,
2739                                           "%*s  %sfailed to match trie start class...%s\n",
2740                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2741                         );
2742                         sayNO_SILENT;
2743                    }
2744                 }
2745
2746             {
2747                 U8 *uc = ( U8* )locinput;
2748
2749                 STRLEN len = 0;
2750                 STRLEN foldlen = 0;
2751                 U8 *uscan = (U8*)NULL;
2752                 STRLEN bufflen=0;
2753                 SV *sv_accept_buff = NULL;
2754                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2755
2756                 ST.accepted = 0; /* how many accepting states we have seen */
2757                 ST.B = next;
2758                 ST.jump = trie->jump;
2759
2760 #ifdef DEBUGGING
2761                 ST.me = scan;
2762 #endif
2763
2764
2765
2766                 /*
2767                    traverse the TRIE keeping track of all accepting states
2768                    we transition through until we get to a failing node.
2769                 */
2770
2771                 while ( state && uc <= (U8*)PL_regeol ) {
2772                     U32 base = trie->states[ state ].trans.base;
2773                     UV uvc;
2774                     U16 charid;
2775                     /* We use charid to hold the wordnum as we don't use it
2776                        for charid until after we have done the wordnum logic.
2777                        We define an alias just so that the wordnum logic reads
2778                        more naturally. */
2779
2780 #define got_wordnum charid
2781                     got_wordnum = trie->states[ state ].wordnum;
2782
2783                     if ( got_wordnum ) {
2784                         if ( ! ST.accepted ) {
2785                             ENTER;
2786                             SAVETMPS;
2787                             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2788                             sv_accept_buff=newSV(bufflen *
2789                                             sizeof(reg_trie_accepted) - 1);
2790                             SvCUR_set(sv_accept_buff, 0);
2791                             SvPOK_on(sv_accept_buff);
2792                             sv_2mortal(sv_accept_buff);
2793                             SAVETMPS;
2794                             ST.accept_buff =
2795                                 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2796                         }
2797                         do {
2798                             if (ST.accepted >= bufflen) {
2799                                 bufflen *= 2;
2800                                 ST.accept_buff =(reg_trie_accepted*)
2801                                     SvGROW(sv_accept_buff,
2802                                         bufflen * sizeof(reg_trie_accepted));
2803                             }
2804                             SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2805                                 + sizeof(reg_trie_accepted));
2806
2807
2808                             ST.accept_buff[ST.accepted].wordnum = got_wordnum;
2809                             ST.accept_buff[ST.accepted].endpos = uc;
2810                             ++ST.accepted;
2811                         } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
2812                     }
2813 #undef got_wordnum
2814
2815                     DEBUG_TRIE_EXECUTE_r({
2816                                 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
2817                                 PerlIO_printf( Perl_debug_log,
2818                                     "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
2819                                     2+depth * 2, "", PL_colors[4],
2820                                     (UV)state, (UV)ST.accepted );
2821                     });
2822
2823                     if ( base ) {
2824                         REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
2825                             uvc, charid, foldlen, foldbuf, uniflags);
2826
2827                         if (charid &&
2828                              (base + charid > trie->uniquecharcount )
2829                              && (base + charid - 1 - trie->uniquecharcount
2830                                     < trie->lasttrans)
2831                              && trie->trans[base + charid - 1 -
2832                                     trie->uniquecharcount].check == state)
2833                         {
2834                             state = trie->trans[base + charid - 1 -
2835                                 trie->uniquecharcount ].next;
2836                         }
2837                         else {
2838                             state = 0;
2839                         }
2840                         uc += len;
2841
2842                     }
2843                     else {
2844                         state = 0;
2845                     }
2846                     DEBUG_TRIE_EXECUTE_r(
2847                         PerlIO_printf( Perl_debug_log,
2848                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
2849                             charid, uvc, (UV)state, PL_colors[5] );
2850                     );
2851                 }
2852                 if (!ST.accepted )
2853                    sayNO;
2854
2855                 DEBUG_EXECUTE_r(
2856                     PerlIO_printf( Perl_debug_log,
2857                         "%*s  %sgot %"IVdf" possible matches%s\n",
2858                         REPORT_CODE_OFF + depth * 2, "",
2859                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
2860                 );
2861             }}
2862
2863             /* FALL THROUGH */
2864
2865         case TRIE_next_fail: /* we failed - try next alterative */
2866
2867             if ( ST.accepted == 1 ) {
2868                 /* only one choice left - just continue */
2869                 DEBUG_EXECUTE_r({
2870                     reg_trie_data * const trie
2871                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2872                     SV ** const tmp = RX_DEBUG(reginfo->prog)
2873                                     ? av_fetch( trie->words, ST.accept_buff[ 0 ].wordnum-1, 0 )
2874                                     : NULL;
2875                     PerlIO_printf( Perl_debug_log,
2876                         "%*s  %sonly one match left: #%d <%s>%s\n",
2877                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
2878                         ST.accept_buff[ 0 ].wordnum,
2879                         tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2880                         PL_colors[5] );
2881                 });
2882                 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
2883                 /* in this case we free tmps/leave before we call regmatch
2884                    as we wont be using accept_buff again. */
2885                 FREETMPS;
2886                 LEAVE;
2887                 locinput = PL_reginput;
2888                 nextchr = UCHARAT(locinput);
2889
2890                 if ( !ST.jump )
2891                     scan = ST.B;
2892                 else
2893                     scan = ST.B - ST.jump[ST.accept_buff[0].wordnum];
2894
2895                 continue; /* execute rest of RE */
2896             }
2897
2898             if (!ST.accepted-- ) {
2899                 FREETMPS;
2900                 LEAVE;
2901                 sayNO;
2902             }
2903
2904             /*
2905                There are at least two accepting states left.  Presumably
2906                the number of accepting states is going to be low,
2907                typically two. So we simply scan through to find the one
2908                with lowest wordnum.  Once we find it, we swap the last
2909                state into its place and decrement the size. We then try to
2910                match the rest of the pattern at the point where the word
2911                ends. If we succeed, control just continues along the
2912                regex; if we fail we return here to try the next accepting
2913                state
2914              */
2915
2916             {
2917                 U32 best = 0;
2918                 U32 cur;
2919                 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
2920                     DEBUG_TRIE_EXECUTE_r(
2921                         PerlIO_printf( Perl_debug_log,
2922                             "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
2923                             REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
2924                             (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
2925                             ST.accept_buff[ cur ].wordnum, PL_colors[5] );
2926                     );
2927
2928                     if (ST.accept_buff[cur].wordnum <
2929                             ST.accept_buff[best].wordnum)
2930                         best = cur;
2931                 }
2932
2933                 DEBUG_EXECUTE_r({
2934                     reg_trie_data * const trie
2935                         = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2936                     SV ** const tmp = RX_DEBUG(reginfo->prog)
2937                                 ? av_fetch( trie->words, ST.accept_buff[ best ].wordnum - 1, 0 )
2938                                 : NULL;
2939                     PerlIO_printf( Perl_debug_log, "%*s  %strying alternation #%d <%s> at node #%d %s\n",
2940                         REPORT_CODE_OFF+depth*2, "", PL_colors[4],
2941                         ST.accept_buff[best].wordnum,
2942                         tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", REG_NODE_NUM(scan),
2943                         PL_colors[5] );
2944                 });
2945
2946                 if ( best<ST.accepted ) {
2947                     reg_trie_accepted tmp = ST.accept_buff[ best ];
2948                     ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
2949                     ST.accept_buff[ ST.accepted ] = tmp;
2950                     best = ST.accepted;
2951                 }
2952                 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
2953                 if ( !ST.jump ) {
2954                     PUSH_STATE_GOTO(TRIE_next, ST.B);
2955                     /* NOTREACHED */
2956                 } else {
2957                     PUSH_STATE_GOTO(TRIE_next, ST.B - ST.jump[ST.accept_buff[best].wordnum]);
2958                     /* NOTREACHED */
2959                 }
2960                 /* NOTREACHED */
2961             }
2962             /* NOTREACHED */
2963
2964 #undef  ST
2965
2966         case EXACT: {
2967             char *s = STRING(scan);
2968             st->ln = STR_LEN(scan);
2969             if (do_utf8 != UTF) {
2970                 /* The target and the pattern have differing utf8ness. */
2971                 char *l = locinput;
2972                 const char * const e = s + st->ln;
2973
2974                 if (do_utf8) {
2975                     /* The target is utf8, the pattern is not utf8. */
2976                     while (s < e) {
2977                         STRLEN ulen;
2978                         if (l >= PL_regeol)
2979                              sayNO;
2980                         if (NATIVE_TO_UNI(*(U8*)s) !=
2981                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
2982                                             uniflags))
2983                              sayNO;
2984                         l += ulen;
2985                         s ++;
2986                     }
2987                 }
2988                 else {
2989                     /* The target is not utf8, the pattern is utf8. */
2990                     while (s < e) {
2991                         STRLEN ulen;
2992                         if (l >= PL_regeol)
2993                             sayNO;
2994                         if (NATIVE_TO_UNI(*((U8*)l)) !=
2995                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
2996                                            uniflags))
2997                             sayNO;
2998                         s += ulen;
2999                         l ++;
3000                     }
3001                 }
3002                 locinput = l;
3003                 nextchr = UCHARAT(locinput);
3004                 break;
3005             }
3006             /* The target and the pattern have the same utf8ness. */
3007             /* Inline the first character, for speed. */
3008             if (UCHARAT(s) != nextchr)
3009                 sayNO;
3010             if (PL_regeol - locinput < st->ln)
3011                 sayNO;
3012             if (st->ln > 1 && memNE(s, locinput, st->ln))
3013                 sayNO;
3014             locinput += st->ln;
3015             nextchr = UCHARAT(locinput);
3016             break;
3017             }
3018         case EXACTFL:
3019             PL_reg_flags |= RF_tainted;
3020             /* FALL THROUGH */
3021         case EXACTF: {
3022             char * const s = STRING(scan);
3023             st->ln = STR_LEN(scan);
3024
3025             if (do_utf8 || UTF) {
3026               /* Either target or the pattern are utf8. */
3027                 const char * const l = locinput;
3028                 char *e = PL_regeol;
3029
3030                 if (ibcmp_utf8(s, 0,  st->ln, (bool)UTF,
3031                                l, &e, 0,  do_utf8)) {
3032                      /* One more case for the sharp s:
3033                       * pack("U0U*", 0xDF) =~ /ss/i,
3034                       * the 0xC3 0x9F are the UTF-8
3035                       * byte sequence for the U+00DF. */
3036                      if (!(do_utf8 &&
3037                            toLOWER(s[0]) == 's' &&
3038                            st->ln >= 2 &&
3039                            toLOWER(s[1]) == 's' &&
3040                            (U8)l[0] == 0xC3 &&
3041                            e - l >= 2 &&
3042                            (U8)l[1] == 0x9F))
3043                           sayNO;
3044                 }
3045                 locinput = e;
3046                 nextchr = UCHARAT(locinput);
3047                 break;
3048             }
3049
3050             /* Neither the target and the pattern are utf8. */
3051
3052             /* Inline the first character, for speed. */
3053             if (UCHARAT(s) != nextchr &&
3054                 UCHARAT(s) != ((OP(scan) == EXACTF)
3055                                ? PL_fold : PL_fold_locale)[nextchr])
3056                 sayNO;
3057             if (PL_regeol - locinput < st->ln)
3058                 sayNO;
3059             if (st->ln > 1 && (OP(scan) == EXACTF
3060                            ? ibcmp(s, locinput, st->ln)
3061                            : ibcmp_locale(s, locinput, st->ln)))
3062                 sayNO;
3063             locinput += st->ln;
3064             nextchr = UCHARAT(locinput);
3065             break;
3066             }
3067         case ANYOF:
3068             if (do_utf8) {
3069                 STRLEN inclasslen = PL_regeol - locinput;
3070
3071                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3072                     sayNO_ANYOF;
3073                 if (locinput >= PL_regeol)
3074                     sayNO;
3075                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3076                 nextchr = UCHARAT(locinput);
3077                 break;
3078             }
3079             else {
3080                 if (nextchr < 0)
3081                     nextchr = UCHARAT(locinput);
3082                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3083                     sayNO_ANYOF;
3084                 if (!nextchr && locinput >= PL_regeol)
3085                     sayNO;
3086                 nextchr = UCHARAT(++locinput);
3087                 break;
3088             }
3089         no_anyof:
3090             /* If we might have the case of the German sharp s
3091              * in a casefolding Unicode character class. */
3092
3093             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3094                  locinput += SHARP_S_SKIP;
3095                  nextchr = UCHARAT(locinput);
3096             }
3097             else
3098                  sayNO;
3099             break;
3100         case ALNUML:
3101             PL_reg_flags |= RF_tainted;
3102             /* FALL THROUGH */
3103         case ALNUM:
3104             if (!nextchr)
3105                 sayNO;
3106             if (do_utf8) {
3107                 LOAD_UTF8_CHARCLASS_ALNUM();
3108                 if (!(OP(scan) == ALNUM
3109                       ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3110                       : isALNUM_LC_utf8((U8*)locinput)))
3111                 {
3112                     sayNO;
3113                 }
3114                 locinput += PL_utf8skip[nextchr];
3115                 nextchr = UCHARAT(locinput);
3116                 break;
3117             }
3118             if (!(OP(scan) == ALNUM
3119                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3120                 sayNO;
3121             nextchr = UCHARAT(++locinput);
3122             break;
3123         case NALNUML:
3124             PL_reg_flags |= RF_tainted;
3125             /* FALL THROUGH */
3126         case NALNUM:
3127             if (!nextchr && locinput >= PL_regeol)
3128                 sayNO;
3129             if (do_utf8) {
3130                 LOAD_UTF8_CHARCLASS_ALNUM();
3131                 if (OP(scan) == NALNUM
3132                     ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3133                     : isALNUM_LC_utf8((U8*)locinput))
3134                 {
3135                     sayNO;
3136                 }
3137                 locinput += PL_utf8skip[nextchr];
3138                 nextchr = UCHARAT(locinput);
3139                 break;
3140             }
3141             if (OP(scan) == NALNUM
3142                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3143                 sayNO;
3144             nextchr = UCHARAT(++locinput);
3145             break;
3146         case BOUNDL:
3147         case NBOUNDL:
3148             PL_reg_flags |= RF_tainted;
3149             /* FALL THROUGH */
3150         case BOUND:
3151         case NBOUND:
3152             /* was last char in word? */
3153             if (do_utf8) {
3154                 if (locinput == PL_bostr)
3155                     st->ln = '\n';
3156                 else {
3157                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3158
3159                     st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3160                 }
3161                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3162                     st->ln = isALNUM_uni(st->ln);
3163                     LOAD_UTF8_CHARCLASS_ALNUM();
3164                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3165                 }
3166                 else {
3167                     st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3168                     n = isALNUM_LC_utf8((U8*)locinput);
3169                 }
3170             }
3171             else {
3172                 st->ln = (locinput != PL_bostr) ?
3173                     UCHARAT(locinput - 1) : '\n';
3174                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3175                     st->ln = isALNUM(st->ln);
3176                     n = isALNUM(nextchr);
3177                 }
3178                 else {
3179                     st->ln = isALNUM_LC(st->ln);
3180                     n = isALNUM_LC(nextchr);
3181                 }
3182             }
3183             if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3184                                     OP(scan) == BOUNDL))
3185                     sayNO;
3186             break;
3187         case SPACEL:
3188             PL_reg_flags |= RF_tainted;
3189             /* FALL THROUGH */
3190         case SPACE:
3191             if (!nextchr)
3192                 sayNO;
3193             if (do_utf8) {
3194                 if (UTF8_IS_CONTINUED(nextchr)) {
3195                     LOAD_UTF8_CHARCLASS_SPACE();
3196                     if (!(OP(scan) == SPACE
3197                           ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3198                           : isSPACE_LC_utf8((U8*)locinput)))
3199                     {
3200                         sayNO;
3201                     }
3202                     locinput += PL_utf8skip[nextchr];
3203                     nextchr = UCHARAT(locinput);
3204                     break;
3205                 }
3206                 if (!(OP(scan) == SPACE
3207                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3208                     sayNO;
3209                 nextchr = UCHARAT(++locinput);
3210             }
3211             else {
3212                 if (!(OP(scan) == SPACE
3213                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3214                     sayNO;
3215                 nextchr = UCHARAT(++locinput);
3216             }
3217             break;
3218         case NSPACEL:
3219             PL_reg_flags |= RF_tainted;
3220             /* FALL THROUGH */
3221         case NSPACE:
3222             if (!nextchr && locinput >= PL_regeol)
3223                 sayNO;
3224             if (do_utf8) {
3225                 LOAD_UTF8_CHARCLASS_SPACE();
3226                 if (OP(scan) == NSPACE
3227                     ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3228                     : isSPACE_LC_utf8((U8*)locinput))
3229                 {
3230                     sayNO;
3231                 }
3232                 locinput += PL_utf8skip[nextchr];
3233                 nextchr = UCHARAT(locinput);
3234                 break;
3235             }
3236             if (OP(scan) == NSPACE
3237                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3238                 sayNO;
3239             nextchr = UCHARAT(++locinput);
3240             break;
3241         case DIGITL:
3242             PL_reg_flags |= RF_tainted;
3243             /* FALL THROUGH */
3244         case DIGIT:
3245             if (!nextchr)
3246                 sayNO;
3247             if (do_utf8) {
3248                 LOAD_UTF8_CHARCLASS_DIGIT();
3249                 if (!(OP(scan) == DIGIT
3250                       ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3251                       : isDIGIT_LC_utf8((U8*)locinput)))
3252                 {
3253                     sayNO;
3254                 }
3255                 locinput += PL_utf8skip[nextchr];
3256                 nextchr = UCHARAT(locinput);
3257                 break;
3258             }
3259             if (!(OP(scan) == DIGIT
3260                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3261                 sayNO;
3262             nextchr = UCHARAT(++locinput);
3263             break;
3264         case NDIGITL:
3265             PL_reg_flags |= RF_tainted;
3266             /* FALL THROUGH */
3267         case NDIGIT:
3268             if (!nextchr && locinput >= PL_regeol)
3269                 sayNO;
3270             if (do_utf8) {
3271                 LOAD_UTF8_CHARCLASS_DIGIT();
3272                 if (OP(scan) == NDIGIT
3273                     ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3274                     : isDIGIT_LC_utf8((U8*)locinput))
3275                 {
3276                     sayNO;
3277                 }
3278                 locinput += PL_utf8skip[nextchr];
3279                 nextchr = UCHARAT(locinput);
3280                 break;
3281             }
3282             if (OP(scan) == NDIGIT
3283                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3284                 sayNO;
3285             nextchr = UCHARAT(++locinput);
3286             break;
3287         case CLUMP:
3288             if (locinput >= PL_regeol)
3289                 sayNO;
3290             if  (do_utf8) {
3291                 LOAD_UTF8_CHARCLASS_MARK();
3292                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3293                     sayNO;
3294                 locinput += PL_utf8skip[nextchr];
3295                 while (locinput < PL_regeol &&
3296                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3297                     locinput += UTF8SKIP(locinput);
3298                 if (locinput > PL_regeol)
3299                     sayNO;
3300             }
3301             else
3302                locinput++;
3303             nextchr = UCHARAT(locinput);
3304             break;
3305         case REFFL:
3306             PL_reg_flags |= RF_tainted;
3307             /* FALL THROUGH */
3308         case REF:
3309         case REFF: {
3310             char *s;
3311             n = ARG(scan);  /* which paren pair */
3312             st->ln = PL_regstartp[n];
3313             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3314             if ((I32)*PL_reglastparen < n || st->ln == -1)
3315                 sayNO;                  /* Do not match unless seen CLOSEn. */
3316             if (st->ln == PL_regendp[n])
3317                 break;
3318
3319             s = PL_bostr + st->ln;
3320             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
3321                 char *l = locinput;
3322                 const char *e = PL_bostr + PL_regendp[n];
3323                 /*
3324                  * Note that we can't do the "other character" lookup trick as
3325                  * in the 8-bit case (no pun intended) because in Unicode we
3326                  * have to map both upper and title case to lower case.
3327                  */
3328                 if (OP(scan) == REFF) {
3329                     while (s < e) {
3330                         STRLEN ulen1, ulen2;
3331                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3332                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3333
3334                         if (l >= PL_regeol)
3335                             sayNO;
3336                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3337                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3338                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3339                             sayNO;
3340                         s += ulen1;
3341                         l += ulen2;
3342                     }
3343                 }
3344                 locinput = l;
3345                 nextchr = UCHARAT(locinput);
3346                 break;
3347             }
3348
3349             /* Inline the first character, for speed. */
3350             if (UCHARAT(s) != nextchr &&
3351                 (OP(scan) == REF ||
3352                  (UCHARAT(s) != ((OP(scan) == REFF
3353                                   ? PL_fold : PL_fold_locale)[nextchr]))))
3354                 sayNO;
3355             st->ln = PL_regendp[n] - st->ln;
3356             if (locinput + st->ln > PL_regeol)
3357                 sayNO;
3358             if (st->ln > 1 && (OP(scan) == REF
3359                            ? memNE(s, locinput, st->ln)
3360                            : (OP(scan) == REFF
3361                               ? ibcmp(s, locinput, st->ln)
3362                               : ibcmp_locale(s, locinput, st->ln))))
3363                 sayNO;
3364             locinput += st->ln;
3365             nextchr = UCHARAT(locinput);
3366             break;
3367             }
3368
3369         case NOTHING:
3370         case TAIL:
3371             break;
3372         case BACK:
3373             break;
3374
3375 #undef  ST
3376 #define ST st->u.eval
3377
3378         case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3379         {
3380             SV *ret;
3381             {
3382                 /* execute the code in the {...} */
3383                 dSP;
3384                 SV ** const before = SP;
3385                 OP_4tree * const oop = PL_op;
3386                 COP * const ocurcop = PL_curcop;
3387                 PAD *old_comppad;
3388
3389                 n = ARG(scan);
3390                 PL_op = (OP_4tree*)rex->data->data[n];
3391                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3392                 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3393                 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3394
3395                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3396                 SPAGAIN;
3397                 if (SP == before)
3398                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3399                 else {
3400                     ret = POPs;
3401                     PUTBACK;
3402                 }
3403
3404                 PL_op = oop;
3405                 PAD_RESTORE_LOCAL(old_comppad);
3406                 PL_curcop = ocurcop;
3407                 if (!st->logical) {
3408                     /* /(?{...})/ */
3409                     sv_setsv(save_scalar(PL_replgv), ret);
3410                     break;
3411                 }
3412             }
3413             if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3414                 regexp *re;
3415                 {
3416                     /* extract RE object from returned value; compiling if
3417                      * necessary */
3418
3419                     MAGIC *mg = NULL;
3420                     const SV *sv;
3421                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3422                         mg = mg_find(sv, PERL_MAGIC_qr);
3423                     else if (SvSMAGICAL(ret)) {
3424                         if (SvGMAGICAL(ret))
3425                             sv_unmagic(ret, PERL_MAGIC_qr);
3426                         else
3427                             mg = mg_find(ret, PERL_MAGIC_qr);
3428                     }
3429
3430                     if (mg) {
3431                         re = (regexp *)mg->mg_obj;
3432                         (void)ReREFCNT_inc(re);
3433                     }
3434                     else {
3435                         STRLEN len;
3436                         const char * const t = SvPV_const(ret, len);
3437                         PMOP pm;
3438                         const I32 osize = PL_regsize;
3439
3440                         Zero(&pm, 1, PMOP);
3441                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3442                         re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3443                         if (!(SvFLAGS(ret)
3444                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3445                                 | SVs_GMG)))
3446                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3447                                         PERL_MAGIC_qr,0,0);
3448                         PL_regsize = osize;
3449                     }
3450                 }
3451
3452                 /* run the pattern returned from (??{...}) */
3453                 ST.cp = regcppush(0);   /* Save *all* the positions. */
3454                 REGCP_SET(ST.lastcp);
3455                 *PL_reglastparen = 0;
3456                 *PL_reglastcloseparen = 0;
3457                 PL_reginput = locinput;
3458
3459                 /* XXXX This is too dramatic a measure... */
3460                 PL_reg_maxiter = 0;
3461
3462                 st->logical = 0;
3463                 ST.toggle_reg_flags = PL_reg_flags;
3464                 if (re->reganch & ROPT_UTF8)
3465                     PL_reg_flags |= RF_utf8;
3466                 else
3467                     PL_reg_flags &= ~RF_utf8;
3468                 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3469
3470                 ST.prev_rex = rex;
3471                 ST.prev_curlyx = cur_curlyx;
3472                 rex = re;
3473                 cur_curlyx = NULL;
3474                 ST.B = next;
3475                 ST.prev_eval = cur_eval;
3476                 cur_eval = st;
3477
3478                 DEBUG_EXECUTE_r(
3479                     debug_start_match(re, do_utf8, locinput, PL_regeol,
3480                         "Matching embedded");
3481                     );
3482                 /* now continue from first node in postoned RE */
3483                 PUSH_YES_STATE_GOTO(EVAL_AB, re->program + 1);
3484                 /* NOTREACHED */
3485             }
3486             /* /(?(?{...})X|Y)/ */
3487             st->sw = SvTRUE(ret);
3488             st->logical = 0;
3489             break;
3490         }
3491
3492         case EVAL_AB: /* cleanup after a successful (??{A})B */
3493             /* note: this is called twice; first after popping B, then A */
3494             PL_reg_flags ^= ST.toggle_reg_flags;
3495             ReREFCNT_dec(rex);
3496             rex = ST.prev_rex;
3497             regcpblow(ST.cp);
3498             cur_eval = ST.prev_eval;
3499             cur_curlyx = ST.prev_curlyx;
3500             /* XXXX This is too dramatic a measure... */
3501             PL_reg_maxiter = 0;
3502             sayYES_FINAL;
3503
3504
3505         case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3506             /* note: this is called twice; first after popping B, then A */
3507             PL_reg_flags ^= ST.toggle_reg_flags;
3508             ReREFCNT_dec(rex);
3509             rex = ST.prev_rex;
3510             PL_reginput = locinput;
3511             REGCP_UNWIND(ST.lastcp);
3512             regcppop(rex);
3513             cur_eval = ST.prev_eval;
3514             cur_curlyx = ST.prev_curlyx;
3515             /* XXXX This is too dramatic a measure... */
3516             PL_reg_maxiter = 0;
3517             sayNO_SILENT;
3518
3519 #undef ST
3520
3521         case OPEN:
3522             n = ARG(scan);  /* which paren pair */
3523             PL_reg_start_tmp[n] = locinput;
3524             if (n > PL_regsize)
3525                 PL_regsize = n;
3526             break;
3527         case CLOSE:
3528             n = ARG(scan);  /* which paren pair */
3529             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3530             PL_regendp[n] = locinput - PL_bostr;
3531             if (n > (I32)*PL_reglastparen)
3532                 *PL_reglastparen = n;
3533             *PL_reglastcloseparen = n;
3534             break;
3535         case GROUPP:
3536             n = ARG(scan);  /* which paren pair */
3537             st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3538             break;
3539         case IFTHEN:
3540             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3541             if (st->sw)
3542                 next = NEXTOPER(NEXTOPER(scan));
3543             else {
3544                 next = scan + ARG(scan);
3545                 if (OP(next) == IFTHEN) /* Fake one. */
3546                     next = NEXTOPER(NEXTOPER(next));
3547             }
3548             break;
3549         case LOGICAL:
3550             st->logical = scan->flags;
3551             break;
3552 /*******************************************************************
3553  cur_curlyx points to the regmatch_state associated with the most recent CURLYX.
3554  This struct contains info about the innermost (...)* loop (an
3555  "infoblock"), and a pointer to the next outer cur_curlyx.
3556
3557  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3558
3559    1) After matching Y, regnode for CURLYX is processed;
3560
3561    2) This regnode populates cur_curlyx, and calls regmatch() recursively
3562       with the starting point at WHILEM node;
3563
3564    3) Each hit of WHILEM node tries to match A and Z (in the order
3565       depending on the current iteration, min/max of {min,max} and
3566       greediness).  The information about where are nodes for "A"
3567       and "Z" is read from cur_curlyx, as is info on how many times "A"
3568       was already matched, and greediness.
3569
3570    4) After A matches, the same WHILEM node is hit again.
3571
3572    5) Each time WHILEM is hit, cur_curlyx is the infoblock created by CURLYX
3573       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
3574       resets cur_curlyx, since this Y(A)*Z can be a part of some other loop:
3575       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
3576       of the external loop.
3577
3578  Currently present infoblocks form a tree with a stem formed by cur_curlyx
3579  and whatever it mentions via ->next, and additional attached trees
3580  corresponding to temporarily unset infoblocks as in "5" above.
3581
3582  In the following picture, infoblocks for outer loop of
3583  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
3584  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
3585  infoblocks are drawn below the "reset" infoblock.
3586
3587  In fact in the picture below we do not show failed matches for Z and T
3588  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
3589  more obvious *why* one needs to *temporary* unset infoblocks.]
3590
3591   Matched       REx position    InfoBlocks      Comment
3592                 (Y(A)*?Z)*?T    x
3593                 Y(A)*?Z)*?T     x <- O
3594   Y             (A)*?Z)*?T      x <- O
3595   Y             A)*?Z)*?T       x <- O <- I
3596   YA            )*?Z)*?T        x <- O <- I
3597   YA            A)*?Z)*?T       x <- O <- I
3598   YAA           )*?Z)*?T        x <- O <- I
3599   YAA           Z)*?T           x <- O          # Temporary unset I
3600                                      I
3601
3602   YAAZ          Y(A)*?Z)*?T     x <- O
3603                                      I
3604
3605   YAAZY         (A)*?Z)*?T      x <- O
3606                                      I
3607
3608   YAAZY         A)*?Z)*?T       x <- O <- I
3609                                      I
3610
3611   YAAZYA        )*?Z)*?T        x <- O <- I
3612                                      I
3613
3614   YAAZYA        Z)*?T           x <- O          # Temporary unset I
3615                                      I,I
3616
3617   YAAZYAZ       )*?T            x <- O
3618                                      I,I
3619
3620   YAAZYAZ       T               x               # Temporary unset O
3621                                 O
3622                                 I,I
3623
3624   YAAZYAZT                      x
3625                                 O
3626                                 I,I
3627  *******************************************************************/
3628
3629         case CURLYX: {
3630                 /* No need to save/restore up to this paren */
3631                 parenfloor = scan->flags;
3632
3633                 /* Dave says:
3634
3635                    CURLYX and WHILEM are always paired: they're the moral
3636                    equivalent of pp_enteriter anbd pp_iter.
3637
3638                    The only time next could be null is if the node tree is
3639                    corrupt. This was mentioned on p5p a few days ago.
3640
3641                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3642                    So we'll assert that this is true:
3643                 */
3644                 assert(next);
3645                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3646                     next += ARG(next);
3647                 /* XXXX Probably it is better to teach regpush to support
3648                    parenfloor > PL_regsize... */
3649                 if (parenfloor > (I32)*PL_reglastparen)
3650                     parenfloor = *PL_reglastparen; /* Pessimization... */
3651
3652                 st->u.curlyx.cp = PL_savestack_ix;
3653                 st->u.curlyx.outercc = cur_curlyx;
3654                 cur_curlyx = st;
3655                 /* these fields contain the state of the current curly.
3656                  * they are accessed by subsequent WHILEMs;
3657                  * cur and lastloc are also updated by WHILEM */
3658                 st->u.curlyx.parenfloor = parenfloor;
3659                 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3660                 st->u.curlyx.min = ARG1(scan);
3661                 st->u.curlyx.max  = ARG2(scan);
3662                 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3663                 st->u.curlyx.lastloc = 0;
3664                 /* st->next and st->minmod are also read by WHILEM */
3665
3666                 PL_reginput = locinput;
3667                 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3668                 /*** all unsaved local vars undefined at this point */
3669                 regcpblow(st->u.curlyx.cp);
3670                 cur_curlyx = st->u.curlyx.outercc;
3671                 saySAME(result);
3672             }
3673             /* NOTREACHED */
3674         case WHILEM: {
3675                 /*
3676                  * This is really hard to understand, because after we match
3677                  * what we're trying to match, we must make sure the rest of
3678                  * the REx is going to match for sure, and to do that we have
3679                  * to go back UP the parse tree by recursing ever deeper.  And
3680                  * if it fails, we have to reset our parent's current state
3681                  * that we can try again after backing off.
3682                  */
3683
3684                 /* Dave says:
3685
3686                    cur_curlyx gets initialised by CURLYX ready for use by WHILEM.
3687                    So again, unless somethings been corrupted, cur_curlyx cannot
3688                    be null at that point in WHILEM.
3689
3690                    See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3691                    So we'll assert that this is true:
3692                 */
3693                 assert(cur_curlyx);
3694                 st->u.whilem.lastloc = cur_curlyx->u.curlyx.lastloc; /* Detection of 0-len. */
3695                 st->u.whilem.cache_offset = 0;
3696                 st->u.whilem.cache_bit = 0;
3697
3698                 n = cur_curlyx->u.curlyx.cur + 1; /* how many we know we matched */
3699                 PL_reginput = locinput;
3700
3701                 DEBUG_EXECUTE_r(
3702                     PerlIO_printf(Perl_debug_log,
3703                                   "%*s  %ld out of %ld..%ld  cc=%"UVxf"\n",
3704                                   REPORT_CODE_OFF+depth*2, "",
3705                                   (long)n, (long)cur_curlyx->u.curlyx.min,
3706                                   (long)cur_curlyx->u.curlyx.max,
3707                                   PTR2UV(cur_curlyx))
3708                     );
3709
3710                 /* If degenerate scan matches "", assume scan done. */
3711
3712                 if (locinput == cur_curlyx->u.curlyx.lastloc && n >=
3713                     cur_curlyx->u.curlyx.min)
3714                 {
3715                     st->u.whilem.savecc = cur_curlyx;
3716                     cur_curlyx = cur_curlyx->u.curlyx.outercc;
3717                     if (cur_curlyx)
3718                         st->ln = cur_curlyx->u.curlyx.cur;
3719                     DEBUG_EXECUTE_r(
3720                         PerlIO_printf(Perl_debug_log,
3721                            "%*s  empty match detected, try continuation...\n",
3722                            REPORT_CODE_OFF+depth*2, "")
3723                         );
3724                     REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3725                     /*** all unsaved local vars undefined at this point */
3726                     cur_curlyx = st->u.whilem.savecc;
3727                     if (result)
3728                         sayYES;
3729                     if (cur_curlyx->u.curlyx.outercc)
3730                         cur_curlyx->u.curlyx.outercc->u.curlyx.cur = st->ln;
3731                     sayNO;
3732                 }
3733
3734                 /* First just match a string of min scans. */
3735
3736                 if (n < cur_curlyx->u.curlyx.min) {
3737                     cur_curlyx->u.curlyx.cur = n;
3738                     cur_curlyx->u.curlyx.lastloc = locinput;
3739                     REGMATCH(cur_curlyx->u.curlyx.scan, WHILEM2);
3740                     /*** all unsaved local vars undefined at this point */
3741                     if (result)
3742                         sayYES;
3743                     cur_curlyx->u.curlyx.cur = n - 1;
3744                     cur_curlyx->u.curlyx.lastloc = st->u.whilem.lastloc;
3745                     sayNO;
3746                 }
3747
3748                 if (scan->flags) {
3749                     /* Check whether we already were at this position.
3750                         Postpone detection until we know the match is not
3751                         *that* much linear. */
3752                 if (!PL_reg_maxiter) {
3753                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3754                     /* possible overflow for long strings and many CURLYX's */
3755                     if (PL_reg_maxiter < 0)
3756                         PL_reg_maxiter = I32_MAX;
3757                     PL_reg_leftiter = PL_reg_maxiter;
3758                 }
3759                 if (PL_reg_leftiter-- == 0) {
3760                     const I32 size = (PL_reg_maxiter + 7)/8;
3761                     if (PL_reg_poscache) {
3762                         if ((I32)PL_reg_poscache_size < size) {
3763                             Renew(PL_reg_poscache, size, char);
3764                             PL_reg_poscache_size = size;
3765                         }
3766                         Zero(PL_reg_poscache, size, char);
3767                     }
3768                     else {
3769                         PL_reg_poscache_size = size;
3770                         Newxz(PL_reg_poscache, size, char);
3771                     }
3772                     DEBUG_EXECUTE_r(
3773                         PerlIO_printf(Perl_debug_log,
3774               "%sDetected a super-linear match, switching on caching%s...\n",
3775                                       PL_colors[4], PL_colors[5])
3776                         );
3777                 }
3778                 if (PL_reg_leftiter < 0) {
3779                     st->u.whilem.cache_offset = locinput - PL_bostr;
3780
3781                     st->u.whilem.cache_offset = (scan->flags & 0xf) - 1
3782                             + st->u.whilem.cache_offset * (scan->flags>>4);
3783                     st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
3784                     st->u.whilem.cache_offset /= 8;
3785                     if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
3786                     DEBUG_EXECUTE_r(
3787                         PerlIO_printf(Perl_debug_log,
3788                                       "%*s  already tried at this position...\n",
3789                                       REPORT_CODE_OFF+depth*2, "")
3790                         );
3791                         sayNO; /* cache records failure */
3792                     }
3793                 }
3794                 }
3795
3796                 /* Prefer next over scan for minimal matching. */
3797
3798                 if (cur_curlyx->minmod) {
3799                     st->u.whilem.savecc = cur_curlyx;
3800                     cur_curlyx = cur_curlyx->u.curlyx.outercc;
3801                     if (cur_curlyx)
3802                         st->ln = cur_curlyx->u.curlyx.cur;
3803                     st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
3804                     REGCP_SET(st->u.whilem.lastcp);
3805                     REGMATCH(st->u.whilem.savecc->next, WHILEM3);
3806                     /*** all unsaved local vars undefined at this point */
3807                     cur_curlyx = st->u.whilem.savecc;
3808                     if (result) {
3809                         regcpblow(st->u.whilem.cp);
3810                         sayYES; /* All done. */
3811                     }
3812                     REGCP_UNWIND(st->u.whilem.lastcp);
3813                     regcppop(rex);
3814                     if (cur_curlyx->u.curlyx.outercc)
3815                         cur_curlyx->u.curlyx.outercc->u.curlyx.cur = st->ln;
3816
3817                     if (n >= cur_curlyx->u.curlyx.max) { /* Maximum greed exceeded? */
3818                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3819                             && !(PL_reg_flags & RF_warned)) {
3820                             PL_reg_flags |= RF_warned;
3821                             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3822                                  "Complex regular subexpression recursion",
3823                                  REG_INFTY - 1);
3824                         }
3825                         CACHEsayNO;
3826                     }
3827
3828                     DEBUG_EXECUTE_r(
3829                         PerlIO_printf(Perl_debug_log,
3830                                       "%*s  trying longer...\n",
3831                                       REPORT_CODE_OFF+depth*2, "")
3832                         );
3833                     /* Try scanning more and see if it helps. */
3834                     PL_reginput = locinput;
3835                     cur_curlyx->u.curlyx.cur = n;
3836                     cur_curlyx->u.curlyx.lastloc = locinput;
3837                     st->u.whilem.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
3838                     REGCP_SET(st->u.whilem.lastcp);
3839                     REGMATCH(cur_curlyx->u.curlyx.scan, WHILEM4);
3840                     /*** all unsaved local vars undefined at this point */
3841                     if (result) {
3842                         regcpblow(st->u.whilem.cp);
3843                         sayYES;
3844                     }
3845                     REGCP_UNWIND(st->u.whilem.lastcp);
3846                     regcppop(rex);
3847                     cur_curlyx->u.curlyx.cur = n - 1;
3848                     cur_curlyx->u.curlyx.lastloc = st->u.whilem.lastloc;
3849                     CACHEsayNO;
3850                 }
3851
3852                 /* Prefer scan over next for maximal matching. */
3853
3854                 if (n < cur_curlyx->u.curlyx.max) {     /* More greed allowed? */
3855                     st->u.whilem.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
3856                     cur_curlyx->u.curlyx.cur = n;
3857                     cur_curlyx->u.curlyx.lastloc = locinput;
3858                     REGCP_SET(st->u.whilem.lastcp);
3859                     REGMATCH(cur_curlyx->u.curlyx.scan, WHILEM5);
3860                     /*** all unsaved local vars undefined at this point */
3861                     if (result) {
3862                         regcpblow(st->u.whilem.cp);
3863                         sayYES;
3864                     }
3865                     REGCP_UNWIND(st->u.whilem.lastcp);
3866                     regcppop(rex);      /* Restore some previous $<digit>s? */
3867                     PL_reginput = locinput;
3868                     DEBUG_EXECUTE_r(
3869                         PerlIO_printf(Perl_debug_log,
3870                                       "%*s  failed, try continuation...\n",
3871                                       REPORT_CODE_OFF+depth*2, "")
3872                         );
3873                 }
3874                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3875                         && !(PL_reg_flags & RF_warned)) {
3876                     PL_reg_flags |= RF_warned;
3877                     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3878                          "Complex regular subexpression recursion",
3879                          REG_INFTY - 1);
3880                 }
3881
3882                 /* Failed deeper matches of scan, so see if this one works. */
3883                 st->u.whilem.savecc = cur_curlyx;
3884                 cur_curlyx = cur_curlyx->u.curlyx.outercc;
3885                 if (cur_curlyx)
3886                     st->ln = cur_curlyx->u.curlyx.cur;
3887                 REGMATCH(st->u.whilem.savecc->next, WHILEM6);
3888                 /*** all unsaved local vars undefined at this point */
3889                 cur_curlyx = st->u.whilem.savecc;
3890                 if (result)
3891                     sayYES;
3892                 if (cur_curlyx->u.curlyx.outercc)
3893                     cur_curlyx->u.curlyx.outercc->u.curlyx.cur = st->ln;
3894                 cur_curlyx->u.curlyx.cur = n - 1;
3895                 cur_curlyx->u.curlyx.lastloc = st->u.whilem.lastloc;
3896                 CACHEsayNO;
3897             }
3898             /* NOTREACHED */
3899
3900 #undef  ST
3901 #define ST st->u.branch
3902
3903         case BRANCHJ:       /*  /(...|A|...)/ with long next pointer */
3904             next = scan + ARG(scan);
3905             if (next == scan)
3906                 next = NULL;
3907             scan = NEXTOPER(scan);
3908             /* FALL THROUGH */
3909
3910         case BRANCH:        /*  /(...|A|...)/ */
3911             scan = NEXTOPER(scan); /* scan now points to inner node */
3912             if (!next || (OP(next) != BRANCH && OP(next) != BRANCHJ))
3913                 /* last branch; skip state push and jump direct to node */
3914                 continue;
3915             ST.lastparen = *PL_reglastparen;
3916             ST.next_branch = next;
3917             REGCP_SET(ST.cp);
3918             PL_reginput = locinput;
3919
3920             /* Now go into the branch */
3921             PUSH_STATE_GOTO(BRANCH_next, scan);
3922             /* NOTREACHED */
3923
3924         case BRANCH_next_fail: /* that branch failed; try the next, if any */
3925             REGCP_UNWIND(ST.cp);
3926             for (n = *PL_reglastparen; n > ST.lastparen; n--)
3927                 PL_regendp[n] = -1;
3928             *PL_reglastparen = n;
3929             scan = ST.next_branch;
3930             /* no more branches? */
3931             if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ))
3932                 sayNO;
3933             continue; /* execute next BRANCH[J] op */
3934             /* NOTREACHED */
3935
3936         case MINMOD:
3937             st->minmod = 1;
3938             break;
3939
3940 #undef  ST
3941 #define ST st->u.curlym
3942
3943         case CURLYM:    /* /A{m,n}B/ where A is fixed-length */
3944
3945             /* This is an optimisation of CURLYX that enables us to push
3946              * only a single backtracking state, no matter now many matches
3947              * there are in {m,n}. It relies on the pattern being constant
3948              * length, with no parens to influence future backrefs
3949              */
3950
3951             ST.me = scan;
3952             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3953
3954             /* if paren positive, emulate an OPEN/CLOSE around A */
3955             if (ST.me->flags) {
3956                 I32 paren = ST.me->flags;
3957                 if (paren > PL_regsize)
3958                     PL_regsize = paren;
3959                 if (paren > (I32)*PL_reglastparen)
3960                     *PL_reglastparen = paren;
3961                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3962             }
3963             ST.A = scan;
3964             ST.B = next;
3965             ST.alen = 0;
3966             ST.count = 0;
3967             ST.minmod = st->minmod;
3968             st->minmod = 0;
3969             ST.c1 = CHRTEST_UNINIT;
3970             REGCP_SET(ST.cp);
3971
3972             if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
3973                 goto curlym_do_B;
3974
3975           curlym_do_A: /* execute the A in /A{m,n}B/  */
3976             PL_reginput = locinput;
3977             PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
3978             /* NOTREACHED */
3979
3980         case CURLYM_A: /* we've just matched an A */
3981             locinput = st->locinput;
3982             nextchr = UCHARAT(locinput);
3983
3984             ST.count++;
3985             /* after first match, determine A's length: u.curlym.alen */
3986             if (ST.count == 1) {
3987                 if (PL_reg_match_utf8) {
3988                     char *s = locinput;
3989                     while (s < PL_reginput) {
3990                         ST.alen++;
3991                         s += UTF8SKIP(s);
3992                     }
3993                 }
3994                 else {
3995                     ST.alen = PL_reginput - locinput;
3996                 }
3997                 if (ST.alen == 0)
3998                     ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
3999             }
4000             DEBUG_EXECUTE_r(
4001                 PerlIO_printf(Perl_debug_log,
4002                           "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4003                           (int)(REPORT_CODE_OFF+(depth*2)), "",
4004                           (IV) ST.count, (IV)ST.alen)
4005             );
4006
4007             locinput = PL_reginput;
4008             if (ST.count < (ST.minmod ? ARG1(ST.me) : ARG2(ST.me)))
4009                 goto curlym_do_A; /* try to match another A */
4010             goto curlym_do_B; /* try to match B */
4011
4012         case CURLYM_A_fail: /* just failed to match an A */
4013             REGCP_UNWIND(ST.cp);
4014             if (ST.minmod || ST.count < ARG1(ST.me) /* min*/ )
4015                 sayNO;
4016
4017           curlym_do_B: /* execute the B in /A{m,n}B/  */
4018             PL_reginput = locinput;
4019             if (ST.c1 == CHRTEST_UNINIT) {
4020                 /* calculate c1 and c2 for possible match of 1st char
4021                  * following curly */
4022                 ST.c1 = ST.c2 = CHRTEST_VOID;
4023                 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4024                     regnode *text_node = ST.B;
4025                     if (! HAS_TEXT(text_node))
4026                         FIND_NEXT_IMPT(text_node);
4027                     if (HAS_TEXT(text_node)
4028                         && PL_regkind[OP(text_node)] != REF)
4029                     {
4030                         ST.c1 = (U8)*STRING(text_node);
4031                         ST.c2 =
4032                             (OP(text_node) == EXACTF || OP(text_node) == REFF)
4033                             ? PL_fold[ST.c1]
4034                             : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4035                                 ? PL_fold_locale[ST.c1]
4036                                 : ST.c1;
4037                     }
4038                 }
4039             }
4040
4041             DEBUG_EXECUTE_r(
4042                 PerlIO_printf(Perl_debug_log,
4043                     "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
4044                     (int)(REPORT_CODE_OFF+(depth*2)),
4045                     "", (IV)ST.count)
4046                 );
4047             if (ST.c1 != CHRTEST_VOID
4048                     && UCHARAT(PL_reginput) != ST.c1
4049                     && UCHARAT(PL_reginput) != ST.c2)
4050             {
4051                 /* simulate B failing */
4052                 state_num = CURLYM_B_fail;
4053                 goto reenter_switch;
4054             }
4055
4056             if (ST.me->flags) {
4057                 /* mark current A as captured */
4058                 I32 paren = ST.me->flags;
4059                 if (ST.count) {
4060                     PL_regstartp[paren]
4061                         = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4062                     PL_regendp[paren] = PL_reginput - PL_bostr;
4063                 }
4064                 else
4065                     PL_regendp[paren] = -1;
4066             }
4067             PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4068             /* NOTREACHED */
4069
4070         case CURLYM_B_fail: /* just failed to match a B */
4071             REGCP_UNWIND(ST.cp);
4072             if (ST.minmod) {
4073                 if (ST.count == ARG2(ST.me) /* max */)
4074                     sayNO;
4075                 goto curlym_do_A; /* try to match a further A */
4076             }
4077             /* backtrack one A */
4078             if (ST.count == ARG1(ST.me) /* min */)
4079                 sayNO;
4080             ST.count--;
4081             locinput = HOPc(locinput, -ST.alen);
4082             goto curlym_do_B; /* try to match B */
4083
4084 #undef ST
4085 #define ST st->u.curly
4086
4087 #define CURLY_SETPAREN(paren, success) \
4088     if (paren) { \
4089         if (success) { \
4090             PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr; \
4091             PL_regendp[paren] = locinput - PL_bostr; \
4092         } \
4093         else \
4094             PL_regendp[paren] = -1; \
4095     }
4096
4097         case STAR:              /*  /A*B/ where A is width 1 */
4098             ST.paren = 0;
4099             ST.min = 0;
4100             ST.max = REG_INFTY;
4101             scan = NEXTOPER(scan);
4102             goto repeat;
4103         case PLUS:              /*  /A+B/ where A is width 1 */
4104             ST.paren = 0;
4105             ST.min = 1;
4106             ST.max = REG_INFTY;
4107             scan = NEXTOPER(scan);
4108             goto repeat;
4109         case CURLYN:            /*  /(A){m,n}B/ where A is width 1 */
4110             ST.paren = scan->flags;     /* Which paren to set */
4111             if (ST.paren > PL_regsize)
4112                 PL_regsize = ST.paren;
4113             if (ST.paren > (I32)*PL_reglastparen)
4114                 *PL_reglastparen = ST.paren;
4115             ST.min = ARG1(scan);  /* min to match */
4116             ST.max = ARG2(scan);  /* max to match */
4117             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4118             goto repeat;
4119         case CURLY:             /*  /A{m,n}B/ where A is width 1 */
4120             ST.paren = 0;
4121             ST.min = ARG1(scan);  /* min to match */
4122             ST.max = ARG2(scan);  /* max to match */
4123             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4124           repeat:
4125             /*
4126             * Lookahead to avoid useless match attempts
4127             * when we know what character comes next.
4128             *
4129             * Used to only do .*x and .*?x, but now it allows
4130             * for )'s, ('s and (?{ ... })'s to be in the way
4131             * of the quantifier and the EXACT-like node.  -- japhy
4132             */
4133
4134             if (ST.min > ST.max) /* XXX make this a compile-time check? */
4135                 sayNO;
4136             if (HAS_TEXT(next) || JUMPABLE(next)) {
4137                 U8 *s;
4138                 regnode *text_node = next;
4139
4140                 if (! HAS_TEXT(text_node))
4141                     FIND_NEXT_IMPT(text_node);
4142
4143                 if (! HAS_TEXT(text_node))
4144                     ST.c1 = ST.c2 = CHRTEST_VOID;
4145                 else {
4146                     if (PL_regkind[OP(text_node)] == REF) {
4147                         ST.c1 = ST.c2 = CHRTEST_VOID;
4148                         goto assume_ok_easy;
4149                     }
4150                     else
4151                         s = (U8*)STRING(text_node);
4152
4153                     if (!UTF) {
4154                         ST.c2 = ST.c1 = *s;
4155                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4156                             ST.c2 = PL_fold[ST.c1];
4157                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4158                             ST.c2 = PL_fold_locale[ST.c1];
4159                     }
4160                     else { /* UTF */
4161                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4162                              STRLEN ulen1, ulen2;
4163                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4164                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4165
4166                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4167                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4168 #ifdef EBCDIC
4169                              ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4170                                                     ckWARN(WARN_UTF8) ?
4171                                                     0 : UTF8_ALLOW_ANY);
4172                              ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4173                                                     ckWARN(WARN_UTF8) ?
4174                                                     0 : UTF8_ALLOW_ANY);
4175 #else
4176                              ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4177                                                     uniflags);
4178                              ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4179                                                     uniflags);
4180 #endif
4181                         }
4182                         else {
4183                             ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4184                                                      uniflags);
4185                         }
4186                     }
4187                 }
4188             }
4189             else
4190                 ST.c1 = ST.c2 = CHRTEST_VOID;
4191         assume_ok_easy:
4192
4193             ST.A = scan;
4194             ST.B = next;
4195             PL_reginput = locinput;
4196             if (st->minmod) {
4197                 st->minmod = 0;
4198                 if (ST.min && regrepeat(rex, ST.A, ST.min) < ST.min)
4199                     sayNO;
4200                 ST.count = ST.min;
4201                 locinput = PL_reginput;
4202                 REGCP_SET(ST.cp);
4203                 if (ST.c1 == CHRTEST_VOID)
4204                     goto curly_try_B_min;
4205
4206                 ST.oldloc = locinput;
4207
4208                 /* set ST.maxpos to the furthest point along the
4209                  * string that could possibly match */
4210                 if  (ST.max == REG_INFTY) {
4211                     ST.maxpos = PL_regeol - 1;
4212                     if (do_utf8)
4213                         while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4214                             ST.maxpos--;
4215                 }
4216                 else if (do_utf8) {
4217                     int m = ST.max - ST.min;
4218                     for (ST.maxpos = locinput;
4219                          m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4220                         ST.maxpos += UTF8SKIP(ST.maxpos);
4221                 }
4222                 else {
4223                     ST.maxpos = locinput + ST.max - ST.min;
4224                     if (ST.maxpos >= PL_regeol)
4225                         ST.maxpos = PL_regeol - 1;
4226                 }
4227                 goto curly_try_B_min_known;
4228
4229             }
4230             else {
4231                 ST.count = regrepeat(rex, ST.A, ST.max);
4232                 locinput = PL_reginput;
4233                 if (ST.count < ST.min)
4234                     sayNO;
4235                 if ((ST.count > ST.min)
4236                     && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4237                 {
4238                     /* A{m,n} must come at the end of the string, there's
4239                      * no point in backing off ... */
4240                     ST.min = ST.count;
4241                     /* ...except that $ and \Z can match before *and* after
4242                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4243                        We may back off by one in this case. */
4244                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4245                         ST.min--;
4246                 }
4247                 REGCP_SET(ST.cp);
4248                 goto curly_try_B_max;
4249             }
4250             /* NOTREACHED */
4251
4252
4253         case CURLY_B_min_known_fail:
4254             /* failed to find B in a non-greedy match where c1,c2 valid */
4255             if (ST.paren && ST.count)
4256                 PL_regendp[ST.paren] = -1;
4257
4258             PL_reginput = locinput;     /* Could be reset... */
4259             REGCP_UNWIND(ST.cp);
4260             /* Couldn't or didn't -- move forward. */
4261             ST.oldloc = locinput;
4262             if (do_utf8)
4263                 locinput += UTF8SKIP(locinput);
4264             else
4265                 locinput++;
4266             ST.count++;
4267           curly_try_B_min_known:
4268              /* find the next place where 'B' could work, then call B */
4269             {
4270                 int n;
4271                 if (do_utf8) {
4272                     n = (ST.oldloc == locinput) ? 0 : 1;
4273                     if (ST.c1 == ST.c2) {
4274                         STRLEN len;
4275                         /* set n to utf8_distance(oldloc, locinput) */
4276                         while (locinput <= ST.maxpos &&
4277                                utf8n_to_uvchr((U8*)locinput,
4278                                               UTF8_MAXBYTES, &len,
4279                                               uniflags) != (UV)ST.c1) {
4280                             locinput += len;
4281                             n++;
4282                         }
4283                     }
4284                     else {
4285                         /* set n to utf8_distance(oldloc, locinput) */
4286                         while (locinput <= ST.maxpos) {
4287                             STRLEN len;
4288                             const UV c = utf8n_to_uvchr((U8*)locinput,
4289                                                   UTF8_MAXBYTES, &len,
4290                                                   uniflags);
4291                             if (c == (UV)ST.c1 || c == (UV)ST.c2)
4292                                 break;
4293                             locinput += len;
4294                             n++;
4295                         }
4296                     }
4297                 }
4298                 else {
4299                     if (ST.c1 == ST.c2) {
4300                         while (locinput <= ST.maxpos &&
4301                                UCHARAT(locinput) != ST.c1)
4302                             locinput++;
4303                     }
4304                     else {
4305                         while (locinput <= ST.maxpos
4306                                && UCHARAT(locinput) != ST.c1
4307                                && UCHARAT(locinput) != ST.c2)
4308                             locinput++;
4309                     }
4310                     n = locinput - ST.oldloc;
4311                 }
4312                 if (locinput > ST.maxpos)
4313                     sayNO;
4314                 /* PL_reginput == oldloc now */
4315                 if (n) {
4316                     ST.count += n;
4317                     if (regrepeat(rex, ST.A, n) < n)
4318                         sayNO;
4319                 }
4320                 PL_reginput = locinput;
4321                 CURLY_SETPAREN(ST.paren, ST.count);
4322                 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
4323             }
4324             /* NOTREACHED */
4325
4326
4327         case CURLY_B_min_fail:
4328             /* failed to find B in a non-greedy match where c1,c2 invalid */
4329             if (ST.paren && ST.count)
4330                 PL_regendp[ST.paren] = -1;
4331
4332             REGCP_UNWIND(ST.cp);
4333             /* failed -- move forward one */
4334             PL_reginput = locinput;
4335             if (regrepeat(rex, ST.A, 1)) {
4336                 ST.count++;
4337                 locinput = PL_reginput;
4338                 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
4339                         ST.count > 0)) /* count overflow ? */
4340                 {
4341                   curly_try_B_min:
4342                     CURLY_SETPAREN(ST.paren, ST.count);
4343                     PUSH_STATE_GOTO(CURLY_B_min, ST.B);
4344                 }
4345             }
4346             sayNO;
4347             /* NOTREACHED */
4348
4349
4350         curly_try_B_max:
4351             /* a successful greedy match: now try to match B */
4352             {
4353                 UV c = 0;
4354                 if (ST.c1 != CHRTEST_VOID)
4355                     c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
4356                                            UTF8_MAXBYTES, 0, uniflags)
4357                                 : (UV) UCHARAT(PL_reginput);
4358                 /* If it could work, try it. */
4359                 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
4360                     CURLY_SETPAREN(ST.paren, ST.count);
4361                     PUSH_STATE_GOTO(CURLY_B_max, ST.B);
4362                     /* NOTREACHED */
4363                 }
4364             }
4365             /* FALL THROUGH */
4366         case CURLY_B_max_fail:
4367             /* failed to find B in a greedy match */
4368             if (ST.paren && ST.count)
4369                 PL_regendp[ST.paren] = -1;
4370
4371             REGCP_UNWIND(ST.cp);
4372             /*  back up. */
4373             if (--ST.count < ST.min)
4374                 sayNO;
4375             PL_reginput = locinput = HOPc(locinput, -1);
4376             goto curly_try_B_max;
4377
4378 #undef ST
4379
4380
4381         case END:
4382             if (cur_eval) {
4383                 /* we've just finished A in /(??{A})B/; now continue with B */
4384                 I32 tmpix;
4385
4386
4387                 st->u.eval.toggle_reg_flags
4388                             = cur_eval->u.eval.toggle_reg_flags;
4389                 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
4390
4391                 st->u.eval.prev_rex = rex;              /* inner */
4392                 rex    = cur_eval->u.eval.prev_rex;     /* outer */
4393                 cur_curlyx = cur_eval->u.eval.prev_curlyx;
4394                 ReREFCNT_inc(rex);
4395                 st->u.eval.cp = regcppush(0);   /* Save *all* the positions. */
4396                 REGCP_SET(st->u.eval.lastcp);
4397                 PL_reginput = locinput;
4398
4399                 /* Restore parens of the outer rex without popping the
4400                  * savestack */
4401                 tmpix = PL_savestack_ix;
4402                 PL_savestack_ix = cur_eval->u.eval.lastcp;
4403                 regcppop(rex);
4404                 PL_savestack_ix = tmpix;
4405
4406                 st->u.eval.prev_eval = cur_eval;
4407                 cur_eval = cur_eval->u.eval.prev_eval;
4408                 DEBUG_EXECUTE_r(
4409                     PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ...\n",
4410                                       REPORT_CODE_OFF+depth*2, ""););
4411                 PUSH_YES_STATE_GOTO(EVAL_AB,
4412                         st->u.eval.prev_eval->u.eval.B); /* match B */
4413             }
4414
4415             if (locinput < reginfo->till) {
4416                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4417                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4418                                       PL_colors[4],
4419                                       (long)(locinput - PL_reg_starttry),
4420                                       (long)(reginfo->till - PL_reg_starttry),
4421                                       PL_colors[5]));
4422                 sayNO_FINAL;            /* Cannot match: too short. */
4423             }
4424             PL_reginput = locinput;     /* put where regtry can find it */
4425             sayYES_FINAL;               /* Success! */
4426
4427         case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4428             DEBUG_EXECUTE_r(
4429             PerlIO_printf(Perl_debug_log,
4430                 "%*s  %ssubpattern success...%s\n",
4431                 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
4432             PL_reginput = locinput;     /* put where regtry can find it */
4433             sayYES_FINAL;               /* Success! */
4434
4435 #undef  ST
4436 #define ST st->u.ifmatch
4437
4438         case SUSPEND:   /* (?>A) */
4439             ST.wanted = 1;
4440             PL_reginput = locinput;
4441             goto do_ifmatch;
4442
4443         case UNLESSM:   /* -ve lookaround: (?!A), or with flags, (?<!A) */
4444             ST.wanted = 0;
4445             goto ifmatch_trivial_fail_test;
4446
4447         case IFMATCH:   /* +ve lookaround: (?=A), or with flags, (?<=A) */
4448             ST.wanted = 1;
4449           ifmatch_trivial_fail_test:
4450             if (scan->flags) {
4451                 char * const s = HOPBACKc(locinput, scan->flags);
4452                 if (!s) {
4453                     /* trivial fail */
4454                     if (st->logical) {
4455                         st->logical = 0;
4456                         st->sw = 1 - (bool)ST.wanted;
4457                     }
4458                     else if (ST.wanted)
4459                         sayNO;
4460                     next = scan + ARG(scan);
4461                     if (next == scan)
4462                         next = NULL;
4463                     break;
4464                 }
4465                 PL_reginput = s;
4466             }
4467             else
4468                 PL_reginput = locinput;
4469
4470           do_ifmatch:
4471             ST.me = scan;
4472             /* execute body of (?...A) */
4473             PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
4474             /* NOTREACHED */
4475
4476         case IFMATCH_A_fail: /* body of (?...A) failed */
4477             ST.wanted = !ST.wanted;
4478             /* FALL THROUGH */
4479
4480         case IFMATCH_A: /* body of (?...A) succeeded */
4481             if (st->logical) {
4482                 st->logical = 0;
4483                 st->sw = (bool)ST.wanted;
4484             }
4485             else if (!ST.wanted)
4486                 sayNO;
4487
4488             if (OP(ST.me) == SUSPEND)
4489                 locinput = PL_reginput;
4490             else {
4491                 locinput = PL_reginput = st->locinput;
4492                 nextchr = UCHARAT(locinput);
4493             }
4494             scan = ST.me + ARG(ST.me);
4495             if (scan == ST.me)
4496                 scan = NULL;
4497             continue; /* execute B */
4498
4499 #undef ST
4500
4501         case LONGJMP:
4502             next = scan + ARG(scan);
4503             if (next == scan)
4504                 next = NULL;
4505             break;
4506         default:
4507             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4508                           PTR2UV(scan), OP(scan));
4509             Perl_croak(aTHX_ "regexp memory corruption");
4510         }
4511
4512         scan = next;
4513         continue;
4514         /* NOTREACHED */
4515
4516       push_yes_state:
4517         /* push a state that backtracks on success */
4518         st->u.yes.prev_yes_state = yes_state;
4519         yes_state = st;
4520         /* FALL THROUGH */
4521       push_state:
4522         /* push a new regex state, then continue at scan  */
4523         {
4524             regmatch_state *newst;
4525
4526             DEBUG_STATE_pp("push");
4527             depth++;
4528             st->locinput = locinput;
4529             newst = st+1;
4530             if (newst >  SLAB_LAST(PL_regmatch_slab))
4531                 newst = S_push_slab(aTHX);
4532             PL_regmatch_state = newst;
4533             /* XXX probably don't need to initialise these */
4534             newst->minmod = 0;
4535             newst->sw = 0;
4536             newst->logical = 0;
4537
4538
4539             locinput = PL_reginput;
4540             nextchr = UCHARAT(locinput);
4541             st = newst;
4542             continue;
4543             /* NOTREACHED */
4544         }
4545
4546         /* simulate recursively calling regmatch(), but without actually
4547          * recursing - ie save the current state on the heap rather than on
4548          * the stack, then re-enter the loop. This avoids complex regexes
4549          * blowing the processor stack */
4550
4551       start_recurse:
4552         {
4553             /* push new state */
4554             regmatch_state *oldst = st;
4555
4556             DEBUG_STATE_pp("push");
4557             depth++;
4558
4559             /* grab the next free state slot */
4560             st++;
4561             if (st >  SLAB_LAST(PL_regmatch_slab))
4562                 st = S_push_slab(aTHX);
4563             PL_regmatch_state = st;
4564
4565             oldst->next = next;
4566             oldst->n = n;
4567             oldst->locinput = locinput;
4568
4569             locinput = PL_reginput;
4570             nextchr = UCHARAT(locinput);
4571             st->minmod = 0;
4572             st->sw = 0;
4573             st->logical = 0;
4574
4575         }
4576     }
4577
4578
4579
4580     /*
4581     * We get here only if there's trouble -- normally "case END" is
4582     * the terminating point.
4583     */
4584     Perl_croak(aTHX_ "corrupted regexp pointers");
4585     /*NOTREACHED*/
4586     sayNO;
4587
4588 yes_final:
4589
4590     if (yes_state) {
4591         /* we have successfully completed a subexpression, but we must now
4592          * pop to the state marked by yes_state and continue from there */
4593         assert(st != yes_state);
4594 #ifdef DEBUGGING
4595         while (st != yes_state) {
4596             st--;
4597             if (st < SLAB_FIRST(PL_regmatch_slab)) {
4598                 PL_regmatch_slab = PL_regmatch_slab->prev;
4599                 st = SLAB_LAST(PL_regmatch_slab);
4600             }
4601             DEBUG_STATE_pp("pop (yes)");
4602             depth--;
4603         }
4604 #else
4605         while (yes_state < SLAB_FIRST(PL_regmatch_slab)
4606             || yes_state > SLAB_LAST(PL_regmatch_slab))
4607         {
4608             /* not in this slab, pop slab */
4609             depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
4610             PL_regmatch_slab = PL_regmatch_slab->prev;
4611             st = SLAB_LAST(PL_regmatch_slab);
4612         }
4613         depth -= (st - yes_state);
4614 #endif
4615         st = yes_state;
4616         yes_state = st->u.yes.prev_yes_state;
4617         PL_regmatch_state = st;
4618
4619         switch (st->resume_state) {
4620         case EVAL_AB:
4621         case IFMATCH_A:
4622         case CURLYM_A:
4623             state_num = st->resume_state;
4624             goto reenter_switch;
4625
4626         case CURLYM_B:
4627         case BRANCH_next:
4628         case TRIE_next:
4629         case CURLY_B_max:
4630         default:
4631             Perl_croak(aTHX_ "unexpected yes resume state");
4632         }
4633     }
4634
4635     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4636                           PL_colors[4], PL_colors[5]));
4637 yes:
4638
4639     result = 1;
4640     /* XXX this is duplicate(ish) code to that in the do_no section.
4641      * will disappear when REGFMATCH goes */
4642     if (depth) {
4643         /* restore previous state and re-enter */
4644         st--;
4645         if (st < SLAB_FIRST(PL_regmatch_slab)) {
4646             PL_regmatch_slab = PL_regmatch_slab->prev;
4647             st = SLAB_LAST(PL_regmatch_slab);
4648         }
4649         PL_regmatch_state = st;
4650         scan    = st->scan;
4651         next    = st->next;
4652         n       = st->n;
4653         locinput= st->locinput;
4654         nextchr = UCHARAT(locinput);
4655
4656         DEBUG_STATE_pp("pop");
4657         depth--;
4658
4659         switch (st->resume_state) {
4660         case resume_CURLYX:
4661             goto resume_point_CURLYX;
4662         case resume_WHILEM1:
4663             goto resume_point_WHILEM1;
4664         case resume_WHILEM2:
4665             goto resume_point_WHILEM2;
4666         case resume_WHILEM3:
4667             goto resume_point_WHILEM3;
4668         case resume_WHILEM4:
4669             goto resume_point_WHILEM4;
4670         case resume_WHILEM5:
4671             goto resume_point_WHILEM5;
4672         case resume_WHILEM6:
4673             goto resume_point_WHILEM6;
4674
4675         case TRIE_next:
4676         case CURLYM_A:
4677         case CURLYM_B:
4678         case EVAL_AB:
4679         case IFMATCH_A:
4680         case BRANCH_next:
4681         case CURLY_B_max:
4682         case CURLY_B_min:
4683         case CURLY_B_min_known:
4684             break;
4685
4686         default:
4687             Perl_croak(aTHX_ "regexp resume memory corruption");
4688         }
4689     }
4690     goto final_exit;
4691
4692 no:
4693     DEBUG_EXECUTE_r(
4694         PerlIO_printf(Perl_debug_log,
4695             "%*s  %sfailed...%s\n",
4696             REPORT_CODE_OFF+depth*2, "",
4697             PL_colors[4], PL_colors[5])
4698         );
4699 no_final:
4700 do_no:
4701
4702     result = 0;
4703
4704     if (depth) {
4705         /* there's a previous state to backtrack to */
4706         st--;
4707         if (st < SLAB_FIRST(PL_regmatch_slab)) {
4708             PL_regmatch_slab = PL_regmatch_slab->prev;
4709             st = SLAB_LAST(PL_regmatch_slab);
4710         }
4711         PL_regmatch_state = st;
4712         scan    = st->scan;
4713         next    = st->next;
4714         n       = st->n;
4715         locinput= st->locinput;
4716         nextchr = UCHARAT(locinput);
4717
4718         DEBUG_STATE_pp("pop");
4719         depth--;
4720
4721         switch (st->resume_state) {
4722         case resume_CURLYX:
4723             goto resume_point_CURLYX;
4724         case resume_WHILEM1:
4725             goto resume_point_WHILEM1;
4726         case resume_WHILEM2:
4727             goto resume_point_WHILEM2;
4728         case resume_WHILEM3:
4729             goto resume_point_WHILEM3;
4730         case resume_WHILEM4:
4731             goto resume_point_WHILEM4;
4732         case resume_WHILEM5:
4733             goto resume_point_WHILEM5;
4734         case resume_WHILEM6:
4735             goto resume_point_WHILEM6;
4736
4737         case TRIE_next:
4738         case EVAL_AB:
4739         case BRANCH_next:
4740         case CURLYM_A:
4741         case CURLYM_B:
4742         case IFMATCH_A:
4743         case CURLY_B_max:
4744         case CURLY_B_min:
4745         case CURLY_B_min_known:
4746             if (yes_state == st)
4747                 yes_state = st->u.yes.prev_yes_state;
4748             state_num = st->resume_state + 1; /* failure = success + 1 */
4749             goto reenter_switch;
4750
4751         default:
4752             Perl_croak(aTHX_ "regexp resume memory corruption");
4753         }
4754     }
4755
4756 final_exit:
4757
4758     /* restore original high-water mark */
4759     PL_regmatch_slab  = orig_slab;
4760     PL_regmatch_state = orig_state;
4761
4762     /* free all slabs above current one */
4763     if (orig_slab->next) {
4764         regmatch_slab *sl = orig_slab->next;
4765         orig_slab->next = NULL;
4766         while (sl) {
4767             regmatch_slab * const osl = sl;
4768             sl = sl->next;
4769             Safefree(osl);
4770         }
4771     }
4772
4773     return result;
4774
4775 }
4776
4777 /*
4778  - regrepeat - repeatedly match something simple, report how many
4779  */
4780 /*
4781  * [This routine now assumes that it will only match on things of length 1.
4782  * That was true before, but now we assume scan - reginput is the count,
4783  * rather than incrementing count on every character.  [Er, except utf8.]]
4784  */
4785 STATIC I32
4786 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max)
4787 {
4788     dVAR;
4789     register char *scan;
4790     register I32 c;
4791     register char *loceol = PL_regeol;
4792     register I32 hardcount = 0;
4793     register bool do_utf8 = PL_reg_match_utf8;
4794
4795     scan = PL_reginput;
4796     if (max == REG_INFTY)
4797         max = I32_MAX;
4798     else if (max < loceol - scan)
4799         loceol = scan + max;
4800     switch (OP(p)) {
4801     case REG_ANY:
4802         if (do_utf8) {
4803             loceol = PL_regeol;
4804             while (scan < loceol && hardcount < max && *scan != '\n') {
4805                 scan += UTF8SKIP(scan);
4806                 hardcount++;
4807             }
4808         } else {
4809             while (scan < loceol && *scan != '\n')
4810                 scan++;
4811         }
4812         break;
4813     case SANY:
4814         if (do_utf8) {
4815             loceol = PL_regeol;
4816             while (scan < loceol && hardcount < max) {
4817                 scan += UTF8SKIP(scan);
4818                 hardcount++;
4819             }
4820         }
4821         else
4822             scan = loceol;
4823         break;
4824     case CANY:
4825         scan = loceol;
4826         break;
4827     case EXACT:         /* length of string is 1 */
4828         c = (U8)*STRING(p);
4829         while (scan < loceol && UCHARAT(scan) == c)
4830             scan++;
4831         break;
4832     case EXACTF:        /* length of string is 1 */
4833         c = (U8)*STRING(p);
4834         while (scan < loceol &&
4835                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4836             scan++;
4837         break;
4838     case EXACTFL:       /* length of string is 1 */
4839         PL_reg_flags |= RF_tainted;
4840         c = (U8)*STRING(p);
4841         while (scan < loceol &&
4842                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4843             scan++;
4844         break;
4845     case ANYOF:
4846         if (do_utf8) {
4847             loceol = PL_regeol;
4848             while (hardcount < max && scan < loceol &&
4849                    reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
4850                 scan += UTF8SKIP(scan);
4851                 hardcount++;
4852             }
4853         } else {
4854             while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
4855                 scan++;
4856         }
4857         break;
4858     case ALNUM:
4859         if (do_utf8) {
4860             loceol = PL_regeol;
4861             LOAD_UTF8_CHARCLASS_ALNUM();
4862             while (hardcount < max && scan < loceol &&
4863                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4864                 scan += UTF8SKIP(scan);
4865                 hardcount++;
4866             }
4867         } else {
4868             while (scan < loceol && isALNUM(*scan))
4869                 scan++;
4870         }
4871         break;
4872     case ALNUML:
4873         PL_reg_flags |= RF_tainted;
4874         if (do_utf8) {
4875             loceol = PL_regeol;
4876             while (hardcount < max && scan < loceol &&
4877                    isALNUM_LC_utf8((U8*)scan)) {
4878                 scan += UTF8SKIP(scan);
4879                 hardcount++;
4880             }
4881         } else {
4882             while (scan < loceol && isALNUM_LC(*scan))
4883                 scan++;
4884         }
4885         break;
4886     case NALNUM:
4887         if (do_utf8) {
4888             loceol = PL_regeol;
4889             LOAD_UTF8_CHARCLASS_ALNUM();
4890             while (hardcount < max && scan < loceol &&
4891                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4892                 scan += UTF8SKIP(scan);
4893                 hardcount++;
4894             }
4895         } else {
4896             while (scan < loceol && !isALNUM(*scan))
4897                 scan++;
4898         }
4899         break;
4900     case NALNUML:
4901         PL_reg_flags |= RF_tainted;
4902         if (do_utf8) {
4903             loceol = PL_regeol;
4904             while (hardcount < max && scan < loceol &&
4905                    !isALNUM_LC_utf8((U8*)scan)) {
4906                 scan += UTF8SKIP(scan);
4907                 hardcount++;
4908             }
4909         } else {
4910             while (scan < loceol && !isALNUM_LC(*scan))
4911                 scan++;
4912         }
4913         break;
4914     case SPACE:
4915         if (do_utf8) {
4916             loceol = PL_regeol;
4917             LOAD_UTF8_CHARCLASS_SPACE();
4918             while (hardcount < max && scan < loceol &&
4919                    (*scan == ' ' ||
4920                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4921                 scan += UTF8SKIP(scan);
4922                 hardcount++;
4923             }
4924         } else {
4925             while (scan < loceol && isSPACE(*scan))
4926                 scan++;
4927         }
4928         break;
4929     case SPACEL:
4930         PL_reg_flags |= RF_tainted;
4931         if (do_utf8) {
4932             loceol = PL_regeol;
4933             while (hardcount < max && scan < loceol &&
4934                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4935                 scan += UTF8SKIP(scan);
4936                 hardcount++;
4937             }
4938         } else {
4939             while (scan < loceol && isSPACE_LC(*scan))
4940                 scan++;
4941         }
4942         break;
4943     case NSPACE:
4944         if (do_utf8) {
4945             loceol = PL_regeol;
4946             LOAD_UTF8_CHARCLASS_SPACE();
4947             while (hardcount < max && scan < loceol &&
4948                    !(*scan == ' ' ||
4949                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4950                 scan += UTF8SKIP(scan);
4951                 hardcount++;
4952             }
4953         } else {
4954             while (scan < loceol && !isSPACE(*scan))
4955                 scan++;
4956             break;
4957         }
4958     case NSPACEL:
4959         PL_reg_flags |= RF_tainted;
4960         if (do_utf8) {
4961             loceol = PL_regeol;
4962             while (hardcount < max && scan < loceol &&
4963                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4964                 scan += UTF8SKIP(scan);
4965                 hardcount++;
4966             }
4967         } else {
4968             while (scan < loceol && !isSPACE_LC(*scan))
4969                 scan++;
4970         }
4971         break;
4972     case DIGIT:
4973         if (do_utf8) {
4974             loceol = PL_regeol;
4975             LOAD_UTF8_CHARCLASS_DIGIT();
4976             while (hardcount < max && scan < loceol &&
4977                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4978                 scan += UTF8SKIP(scan);
4979                 hardcount++;
4980             }
4981         } else {
4982             while (scan < loceol && isDIGIT(*scan))
4983                 scan++;
4984         }
4985         break;
4986     case NDIGIT:
4987         if (do_utf8) {
4988             loceol = PL_regeol;
4989             LOAD_UTF8_CHARCLASS_DIGIT();
4990             while (hardcount < max && scan < loceol &&
4991                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4992                 scan += UTF8SKIP(scan);
4993                 hardcount++;
4994             }
4995         } else {
4996             while (scan < loceol && !isDIGIT(*scan))
4997                 scan++;
4998         }
4999         break;
5000     default:            /* Called on something of 0 width. */
5001         break;          /* So match right here or not at all. */
5002     }
5003
5004     if (hardcount)
5005         c = hardcount;
5006     else
5007         c = scan - PL_reginput;
5008     PL_reginput = scan;
5009
5010     DEBUG_r({
5011         GET_RE_DEBUG_FLAGS_DECL;
5012         DEBUG_EXECUTE_r({
5013             SV * const prop = sv_newmortal();
5014             regprop(prog, prop, p);
5015             PerlIO_printf(Perl_debug_log,
5016                         "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
5017                         REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
5018         });
5019     });
5020
5021     return(c);
5022 }
5023
5024
5025 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5026 /*
5027 - regclass_swash - prepare the utf8 swash
5028 */
5029
5030 SV *
5031 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5032 {
5033     dVAR;
5034     SV *sw  = NULL;
5035     SV *si  = NULL;
5036     SV *alt = NULL;
5037     const struct reg_data * const data = prog ? prog->data : NULL;
5038
5039     if (data && data->count) {
5040         const U32 n = ARG(node);
5041
5042         if (data->what[n] == 's') {
5043             SV * const rv = (SV*)data->data[n];
5044             AV * const av = (AV*)SvRV((SV*)rv);
5045             SV **const ary = AvARRAY(av);
5046             SV **a, **b;
5047
5048             /* See the end of regcomp.c:S_regclass() for
5049              * documentation of these array elements. */
5050
5051             si = *ary;
5052             a  = SvROK(ary[1]) ? &ary[1] : 0;
5053             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
5054
5055             if (a)
5056                 sw = *a;
5057             else if (si && doinit) {
5058                 sw = swash_init("utf8", "", si, 1, 0);
5059                 (void)av_store(av, 1, sw);
5060             }
5061             if (b)
5062                 alt = *b;
5063         }
5064     }
5065
5066     if (listsvp)
5067         *listsvp = si;
5068     if (altsvp)
5069         *altsvp  = alt;
5070
5071     return sw;
5072 }
5073 #endif
5074
5075 /*
5076  - reginclass - determine if a character falls into a character class
5077
5078   The n is the ANYOF regnode, the p is the target string, lenp
5079   is pointer to the maximum length of how far to go in the p
5080   (if the lenp is zero, UTF8SKIP(p) is used),
5081   do_utf8 tells whether the target string is in UTF-8.
5082
5083  */
5084
5085 STATIC bool
5086 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5087 {
5088     dVAR;
5089     const char flags = ANYOF_FLAGS(n);
5090     bool match = FALSE;
5091     UV c = *p;
5092     STRLEN len = 0;
5093     STRLEN plen;
5094
5095     if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5096         c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5097                 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5098                 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5099         if (len == (STRLEN)-1)
5100             Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5101     }
5102
5103     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5104     if (do_utf8 || (flags & ANYOF_UNICODE)) {
5105         if (lenp)
5106             *lenp = 0;
5107         if (do_utf8 && !ANYOF_RUNTIME(n)) {
5108             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5109                 match = TRUE;
5110         }
5111         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5112             match = TRUE;
5113         if (!match) {
5114             AV *av;
5115             SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5116
5117             if (sw) {
5118                 if (swash_fetch(sw, p, do_utf8))
5119                     match = TRUE;
5120                 else if (flags & ANYOF_FOLD) {
5121                     if (!match && lenp && av) {
5122                         I32 i;
5123                         for (i = 0; i <= av_len(av); i++) {
5124                             SV* const sv = *av_fetch(av, i, FALSE);
5125                             STRLEN len;
5126                             const char * const s = SvPV_const(sv, len);
5127
5128                             if (len <= plen && memEQ(s, (char*)p, len)) {
5129                                 *lenp = len;
5130                                 match = TRUE;
5131                                 break;
5132                             }
5133                         }
5134                     }
5135                     if (!match) {
5136                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5137                         STRLEN tmplen;
5138
5139                         to_utf8_fold(p, tmpbuf, &tmplen);
5140                         if (swash_fetch(sw, tmpbuf, do_utf8))
5141                             match = TRUE;
5142                     }
5143                 }
5144             }
5145         }
5146         if (match && lenp && *lenp == 0)
5147             *lenp = UNISKIP(NATIVE_TO_UNI(c));
5148     }
5149     if (!match && c < 256) {
5150         if (ANYOF_BITMAP_TEST(n, c))
5151             match = TRUE;
5152         else if (flags & ANYOF_FOLD) {
5153             U8 f;
5154
5155             if (flags & ANYOF_LOCALE) {
5156                 PL_reg_flags |= RF_tainted;
5157                 f = PL_fold_locale[c];
5158             }
5159             else
5160                 f = PL_fold[c];
5161             if (f != c && ANYOF_BITMAP_TEST(n, f))
5162                 match = TRUE;
5163         }
5164
5165         if (!match && (flags & ANYOF_CLASS)) {
5166             PL_reg_flags |= RF_tainted;
5167             if (
5168                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
5169                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
5170                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
5171                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
5172                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
5173                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
5174                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
5175                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5176                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
5177                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
5178                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
5179                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
5180                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
5181                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
5182                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
5183                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
5184                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
5185                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
5186                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
5187                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
5188                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
5189                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
5190                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
5191                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
5192                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
5193                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
5194                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
5195                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
5196                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
5197                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
5198                 ) /* How's that for a conditional? */
5199             {
5200                 match = TRUE;
5201             }
5202         }
5203     }
5204
5205     return (flags & ANYOF_INVERT) ? !match : match;
5206 }
5207
5208 STATIC U8 *
5209 S_reghop3(U8 *s, I32 off, const U8* lim)
5210 {
5211     dVAR;
5212     if (off >= 0) {
5213         while (off-- && s < lim) {
5214             /* XXX could check well-formedness here */
5215             s += UTF8SKIP(s);
5216         }
5217     }
5218     else {
5219         while (off++ && s > lim) {
5220             s--;
5221             if (UTF8_IS_CONTINUED(*s)) {
5222                 while (s > lim && UTF8_IS_CONTINUATION(*s))
5223                     s--;
5224             }
5225             /* XXX could check well-formedness here */
5226         }
5227     }
5228     return s;
5229 }
5230
5231 STATIC U8 *
5232 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
5233 {
5234     dVAR;
5235     if (off >= 0) {
5236         while (off-- && s < rlim) {
5237             /* XXX could check well-formedness here */
5238             s += UTF8SKIP(s);
5239         }
5240     }
5241     else {
5242         while (off++ && s > llim) {
5243             s--;
5244             if (UTF8_IS_CONTINUED(*s)) {
5245                 while (s > llim && UTF8_IS_CONTINUATION(*s))
5246                     s--;
5247             }
5248             /* XXX could check well-formedness here */
5249         }
5250     }
5251     return s;
5252 }
5253
5254
5255 STATIC U8 *
5256 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5257 {
5258     dVAR;
5259     if (off >= 0) {
5260         while (off-- && s < lim) {
5261             /* XXX could check well-formedness here */
5262             s += UTF8SKIP(s);
5263         }
5264         if (off >= 0)
5265             return NULL;
5266     }
5267     else {
5268         while (off++ && s > lim) {
5269             s--;
5270             if (UTF8_IS_CONTINUED(*s)) {
5271                 while (s > lim && UTF8_IS_CONTINUATION(*s))
5272                     s--;
5273             }
5274             /* XXX could check well-formedness here */
5275         }
5276         if (off <= 0)
5277             return NULL;
5278     }
5279     return s;
5280 }
5281
5282 static void
5283 restore_pos(pTHX_ void *arg)
5284 {
5285     dVAR;
5286     regexp * const rex = (regexp *)arg;
5287     if (PL_reg_eval_set) {
5288         if (PL_reg_oldsaved) {
5289             rex->subbeg = PL_reg_oldsaved;
5290             rex->sublen = PL_reg_oldsavedlen;
5291 #ifdef PERL_OLD_COPY_ON_WRITE
5292             rex->saved_copy = PL_nrs;
5293 #endif
5294             RX_MATCH_COPIED_on(rex);
5295         }
5296         PL_reg_magic->mg_len = PL_reg_oldpos;
5297         PL_reg_eval_set = 0;
5298         PL_curpm = PL_reg_oldcurpm;
5299     }
5300 }
5301
5302 STATIC void
5303 S_to_utf8_substr(pTHX_ register regexp *prog)
5304 {
5305     if (prog->float_substr && !prog->float_utf8) {
5306         SV* const sv = newSVsv(prog->float_substr);
5307         prog->float_utf8 = sv;
5308         sv_utf8_upgrade(sv);
5309         if (SvTAIL(prog->float_substr))
5310             SvTAIL_on(sv);
5311         if (prog->float_substr == prog->check_substr)
5312             prog->check_utf8 = sv;
5313     }
5314     if (prog->anchored_substr && !prog->anchored_utf8) {
5315         SV* const sv = newSVsv(prog->anchored_substr);
5316         prog->anchored_utf8 = sv;
5317         sv_utf8_upgrade(sv);
5318         if (SvTAIL(prog->anchored_substr))
5319             SvTAIL_on(sv);
5320         if (prog->anchored_substr == prog->check_substr)
5321             prog->check_utf8 = sv;
5322     }
5323 }
5324
5325 STATIC void
5326 S_to_byte_substr(pTHX_ register regexp *prog)
5327 {
5328     dVAR;
5329     if (prog->float_utf8 && !prog->float_substr) {
5330         SV* sv = newSVsv(prog->float_utf8);
5331         prog->float_substr = sv;
5332         if (sv_utf8_downgrade(sv, TRUE)) {
5333             if (SvTAIL(prog->float_utf8))
5334                 SvTAIL_on(sv);
5335         } else {
5336             SvREFCNT_dec(sv);
5337             prog->float_substr = sv = &PL_sv_undef;
5338         }
5339         if (prog->float_utf8 == prog->check_utf8)
5340             prog->check_substr = sv;
5341     }
5342     if (prog->anchored_utf8 && !prog->anchored_substr) {
5343         SV* sv = newSVsv(prog->anchored_utf8);
5344         prog->anchored_substr = sv;
5345         if (sv_utf8_downgrade(sv, TRUE)) {
5346             if (SvTAIL(prog->anchored_utf8))
5347                 SvTAIL_on(sv);
5348         } else {
5349             SvREFCNT_dec(sv);
5350             prog->anchored_substr = sv = &PL_sv_undef;
5351         }
5352         if (prog->anchored_utf8 == prog->check_utf8)
5353             prog->check_substr = sv;
5354     }
5355 }
5356
5357 /*
5358  * Local variables:
5359  * c-indentation-style: bsd
5360  * c-basic-offset: 4
5361  * indent-tabs-mode: t
5362  * End:
5363  *
5364  * ex: set ts=8 sts=4 sw=4 noet:
5365  */