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