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