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->startp[0] = startpos - PL_bostr;
2225         prog->endp[0] = PL_reginput - PL_bostr;
2226         return 1;
2227     }
2228     REGCP_UNWIND(lastcp);
2229     return 0;
2230 }
2231
2232 #define RE_UNWIND_BRANCH        1
2233 #define RE_UNWIND_BRANCHJ       2
2234
2235 union re_unwind_t;
2236
2237 typedef struct {                /* XX: makes sense to enlarge it... */
2238     I32 type;
2239     I32 prev;
2240     CHECKPOINT lastcp;
2241 } re_unwind_generic_t;
2242
2243 typedef struct {
2244     I32 type;
2245     I32 prev;
2246     CHECKPOINT lastcp;
2247     I32 lastparen;
2248     regnode *next;
2249     char *locinput;
2250     I32 nextchr;
2251 #ifdef DEBUGGING
2252     int regindent;
2253 #endif
2254 } re_unwind_branch_t;
2255
2256 typedef union re_unwind_t {
2257     I32 type;
2258     re_unwind_generic_t generic;
2259     re_unwind_branch_t branch;
2260 } re_unwind_t;
2261
2262 #define sayYES goto yes
2263 #define sayNO goto no
2264 #define sayNO_ANYOF goto no_anyof
2265 #define sayYES_FINAL goto yes_final
2266 #define sayYES_LOUD  goto yes_loud
2267 #define sayNO_FINAL  goto no_final
2268 #define sayNO_SILENT goto do_no
2269 #define saySAME(x) if (x) goto yes; else goto no
2270
2271 #define POSCACHE_SUCCESS 0      /* caching success rather than failure */
2272 #define POSCACHE_SEEN 1         /* we know what we're caching */
2273 #define POSCACHE_START 2        /* the real cache: this bit maps to pos 0 */
2274 #define CACHEsayYES STMT_START { \
2275     if (cache_offset | cache_bit) { \
2276         if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) \
2277             PL_reg_poscache[0] |= (1<<POSCACHE_SUCCESS) || (1<<POSCACHE_SEEN); \
2278         else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2279             /* cache records failure, but this is success */ \
2280             DEBUG_r( \
2281                 PerlIO_printf(Perl_debug_log, \
2282                     "%*s  (remove success from failure cache)\n", \
2283                     REPORT_CODE_OFF+PL_regindent*2, "") \
2284             ); \
2285             PL_reg_poscache[cache_offset] &= ~(1<<cache_bit); \
2286         } \
2287     } \
2288     sayYES; \
2289 } STMT_END
2290 #define CACHEsayNO STMT_START { \
2291     if (cache_offset | cache_bit) { \
2292         if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) \
2293             PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2294         else if ((PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2295             /* cache records success, but this is failure */ \
2296             DEBUG_r( \
2297                 PerlIO_printf(Perl_debug_log, \
2298                     "%*s  (remove failure from success cache)\n", \
2299                     REPORT_CODE_OFF+PL_regindent*2, "") \
2300             ); \
2301             PL_reg_poscache[cache_offset] &= ~(1<<cache_bit); \
2302         } \
2303     } \
2304     sayNO; \
2305 } STMT_END
2306
2307 /* this is used to determine how far from the left messages like
2308    'failed...' are printed. Currently 29 makes these messages line
2309    up with the opcode they refer to. Earlier perls used 25 which
2310    left these messages outdented making reviewing a debug output
2311    quite difficult.
2312 */
2313 #define REPORT_CODE_OFF 29
2314
2315
2316 /* Make sure there is a test for this +1 options in re_tests */
2317 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2318
2319 #define TRIE_CHECK_STATE_IS_ACCEPTING STMT_START {                       \
2320     if ( trie->states[ state ].wordnum ) {                               \
2321         if ( !accepted ) {                                               \
2322             ENTER;                                                       \
2323             SAVETMPS;                                                    \
2324             bufflen = TRIE_INITAL_ACCEPT_BUFFLEN ;                       \
2325             sv_accept_buff=NEWSV( 1234,                                  \
2326               bufflen * sizeof(reg_trie_accepted) - 1 );                 \
2327             SvCUR_set( sv_accept_buff, sizeof(reg_trie_accepted) );      \
2328             SvPOK_on( sv_accept_buff );                                  \
2329             sv_2mortal( sv_accept_buff );                                \
2330             accept_buff = (reg_trie_accepted*)SvPV_nolen( sv_accept_buff );\
2331         } else {                                                         \
2332             if ( accepted >= bufflen ) {                                 \
2333                 bufflen *= 2;                                            \
2334                 accept_buff =(reg_trie_accepted*)SvGROW( sv_accept_buff, \
2335                     bufflen * sizeof(reg_trie_accepted) );               \
2336             }                                                            \
2337             SvCUR_set( sv_accept_buff,SvCUR( sv_accept_buff )            \
2338                 + sizeof( reg_trie_accepted ) );                         \
2339         }                                                                \
2340         accept_buff[ accepted ].wordnum = trie->states[ state ].wordnum; \
2341         accept_buff[ accepted ].endpos = uc;                             \
2342         ++accepted;                                                      \
2343     } } STMT_END
2344
2345 #define TRIE_HANDLE_CHAR STMT_START {                                   \
2346         if ( uvc < 256 ) {                                              \
2347             charid = trie->charmap[ uvc ];                              \
2348         } else {                                                        \
2349             charid = 0;                                                 \
2350             if( trie->widecharmap ) {                                   \
2351             SV** svpp = (SV**)NULL;                                     \
2352             svpp = hv_fetch( trie->widecharmap, (char*)&uvc,            \
2353                           sizeof( UV ), 0 );                            \
2354             if ( svpp ) {                                               \
2355                 charid = (U16)SvIV( *svpp );                            \
2356                 }                                                       \
2357             }                                                           \
2358         }                                                               \
2359         if ( charid &&                                                  \
2360              ( base + charid > trie->uniquecharcount ) &&               \
2361              ( base + charid - 1 - trie->uniquecharcount < trie->lasttrans) && \
2362              trie->trans[ base + charid - 1 - trie->uniquecharcount ].check == state ) \
2363         {                                                               \
2364             state = trie->trans[ base + charid - 1 - trie->uniquecharcount ].next;     \
2365         } else {                                                        \
2366             state = 0;                                                  \
2367         }                                                               \
2368         uc += len;                                                      \
2369     } STMT_END
2370
2371 /*
2372  - regmatch - main matching routine
2373  *
2374  * Conceptually the strategy is simple:  check to see whether the current
2375  * node matches, call self recursively to see whether the rest matches,
2376  * and then act accordingly.  In practice we make some effort to avoid
2377  * recursion, in particular by going through "ordinary" nodes (that don't
2378  * need to know whether the rest of the match failed) by a loop instead of
2379  * by recursion.
2380  */
2381 /* [lwall] I've hoisted the register declarations to the outer block in order to
2382  * maybe save a little bit of pushing and popping on the stack.  It also takes
2383  * advantage of machines that use a register save mask on subroutine entry.
2384  */
2385 STATIC I32                      /* 0 failure, 1 success */
2386 S_regmatch(pTHX_ regnode *prog)
2387 {
2388     dVAR;
2389     register regnode *scan;     /* Current node. */
2390     regnode *next;              /* Next node. */
2391     regnode *inner;             /* Next node in internal branch. */
2392     register I32 nextchr;       /* renamed nextchr - nextchar colides with
2393                                    function of same name */
2394     register I32 n;             /* no or next */
2395     register I32 ln = 0;        /* len or last */
2396     register char *s = Nullch;  /* operand or save */
2397     register char *locinput = PL_reginput;
2398     register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
2399     int minmod = 0, sw = 0, logical = 0;
2400     I32 unwind = 0;
2401
2402     /* used by the trie code */
2403     SV                 *sv_accept_buff = 0;  /* accepting states we have traversed */
2404     reg_trie_accepted  *accept_buff = 0;     /* "" */
2405     reg_trie_data      *trie;                /* what trie are we using right now */
2406     U32 accepted = 0;                        /* how many accepting states we have seen*/
2407
2408 #if 0
2409     I32 firstcp = PL_savestack_ix;
2410 #endif
2411     register const bool do_utf8 = PL_reg_match_utf8;
2412 #ifdef DEBUGGING
2413     SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
2414     SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
2415     SV *dsv2 = PERL_DEBUG_PAD_ZERO(2);
2416
2417     SV *re_debug_flags = NULL;
2418 #endif
2419     U32 uniflags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
2420
2421     GET_RE_DEBUG_FLAGS;
2422
2423 #ifdef DEBUGGING
2424     PL_regindent++;
2425 #endif
2426
2427
2428     /* Note that nextchr is a byte even in UTF */
2429     nextchr = UCHARAT(locinput);
2430     scan = prog;
2431     while (scan != NULL) {
2432
2433         DEBUG_EXECUTE_r( {
2434             SV *prop = sv_newmortal();
2435             const int docolor = *PL_colors[0];
2436             const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2437             int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2438             /* The part of the string before starttry has one color
2439                (pref0_len chars), between starttry and current
2440                position another one (pref_len - pref0_len chars),
2441                after the current position the third one.
2442                We assume that pref0_len <= pref_len, otherwise we
2443                decrease pref0_len.  */
2444             int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2445                 ? (5 + taill) - l : locinput - PL_bostr;
2446             int pref0_len;
2447
2448             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2449                 pref_len++;
2450             pref0_len = pref_len  - (locinput - PL_reg_starttry);
2451             if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2452                 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2453                       ? (5 + taill) - pref_len : PL_regeol - locinput);
2454             while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2455                 l--;
2456             if (pref0_len < 0)
2457                 pref0_len = 0;
2458             if (pref0_len > pref_len)
2459                 pref0_len = pref_len;
2460             regprop(prop, scan);
2461             {
2462               const char * const s0 =
2463                 do_utf8 && OP(scan) != CANY ?
2464                 pv_uni_display(dsv0, (U8*)(locinput - pref_len),
2465                                pref0_len, 60, UNI_DISPLAY_REGEX) :
2466                 locinput - pref_len;
2467               const int len0 = do_utf8 ? strlen(s0) : pref0_len;
2468               const char * const s1 = do_utf8 && OP(scan) != CANY ?
2469                 pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len),
2470                                pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2471                 locinput - pref_len + pref0_len;
2472               const int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
2473               const char * const s2 = do_utf8 && OP(scan) != CANY ?
2474                 pv_uni_display(dsv2, (U8*)locinput,
2475                                PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2476                 locinput;
2477               const int len2 = do_utf8 ? strlen(s2) : l;
2478               PerlIO_printf(Perl_debug_log,
2479                             "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2480                             (IV)(locinput - PL_bostr),
2481                             PL_colors[4],
2482                             len0, s0,
2483                             PL_colors[5],
2484                             PL_colors[2],
2485                             len1, s1,
2486                             PL_colors[3],
2487                             (docolor ? "" : "> <"),
2488                             PL_colors[0],
2489                             len2, s2,
2490                             PL_colors[1],
2491                             15 - l - pref_len + 1,
2492                             "",
2493                             (IV)(scan - PL_regprogram), PL_regindent*2, "",
2494                             SvPVX_const(prop));
2495             }
2496         });
2497
2498         next = scan + NEXT_OFF(scan);
2499         if (next == scan)
2500             next = NULL;
2501
2502         switch (OP(scan)) {
2503         case BOL:
2504             if (locinput == PL_bostr)
2505             {
2506                 /* regtill = regbol; */
2507                 break;
2508             }
2509             sayNO;
2510         case MBOL:
2511             if (locinput == PL_bostr ||
2512                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2513             {
2514                 break;
2515             }
2516             sayNO;
2517         case SBOL:
2518             if (locinput == PL_bostr)
2519                 break;
2520             sayNO;
2521         case GPOS:
2522             if (locinput == PL_reg_ganch)
2523                 break;
2524             sayNO;
2525         case EOL:
2526                 goto seol;
2527         case MEOL:
2528             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2529                 sayNO;
2530             break;
2531         case SEOL:
2532           seol:
2533             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2534                 sayNO;
2535             if (PL_regeol - locinput > 1)
2536                 sayNO;
2537             break;
2538         case EOS:
2539             if (PL_regeol != locinput)
2540                 sayNO;
2541             break;
2542         case SANY:
2543             if (!nextchr && locinput >= PL_regeol)
2544                 sayNO;
2545             if (do_utf8) {
2546                 locinput += PL_utf8skip[nextchr];
2547                 if (locinput > PL_regeol)
2548                     sayNO;
2549                 nextchr = UCHARAT(locinput);
2550             }
2551             else
2552                 nextchr = UCHARAT(++locinput);
2553             break;
2554         case CANY:
2555             if (!nextchr && locinput >= PL_regeol)
2556                 sayNO;
2557             nextchr = UCHARAT(++locinput);
2558             break;
2559         case REG_ANY:
2560             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2561                 sayNO;
2562             if (do_utf8) {
2563                 locinput += PL_utf8skip[nextchr];
2564                 if (locinput > PL_regeol)
2565                     sayNO;
2566                 nextchr = UCHARAT(locinput);
2567             }
2568             else
2569                 nextchr = UCHARAT(++locinput);
2570             break;
2571
2572
2573
2574         /*
2575            traverse the TRIE keeping track of all accepting states
2576            we transition through until we get to a failing node.
2577
2578            we use two slightly different pieces of code to handle
2579            the traversal depending on whether its case sensitive or
2580            not. we reuse the accept code however. (this should probably
2581            be turned into a macro.)
2582
2583         */
2584         case TRIEF:
2585         case TRIEFL:
2586             {
2587                 U8 *uc = ( U8* )locinput;
2588                 U32 state = 1;
2589                 U16 charid = 0;
2590                 U32 base = 0;
2591                 UV uvc = 0;
2592                 STRLEN len = 0;
2593                 STRLEN foldlen = 0;
2594                 U8 *uscan = (U8*)NULL;
2595                 STRLEN bufflen=0;
2596                 accepted = 0;
2597
2598                 trie = (reg_trie_data*)PL_regdata->data[ ARG( scan ) ];
2599
2600                 while ( state && uc <= (U8*)PL_regeol ) {
2601
2602                     TRIE_CHECK_STATE_IS_ACCEPTING;
2603
2604                     base = trie->states[ state ].trans.base;
2605
2606                     DEBUG_TRIE_EXECUTE_r(
2607                                 PerlIO_printf( Perl_debug_log,
2608                                     "%*s  %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2609                                     REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2610                                     (UV)state, (UV)base, (UV)accepted );
2611                     );
2612
2613                     if ( base ) {
2614
2615                         if ( do_utf8 ) {
2616                             if ( foldlen>0 ) {
2617                                 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2618                                 foldlen -= len;
2619                                 uscan += len;
2620                                 len=0;
2621                             } else {
2622                                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2623                                 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2624                                 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2625                                 foldlen -= UNISKIP( uvc );
2626                                 uscan = foldbuf + UNISKIP( uvc );
2627                             }
2628                         } else {
2629                             uvc = (UV)*uc;
2630                             len = 1;
2631                         }
2632
2633                         TRIE_HANDLE_CHAR;
2634
2635                     } else {
2636                         state = 0;
2637                     }
2638                     DEBUG_TRIE_EXECUTE_r(
2639                         PerlIO_printf( Perl_debug_log,
2640                             "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
2641                             charid, uvc, (UV)state, PL_colors[5] );
2642                     );
2643                 }
2644                 if ( !accepted ) {
2645                    sayNO;
2646                 } else {
2647                     goto TrieAccept;
2648                 }
2649             }
2650             /* unreached codepoint: we jump into the middle of the next case
2651                from previous if blocks */
2652         case TRIE:
2653             {
2654                 U8 *uc = (U8*)locinput;
2655                 U32 state = 1;
2656                 U16 charid = 0;
2657                 U32 base = 0;
2658                 UV uvc = 0;
2659                 STRLEN len = 0;
2660                 STRLEN bufflen = 0;
2661                 accepted = 0;
2662
2663                 trie = (reg_trie_data*)PL_regdata->data[ ARG( scan ) ];
2664
2665                 while ( state && uc <= (U8*)PL_regeol ) {
2666
2667                     TRIE_CHECK_STATE_IS_ACCEPTING;
2668
2669                     base = trie->states[ state ].trans.base;
2670
2671                     DEBUG_TRIE_EXECUTE_r(
2672                             PerlIO_printf( Perl_debug_log,
2673                                 "%*s  %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2674                                 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2675                                 (UV)state, (UV)base, (UV)accepted );
2676                     );
2677
2678                     if ( base ) {
2679
2680                         if ( do_utf8 ) {
2681                             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2682                         } else {
2683                             uvc = (U32)*uc;
2684                             len = 1;
2685                         }
2686
2687                         TRIE_HANDLE_CHAR;
2688
2689                     } else {
2690                         state = 0;
2691                     }
2692                     DEBUG_TRIE_EXECUTE_r(
2693                             PerlIO_printf( Perl_debug_log,
2694                                 "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
2695                                 charid, uvc, (UV)state, PL_colors[5] );
2696                     );
2697                 }
2698                 if ( !accepted ) {
2699                    sayNO;
2700                 }
2701             }
2702
2703
2704             /*
2705                There was at least one accepting state that we
2706                transitioned through. Presumably the number of accepting
2707                states is going to be low, typically one or two. So we
2708                simply scan through to find the one with lowest wordnum.
2709                Once we find it, we swap the last state into its place
2710                and decrement the size. We then try to match the rest of
2711                the pattern at the point where the word ends, if we
2712                succeed then we end the loop, otherwise the loop
2713                eventually terminates once all of the accepting states
2714                have been tried.
2715             */
2716         TrieAccept:
2717             {
2718                 int gotit = 0;
2719
2720                 if ( accepted == 1 ) {
2721                     DEBUG_EXECUTE_r({
2722                         SV **tmp = av_fetch( trie->words, accept_buff[ 0 ].wordnum-1, 0 );
2723                         PerlIO_printf( Perl_debug_log,
2724                             "%*s  %sonly one match : #%d <%s>%s\n",
2725                             REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2726                             accept_buff[ 0 ].wordnum,
2727                             tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2728                             PL_colors[5] );
2729                     });
2730                     PL_reginput = (char *)accept_buff[ 0 ].endpos;
2731                     /* in this case we free tmps/leave before we call regmatch
2732                        as we wont be using accept_buff again. */
2733                     FREETMPS;
2734                     LEAVE;
2735                     gotit = regmatch( scan + NEXT_OFF( scan ) );
2736                 } else {
2737                     DEBUG_EXECUTE_r(
2738                         PerlIO_printf( Perl_debug_log,"%*s  %sgot %"IVdf" possible matches%s\n",
2739                             REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], (IV)accepted,
2740                             PL_colors[5] );
2741                     );
2742                     while ( !gotit && accepted-- ) {
2743                         U32 best = 0;
2744                         U32 cur;
2745                         for( cur = 1 ; cur <= accepted ; cur++ ) {
2746                             DEBUG_TRIE_EXECUTE_r(
2747                                 PerlIO_printf( Perl_debug_log,
2748                                     "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
2749                                     REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2750                                     (IV)best, accept_buff[ best ].wordnum, (IV)cur,
2751                                     accept_buff[ cur ].wordnum, PL_colors[5] );
2752                             );
2753
2754                             if ( accept_buff[ cur ].wordnum < accept_buff[ best ].wordnum )
2755                                     best = cur;
2756                         }
2757                         DEBUG_EXECUTE_r({
2758                             SV **tmp = av_fetch( trie->words, accept_buff[ best ].wordnum - 1, 0 );
2759                             PerlIO_printf( Perl_debug_log, "%*s  %strying alternation #%d <%s> at 0x%p%s\n",
2760                                 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2761                                 accept_buff[best].wordnum,
2762                                 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",scan,
2763                                 PL_colors[5] );
2764                         });
2765                         if ( best<accepted ) {
2766                             reg_trie_accepted tmp = accept_buff[ best ];
2767                             accept_buff[ best ] = accept_buff[ accepted ];
2768                             accept_buff[ accepted ] = tmp;
2769                             best = accepted;
2770                         }
2771                         PL_reginput = (char *)accept_buff[ best ].endpos;
2772
2773                         /*
2774                            as far as I can tell we only need the SAVETMPS/FREETMPS
2775                            for re's with EVAL in them but I'm leaving them in for
2776                            all until I can be sure.
2777                          */
2778                         SAVETMPS;
2779                         gotit = regmatch( scan + NEXT_OFF( scan ) ) ;
2780                         FREETMPS;
2781                     }
2782                     FREETMPS;
2783                     LEAVE;
2784                 }
2785
2786                 if ( gotit ) {
2787                     sayYES;
2788                 } else {
2789                     sayNO;
2790                 }
2791             }
2792             /* unreached codepoint */
2793         case EXACT:
2794             s = STRING(scan);
2795             ln = STR_LEN(scan);
2796             if (do_utf8 != UTF) {
2797                 /* The target and the pattern have differing utf8ness. */
2798                 char *l = locinput;
2799                 const char *e = s + ln;
2800
2801                 if (do_utf8) {
2802                     /* The target is utf8, the pattern is not utf8. */
2803                     while (s < e) {
2804                         STRLEN ulen;
2805                         if (l >= PL_regeol)
2806                              sayNO;
2807                         if (NATIVE_TO_UNI(*(U8*)s) !=
2808                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
2809                                             uniflags))
2810                              sayNO;
2811                         l += ulen;
2812                         s ++;
2813                     }
2814                 }
2815                 else {
2816                     /* The target is not utf8, the pattern is utf8. */
2817                     while (s < e) {
2818                         STRLEN ulen;
2819                         if (l >= PL_regeol)
2820                             sayNO;
2821                         if (NATIVE_TO_UNI(*((U8*)l)) !=
2822                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
2823                                            uniflags))
2824                             sayNO;
2825                         s += ulen;
2826                         l ++;
2827                     }
2828                 }
2829                 locinput = l;
2830                 nextchr = UCHARAT(locinput);
2831                 break;
2832             }
2833             /* The target and the pattern have the same utf8ness. */
2834             /* Inline the first character, for speed. */
2835             if (UCHARAT(s) != nextchr)
2836                 sayNO;
2837             if (PL_regeol - locinput < ln)
2838                 sayNO;
2839             if (ln > 1 && memNE(s, locinput, ln))
2840                 sayNO;
2841             locinput += ln;
2842             nextchr = UCHARAT(locinput);
2843             break;
2844         case EXACTFL:
2845             PL_reg_flags |= RF_tainted;
2846             /* FALL THROUGH */
2847         case EXACTF:
2848             s = STRING(scan);
2849             ln = STR_LEN(scan);
2850
2851             if (do_utf8 || UTF) {
2852               /* Either target or the pattern are utf8. */
2853                 char *l = locinput;
2854                 char *e = PL_regeol;
2855
2856                 if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
2857                                l, &e, 0,  do_utf8)) {
2858                      /* One more case for the sharp s:
2859                       * pack("U0U*", 0xDF) =~ /ss/i,
2860                       * the 0xC3 0x9F are the UTF-8
2861                       * byte sequence for the U+00DF. */
2862                      if (!(do_utf8 &&
2863                            toLOWER(s[0]) == 's' &&
2864                            ln >= 2 &&
2865                            toLOWER(s[1]) == 's' &&
2866                            (U8)l[0] == 0xC3 &&
2867                            e - l >= 2 &&
2868                            (U8)l[1] == 0x9F))
2869                           sayNO;
2870                 }
2871                 locinput = e;
2872                 nextchr = UCHARAT(locinput);
2873                 break;
2874             }
2875
2876             /* Neither the target and the pattern are utf8. */
2877
2878             /* Inline the first character, for speed. */
2879             if (UCHARAT(s) != nextchr &&
2880                 UCHARAT(s) != ((OP(scan) == EXACTF)
2881                                ? PL_fold : PL_fold_locale)[nextchr])
2882                 sayNO;
2883             if (PL_regeol - locinput < ln)
2884                 sayNO;
2885             if (ln > 1 && (OP(scan) == EXACTF
2886                            ? ibcmp(s, locinput, ln)
2887                            : ibcmp_locale(s, locinput, ln)))
2888                 sayNO;
2889             locinput += ln;
2890             nextchr = UCHARAT(locinput);
2891             break;
2892         case ANYOF:
2893             if (do_utf8) {
2894                 STRLEN inclasslen = PL_regeol - locinput;
2895
2896                 if (!reginclass(scan, (U8*)locinput, &inclasslen, do_utf8))
2897                     sayNO_ANYOF;
2898                 if (locinput >= PL_regeol)
2899                     sayNO;
2900                 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
2901                 nextchr = UCHARAT(locinput);
2902                 break;
2903             }
2904             else {
2905                 if (nextchr < 0)
2906                     nextchr = UCHARAT(locinput);
2907                 if (!REGINCLASS(scan, (U8*)locinput))
2908                     sayNO_ANYOF;
2909                 if (!nextchr && locinput >= PL_regeol)
2910                     sayNO;
2911                 nextchr = UCHARAT(++locinput);
2912                 break;
2913             }
2914         no_anyof:
2915             /* If we might have the case of the German sharp s
2916              * in a casefolding Unicode character class. */
2917
2918             if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
2919                  locinput += SHARP_S_SKIP;
2920                  nextchr = UCHARAT(locinput);
2921             }
2922             else
2923                  sayNO;
2924             break;
2925         case ALNUML:
2926             PL_reg_flags |= RF_tainted;
2927             /* FALL THROUGH */
2928         case ALNUM:
2929             if (!nextchr)
2930                 sayNO;
2931             if (do_utf8) {
2932                 LOAD_UTF8_CHARCLASS_ALNUM();
2933                 if (!(OP(scan) == ALNUM
2934                       ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2935                       : isALNUM_LC_utf8((U8*)locinput)))
2936                 {
2937                     sayNO;
2938                 }
2939                 locinput += PL_utf8skip[nextchr];
2940                 nextchr = UCHARAT(locinput);
2941                 break;
2942             }
2943             if (!(OP(scan) == ALNUM
2944                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
2945                 sayNO;
2946             nextchr = UCHARAT(++locinput);
2947             break;
2948         case NALNUML:
2949             PL_reg_flags |= RF_tainted;
2950             /* FALL THROUGH */
2951         case NALNUM:
2952             if (!nextchr && locinput >= PL_regeol)
2953                 sayNO;
2954             if (do_utf8) {
2955                 LOAD_UTF8_CHARCLASS_ALNUM();
2956                 if (OP(scan) == NALNUM
2957                     ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2958                     : isALNUM_LC_utf8((U8*)locinput))
2959                 {
2960                     sayNO;
2961                 }
2962                 locinput += PL_utf8skip[nextchr];
2963                 nextchr = UCHARAT(locinput);
2964                 break;
2965             }
2966             if (OP(scan) == NALNUM
2967                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
2968                 sayNO;
2969             nextchr = UCHARAT(++locinput);
2970             break;
2971         case BOUNDL:
2972         case NBOUNDL:
2973             PL_reg_flags |= RF_tainted;
2974             /* FALL THROUGH */
2975         case BOUND:
2976         case NBOUND:
2977             /* was last char in word? */
2978             if (do_utf8) {
2979                 if (locinput == PL_bostr)
2980                     ln = '\n';
2981                 else {
2982                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
2983
2984                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0);
2985                 }
2986                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2987                     ln = isALNUM_uni(ln);
2988                     LOAD_UTF8_CHARCLASS_ALNUM();
2989                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
2990                 }
2991                 else {
2992                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
2993                     n = isALNUM_LC_utf8((U8*)locinput);
2994                 }
2995             }
2996             else {
2997                 ln = (locinput != PL_bostr) ?
2998                     UCHARAT(locinput - 1) : '\n';
2999                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3000                     ln = isALNUM(ln);
3001                     n = isALNUM(nextchr);
3002                 }
3003                 else {
3004                     ln = isALNUM_LC(ln);
3005                     n = isALNUM_LC(nextchr);
3006                 }
3007             }
3008             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3009                                     OP(scan) == BOUNDL))
3010                     sayNO;
3011             break;
3012         case SPACEL:
3013             PL_reg_flags |= RF_tainted;
3014             /* FALL THROUGH */
3015         case SPACE:
3016             if (!nextchr)
3017                 sayNO;
3018             if (do_utf8) {
3019                 if (UTF8_IS_CONTINUED(nextchr)) {
3020                     LOAD_UTF8_CHARCLASS_SPACE();
3021                     if (!(OP(scan) == SPACE
3022                           ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3023                           : isSPACE_LC_utf8((U8*)locinput)))
3024                     {
3025                         sayNO;
3026                     }
3027                     locinput += PL_utf8skip[nextchr];
3028                     nextchr = UCHARAT(locinput);
3029                     break;
3030                 }
3031                 if (!(OP(scan) == SPACE
3032                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3033                     sayNO;
3034                 nextchr = UCHARAT(++locinput);
3035             }
3036             else {
3037                 if (!(OP(scan) == SPACE
3038                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3039                     sayNO;
3040                 nextchr = UCHARAT(++locinput);
3041             }
3042             break;
3043         case NSPACEL:
3044             PL_reg_flags |= RF_tainted;
3045             /* FALL THROUGH */
3046         case NSPACE:
3047             if (!nextchr && locinput >= PL_regeol)
3048                 sayNO;
3049             if (do_utf8) {
3050                 LOAD_UTF8_CHARCLASS_SPACE();
3051                 if (OP(scan) == NSPACE
3052                     ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3053                     : isSPACE_LC_utf8((U8*)locinput))
3054                 {
3055                     sayNO;
3056                 }
3057                 locinput += PL_utf8skip[nextchr];
3058                 nextchr = UCHARAT(locinput);
3059                 break;
3060             }
3061             if (OP(scan) == NSPACE
3062                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3063                 sayNO;
3064             nextchr = UCHARAT(++locinput);
3065             break;
3066         case DIGITL:
3067             PL_reg_flags |= RF_tainted;
3068             /* FALL THROUGH */
3069         case DIGIT:
3070             if (!nextchr)
3071                 sayNO;
3072             if (do_utf8) {
3073                 LOAD_UTF8_CHARCLASS_DIGIT();
3074                 if (!(OP(scan) == DIGIT
3075                       ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3076                       : isDIGIT_LC_utf8((U8*)locinput)))
3077                 {
3078                     sayNO;
3079                 }
3080                 locinput += PL_utf8skip[nextchr];
3081                 nextchr = UCHARAT(locinput);
3082                 break;
3083             }
3084             if (!(OP(scan) == DIGIT
3085                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3086                 sayNO;
3087             nextchr = UCHARAT(++locinput);
3088             break;
3089         case NDIGITL:
3090             PL_reg_flags |= RF_tainted;
3091             /* FALL THROUGH */
3092         case NDIGIT:
3093             if (!nextchr && locinput >= PL_regeol)
3094                 sayNO;
3095             if (do_utf8) {
3096                 LOAD_UTF8_CHARCLASS_DIGIT();
3097                 if (OP(scan) == NDIGIT
3098                     ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3099                     : isDIGIT_LC_utf8((U8*)locinput))
3100                 {
3101                     sayNO;
3102                 }
3103                 locinput += PL_utf8skip[nextchr];
3104                 nextchr = UCHARAT(locinput);
3105                 break;
3106             }
3107             if (OP(scan) == NDIGIT
3108                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3109                 sayNO;
3110             nextchr = UCHARAT(++locinput);
3111             break;
3112         case CLUMP:
3113             if (locinput >= PL_regeol)
3114                 sayNO;
3115             if  (do_utf8) {
3116                 LOAD_UTF8_CHARCLASS_MARK();
3117                 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3118                     sayNO;
3119                 locinput += PL_utf8skip[nextchr];
3120                 while (locinput < PL_regeol &&
3121                        swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3122                     locinput += UTF8SKIP(locinput);
3123                 if (locinput > PL_regeol)
3124                     sayNO;
3125             }
3126             else
3127                locinput++;
3128             nextchr = UCHARAT(locinput);
3129             break;
3130         case REFFL:
3131             PL_reg_flags |= RF_tainted;
3132             /* FALL THROUGH */
3133         case REF:
3134         case REFF:
3135             n = ARG(scan);  /* which paren pair */
3136             ln = PL_regstartp[n];
3137             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3138             if ((I32)*PL_reglastparen < n || ln == -1)
3139                 sayNO;                  /* Do not match unless seen CLOSEn. */
3140             if (ln == PL_regendp[n])
3141                 break;
3142
3143             s = PL_bostr + ln;
3144             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
3145                 char *l = locinput;
3146                 const char *e = PL_bostr + PL_regendp[n];
3147                 /*
3148                  * Note that we can't do the "other character" lookup trick as
3149                  * in the 8-bit case (no pun intended) because in Unicode we
3150                  * have to map both upper and title case to lower case.
3151                  */
3152                 if (OP(scan) == REFF) {
3153                     while (s < e) {
3154                         STRLEN ulen1, ulen2;
3155                         U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3156                         U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3157
3158                         if (l >= PL_regeol)
3159                             sayNO;
3160                         toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3161                         toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3162                         if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3163                             sayNO;
3164                         s += ulen1;
3165                         l += ulen2;
3166                     }
3167                 }
3168                 locinput = l;
3169                 nextchr = UCHARAT(locinput);
3170                 break;
3171             }
3172
3173             /* Inline the first character, for speed. */
3174             if (UCHARAT(s) != nextchr &&
3175                 (OP(scan) == REF ||
3176                  (UCHARAT(s) != ((OP(scan) == REFF
3177                                   ? PL_fold : PL_fold_locale)[nextchr]))))
3178                 sayNO;
3179             ln = PL_regendp[n] - ln;
3180             if (locinput + ln > PL_regeol)
3181                 sayNO;
3182             if (ln > 1 && (OP(scan) == REF
3183                            ? memNE(s, locinput, ln)
3184                            : (OP(scan) == REFF
3185                               ? ibcmp(s, locinput, ln)
3186                               : ibcmp_locale(s, locinput, ln))))
3187                 sayNO;
3188             locinput += ln;
3189             nextchr = UCHARAT(locinput);
3190             break;
3191
3192         case NOTHING:
3193         case TAIL:
3194             break;
3195         case BACK:
3196             break;
3197         case EVAL:
3198         {
3199             dSP;
3200             OP_4tree *oop = PL_op;
3201             COP *ocurcop = PL_curcop;
3202             PAD *old_comppad;
3203             SV *ret;
3204             struct regexp *oreg = PL_reg_re;
3205
3206             n = ARG(scan);
3207             PL_op = (OP_4tree*)PL_regdata->data[n];
3208             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3209             PAD_SAVE_LOCAL(old_comppad, (PAD*)PL_regdata->data[n + 2]);
3210             PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3211
3212             {
3213                 SV **before = SP;
3214                 CALLRUNOPS(aTHX);                       /* Scalar context. */
3215                 SPAGAIN;
3216                 if (SP == before)
3217                     ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3218                 else {
3219                     ret = POPs;
3220                     PUTBACK;
3221                 }
3222             }
3223
3224             PL_op = oop;
3225             PAD_RESTORE_LOCAL(old_comppad);
3226             PL_curcop = ocurcop;
3227             if (logical) {
3228                 if (logical == 2) {     /* Postponed subexpression. */
3229                     regexp *re;
3230                     MAGIC *mg = Null(MAGIC*);
3231                     re_cc_state state;
3232                     CHECKPOINT cp, lastcp;
3233                     int toggleutf;
3234                     register SV *sv;
3235
3236                     if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3237                         mg = mg_find(sv, PERL_MAGIC_qr);
3238                     else if (SvSMAGICAL(ret)) {
3239                         if (SvGMAGICAL(ret))
3240                             sv_unmagic(ret, PERL_MAGIC_qr);
3241                         else
3242                             mg = mg_find(ret, PERL_MAGIC_qr);
3243                     }
3244
3245                     if (mg) {
3246                         re = (regexp *)mg->mg_obj;
3247                         (void)ReREFCNT_inc(re);
3248                     }
3249                     else {
3250                         STRLEN len;
3251                         const char *t = SvPV_const(ret, len);
3252                         PMOP pm;
3253                         char * const oprecomp = PL_regprecomp;
3254                         const I32 osize = PL_regsize;
3255                         const I32 onpar = PL_regnpar;
3256
3257                         Zero(&pm, 1, PMOP);
3258                         if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3259                         re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3260                         if (!(SvFLAGS(ret)
3261                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3262                                 | SVs_GMG)))
3263                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
3264                                         PERL_MAGIC_qr,0,0);
3265                         PL_regprecomp = oprecomp;
3266                         PL_regsize = osize;
3267                         PL_regnpar = onpar;
3268                     }
3269                     DEBUG_EXECUTE_r(
3270                         PerlIO_printf(Perl_debug_log,
3271                                       "Entering embedded \"%s%.60s%s%s\"\n",
3272                                       PL_colors[0],
3273                                       re->precomp,
3274                                       PL_colors[1],
3275                                       (strlen(re->precomp) > 60 ? "..." : ""))
3276                         );
3277                     state.node = next;
3278                     state.prev = PL_reg_call_cc;
3279                     state.cc = PL_regcc;
3280                     state.re = PL_reg_re;
3281
3282                     PL_regcc = 0;
3283
3284                     cp = regcppush(0);  /* Save *all* the positions. */
3285                     REGCP_SET(lastcp);
3286                     cache_re(re);
3287                     state.ss = PL_savestack_ix;
3288                     *PL_reglastparen = 0;
3289                     *PL_reglastcloseparen = 0;
3290                     PL_reg_call_cc = &state;
3291                     PL_reginput = locinput;
3292                     toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3293                                 ((re->reganch & ROPT_UTF8) != 0);
3294                     if (toggleutf) PL_reg_flags ^= RF_utf8;
3295
3296                     /* XXXX This is too dramatic a measure... */
3297                     PL_reg_maxiter = 0;
3298
3299                     if (regmatch(re->program + 1)) {
3300                         /* Even though we succeeded, we need to restore
3301                            global variables, since we may be wrapped inside
3302                            SUSPEND, thus the match may be not finished yet. */
3303
3304                         /* XXXX Do this only if SUSPENDed? */
3305                         PL_reg_call_cc = state.prev;
3306                         PL_regcc = state.cc;
3307                         PL_reg_re = state.re;
3308                         cache_re(PL_reg_re);
3309                         if (toggleutf) PL_reg_flags ^= RF_utf8;
3310
3311                         /* XXXX This is too dramatic a measure... */
3312                         PL_reg_maxiter = 0;
3313
3314                         /* These are needed even if not SUSPEND. */
3315                         ReREFCNT_dec(re);
3316                         regcpblow(cp);
3317                         sayYES;
3318                     }
3319                     ReREFCNT_dec(re);
3320                     REGCP_UNWIND(lastcp);
3321                     regcppop();
3322                     PL_reg_call_cc = state.prev;
3323                     PL_regcc = state.cc;
3324                     PL_reg_re = state.re;
3325                     cache_re(PL_reg_re);
3326                     if (toggleutf) PL_reg_flags ^= RF_utf8;
3327
3328                     /* XXXX This is too dramatic a measure... */
3329                     PL_reg_maxiter = 0;
3330
3331                     logical = 0;
3332                     sayNO;
3333                 }
3334                 sw = SvTRUE(ret);
3335                 logical = 0;
3336             }
3337             else {
3338                 sv_setsv(save_scalar(PL_replgv), ret);
3339                 cache_re(oreg);
3340             }
3341             break;
3342         }
3343         case OPEN:
3344             n = ARG(scan);  /* which paren pair */
3345             PL_reg_start_tmp[n] = locinput;
3346             if (n > PL_regsize)
3347                 PL_regsize = n;
3348             break;
3349         case CLOSE:
3350             n = ARG(scan);  /* which paren pair */
3351             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3352             PL_regendp[n] = locinput - PL_bostr;
3353             if (n > (I32)*PL_reglastparen)
3354                 *PL_reglastparen = n;
3355             *PL_reglastcloseparen = n;
3356             break;
3357         case GROUPP:
3358             n = ARG(scan);  /* which paren pair */
3359             sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3360             break;
3361         case IFTHEN:
3362             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
3363             if (sw)
3364                 next = NEXTOPER(NEXTOPER(scan));
3365             else {
3366                 next = scan + ARG(scan);
3367                 if (OP(next) == IFTHEN) /* Fake one. */
3368                     next = NEXTOPER(NEXTOPER(next));
3369             }
3370             break;
3371         case LOGICAL:
3372             logical = scan->flags;
3373             break;
3374 /*******************************************************************
3375  PL_regcc contains infoblock about the innermost (...)* loop, and
3376  a pointer to the next outer infoblock.
3377
3378  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3379
3380    1) After matching X, regnode for CURLYX is processed;
3381
3382    2) This regnode creates infoblock on the stack, and calls
3383       regmatch() recursively with the starting point at WHILEM node;
3384
3385    3) Each hit of WHILEM node tries to match A and Z (in the order
3386       depending on the current iteration, min/max of {min,max} and
3387       greediness).  The information about where are nodes for "A"
3388       and "Z" is read from the infoblock, as is info on how many times "A"
3389       was already matched, and greediness.
3390
3391    4) After A matches, the same WHILEM node is hit again.
3392
3393    5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
3394       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
3395       resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
3396       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
3397       of the external loop.
3398
3399  Currently present infoblocks form a tree with a stem formed by PL_curcc
3400  and whatever it mentions via ->next, and additional attached trees
3401  corresponding to temporarily unset infoblocks as in "5" above.
3402
3403  In the following picture infoblocks for outer loop of
3404  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
3405  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
3406  infoblocks are drawn below the "reset" infoblock.
3407
3408  In fact in the picture below we do not show failed matches for Z and T
3409  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
3410  more obvious *why* one needs to *temporary* unset infoblocks.]
3411
3412   Matched       REx position    InfoBlocks      Comment
3413                 (Y(A)*?Z)*?T    x
3414                 Y(A)*?Z)*?T     x <- O
3415   Y             (A)*?Z)*?T      x <- O
3416   Y             A)*?Z)*?T       x <- O <- I
3417   YA            )*?Z)*?T        x <- O <- I
3418   YA            A)*?Z)*?T       x <- O <- I
3419   YAA           )*?Z)*?T        x <- O <- I
3420   YAA           Z)*?T           x <- O          # Temporary unset I
3421                                      I
3422
3423   YAAZ          Y(A)*?Z)*?T     x <- O
3424                                      I
3425
3426   YAAZY         (A)*?Z)*?T      x <- O
3427                                      I
3428
3429   YAAZY         A)*?Z)*?T       x <- O <- I
3430                                      I
3431
3432   YAAZYA        )*?Z)*?T        x <- O <- I
3433                                      I
3434
3435   YAAZYA        Z)*?T           x <- O          # Temporary unset I
3436                                      I,I
3437
3438   YAAZYAZ       )*?T            x <- O
3439                                      I,I
3440
3441   YAAZYAZ       T               x               # Temporary unset O
3442                                 O
3443                                 I,I
3444
3445   YAAZYAZT                      x
3446                                 O
3447                                 I,I
3448  *******************************************************************/
3449         case CURLYX: {
3450                 CURCUR cc;
3451                 CHECKPOINT cp = PL_savestack_ix;
3452                 /* No need to save/restore up to this paren */
3453                 I32 parenfloor = scan->flags;
3454
3455                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3456                     next += ARG(next);
3457                 cc.oldcc = PL_regcc;
3458                 PL_regcc = &cc;
3459                 /* XXXX Probably it is better to teach regpush to support
3460                    parenfloor > PL_regsize... */
3461                 if (parenfloor > (I32)*PL_reglastparen)
3462                     parenfloor = *PL_reglastparen; /* Pessimization... */
3463                 cc.parenfloor = parenfloor;
3464                 cc.cur = -1;
3465                 cc.min = ARG1(scan);
3466                 cc.max  = ARG2(scan);
3467                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3468                 cc.next = next;
3469                 cc.minmod = minmod;
3470                 cc.lastloc = 0;
3471                 PL_reginput = locinput;
3472                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
3473                 regcpblow(cp);
3474                 PL_regcc = cc.oldcc;
3475                 saySAME(n);
3476             }
3477             /* NOT REACHED */
3478         case WHILEM: {
3479                 /*
3480                  * This is really hard to understand, because after we match
3481                  * what we're trying to match, we must make sure the rest of
3482                  * the REx is going to match for sure, and to do that we have
3483                  * to go back UP the parse tree by recursing ever deeper.  And
3484                  * if it fails, we have to reset our parent's current state
3485                  * that we can try again after backing off.
3486                  */
3487
3488                 CHECKPOINT cp, lastcp;
3489                 CURCUR* cc = PL_regcc;
3490                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
3491                 I32 cache_offset = 0, cache_bit = 0;
3492
3493                 n = cc->cur + 1;        /* how many we know we matched */
3494                 PL_reginput = locinput;
3495
3496                 DEBUG_EXECUTE_r(
3497                     PerlIO_printf(Perl_debug_log,
3498                                   "%*s  %ld out of %ld..%ld  cc=%"UVxf"\n",
3499                                   REPORT_CODE_OFF+PL_regindent*2, "",
3500                                   (long)n, (long)cc->min,
3501                                   (long)cc->max, PTR2UV(cc))
3502                     );
3503
3504                 /* If degenerate scan matches "", assume scan done. */
3505
3506                 if (locinput == cc->lastloc && n >= cc->min) {
3507                     PL_regcc = cc->oldcc;
3508                     if (PL_regcc)
3509                         ln = PL_regcc->cur;
3510                     DEBUG_EXECUTE_r(
3511                         PerlIO_printf(Perl_debug_log,
3512                            "%*s  empty match detected, try continuation...\n",
3513                            REPORT_CODE_OFF+PL_regindent*2, "")
3514                         );
3515                     if (regmatch(cc->next))
3516                         sayYES;
3517                     if (PL_regcc)
3518                         PL_regcc->cur = ln;
3519                     PL_regcc = cc;
3520                     sayNO;
3521                 }
3522
3523                 /* First just match a string of min scans. */
3524
3525                 if (n < cc->min) {
3526                     cc->cur = n;
3527                     cc->lastloc = locinput;
3528                     if (regmatch(cc->scan))
3529                         sayYES;
3530                     cc->cur = n - 1;
3531                     cc->lastloc = lastloc;
3532                     sayNO;
3533                 }
3534
3535                 if (scan->flags) {
3536                     /* Check whether we already were at this position.
3537                         Postpone detection until we know the match is not
3538                         *that* much linear. */
3539                 if (!PL_reg_maxiter) {
3540                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3541                     PL_reg_leftiter = PL_reg_maxiter;
3542                 }
3543                 if (PL_reg_leftiter-- == 0) {
3544                     const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8;
3545                     if (PL_reg_poscache) {
3546                         if ((I32)PL_reg_poscache_size < size) {
3547                             Renew(PL_reg_poscache, size, char);
3548                             PL_reg_poscache_size = size;
3549                         }
3550                         Zero(PL_reg_poscache, size, char);
3551                     }
3552                     else {
3553                         PL_reg_poscache_size = size;
3554                         Newxz(PL_reg_poscache, size, char);
3555                     }
3556                     DEBUG_EXECUTE_r(
3557                         PerlIO_printf(Perl_debug_log,
3558               "%sDetected a super-linear match, switching on caching%s...\n",
3559                                       PL_colors[4], PL_colors[5])
3560                         );
3561                 }
3562                 if (PL_reg_leftiter < 0) {
3563                     cache_offset = locinput - PL_bostr;
3564
3565                     cache_offset = (scan->flags & 0xf) - 1 + POSCACHE_START
3566                             + cache_offset * (scan->flags>>4);
3567                     cache_bit = cache_offset % 8;
3568                     cache_offset /= 8;
3569                     if (PL_reg_poscache[cache_offset] & (1<<cache_bit)) {
3570                     DEBUG_EXECUTE_r(
3571                         PerlIO_printf(Perl_debug_log,
3572                                       "%*s  already tried at this position...\n",
3573                                       REPORT_CODE_OFF+PL_regindent*2, "")
3574                         );
3575                         if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))
3576                             /* cache records success */
3577                             sayYES;
3578                         else
3579                             /* cache records failure */
3580                             sayNO_SILENT;
3581                     }
3582                     PL_reg_poscache[cache_offset] |= (1<<cache_bit);
3583                 }
3584                 }
3585
3586                 /* Prefer next over scan for minimal matching. */
3587
3588                 if (cc->minmod) {
3589                     PL_regcc = cc->oldcc;
3590                     if (PL_regcc)
3591                         ln = PL_regcc->cur;
3592                     cp = regcppush(cc->parenfloor);
3593                     REGCP_SET(lastcp);
3594                     if (regmatch(cc->next)) {
3595                         regcpblow(cp);
3596                         CACHEsayYES;    /* All done. */
3597                     }
3598                     REGCP_UNWIND(lastcp);
3599                     regcppop();
3600                     if (PL_regcc)
3601                         PL_regcc->cur = ln;
3602                     PL_regcc = cc;
3603
3604                     if (n >= cc->max) { /* Maximum greed exceeded? */
3605                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3606                             && !(PL_reg_flags & RF_warned)) {
3607                             PL_reg_flags |= RF_warned;
3608                             Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3609                                  "Complex regular subexpression recursion",
3610                                  REG_INFTY - 1);
3611                         }
3612                         CACHEsayNO;
3613                     }
3614
3615                     DEBUG_EXECUTE_r(
3616                         PerlIO_printf(Perl_debug_log,
3617                                       "%*s  trying longer...\n",
3618                                       REPORT_CODE_OFF+PL_regindent*2, "")
3619                         );
3620                     /* Try scanning more and see if it helps. */
3621                     PL_reginput = locinput;
3622                     cc->cur = n;
3623                     cc->lastloc = locinput;
3624                     cp = regcppush(cc->parenfloor);
3625                     REGCP_SET(lastcp);
3626                     if (regmatch(cc->scan)) {
3627                         regcpblow(cp);
3628                         CACHEsayYES;
3629                     }
3630                     REGCP_UNWIND(lastcp);
3631                     regcppop();
3632                     cc->cur = n - 1;
3633                     cc->lastloc = lastloc;
3634                     CACHEsayNO;
3635                 }
3636
3637                 /* Prefer scan over next for maximal matching. */
3638
3639                 if (n < cc->max) {      /* More greed allowed? */
3640                     cp = regcppush(cc->parenfloor);
3641                     cc->cur = n;
3642                     cc->lastloc = locinput;
3643                     REGCP_SET(lastcp);
3644                     if (regmatch(cc->scan)) {
3645                         regcpblow(cp);
3646                         CACHEsayYES;
3647                     }
3648                     REGCP_UNWIND(lastcp);
3649                     regcppop();         /* Restore some previous $<digit>s? */
3650                     PL_reginput = locinput;
3651                     DEBUG_EXECUTE_r(
3652                         PerlIO_printf(Perl_debug_log,
3653                                       "%*s  failed, try continuation...\n",
3654                                       REPORT_CODE_OFF+PL_regindent*2, "")
3655                         );
3656                 }
3657                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3658                         && !(PL_reg_flags & RF_warned)) {
3659                     PL_reg_flags |= RF_warned;
3660                     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3661                          "Complex regular subexpression recursion",
3662                          REG_INFTY - 1);
3663                 }
3664
3665                 /* Failed deeper matches of scan, so see if this one works. */
3666                 PL_regcc = cc->oldcc;
3667                 if (PL_regcc)
3668                     ln = PL_regcc->cur;
3669                 if (regmatch(cc->next))
3670                     CACHEsayYES;
3671                 if (PL_regcc)
3672                     PL_regcc->cur = ln;
3673                 PL_regcc = cc;
3674                 cc->cur = n - 1;
3675                 cc->lastloc = lastloc;
3676                 CACHEsayNO;
3677             }
3678             /* NOT REACHED */
3679         case BRANCHJ:
3680             next = scan + ARG(scan);
3681             if (next == scan)
3682                 next = NULL;
3683             inner = NEXTOPER(NEXTOPER(scan));
3684             goto do_branch;
3685         case BRANCH:
3686             inner = NEXTOPER(scan);
3687           do_branch:
3688             {
3689                 c1 = OP(scan);
3690                 if (OP(next) != c1)     /* No choice. */
3691                     next = inner;       /* Avoid recursion. */
3692                 else {
3693                     const I32 lastparen = *PL_reglastparen;
3694                     I32 unwind1;
3695                     re_unwind_branch_t *uw;
3696
3697                     /* Put unwinding data on stack */
3698                     unwind1 = SSNEWt(1,re_unwind_branch_t);
3699                     uw = SSPTRt(unwind1,re_unwind_branch_t);
3700                     uw->prev = unwind;
3701                     unwind = unwind1;
3702                     uw->type = ((c1 == BRANCH)
3703                                 ? RE_UNWIND_BRANCH
3704                                 : RE_UNWIND_BRANCHJ);
3705                     uw->lastparen = lastparen;
3706                     uw->next = next;
3707                     uw->locinput = locinput;
3708                     uw->nextchr = nextchr;
3709 #ifdef DEBUGGING
3710                     uw->regindent = ++PL_regindent;
3711 #endif
3712
3713                     REGCP_SET(uw->lastcp);
3714
3715                     /* Now go into the first branch */
3716                     next = inner;
3717                 }
3718             }
3719             break;
3720         case MINMOD:
3721             minmod = 1;
3722             break;
3723         case CURLYM:
3724         {
3725             I32 l = 0;
3726             CHECKPOINT lastcp;
3727
3728             /* We suppose that the next guy does not need
3729                backtracking: in particular, it is of constant non-zero length,
3730                and has no parenths to influence future backrefs. */
3731             ln = ARG1(scan);  /* min to match */
3732             n  = ARG2(scan);  /* max to match */
3733             paren = scan->flags;
3734             if (paren) {
3735                 if (paren > PL_regsize)
3736                     PL_regsize = paren;
3737                 if (paren > (I32)*PL_reglastparen)
3738                     *PL_reglastparen = paren;
3739             }
3740             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3741             if (paren)
3742                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3743             PL_reginput = locinput;
3744             if (minmod) {
3745                 minmod = 0;
3746                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
3747                     sayNO;
3748                 locinput = PL_reginput;
3749                 if (HAS_TEXT(next) || JUMPABLE(next)) {
3750                     regnode *text_node = next;
3751
3752                     if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3753
3754                     if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3755                     else {
3756                         if (PL_regkind[(U8)OP(text_node)] == REF) {
3757                             c1 = c2 = -1000;
3758                             goto assume_ok_MM;
3759                         }
3760                         else { c1 = (U8)*STRING(text_node); }
3761                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3762                             c2 = PL_fold[c1];
3763                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3764                             c2 = PL_fold_locale[c1];
3765                         else
3766                             c2 = c1;
3767                     }
3768                 }
3769                 else
3770                     c1 = c2 = -1000;
3771             assume_ok_MM:
3772                 REGCP_SET(lastcp);
3773                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3774                     /* If it could work, try it. */
3775                     if (c1 == -1000 ||
3776                         UCHARAT(PL_reginput) == c1 ||
3777                         UCHARAT(PL_reginput) == c2)
3778                     {
3779                         if (paren) {
3780                             if (ln) {
3781                                 PL_regstartp[paren] =
3782                                     HOPc(PL_reginput, -l) - PL_bostr;
3783                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3784                             }
3785                             else
3786                                 PL_regendp[paren] = -1;
3787                         }
3788                         if (regmatch(next))
3789                             sayYES;
3790                         REGCP_UNWIND(lastcp);
3791                     }
3792                     /* Couldn't or didn't -- move forward. */
3793                     PL_reginput = locinput;
3794                     if (regrepeat_hard(scan, 1, &l)) {
3795                         ln++;
3796                         locinput = PL_reginput;
3797                     }
3798                     else
3799                         sayNO;
3800                 }
3801             }
3802             else {
3803                 n = regrepeat_hard(scan, n, &l);
3804                 locinput = PL_reginput;
3805                 DEBUG_EXECUTE_r(
3806                     PerlIO_printf(Perl_debug_log,
3807                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3808                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3809                                   (IV) n, (IV)l)
3810                     );
3811                 if (n >= ln) {
3812                     if (HAS_TEXT(next) || JUMPABLE(next)) {
3813                         regnode *text_node = next;
3814
3815                         if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3816
3817                         if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3818                         else {
3819                             if (PL_regkind[(U8)OP(text_node)] == REF) {
3820                                 c1 = c2 = -1000;
3821                                 goto assume_ok_REG;
3822                             }
3823                             else { c1 = (U8)*STRING(text_node); }
3824
3825                             if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3826                                 c2 = PL_fold[c1];
3827                             else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3828                                 c2 = PL_fold_locale[c1];
3829                             else
3830                                 c2 = c1;
3831                         }
3832                     }
3833                     else
3834                         c1 = c2 = -1000;
3835                 }
3836             assume_ok_REG:
3837                 REGCP_SET(lastcp);
3838                 while (n >= ln) {
3839                     /* If it could work, try it. */
3840                     if (c1 == -1000 ||
3841                         UCHARAT(PL_reginput) == c1 ||
3842                         UCHARAT(PL_reginput) == c2)
3843                     {
3844                         DEBUG_EXECUTE_r(
3845                                 PerlIO_printf(Perl_debug_log,
3846                                               "%*s  trying tail with n=%"IVdf"...\n",
3847                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
3848                             );
3849                         if (paren) {
3850                             if (n) {
3851                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
3852                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3853                             }
3854                             else
3855                                 PL_regendp[paren] = -1;
3856                         }
3857                         if (regmatch(next))
3858                             sayYES;
3859                         REGCP_UNWIND(lastcp);
3860                     }
3861                     /* Couldn't or didn't -- back up. */
3862                     n--;
3863                     locinput = HOPc(locinput, -l);
3864                     PL_reginput = locinput;
3865                 }
3866             }
3867             sayNO;
3868             break;
3869         }
3870         case CURLYN:
3871             paren = scan->flags;        /* Which paren to set */
3872             if (paren > PL_regsize)
3873                 PL_regsize = paren;
3874             if (paren > (I32)*PL_reglastparen)
3875                 *PL_reglastparen = paren;
3876             ln = ARG1(scan);  /* min to match */
3877             n  = ARG2(scan);  /* max to match */
3878             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3879             goto repeat;
3880         case CURLY:
3881             paren = 0;
3882             ln = ARG1(scan);  /* min to match */
3883             n  = ARG2(scan);  /* max to match */
3884             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3885             goto repeat;
3886         case STAR:
3887             ln = 0;
3888             n = REG_INFTY;
3889             scan = NEXTOPER(scan);
3890             paren = 0;
3891             goto repeat;
3892         case PLUS:
3893             ln = 1;
3894             n = REG_INFTY;
3895             scan = NEXTOPER(scan);
3896             paren = 0;
3897           repeat:
3898             /*
3899             * Lookahead to avoid useless match attempts
3900             * when we know what character comes next.
3901             */
3902
3903             /*
3904             * Used to only do .*x and .*?x, but now it allows
3905             * for )'s, ('s and (?{ ... })'s to be in the way
3906             * of the quantifier and the EXACT-like node.  -- japhy
3907             */
3908
3909             if (HAS_TEXT(next) || JUMPABLE(next)) {
3910                 U8 *s;
3911                 regnode *text_node = next;
3912
3913                 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3914
3915                 if (! HAS_TEXT(text_node)) c1 = c2 = -1000;
3916                 else {
3917                     if (PL_regkind[(U8)OP(text_node)] == REF) {
3918                         c1 = c2 = -1000;
3919                         goto assume_ok_easy;
3920                     }
3921                     else { s = (U8*)STRING(text_node); }
3922
3923                     if (!UTF) {
3924                         c2 = c1 = *s;
3925                         if (OP(text_node) == EXACTF || OP(text_node) == REFF)
3926                             c2 = PL_fold[c1];
3927                         else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3928                             c2 = PL_fold_locale[c1];
3929                     }
3930                     else { /* UTF */
3931                         if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
3932                              STRLEN ulen1, ulen2;
3933                              U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3934                              U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3935
3936                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
3937                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
3938
3939                              c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
3940                                                  uniflags);
3941                              c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
3942                                                  uniflags);
3943                         }
3944                         else {
3945                             c2 = c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
3946                                                      uniflags);
3947                         }
3948                     }
3949                 }
3950             }
3951             else
3952                 c1 = c2 = -1000;
3953         assume_ok_easy:
3954             PL_reginput = locinput;
3955             if (minmod) {
3956                 CHECKPOINT lastcp;
3957                 minmod = 0;
3958                 if (ln && regrepeat(scan, ln) < ln)
3959                     sayNO;
3960                 locinput = PL_reginput;
3961                 REGCP_SET(lastcp);
3962                 if (c1 != -1000) {
3963                     char *e; /* Should not check after this */
3964                     char *old = locinput;
3965                     int count = 0;
3966
3967                     if  (n == REG_INFTY) {
3968                         e = PL_regeol - 1;
3969                         if (do_utf8)
3970                             while (UTF8_IS_CONTINUATION(*(U8*)e))
3971                                 e--;
3972                     }
3973                     else if (do_utf8) {
3974                         int m = n - ln;
3975                         for (e = locinput;
3976                              m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
3977                             e += UTF8SKIP(e);
3978                     }
3979                     else {
3980                         e = locinput + n - ln;
3981                         if (e >= PL_regeol)
3982                             e = PL_regeol - 1;
3983                     }
3984                     while (1) {
3985                         /* Find place 'next' could work */
3986                         if (!do_utf8) {
3987                             if (c1 == c2) {
3988                                 while (locinput <= e &&
3989                                        UCHARAT(locinput) != c1)
3990                                     locinput++;
3991                             } else {
3992                                 while (locinput <= e
3993                                        && UCHARAT(locinput) != c1
3994                                        && UCHARAT(locinput) != c2)
3995                                     locinput++;
3996                             }
3997                             count = locinput - old;
3998                         }
3999                         else {
4000                             if (c1 == c2) {
4001                                 STRLEN len;
4002                                 /* count initialised to
4003                                  * utf8_distance(old, locinput) */
4004                                 while (locinput <= e &&
4005                                        utf8n_to_uvchr((U8*)locinput,
4006                                                       UTF8_MAXBYTES, &len,
4007                                                       uniflags) != (UV)c1) {
4008                                     locinput += len;
4009                                     count++;
4010                                 }
4011                             } else {
4012                                 STRLEN len;
4013                                 /* count initialised to
4014                                  * utf8_distance(old, locinput) */
4015                                 while (locinput <= e) {
4016                                     UV c = utf8n_to_uvchr((U8*)locinput,
4017                                                           UTF8_MAXBYTES, &len,
4018                                                           uniflags);
4019                                     if (c == (UV)c1 || c == (UV)c2)
4020                                         break;
4021                                     locinput += len;
4022                                     count++;
4023                                 }
4024                             }
4025                         }
4026                         if (locinput > e)
4027                             sayNO;
4028                         /* PL_reginput == old now */
4029                         if (locinput != old) {
4030                             ln = 1;     /* Did some */
4031                             if (regrepeat(scan, count) < count)
4032                                 sayNO;
4033                         }
4034                         /* PL_reginput == locinput now */
4035                         TRYPAREN(paren, ln, locinput);
4036                         PL_reginput = locinput; /* Could be reset... */
4037                         REGCP_UNWIND(lastcp);
4038                         /* Couldn't or didn't -- move forward. */
4039                         old = locinput;
4040                         if (do_utf8)
4041                             locinput += UTF8SKIP(locinput);
4042                         else
4043                             locinput++;
4044                         count = 1;
4045                     }
4046                 }
4047                 else
4048                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
4049                     UV c;
4050                     if (c1 != -1000) {
4051                         if (do_utf8)
4052                             c = utf8n_to_uvchr((U8*)PL_reginput,
4053                                                UTF8_MAXBYTES, 0,
4054                                                uniflags);
4055                         else
4056                             c = UCHARAT(PL_reginput);
4057                         /* If it could work, try it. */
4058                         if (c == (UV)c1 || c == (UV)c2)
4059                         {
4060                             TRYPAREN(paren, ln, PL_reginput);
4061                             REGCP_UNWIND(lastcp);
4062                         }
4063                     }
4064                     /* If it could work, try it. */
4065                     else if (c1 == -1000)
4066                     {
4067                         TRYPAREN(paren, ln, PL_reginput);
4068                         REGCP_UNWIND(lastcp);
4069                     }
4070                     /* Couldn't or didn't -- move forward. */
4071                     PL_reginput = locinput;
4072                     if (regrepeat(scan, 1)) {
4073                         ln++;
4074                         locinput = PL_reginput;
4075                     }
4076                     else
4077                         sayNO;
4078                 }
4079             }
4080             else {
4081                 CHECKPOINT lastcp;
4082                 n = regrepeat(scan, n);
4083                 locinput = PL_reginput;
4084                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
4085                     (OP(next) != MEOL ||
4086                         OP(next) == SEOL || OP(next) == EOS))
4087                 {
4088                     ln = n;                     /* why back off? */
4089                     /* ...because $ and \Z can match before *and* after
4090                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4091                        We should back off by one in this case. */
4092                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
4093                         ln--;
4094                 }
4095                 REGCP_SET(lastcp);
4096                 if (paren) {
4097                     UV c = 0;
4098                     while (n >= ln) {
4099                         if (c1 != -1000) {
4100                             if (do_utf8)
4101                                 c = utf8n_to_uvchr((U8*)PL_reginput,
4102                                                    UTF8_MAXBYTES, 0,
4103                                                    uniflags);
4104                             else
4105                                 c = UCHARAT(PL_reginput);
4106                         }
4107                         /* If it could work, try it. */
4108                         if (c1 == -1000 || c == (UV)c1 || c == (UV)c2)
4109                             {
4110                                 TRYPAREN(paren, n, PL_reginput);
4111                                 REGCP_UNWIND(lastcp);
4112                             }
4113                         /* Couldn't or didn't -- back up. */
4114                         n--;
4115                         PL_reginput = locinput = HOPc(locinput, -1);
4116                     }
4117                 }
4118                 else {
4119                     UV c = 0;
4120                     while (n >= ln) {
4121                         if (c1 != -1000) {
4122                             if (do_utf8)
4123                                 c = utf8n_to_uvchr((U8*)PL_reginput,
4124                                                    UTF8_MAXBYTES, 0,
4125                                                    uniflags);
4126                             else
4127                                 c = UCHARAT(PL_reginput);
4128                         }
4129                         /* If it could work, try it. */
4130                         if (c1 == -1000 || c == (UV)c1 || c == (UV)c2)
4131                             {
4132                                 TRYPAREN(paren, n, PL_reginput);
4133                                 REGCP_UNWIND(lastcp);
4134                             }
4135                         /* Couldn't or didn't -- back up. */
4136                         n--;
4137                         PL_reginput = locinput = HOPc(locinput, -1);
4138                     }
4139                 }
4140             }
4141             sayNO;
4142             break;
4143         case END:
4144             if (PL_reg_call_cc) {
4145                 re_cc_state *cur_call_cc = PL_reg_call_cc;
4146                 CURCUR *cctmp = PL_regcc;
4147                 regexp *re = PL_reg_re;
4148                 CHECKPOINT cp, lastcp;
4149
4150                 cp = regcppush(0);      /* Save *all* the positions. */
4151                 REGCP_SET(lastcp);
4152                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
4153                                                     the caller. */
4154                 PL_reginput = locinput; /* Make position available to
4155                                            the callcc. */
4156                 cache_re(PL_reg_call_cc->re);
4157                 PL_regcc = PL_reg_call_cc->cc;
4158                 PL_reg_call_cc = PL_reg_call_cc->prev;
4159                 if (regmatch(cur_call_cc->node)) {
4160                     PL_reg_call_cc = cur_call_cc;
4161                     regcpblow(cp);
4162                     sayYES;
4163                 }
4164                 REGCP_UNWIND(lastcp);
4165                 regcppop();
4166                 PL_reg_call_cc = cur_call_cc;
4167                 PL_regcc = cctmp;
4168                 PL_reg_re = re;
4169                 cache_re(re);
4170
4171                 DEBUG_EXECUTE_r(
4172                     PerlIO_printf(Perl_debug_log,
4173                                   "%*s  continuation failed...\n",
4174                                   REPORT_CODE_OFF+PL_regindent*2, "")
4175                     );
4176                 sayNO_SILENT;
4177             }
4178             if (locinput < PL_regtill) {
4179                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4180                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4181                                       PL_colors[4],
4182                                       (long)(locinput - PL_reg_starttry),
4183                                       (long)(PL_regtill - PL_reg_starttry),
4184                                       PL_colors[5]));
4185                 sayNO_FINAL;            /* Cannot match: too short. */
4186             }
4187             PL_reginput = locinput;     /* put where regtry can find it */
4188             sayYES_FINAL;               /* Success! */
4189         case SUCCEED:
4190             PL_reginput = locinput;     /* put where regtry can find it */
4191             sayYES_LOUD;                /* Success! */
4192         case SUSPEND:
4193             n = 1;
4194             PL_reginput = locinput;
4195             goto do_ifmatch;
4196         case UNLESSM:
4197             n = 0;
4198             if (scan->flags) {
4199                 s = HOPBACKc(locinput, scan->flags);
4200                 if (!s)
4201                     goto say_yes;
4202                 PL_reginput = s;
4203             }
4204             else
4205                 PL_reginput = locinput;
4206             goto do_ifmatch;
4207         case IFMATCH:
4208             n = 1;
4209             if (scan->flags) {
4210                 s = HOPBACKc(locinput, scan->flags);
4211                 if (!s)
4212                     goto say_no;
4213                 PL_reginput = s;
4214             }
4215             else
4216                 PL_reginput = locinput;
4217
4218           do_ifmatch:
4219             inner = NEXTOPER(NEXTOPER(scan));
4220             if (regmatch(inner) != n) {
4221               say_no:
4222                 if (logical) {
4223                     logical = 0;
4224                     sw = 0;
4225                     goto do_longjump;
4226                 }
4227                 else
4228                     sayNO;
4229             }
4230           say_yes:
4231             if (logical) {
4232                 logical = 0;
4233                 sw = 1;
4234             }
4235             if (OP(scan) == SUSPEND) {
4236                 locinput = PL_reginput;
4237                 nextchr = UCHARAT(locinput);
4238             }
4239             /* FALL THROUGH. */
4240         case LONGJMP:
4241           do_longjump:
4242             next = scan + ARG(scan);
4243             if (next == scan)
4244                 next = NULL;
4245             break;
4246         default:
4247             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4248                           PTR2UV(scan), OP(scan));
4249             Perl_croak(aTHX_ "regexp memory corruption");
4250         }
4251       reenter:
4252         scan = next;
4253     }
4254
4255     /*
4256     * We get here only if there's trouble -- normally "case END" is
4257     * the terminating point.
4258     */
4259     Perl_croak(aTHX_ "corrupted regexp pointers");
4260     /*NOTREACHED*/
4261     sayNO;
4262
4263 yes_loud:
4264     DEBUG_EXECUTE_r(
4265         PerlIO_printf(Perl_debug_log,
4266                       "%*s  %scould match...%s\n",
4267                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4268         );
4269     goto yes;
4270 yes_final:
4271     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4272                           PL_colors[4], PL_colors[5]));
4273 yes:
4274 #ifdef DEBUGGING
4275     PL_regindent--;
4276 #endif
4277
4278 #if 0                                   /* Breaks $^R */
4279     if (unwind)
4280         regcpblow(firstcp);
4281 #endif
4282     return 1;
4283
4284 no:
4285     DEBUG_EXECUTE_r(
4286         PerlIO_printf(Perl_debug_log,
4287                       "%*s  %sfailed...%s\n",
4288                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4289         );
4290     goto do_no;
4291 no_final:
4292 do_no:
4293     if (unwind) {
4294         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
4295
4296         switch (uw->type) {
4297         case RE_UNWIND_BRANCH:
4298         case RE_UNWIND_BRANCHJ:
4299         {
4300             re_unwind_branch_t *uwb = &(uw->branch);
4301             const I32 lastparen = uwb->lastparen;
4302
4303             REGCP_UNWIND(uwb->lastcp);
4304             for (n = *PL_reglastparen; n > lastparen; n--)
4305                 PL_regendp[n] = -1;
4306             *PL_reglastparen = n;
4307             scan = next = uwb->next;
4308             if ( !scan ||
4309                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
4310                               ? BRANCH : BRANCHJ) ) {           /* Failure */
4311                 unwind = uwb->prev;
4312 #ifdef DEBUGGING
4313                 PL_regindent--;
4314 #endif
4315                 goto do_no;
4316             }
4317             /* Have more choice yet.  Reuse the same uwb.  */
4318             if ((n = (uwb->type == RE_UNWIND_BRANCH
4319                       ? NEXT_OFF(next) : ARG(next))))
4320                 next += n;
4321             else
4322                 next = NULL;    /* XXXX Needn't unwinding in this case... */
4323             uwb->next = next;
4324             next = NEXTOPER(scan);
4325             if (uwb->type == RE_UNWIND_BRANCHJ)
4326                 next = NEXTOPER(next);
4327             locinput = uwb->locinput;
4328             nextchr = uwb->nextchr;
4329 #ifdef DEBUGGING
4330             PL_regindent = uwb->regindent;
4331 #endif
4332
4333             goto reenter;
4334         }
4335         /* NOT REACHED */
4336         default:
4337             Perl_croak(aTHX_ "regexp unwind memory corruption");
4338         }
4339         /* NOT REACHED */
4340     }
4341 #ifdef DEBUGGING
4342     PL_regindent--;
4343 #endif
4344     return 0;
4345 }
4346
4347 /*
4348  - regrepeat - repeatedly match something simple, report how many
4349  */
4350 /*
4351  * [This routine now assumes that it will only match on things of length 1.
4352  * That was true before, but now we assume scan - reginput is the count,
4353  * rather than incrementing count on every character.  [Er, except utf8.]]
4354  */
4355 STATIC I32
4356 S_regrepeat(pTHX_ const regnode *p, I32 max)
4357 {
4358     dVAR;
4359     register char *scan;
4360     register I32 c;
4361     register char *loceol = PL_regeol;
4362     register I32 hardcount = 0;
4363     register bool do_utf8 = PL_reg_match_utf8;
4364
4365     scan = PL_reginput;
4366     if (max == REG_INFTY)
4367         max = I32_MAX;
4368     else if (max < loceol - scan)
4369       loceol = scan + max;
4370     switch (OP(p)) {
4371     case REG_ANY:
4372         if (do_utf8) {
4373             loceol = PL_regeol;
4374             while (scan < loceol && hardcount < max && *scan != '\n') {
4375                 scan += UTF8SKIP(scan);
4376                 hardcount++;
4377             }
4378         } else {
4379             while (scan < loceol && *scan != '\n')
4380                 scan++;
4381         }
4382         break;
4383     case SANY:
4384         if (do_utf8) {
4385             loceol = PL_regeol;
4386             while (scan < loceol && hardcount < max) {
4387                 scan += UTF8SKIP(scan);
4388                 hardcount++;
4389             }
4390         }
4391         else
4392             scan = loceol;
4393         break;
4394     case CANY:
4395         scan = loceol;
4396         break;
4397     case EXACT:         /* length of string is 1 */
4398         c = (U8)*STRING(p);
4399         while (scan < loceol && UCHARAT(scan) == c)
4400             scan++;
4401         break;
4402     case EXACTF:        /* length of string is 1 */
4403         c = (U8)*STRING(p);
4404         while (scan < loceol &&
4405                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4406             scan++;
4407         break;
4408     case EXACTFL:       /* length of string is 1 */
4409         PL_reg_flags |= RF_tainted;
4410         c = (U8)*STRING(p);
4411         while (scan < loceol &&
4412                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4413             scan++;
4414         break;
4415     case ANYOF:
4416         if (do_utf8) {
4417             loceol = PL_regeol;
4418             while (hardcount < max && scan < loceol &&
4419                    reginclass(p, (U8*)scan, 0, do_utf8)) {
4420                 scan += UTF8SKIP(scan);
4421                 hardcount++;
4422             }
4423         } else {
4424             while (scan < loceol && REGINCLASS(p, (U8*)scan))
4425                 scan++;
4426         }
4427         break;
4428     case ALNUM:
4429         if (do_utf8) {
4430             loceol = PL_regeol;
4431             LOAD_UTF8_CHARCLASS_ALNUM();
4432             while (hardcount < max && scan < loceol &&
4433                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4434                 scan += UTF8SKIP(scan);
4435                 hardcount++;
4436             }
4437         } else {
4438             while (scan < loceol && isALNUM(*scan))
4439                 scan++;
4440         }
4441         break;
4442     case ALNUML:
4443         PL_reg_flags |= RF_tainted;
4444         if (do_utf8) {
4445             loceol = PL_regeol;
4446             while (hardcount < max && scan < loceol &&
4447                    isALNUM_LC_utf8((U8*)scan)) {
4448                 scan += UTF8SKIP(scan);
4449                 hardcount++;
4450             }
4451         } else {
4452             while (scan < loceol && isALNUM_LC(*scan))
4453                 scan++;
4454         }
4455         break;
4456     case NALNUM:
4457         if (do_utf8) {
4458             loceol = PL_regeol;
4459             LOAD_UTF8_CHARCLASS_ALNUM();
4460             while (hardcount < max && scan < loceol &&
4461                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4462                 scan += UTF8SKIP(scan);
4463                 hardcount++;
4464             }
4465         } else {
4466             while (scan < loceol && !isALNUM(*scan))
4467                 scan++;
4468         }
4469         break;
4470     case NALNUML:
4471         PL_reg_flags |= RF_tainted;
4472         if (do_utf8) {
4473             loceol = PL_regeol;
4474             while (hardcount < max && scan < loceol &&
4475                    !isALNUM_LC_utf8((U8*)scan)) {
4476                 scan += UTF8SKIP(scan);
4477                 hardcount++;
4478             }
4479         } else {
4480             while (scan < loceol && !isALNUM_LC(*scan))
4481                 scan++;
4482         }
4483         break;
4484     case SPACE:
4485         if (do_utf8) {
4486             loceol = PL_regeol;
4487             LOAD_UTF8_CHARCLASS_SPACE();
4488             while (hardcount < max && scan < loceol &&
4489                    (*scan == ' ' ||
4490                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4491                 scan += UTF8SKIP(scan);
4492                 hardcount++;
4493             }
4494         } else {
4495             while (scan < loceol && isSPACE(*scan))
4496                 scan++;
4497         }
4498         break;
4499     case SPACEL:
4500         PL_reg_flags |= RF_tainted;
4501         if (do_utf8) {
4502             loceol = PL_regeol;
4503             while (hardcount < max && scan < loceol &&
4504                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4505                 scan += UTF8SKIP(scan);
4506                 hardcount++;
4507             }
4508         } else {
4509             while (scan < loceol && isSPACE_LC(*scan))
4510                 scan++;
4511         }
4512         break;
4513     case NSPACE:
4514         if (do_utf8) {
4515             loceol = PL_regeol;
4516             LOAD_UTF8_CHARCLASS_SPACE();
4517             while (hardcount < max && scan < loceol &&
4518                    !(*scan == ' ' ||
4519                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4520                 scan += UTF8SKIP(scan);
4521                 hardcount++;
4522             }
4523         } else {
4524             while (scan < loceol && !isSPACE(*scan))
4525                 scan++;
4526             break;
4527         }
4528     case NSPACEL:
4529         PL_reg_flags |= RF_tainted;
4530         if (do_utf8) {
4531             loceol = PL_regeol;
4532             while (hardcount < max && scan < loceol &&
4533                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4534                 scan += UTF8SKIP(scan);
4535                 hardcount++;
4536             }
4537         } else {
4538             while (scan < loceol && !isSPACE_LC(*scan))
4539                 scan++;
4540         }
4541         break;
4542     case DIGIT:
4543         if (do_utf8) {
4544             loceol = PL_regeol;
4545             LOAD_UTF8_CHARCLASS_DIGIT();
4546             while (hardcount < max && scan < loceol &&
4547                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4548                 scan += UTF8SKIP(scan);
4549                 hardcount++;
4550             }
4551         } else {
4552             while (scan < loceol && isDIGIT(*scan))
4553                 scan++;
4554         }
4555         break;
4556     case NDIGIT:
4557         if (do_utf8) {
4558             loceol = PL_regeol;
4559             LOAD_UTF8_CHARCLASS_DIGIT();
4560             while (hardcount < max && scan < loceol &&
4561                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4562                 scan += UTF8SKIP(scan);
4563                 hardcount++;
4564             }
4565         } else {
4566             while (scan < loceol && !isDIGIT(*scan))
4567                 scan++;
4568         }
4569         break;
4570     default:            /* Called on something of 0 width. */
4571         break;          /* So match right here or not at all. */
4572     }
4573
4574     if (hardcount)
4575         c = hardcount;
4576     else
4577         c = scan - PL_reginput;
4578     PL_reginput = scan;
4579
4580     DEBUG_r({
4581                 SV *re_debug_flags = NULL;
4582                 SV *prop = sv_newmortal();
4583                 GET_RE_DEBUG_FLAGS;
4584                 DEBUG_EXECUTE_r({
4585                 regprop(prop, p);
4586                 PerlIO_printf(Perl_debug_log,
4587                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
4588                               REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
4589         });
4590         });
4591
4592     return(c);
4593 }
4594
4595 /*
4596  - regrepeat_hard - repeatedly match something, report total lenth and length
4597  *
4598  * The repeater is supposed to have constant non-zero length.
4599  */
4600
4601 STATIC I32
4602 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
4603 {
4604     register char *scan = Nullch;
4605     register char *start;
4606     register char *loceol = PL_regeol;
4607     I32 l = 0;
4608     I32 count = 0, res = 1;
4609
4610     if (!max)
4611         return 0;
4612
4613     start = PL_reginput;
4614     if (PL_reg_match_utf8) {
4615         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
4616             if (!count++) {
4617                 l = 0;
4618                 while (start < PL_reginput) {
4619                     l++;
4620                     start += UTF8SKIP(start);
4621                 }
4622                 *lp = l;
4623                 if (l == 0)
4624                     return max;
4625             }
4626             if (count == max)
4627                 return count;
4628         }
4629     }
4630     else {
4631         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
4632             if (!count++) {
4633                 *lp = l = PL_reginput - start;
4634                 if (max != REG_INFTY && l*max < loceol - scan)
4635                     loceol = scan + l*max;
4636                 if (l == 0)
4637                     return max;
4638             }
4639         }
4640     }
4641     if (!res)
4642         PL_reginput = scan;
4643
4644     return count;
4645 }
4646
4647 /*
4648 - regclass_swash - prepare the utf8 swash
4649 */
4650
4651 SV *
4652 Perl_regclass_swash(pTHX_ register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
4653 {
4654     SV *sw  = NULL;
4655     SV *si  = NULL;
4656     SV *alt = NULL;
4657
4658     if (PL_regdata && PL_regdata->count) {
4659         const U32 n = ARG(node);
4660
4661         if (PL_regdata->what[n] == 's') {
4662             SV * const rv = (SV*)PL_regdata->data[n];
4663             AV * const av = (AV*)SvRV((SV*)rv);
4664             SV **const ary = AvARRAY(av);
4665             SV **a, **b;
4666
4667             /* See the end of regcomp.c:S_reglass() for
4668              * documentation of these array elements. */
4669
4670             si = *ary;
4671             a  = SvTYPE(ary[1]) == SVt_RV   ? &ary[1] : 0;
4672             b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
4673
4674             if (a)
4675                 sw = *a;
4676             else if (si && doinit) {
4677                 sw = swash_init("utf8", "", si, 1, 0);
4678                 (void)av_store(av, 1, sw);
4679             }
4680             if (b)
4681                 alt = *b;
4682         }
4683     }
4684
4685     if (listsvp)
4686         *listsvp = si;
4687     if (altsvp)
4688         *altsvp  = alt;
4689
4690     return sw;
4691 }
4692
4693 /*
4694  - reginclass - determine if a character falls into a character class
4695
4696   The n is the ANYOF regnode, the p is the target string, lenp
4697   is pointer to the maximum length of how far to go in the p
4698   (if the lenp is zero, UTF8SKIP(p) is used),
4699   do_utf8 tells whether the target string is in UTF-8.
4700
4701  */
4702
4703 STATIC bool
4704 S_reginclass(pTHX_ register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
4705 {
4706     dVAR;
4707     const char flags = ANYOF_FLAGS(n);
4708     bool match = FALSE;
4709     UV c = *p;
4710     STRLEN len = 0;
4711     STRLEN plen;
4712
4713     if (do_utf8 && !UTF8_IS_INVARIANT(c))
4714          c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
4715                             ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
4716
4717     plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
4718     if (do_utf8 || (flags & ANYOF_UNICODE)) {
4719         if (lenp)
4720             *lenp = 0;
4721         if (do_utf8 && !ANYOF_RUNTIME(n)) {
4722             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
4723                 match = TRUE;
4724         }
4725         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
4726             match = TRUE;
4727         if (!match) {
4728             AV *av;
4729             SV * const sw = regclass_swash(n, TRUE, 0, (SV**)&av);
4730
4731             if (sw) {
4732                 if (swash_fetch(sw, p, do_utf8))
4733                     match = TRUE;
4734                 else if (flags & ANYOF_FOLD) {
4735                     if (!match && lenp && av) {
4736                         I32 i;
4737                         for (i = 0; i <= av_len(av); i++) {
4738                             SV* const sv = *av_fetch(av, i, FALSE);
4739                             STRLEN len;
4740                             const char * const s = SvPV_const(sv, len);
4741
4742                             if (len <= plen && memEQ(s, (char*)p, len)) {
4743                                 *lenp = len;
4744                                 match = TRUE;
4745                                 break;
4746                             }
4747                         }
4748                     }
4749                     if (!match) {
4750                         U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
4751                         STRLEN tmplen;
4752
4753                         to_utf8_fold(p, tmpbuf, &tmplen);
4754                         if (swash_fetch(sw, tmpbuf, do_utf8))
4755                             match = TRUE;
4756                     }
4757                 }
4758             }
4759         }
4760         if (match && lenp && *lenp == 0)
4761             *lenp = UNISKIP(NATIVE_TO_UNI(c));
4762     }
4763     if (!match && c < 256) {
4764         if (ANYOF_BITMAP_TEST(n, c))
4765             match = TRUE;
4766         else if (flags & ANYOF_FOLD) {
4767             U8 f;
4768
4769             if (flags & ANYOF_LOCALE) {
4770                 PL_reg_flags |= RF_tainted;
4771                 f = PL_fold_locale[c];
4772             }
4773             else
4774                 f = PL_fold[c];
4775             if (f != c && ANYOF_BITMAP_TEST(n, f))
4776                 match = TRUE;
4777         }
4778
4779         if (!match && (flags & ANYOF_CLASS)) {
4780             PL_reg_flags |= RF_tainted;
4781             if (
4782                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
4783                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
4784                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
4785                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
4786                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
4787                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
4788                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
4789                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
4790                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
4791                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
4792                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
4793                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
4794                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
4795                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
4796                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
4797                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
4798                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
4799                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
4800                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
4801                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
4802                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
4803                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
4804                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
4805                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
4806                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
4807                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
4808                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
4809                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
4810                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
4811                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
4812                 ) /* How's that for a conditional? */
4813             {
4814                 match = TRUE;
4815             }
4816         }
4817     }
4818
4819     return (flags & ANYOF_INVERT) ? !match : match;
4820 }
4821
4822 STATIC U8 *
4823 S_reghop(pTHX_ U8 *s, I32 off)
4824 {
4825     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4826 }
4827
4828 STATIC U8 *
4829 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
4830 {
4831     if (off >= 0) {
4832         while (off-- && s < lim) {
4833             /* XXX could check well-formedness here */
4834             s += UTF8SKIP(s);
4835         }
4836     }
4837     else {
4838         while (off++) {
4839             if (s > lim) {
4840                 s--;
4841                 if (UTF8_IS_CONTINUED(*s)) {
4842                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4843                         s--;
4844                 }
4845                 /* XXX could check well-formedness here */
4846             }
4847         }
4848     }
4849     return s;
4850 }
4851
4852 STATIC U8 *
4853 S_reghopmaybe(pTHX_ U8 *s, I32 off)
4854 {
4855     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4856 }
4857
4858 STATIC U8 *
4859 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
4860 {
4861     if (off >= 0) {
4862         while (off-- && s < lim) {
4863             /* XXX could check well-formedness here */
4864             s += UTF8SKIP(s);
4865         }
4866         if (off >= 0)
4867             return 0;
4868     }
4869     else {
4870         while (off++) {
4871             if (s > lim) {
4872                 s--;
4873                 if (UTF8_IS_CONTINUED(*s)) {
4874                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4875                         s--;
4876                 }
4877                 /* XXX could check well-formedness here */
4878             }
4879             else
4880                 break;
4881         }
4882         if (off <= 0)
4883             return 0;
4884     }
4885     return s;
4886 }
4887
4888 static void
4889 restore_pos(pTHX_ void *arg)
4890 {
4891     PERL_UNUSED_ARG(arg);
4892     if (PL_reg_eval_set) {
4893         if (PL_reg_oldsaved) {
4894             PL_reg_re->subbeg = PL_reg_oldsaved;
4895             PL_reg_re->sublen = PL_reg_oldsavedlen;
4896 #ifdef PERL_OLD_COPY_ON_WRITE
4897             PL_reg_re->saved_copy = PL_nrs;
4898 #endif
4899             RX_MATCH_COPIED_on(PL_reg_re);
4900         }
4901         PL_reg_magic->mg_len = PL_reg_oldpos;
4902         PL_reg_eval_set = 0;
4903         PL_curpm = PL_reg_oldcurpm;
4904     }
4905 }
4906
4907 STATIC void
4908 S_to_utf8_substr(pTHX_ register regexp *prog)
4909 {
4910     if (prog->float_substr && !prog->float_utf8) {
4911         SV* sv;
4912         prog->float_utf8 = sv = newSVsv(prog->float_substr);
4913         sv_utf8_upgrade(sv);
4914         if (SvTAIL(prog->float_substr))
4915             SvTAIL_on(sv);
4916         if (prog->float_substr == prog->check_substr)
4917             prog->check_utf8 = sv;
4918     }
4919     if (prog->anchored_substr && !prog->anchored_utf8) {
4920         SV* sv;
4921         prog->anchored_utf8 = sv = newSVsv(prog->anchored_substr);
4922         sv_utf8_upgrade(sv);
4923         if (SvTAIL(prog->anchored_substr))
4924             SvTAIL_on(sv);
4925         if (prog->anchored_substr == prog->check_substr)
4926             prog->check_utf8 = sv;
4927     }
4928 }
4929
4930 STATIC void
4931 S_to_byte_substr(pTHX_ register regexp *prog)
4932 {
4933     if (prog->float_utf8 && !prog->float_substr) {
4934         SV* sv;
4935         prog->float_substr = sv = newSVsv(prog->float_utf8);
4936         if (sv_utf8_downgrade(sv, TRUE)) {
4937             if (SvTAIL(prog->float_utf8))
4938                 SvTAIL_on(sv);
4939         } else {
4940             SvREFCNT_dec(sv);
4941             prog->float_substr = sv = &PL_sv_undef;
4942         }
4943         if (prog->float_utf8 == prog->check_utf8)
4944             prog->check_substr = sv;
4945     }
4946     if (prog->anchored_utf8 && !prog->anchored_substr) {
4947         SV* sv;
4948         prog->anchored_substr = sv = newSVsv(prog->anchored_utf8);
4949         if (sv_utf8_downgrade(sv, TRUE)) {
4950             if (SvTAIL(prog->anchored_utf8))
4951                 SvTAIL_on(sv);
4952         } else {
4953             SvREFCNT_dec(sv);
4954             prog->anchored_substr = sv = &PL_sv_undef;
4955         }
4956         if (prog->anchored_utf8 == prog->check_utf8)
4957             prog->check_substr = sv;
4958     }
4959 }
4960
4961 /*
4962  * Local variables:
4963  * c-indentation-style: bsd
4964  * c-basic-offset: 4
4965  * indent-tabs-mode: t
4966  * End:
4967  *
4968  * ex: set ts=8 sts=4 sw=4 noet:
4969  */