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