regexec.c

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