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 &&
3286                                        UCHARAT(locinput) != c1)
3287                                     locinput++;
3288                             } else {
3289                                 while (locinput <= e
3290                                        && UCHARAT(locinput) != c1
3291                                        && UCHARAT(locinput) != c2)
3292                                     locinput++;
3293                             }
3294                             count = locinput - old;
3295                         }
3296                         else {
3297                             STRLEN len;
3298                             if (c1 == c2) {
3299                                 for (count = 0;
3300                                      locinput <= e &&
3301                                          utf8_to_uvchr((U8*)locinput, &len) != c1;
3302                                      count++)
3303                                     locinput += len;
3304
3305                             } else {
3306                                 for (count = 0; locinput <= e; count++) {
3307                                     UV c = utf8_to_uvchr((U8*)locinput, &len);
3308                                     if (c == c1 || c == c2)
3309                                         break;
3310                                     locinput += len;
3311                                 }
3312                             }
3313                         }
3314                         if (locinput > e)
3315                             sayNO;
3316                         /* PL_reginput == old now */
3317                         if (locinput != old) {
3318                             ln = 1;     /* Did some */
3319                             if (regrepeat(scan, count) < count)
3320                                 sayNO;
3321                         }
3322                         /* PL_reginput == locinput now */
3323                         TRYPAREN(paren, ln, locinput);
3324                         PL_reginput = locinput; /* Could be reset... */
3325                         REGCP_UNWIND(lastcp);
3326                         /* Couldn't or didn't -- move forward. */
3327                         old = locinput;
3328                         if (do_utf8)
3329                             locinput += UTF8SKIP(locinput);
3330                         else
3331                             locinput++;
3332                     }
3333                 }
3334                 else
3335                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3336                     UV c;
3337                     if (c1 != -1000) {
3338                         if (do_utf8)
3339                             c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3340                         else
3341                             c = UCHARAT(PL_reginput);
3342                         /* If it could work, try it. */
3343                         if (c == c1 || c == c2)
3344                         {
3345                             TRYPAREN(paren, n, PL_reginput);
3346                             REGCP_UNWIND(lastcp);
3347                         }
3348                     }
3349                     /* If it could work, try it. */
3350                     else if (c1 == -1000)
3351                     {
3352                         TRYPAREN(paren, n, PL_reginput);
3353                         REGCP_UNWIND(lastcp);
3354                     }
3355                     /* Couldn't or didn't -- move forward. */
3356                     PL_reginput = locinput;
3357                     if (regrepeat(scan, 1)) {
3358                         ln++;
3359                         locinput = PL_reginput;
3360                     }
3361                     else
3362                         sayNO;
3363                 }
3364             }
3365             else {
3366                 CHECKPOINT lastcp;
3367                 n = regrepeat(scan, n);
3368                 locinput = PL_reginput;
3369                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3370                     (!PL_multiline  || OP(next) == SEOL || OP(next) == EOS)) {
3371                     ln = n;                     /* why back off? */
3372                     /* ...because $ and \Z can match before *and* after
3373                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3374                        We should back off by one in this case. */
3375                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3376                         ln--;
3377                 }
3378                 REGCP_SET(lastcp);
3379                 if (paren) {
3380                     UV c = 0;
3381                     while (n >= ln) {
3382                         if (c1 != -1000) {
3383                             if (do_utf8)
3384                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3385                             else
3386                                 c = UCHARAT(PL_reginput);
3387                         }
3388                         /* If it could work, try it. */
3389                         if (c1 == -1000 || c == c1 || c == c2)
3390                             {
3391                                 TRYPAREN(paren, n, PL_reginput);
3392                                 REGCP_UNWIND(lastcp);
3393                             }
3394                         /* Couldn't or didn't -- back up. */
3395                         n--;
3396                         PL_reginput = locinput = HOPc(locinput, -1);
3397                     }
3398                 }
3399                 else {
3400                     UV c = 0;
3401                     while (n >= ln) {
3402                         if (c1 != -1000) {
3403                             if (do_utf8)
3404                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3405                             else
3406                                 c = UCHARAT(PL_reginput);
3407                         }
3408                         /* If it could work, try it. */
3409                         if (c1 == -1000 || c == c1 || c == c2)
3410                             {
3411                                 TRYPAREN(paren, n, PL_reginput);
3412                                 REGCP_UNWIND(lastcp);
3413                             }
3414                         /* Couldn't or didn't -- back up. */
3415                         n--;
3416                         PL_reginput = locinput = HOPc(locinput, -1);
3417                     }
3418                 }
3419             }
3420             sayNO;
3421             break;
3422         case END:
3423             if (PL_reg_call_cc) {
3424                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3425                 CURCUR *cctmp = PL_regcc;
3426                 regexp *re = PL_reg_re;
3427                 CHECKPOINT cp, lastcp;
3428
3429                 cp = regcppush(0);      /* Save *all* the positions. */
3430                 REGCP_SET(lastcp);
3431                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3432                                                     the caller. */
3433                 PL_reginput = locinput; /* Make position available to
3434                                            the callcc. */
3435                 cache_re(PL_reg_call_cc->re);
3436                 PL_regcc = PL_reg_call_cc->cc;
3437                 PL_reg_call_cc = PL_reg_call_cc->prev;
3438                 if (regmatch(cur_call_cc->node)) {
3439                     PL_reg_call_cc = cur_call_cc;
3440                     regcpblow(cp);
3441                     sayYES;
3442                 }
3443                 REGCP_UNWIND(lastcp);
3444                 regcppop();
3445                 PL_reg_call_cc = cur_call_cc;
3446                 PL_regcc = cctmp;
3447                 PL_reg_re = re;
3448                 cache_re(re);
3449
3450                 DEBUG_r(
3451                     PerlIO_printf(Perl_debug_log,
3452                                   "%*s  continuation failed...\n",
3453                                   REPORT_CODE_OFF+PL_regindent*2, "")
3454                     );
3455                 sayNO_SILENT;
3456             }
3457             if (locinput < PL_regtill) {
3458                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3459                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3460                                       PL_colors[4],
3461                                       (long)(locinput - PL_reg_starttry),
3462                                       (long)(PL_regtill - PL_reg_starttry),
3463                                       PL_colors[5]));
3464                 sayNO_FINAL;            /* Cannot match: too short. */
3465             }
3466             PL_reginput = locinput;     /* put where regtry can find it */
3467             sayYES_FINAL;               /* Success! */
3468         case SUCCEED:
3469             PL_reginput = locinput;     /* put where regtry can find it */
3470             sayYES_LOUD;                /* Success! */
3471         case SUSPEND:
3472             n = 1;
3473             PL_reginput = locinput;
3474             goto do_ifmatch;
3475         case UNLESSM:
3476             n = 0;
3477             if (scan->flags) {
3478                 s = HOPBACKc(locinput, scan->flags);
3479                 if (!s)
3480                     goto say_yes;
3481                 PL_reginput = s;
3482             }
3483             else
3484                 PL_reginput = locinput;
3485             goto do_ifmatch;
3486         case IFMATCH:
3487             n = 1;
3488             if (scan->flags) {
3489                 s = HOPBACKc(locinput, scan->flags);
3490                 if (!s)
3491                     goto say_no;
3492                 PL_reginput = s;
3493             }
3494             else
3495                 PL_reginput = locinput;
3496
3497           do_ifmatch:
3498             inner = NEXTOPER(NEXTOPER(scan));
3499             if (regmatch(inner) != n) {
3500               say_no:
3501                 if (logical) {
3502                     logical = 0;
3503                     sw = 0;
3504                     goto do_longjump;
3505                 }
3506                 else
3507                     sayNO;
3508             }
3509           say_yes:
3510             if (logical) {
3511                 logical = 0;
3512                 sw = 1;
3513             }
3514             if (OP(scan) == SUSPEND) {
3515                 locinput = PL_reginput;
3516                 nextchr = UCHARAT(locinput);
3517             }
3518             /* FALL THROUGH. */
3519         case LONGJMP:
3520           do_longjump:
3521             next = scan + ARG(scan);
3522             if (next == scan)
3523                 next = NULL;
3524             break;
3525         default:
3526             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3527                           PTR2UV(scan), OP(scan));
3528             Perl_croak(aTHX_ "regexp memory corruption");
3529         }
3530       reenter:
3531         scan = next;
3532     }
3533
3534     /*
3535     * We get here only if there's trouble -- normally "case END" is
3536     * the terminating point.
3537     */
3538     Perl_croak(aTHX_ "corrupted regexp pointers");
3539     /*NOTREACHED*/
3540     sayNO;
3541
3542 yes_loud:
3543     DEBUG_r(
3544         PerlIO_printf(Perl_debug_log,
3545                       "%*s  %scould match...%s\n",
3546                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3547         );
3548     goto yes;
3549 yes_final:
3550     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3551                           PL_colors[4],PL_colors[5]));
3552 yes:
3553 #ifdef DEBUGGING
3554     PL_regindent--;
3555 #endif
3556
3557 #if 0                                   /* Breaks $^R */
3558     if (unwind)
3559         regcpblow(firstcp);
3560 #endif
3561     return 1;
3562
3563 no:
3564     DEBUG_r(
3565         PerlIO_printf(Perl_debug_log,
3566                       "%*s  %sfailed...%s\n",
3567                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3568         );
3569     goto do_no;
3570 no_final:
3571 do_no:
3572     if (unwind) {
3573         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
3574
3575         switch (uw->type) {
3576         case RE_UNWIND_BRANCH:
3577         case RE_UNWIND_BRANCHJ:
3578         {
3579             re_unwind_branch_t *uwb = &(uw->branch);
3580             I32 lastparen = uwb->lastparen;
3581
3582             REGCP_UNWIND(uwb->lastcp);
3583             for (n = *PL_reglastparen; n > lastparen; n--)
3584                 PL_regendp[n] = -1;
3585             *PL_reglastparen = n;
3586             scan = next = uwb->next;
3587             if ( !scan ||
3588                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
3589                               ? BRANCH : BRANCHJ) ) {           /* Failure */
3590                 unwind = uwb->prev;
3591 #ifdef DEBUGGING
3592                 PL_regindent--;
3593 #endif
3594                 goto do_no;
3595             }
3596             /* Have more choice yet.  Reuse the same uwb.  */
3597             /*SUPPRESS 560*/
3598             if ((n = (uwb->type == RE_UNWIND_BRANCH
3599                       ? NEXT_OFF(next) : ARG(next))))
3600                 next += n;
3601             else
3602                 next = NULL;    /* XXXX Needn't unwinding in this case... */
3603             uwb->next = next;
3604             next = NEXTOPER(scan);
3605             if (uwb->type == RE_UNWIND_BRANCHJ)
3606                 next = NEXTOPER(next);
3607             locinput = uwb->locinput;
3608             nextchr = uwb->nextchr;
3609 #ifdef DEBUGGING
3610             PL_regindent = uwb->regindent;
3611 #endif
3612
3613             goto reenter;
3614         }
3615         /* NOT REACHED */
3616         default:
3617             Perl_croak(aTHX_ "regexp unwind memory corruption");
3618         }
3619         /* NOT REACHED */
3620     }
3621 #ifdef DEBUGGING
3622     PL_regindent--;
3623 #endif
3624     return 0;
3625 }
3626
3627 /*
3628  - regrepeat - repeatedly match something simple, report how many
3629  */
3630 /*
3631  * [This routine now assumes that it will only match on things of length 1.
3632  * That was true before, but now we assume scan - reginput is the count,
3633  * rather than incrementing count on every character.  [Er, except utf8.]]
3634  */
3635 STATIC I32
3636 S_regrepeat(pTHX_ regnode *p, I32 max)
3637 {
3638     register char *scan;
3639     register I32 c;
3640     register char *loceol = PL_regeol;
3641     register I32 hardcount = 0;
3642     register bool do_utf8 = PL_reg_match_utf8;
3643
3644     scan = PL_reginput;
3645     if (max != REG_INFTY && max < loceol - scan)
3646       loceol = scan + max;
3647     switch (OP(p)) {
3648     case REG_ANY:
3649         if (do_utf8) {
3650             loceol = PL_regeol;
3651             while (scan < loceol && hardcount < max && *scan != '\n') {
3652                 scan += UTF8SKIP(scan);
3653                 hardcount++;
3654             }
3655         } else {
3656             while (scan < loceol && *scan != '\n')
3657                 scan++;
3658         }
3659         break;
3660     case SANY:
3661         scan = loceol;
3662         break;
3663     case CANY:
3664         scan = loceol;
3665         break;
3666     case EXACT:         /* length of string is 1 */
3667         c = (U8)*STRING(p);
3668         while (scan < loceol && UCHARAT(scan) == c)
3669             scan++;
3670         break;
3671     case EXACTF:        /* length of string is 1 */
3672         c = (U8)*STRING(p);
3673         while (scan < loceol &&
3674                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
3675             scan++;
3676         break;
3677     case EXACTFL:       /* length of string is 1 */
3678         PL_reg_flags |= RF_tainted;
3679         c = (U8)*STRING(p);
3680         while (scan < loceol &&
3681                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
3682             scan++;
3683         break;
3684     case ANYOF:
3685         if (do_utf8) {
3686             loceol = PL_regeol;
3687             while (hardcount < max && scan < loceol &&
3688                    reginclass(p, (U8*)scan, do_utf8)) {
3689                 scan += UTF8SKIP(scan);
3690                 hardcount++;
3691             }
3692         } else {
3693             while (scan < loceol && reginclass(p, (U8*)scan, do_utf8))
3694                 scan++;
3695         }
3696         break;
3697     case ALNUM:
3698         if (do_utf8) {
3699             loceol = PL_regeol;
3700             LOAD_UTF8_CHARCLASS(alnum,"a");
3701             while (hardcount < max && scan < loceol &&
3702                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3703                 scan += UTF8SKIP(scan);
3704                 hardcount++;
3705             }
3706         } else {
3707             while (scan < loceol && isALNUM(*scan))
3708                 scan++;
3709         }
3710         break;
3711     case ALNUML:
3712         PL_reg_flags |= RF_tainted;
3713         if (do_utf8) {
3714             loceol = PL_regeol;
3715             while (hardcount < max && scan < loceol &&
3716                    isALNUM_LC_utf8((U8*)scan)) {
3717                 scan += UTF8SKIP(scan);
3718                 hardcount++;
3719             }
3720         } else {
3721             while (scan < loceol && isALNUM_LC(*scan))
3722                 scan++;
3723         }
3724         break;
3725     case NALNUM:
3726         if (do_utf8) {
3727             loceol = PL_regeol;
3728             LOAD_UTF8_CHARCLASS(alnum,"a");
3729             while (hardcount < max && scan < loceol &&
3730                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3731                 scan += UTF8SKIP(scan);
3732                 hardcount++;
3733             }
3734         } else {
3735             while (scan < loceol && !isALNUM(*scan))
3736                 scan++;
3737         }
3738         break;
3739     case NALNUML:
3740         PL_reg_flags |= RF_tainted;
3741         if (do_utf8) {
3742             loceol = PL_regeol;
3743             while (hardcount < max && scan < loceol &&
3744                    !isALNUM_LC_utf8((U8*)scan)) {
3745                 scan += UTF8SKIP(scan);
3746                 hardcount++;
3747             }
3748         } else {
3749             while (scan < loceol && !isALNUM_LC(*scan))
3750                 scan++;
3751         }
3752         break;
3753     case SPACE:
3754         if (do_utf8) {
3755             loceol = PL_regeol;
3756             LOAD_UTF8_CHARCLASS(space," ");
3757             while (hardcount < max && scan < loceol &&
3758                    (*scan == ' ' ||
3759                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3760                 scan += UTF8SKIP(scan);
3761                 hardcount++;
3762             }
3763         } else {
3764             while (scan < loceol && isSPACE(*scan))
3765                 scan++;
3766         }
3767         break;
3768     case SPACEL:
3769         PL_reg_flags |= RF_tainted;
3770         if (do_utf8) {
3771             loceol = PL_regeol;
3772             while (hardcount < max && scan < loceol &&
3773                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3774                 scan += UTF8SKIP(scan);
3775                 hardcount++;
3776             }
3777         } else {
3778             while (scan < loceol && isSPACE_LC(*scan))
3779                 scan++;
3780         }
3781         break;
3782     case NSPACE:
3783         if (do_utf8) {
3784             loceol = PL_regeol;
3785             LOAD_UTF8_CHARCLASS(space," ");
3786             while (hardcount < max && scan < loceol &&
3787                    !(*scan == ' ' ||
3788                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3789                 scan += UTF8SKIP(scan);
3790                 hardcount++;
3791             }
3792         } else {
3793             while (scan < loceol && !isSPACE(*scan))
3794                 scan++;
3795             break;
3796         }
3797     case NSPACEL:
3798         PL_reg_flags |= RF_tainted;
3799         if (do_utf8) {
3800             loceol = PL_regeol;
3801             while (hardcount < max && scan < loceol &&
3802                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3803                 scan += UTF8SKIP(scan);
3804                 hardcount++;
3805             }
3806         } else {
3807             while (scan < loceol && !isSPACE_LC(*scan))
3808                 scan++;
3809         }
3810         break;
3811     case DIGIT:
3812         if (do_utf8) {
3813             loceol = PL_regeol;
3814             LOAD_UTF8_CHARCLASS(digit,"0");
3815             while (hardcount < max && scan < loceol &&
3816                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
3817                 scan += UTF8SKIP(scan);
3818                 hardcount++;
3819             }
3820         } else {
3821             while (scan < loceol && isDIGIT(*scan))
3822                 scan++;
3823         }
3824         break;
3825     case NDIGIT:
3826         if (do_utf8) {
3827             loceol = PL_regeol;
3828             LOAD_UTF8_CHARCLASS(digit,"0");
3829             while (hardcount < max && scan < loceol &&
3830                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
3831                 scan += UTF8SKIP(scan);
3832                 hardcount++;
3833             }
3834         } else {
3835             while (scan < loceol && !isDIGIT(*scan))
3836                 scan++;
3837         }
3838         break;
3839     default:            /* Called on something of 0 width. */
3840         break;          /* So match right here or not at all. */
3841     }
3842
3843     if (hardcount)
3844         c = hardcount;
3845     else
3846         c = scan - PL_reginput;
3847     PL_reginput = scan;
3848
3849     DEBUG_r(
3850         {
3851                 SV *prop = sv_newmortal();
3852
3853                 regprop(prop, p);
3854                 PerlIO_printf(Perl_debug_log,
3855                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
3856                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
3857         });
3858
3859     return(c);
3860 }
3861
3862 /*
3863  - regrepeat_hard - repeatedly match something, report total lenth and length
3864  *
3865  * The repeater is supposed to have constant length.
3866  */
3867
3868 STATIC I32
3869 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
3870 {
3871     register char *scan = Nullch;
3872     register char *start;
3873     register char *loceol = PL_regeol;
3874     I32 l = 0;
3875     I32 count = 0, res = 1;
3876
3877     if (!max)
3878         return 0;
3879
3880     start = PL_reginput;
3881     if (PL_reg_match_utf8) {
3882         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3883             if (!count++) {
3884                 l = 0;
3885                 while (start < PL_reginput) {
3886                     l++;
3887                     start += UTF8SKIP(start);
3888                 }
3889                 *lp = l;
3890                 if (l == 0)
3891                     return max;
3892             }
3893             if (count == max)
3894                 return count;
3895         }
3896     }
3897     else {
3898         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3899             if (!count++) {
3900                 *lp = l = PL_reginput - start;
3901                 if (max != REG_INFTY && l*max < loceol - scan)
3902                     loceol = scan + l*max;
3903                 if (l == 0)
3904                     return max;
3905             }
3906         }
3907     }
3908     if (!res)
3909         PL_reginput = scan;
3910
3911     return count;
3912 }
3913
3914 /*
3915 - regclass_swash - prepare the utf8 swash
3916 */
3917
3918 SV *
3919 Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp)
3920 {
3921     SV *sw = NULL;
3922     SV *si = NULL;
3923
3924     if (PL_regdata && PL_regdata->count) {
3925         U32 n = ARG(node);
3926
3927         if (PL_regdata->what[n] == 's') {
3928             SV *rv = (SV*)PL_regdata->data[n];
3929             AV *av = (AV*)SvRV((SV*)rv);
3930             SV **a;
3931
3932             si = *av_fetch(av, 0, FALSE);
3933             a  =  av_fetch(av, 1, FALSE);
3934
3935             if (a)
3936                 sw = *a;
3937             else if (si && doinit) {
3938                 sw = swash_init("utf8", "", si, 1, 0);
3939                 (void)av_store(av, 1, sw);
3940             }
3941         }
3942     }
3943
3944     if (initsvp)
3945         *initsvp = si;
3946
3947     return sw;
3948 }
3949
3950 /*
3951  - reginclass - determine if a character falls into a character class
3952  */
3953
3954 STATIC bool
3955 S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8)
3956 {
3957     char flags = ANYOF_FLAGS(n);
3958     bool match = FALSE;
3959     UV c;
3960     STRLEN len = 0;
3961
3962     c = do_utf8 ? utf8_to_uvchr(p, &len) : *p;
3963
3964     if (do_utf8 || (flags & ANYOF_UNICODE)) {
3965         if (do_utf8 && !ANYOF_RUNTIME(n)) {
3966             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
3967                 match = TRUE;
3968         }
3969         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
3970             match = TRUE;
3971         if (!match) {
3972             SV *sw = regclass_swash(n, TRUE, 0);
3973
3974             if (sw) {
3975                 if (swash_fetch(sw, p, do_utf8))
3976                     match = TRUE;
3977                 else if (flags & ANYOF_FOLD) {
3978                     U8 tmpbuf[UTF8_MAXLEN+1];
3979
3980                     if (flags & ANYOF_LOCALE) {
3981                         PL_reg_flags |= RF_tainted;
3982                         uvchr_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
3983                     }
3984                     else
3985                         uvchr_to_utf8(tmpbuf, toLOWER_utf8(p));
3986                     if (swash_fetch(sw, tmpbuf, do_utf8))
3987                         match = TRUE;
3988                 }
3989             }
3990         }
3991     }
3992     if (!match && c < 256) {
3993         if (ANYOF_BITMAP_TEST(n, c))
3994             match = TRUE;
3995         else if (flags & ANYOF_FOLD) {
3996           I32 f;
3997
3998             if (flags & ANYOF_LOCALE) {
3999                 PL_reg_flags |= RF_tainted;
4000                 f = PL_fold_locale[c];
4001             }
4002             else
4003                 f = PL_fold[c];
4004             if (f != c && ANYOF_BITMAP_TEST(n, f))
4005                 match = TRUE;
4006         }
4007
4008         if (!match && (flags & ANYOF_CLASS)) {
4009             PL_reg_flags |= RF_tainted;
4010             if (
4011                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
4012                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
4013                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
4014                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
4015                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
4016                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
4017                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
4018                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
4019                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
4020                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
4021                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
4022                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
4023                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
4024                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
4025                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
4026                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
4027                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
4028                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
4029                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
4030                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
4031                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
4032                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
4033                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
4034                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
4035                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
4036                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
4037                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
4038                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
4039                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
4040                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
4041                 ) /* How's that for a conditional? */
4042             {
4043                 match = TRUE;
4044             }
4045         }
4046     }
4047
4048     return (flags & ANYOF_INVERT) ? !match : match;
4049 }
4050
4051 STATIC U8 *
4052 S_reghop(pTHX_ U8 *s, I32 off)
4053 {
4054     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4055 }
4056
4057 STATIC U8 *
4058 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
4059 {
4060     if (off >= 0) {
4061         while (off-- && s < lim) {
4062             /* XXX could check well-formedness here */
4063             s += UTF8SKIP(s);
4064         }
4065     }
4066     else {
4067         while (off++) {
4068             if (s > lim) {
4069                 s--;
4070                 if (UTF8_IS_CONTINUED(*s)) {
4071                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4072                         s--;
4073                 }
4074                 /* XXX could check well-formedness here */
4075             }
4076         }
4077     }
4078     return s;
4079 }
4080
4081 STATIC U8 *
4082 S_reghopmaybe(pTHX_ U8 *s, I32 off)
4083 {
4084     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4085 }
4086
4087 STATIC U8 *
4088 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
4089 {
4090     if (off >= 0) {
4091         while (off-- && s < lim) {
4092             /* XXX could check well-formedness here */
4093             s += UTF8SKIP(s);
4094         }
4095         if (off >= 0)
4096             return 0;
4097     }
4098     else {
4099         while (off++) {
4100             if (s > lim) {
4101                 s--;
4102                 if (UTF8_IS_CONTINUED(*s)) {
4103                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4104                         s--;
4105                 }
4106                 /* XXX could check well-formedness here */
4107             }
4108             else
4109                 break;
4110         }
4111         if (off <= 0)
4112             return 0;
4113     }
4114     return s;
4115 }
4116
4117 static void
4118 restore_pos(pTHX_ void *arg)
4119 {
4120     if (PL_reg_eval_set) {
4121         if (PL_reg_oldsaved) {
4122             PL_reg_re->subbeg = PL_reg_oldsaved;
4123             PL_reg_re->sublen = PL_reg_oldsavedlen;
4124             RX_MATCH_COPIED_on(PL_reg_re);
4125         }
4126         PL_reg_magic->mg_len = PL_reg_oldpos;
4127         PL_reg_eval_set = 0;
4128         PL_curpm = PL_reg_oldcurpm;
4129     }
4130 }