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