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