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