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