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) :
 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) :
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)) {
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)) {
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)) {
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))) {
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)) {
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)) {
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)
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)
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);
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)
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)
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)
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)
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 || swash_fetch(PL_utf8_mark,(U8*)locinput))
2398                 sayNO;
2399             locinput += PL_utf8skip[nextchr];
2400             while (locinput < PL_regeol && swash_fetch(PL_utf8_mark,(U8*)locinput))
2401                 locinput += UTF8SKIP(locinput);
2402             if (locinput > PL_regeol)
2403                 sayNO;
2404             nextchr = UCHARAT(locinput);
2405             break;
2406         case REFFL:
2407             PL_reg_flags |= RF_tainted;
2408             /* FALL THROUGH */
2409         case REF:
2410         case REFF:
2411             n = ARG(scan);  /* which paren pair */
2412             ln = PL_regstartp[n];
2413             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2414             if (*PL_reglastparen < n || ln == -1)
2415                 sayNO;                  /* Do not match unless seen CLOSEn. */
2416             if (ln == PL_regendp[n])
2417                 break;
2418
2419             s = PL_bostr + ln;
2420             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
2421                 char *l = locinput;
2422                 char *e = PL_bostr + PL_regendp[n];
2423                 /*
2424                  * Note that we can't do the "other character" lookup trick as
2425                  * in the 8-bit case (no pun intended) because in Unicode we
2426                  * have to map both upper and title case to lower case.
2427                  */
2428                 if (OP(scan) == REFF) {
2429                     while (s < e) {
2430                         if (l >= PL_regeol)
2431                             sayNO;
2432                         if (toLOWER_utf8((U8*)s) != toLOWER_utf8((U8*)l))
2433                             sayNO;
2434                         s += UTF8SKIP(s);
2435                         l += UTF8SKIP(l);
2436                     }
2437                 }
2438                 else {
2439                     while (s < e) {
2440                         if (l >= PL_regeol)
2441                             sayNO;
2442                         if (toLOWER_LC_utf8((U8*)s) != toLOWER_LC_utf8((U8*)l))
2443                             sayNO;
2444                         s += UTF8SKIP(s);
2445                         l += UTF8SKIP(l);
2446                     }
2447                 }
2448                 locinput = l;
2449                 nextchr = UCHARAT(locinput);
2450                 break;
2451             }
2452
2453             /* Inline the first character, for speed. */
2454             if (UCHARAT(s) != nextchr &&
2455                 (OP(scan) == REF ||
2456                  (UCHARAT(s) != ((OP(scan) == REFF
2457                                   ? PL_fold : PL_fold_locale)[nextchr]))))
2458                 sayNO;
2459             ln = PL_regendp[n] - ln;
2460             if (locinput + ln > PL_regeol)
2461                 sayNO;
2462             if (ln > 1 && (OP(scan) == REF
2463                            ? memNE(s, locinput, ln)
2464                            : (OP(scan) == REFF
2465                               ? ibcmp(s, locinput, ln)
2466                               : ibcmp_locale(s, locinput, ln))))
2467                 sayNO;
2468             locinput += ln;
2469             nextchr = UCHARAT(locinput);
2470             break;
2471
2472         case NOTHING:
2473         case TAIL:
2474             break;
2475         case BACK:
2476             break;
2477         case EVAL:
2478         {
2479             dSP;
2480             OP_4tree *oop = PL_op;
2481             COP *ocurcop = PL_curcop;
2482             SV **ocurpad = PL_curpad;
2483             SV *ret;
2484
2485             n = ARG(scan);
2486             PL_op = (OP_4tree*)PL_regdata->data[n];
2487             DEBUG_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
2488             PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 2]);
2489             PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
2490
2491             CALLRUNOPS(aTHX);                   /* Scalar context. */
2492             SPAGAIN;
2493             ret = POPs;
2494             PUTBACK;
2495
2496             PL_op = oop;
2497             PL_curpad = ocurpad;
2498             PL_curcop = ocurcop;
2499             if (logical) {
2500                 if (logical == 2) {     /* Postponed subexpression. */
2501                     regexp *re;
2502                     MAGIC *mg = Null(MAGIC*);
2503                     re_cc_state state;
2504                     CHECKPOINT cp, lastcp;
2505
2506                     if(SvROK(ret) || SvRMAGICAL(ret)) {
2507                         SV *sv = SvROK(ret) ? SvRV(ret) : ret;
2508
2509                         if(SvMAGICAL(sv))
2510                             mg = mg_find(sv, 'r');
2511                     }
2512                     if (mg) {
2513                         re = (regexp *)mg->mg_obj;
2514                         (void)ReREFCNT_inc(re);
2515                     }
2516                     else {
2517                         STRLEN len;
2518                         char *t = SvPV(ret, len);
2519                         PMOP pm;
2520                         char *oprecomp = PL_regprecomp;
2521                         I32 osize = PL_regsize;
2522                         I32 onpar = PL_regnpar;
2523
2524                         Zero(&pm, 1, PMOP);
2525                         re = CALLREGCOMP(aTHX_ t, t + len, &pm);
2526                         if (!(SvFLAGS(ret)
2527                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
2528                             sv_magic(ret,(SV*)ReREFCNT_inc(re),'r',0,0);
2529                         PL_regprecomp = oprecomp;
2530                         PL_regsize = osize;
2531                         PL_regnpar = onpar;
2532                     }
2533                     DEBUG_r(
2534                         PerlIO_printf(Perl_debug_log,
2535                                       "Entering embedded `%s%.60s%s%s'\n",
2536                                       PL_colors[0],
2537                                       re->precomp,
2538                                       PL_colors[1],
2539                                       (strlen(re->precomp) > 60 ? "..." : ""))
2540                         );
2541                     state.node = next;
2542                     state.prev = PL_reg_call_cc;
2543                     state.cc = PL_regcc;
2544                     state.re = PL_reg_re;
2545
2546                     PL_regcc = 0;
2547
2548                     cp = regcppush(0);  /* Save *all* the positions. */
2549                     REGCP_SET(lastcp);
2550                     cache_re(re);
2551                     state.ss = PL_savestack_ix;
2552                     *PL_reglastparen = 0;
2553                     PL_reg_call_cc = &state;
2554                     PL_reginput = locinput;
2555
2556                     /* XXXX This is too dramatic a measure... */
2557                     PL_reg_maxiter = 0;
2558
2559                     if (regmatch(re->program + 1)) {
2560                         /* Even though we succeeded, we need to restore
2561                            global variables, since we may be wrapped inside
2562                            SUSPEND, thus the match may be not finished yet. */
2563
2564                         /* XXXX Do this only if SUSPENDed? */
2565                         PL_reg_call_cc = state.prev;
2566                         PL_regcc = state.cc;
2567                         PL_reg_re = state.re;
2568                         cache_re(PL_reg_re);
2569
2570                         /* XXXX This is too dramatic a measure... */
2571                         PL_reg_maxiter = 0;
2572
2573                         /* These are needed even if not SUSPEND. */
2574                         ReREFCNT_dec(re);
2575                         regcpblow(cp);
2576                         sayYES;
2577                     }
2578                     ReREFCNT_dec(re);
2579                     REGCP_UNWIND(lastcp);
2580                     regcppop();
2581                     PL_reg_call_cc = state.prev;
2582                     PL_regcc = state.cc;
2583                     PL_reg_re = state.re;
2584                     cache_re(PL_reg_re);
2585
2586                     /* XXXX This is too dramatic a measure... */
2587                     PL_reg_maxiter = 0;
2588
2589                     sayNO;
2590                 }
2591                 sw = SvTRUE(ret);
2592                 logical = 0;
2593             }
2594             else
2595                 sv_setsv(save_scalar(PL_replgv), ret);
2596             break;
2597         }
2598         case OPEN:
2599             n = ARG(scan);  /* which paren pair */
2600             PL_reg_start_tmp[n] = locinput;
2601             if (n > PL_regsize)
2602                 PL_regsize = n;
2603             break;
2604         case CLOSE:
2605             n = ARG(scan);  /* which paren pair */
2606             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
2607             PL_regendp[n] = locinput - PL_bostr;
2608             if (n > *PL_reglastparen)
2609                 *PL_reglastparen = n;
2610             break;
2611         case GROUPP:
2612             n = ARG(scan);  /* which paren pair */
2613             sw = (*PL_reglastparen >= n && PL_regendp[n] != -1);
2614             break;
2615         case IFTHEN:
2616             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2617             if (sw)
2618                 next = NEXTOPER(NEXTOPER(scan));
2619             else {
2620                 next = scan + ARG(scan);
2621                 if (OP(next) == IFTHEN) /* Fake one. */
2622                     next = NEXTOPER(NEXTOPER(next));
2623             }
2624             break;
2625         case LOGICAL:
2626             logical = scan->flags;
2627             break;
2628 /*******************************************************************
2629  PL_regcc contains infoblock about the innermost (...)* loop, and
2630  a pointer to the next outer infoblock.
2631
2632  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
2633
2634    1) After matching X, regnode for CURLYX is processed;
2635
2636    2) This regnode creates infoblock on the stack, and calls
2637       regmatch() recursively with the starting point at WHILEM node;
2638
2639    3) Each hit of WHILEM node tries to match A and Z (in the order
2640       depending on the current iteration, min/max of {min,max} and
2641       greediness).  The information about where are nodes for "A"
2642       and "Z" is read from the infoblock, as is info on how many times "A"
2643       was already matched, and greediness.
2644
2645    4) After A matches, the same WHILEM node is hit again.
2646
2647    5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
2648       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
2649       resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
2650       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
2651       of the external loop.
2652
2653  Currently present infoblocks form a tree with a stem formed by PL_curcc
2654  and whatever it mentions via ->next, and additional attached trees
2655  corresponding to temporarily unset infoblocks as in "5" above.
2656
2657  In the following picture infoblocks for outer loop of
2658  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
2659  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
2660  infoblocks are drawn below the "reset" infoblock.
2661
2662  In fact in the picture below we do not show failed matches for Z and T
2663  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
2664  more obvious *why* one needs to *temporary* unset infoblocks.]
2665
2666   Matched       REx position    InfoBlocks      Comment
2667                 (Y(A)*?Z)*?T    x
2668                 Y(A)*?Z)*?T     x <- O
2669   Y             (A)*?Z)*?T      x <- O
2670   Y             A)*?Z)*?T       x <- O <- I
2671   YA            )*?Z)*?T        x <- O <- I
2672   YA            A)*?Z)*?T       x <- O <- I
2673   YAA           )*?Z)*?T        x <- O <- I
2674   YAA           Z)*?T           x <- O          # Temporary unset I
2675                                      I
2676
2677   YAAZ          Y(A)*?Z)*?T     x <- O
2678                                      I
2679
2680   YAAZY         (A)*?Z)*?T      x <- O
2681                                      I
2682
2683   YAAZY         A)*?Z)*?T       x <- O <- I
2684                                      I
2685
2686   YAAZYA        )*?Z)*?T        x <- O <- I
2687                                      I
2688
2689   YAAZYA        Z)*?T           x <- O          # Temporary unset I
2690                                      I,I
2691
2692   YAAZYAZ       )*?T            x <- O
2693                                      I,I
2694
2695   YAAZYAZ       T               x               # Temporary unset O
2696                                 O
2697                                 I,I
2698
2699   YAAZYAZT                      x
2700                                 O
2701                                 I,I
2702  *******************************************************************/
2703         case CURLYX: {
2704                 CURCUR cc;
2705                 CHECKPOINT cp = PL_savestack_ix;
2706                 /* No need to save/restore up to this paren */
2707                 I32 parenfloor = scan->flags;
2708
2709                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
2710                     next += ARG(next);
2711                 cc.oldcc = PL_regcc;
2712                 PL_regcc = &cc;
2713                 /* XXXX Probably it is better to teach regpush to support
2714                    parenfloor > PL_regsize... */
2715                 if (parenfloor > *PL_reglastparen)
2716                     parenfloor = *PL_reglastparen; /* Pessimization... */
2717                 cc.parenfloor = parenfloor;
2718                 cc.cur = -1;
2719                 cc.min = ARG1(scan);
2720                 cc.max  = ARG2(scan);
2721                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2722                 cc.next = next;
2723                 cc.minmod = minmod;
2724                 cc.lastloc = 0;
2725                 PL_reginput = locinput;
2726                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
2727                 regcpblow(cp);
2728                 PL_regcc = cc.oldcc;
2729                 saySAME(n);
2730             }
2731             /* NOT REACHED */
2732         case WHILEM: {
2733                 /*
2734                  * This is really hard to understand, because after we match
2735                  * what we're trying to match, we must make sure the rest of
2736                  * the REx is going to match for sure, and to do that we have
2737                  * to go back UP the parse tree by recursing ever deeper.  And
2738                  * if it fails, we have to reset our parent's current state
2739                  * that we can try again after backing off.
2740                  */
2741
2742                 CHECKPOINT cp, lastcp;
2743                 CURCUR* cc = PL_regcc;
2744                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
2745
2746                 n = cc->cur + 1;        /* how many we know we matched */
2747                 PL_reginput = locinput;
2748
2749                 DEBUG_r(
2750                     PerlIO_printf(Perl_debug_log,
2751                                   "%*s  %ld out of %ld..%ld  cc=%lx\n",
2752                                   REPORT_CODE_OFF+PL_regindent*2, "",
2753                                   (long)n, (long)cc->min,
2754                                   (long)cc->max, (long)cc)
2755                     );
2756
2757                 /* If degenerate scan matches "", assume scan done. */
2758
2759                 if (locinput == cc->lastloc && n >= cc->min) {
2760                     PL_regcc = cc->oldcc;
2761                     if (PL_regcc)
2762                         ln = PL_regcc->cur;
2763                     DEBUG_r(
2764                         PerlIO_printf(Perl_debug_log,
2765                            "%*s  empty match detected, try continuation...\n",
2766                            REPORT_CODE_OFF+PL_regindent*2, "")
2767                         );
2768                     if (regmatch(cc->next))
2769                         sayYES;
2770                     if (PL_regcc)
2771                         PL_regcc->cur = ln;
2772                     PL_regcc = cc;
2773                     sayNO;
2774                 }
2775
2776                 /* First just match a string of min scans. */
2777
2778                 if (n < cc->min) {
2779                     cc->cur = n;
2780                     cc->lastloc = locinput;
2781                     if (regmatch(cc->scan))
2782                         sayYES;
2783                     cc->cur = n - 1;
2784                     cc->lastloc = lastloc;
2785                     sayNO;
2786                 }
2787
2788                 if (scan->flags) {
2789                     /* Check whether we already were at this position.
2790                         Postpone detection until we know the match is not
2791                         *that* much linear. */
2792                 if (!PL_reg_maxiter) {
2793                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
2794                     PL_reg_leftiter = PL_reg_maxiter;
2795                 }
2796                 if (PL_reg_leftiter-- == 0) {
2797                     I32 size = (PL_reg_maxiter + 7)/8;
2798                     if (PL_reg_poscache) {
2799                         if (PL_reg_poscache_size < size) {
2800                             Renew(PL_reg_poscache, size, char);
2801                             PL_reg_poscache_size = size;
2802                         }
2803                         Zero(PL_reg_poscache, size, char);
2804                     }
2805                     else {
2806                         PL_reg_poscache_size = size;
2807                         Newz(29, PL_reg_poscache, size, char);
2808                     }
2809                     DEBUG_r(
2810                         PerlIO_printf(Perl_debug_log,
2811               "%sDetected a super-linear match, switching on caching%s...\n",
2812                                       PL_colors[4], PL_colors[5])
2813                         );
2814                 }
2815                 if (PL_reg_leftiter < 0) {
2816                     I32 o = locinput - PL_bostr, b;
2817
2818                     o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
2819                     b = o % 8;
2820                     o /= 8;
2821                     if (PL_reg_poscache[o] & (1<<b)) {
2822                     DEBUG_r(
2823                         PerlIO_printf(Perl_debug_log,
2824                                       "%*s  already tried at this position...\n",
2825                                       REPORT_CODE_OFF+PL_regindent*2, "")
2826                         );
2827                         sayNO_SILENT;
2828                     }
2829                     PL_reg_poscache[o] |= (1<<b);
2830                 }
2831                 }
2832
2833                 /* Prefer next over scan for minimal matching. */
2834
2835                 if (cc->minmod) {
2836                     PL_regcc = cc->oldcc;
2837                     if (PL_regcc)
2838                         ln = PL_regcc->cur;
2839                     cp = regcppush(cc->parenfloor);
2840                     REGCP_SET(lastcp);
2841                     if (regmatch(cc->next)) {
2842                         regcpblow(cp);
2843                         sayYES; /* All done. */
2844                     }
2845                     REGCP_UNWIND(lastcp);
2846                     regcppop();
2847                     if (PL_regcc)
2848                         PL_regcc->cur = ln;
2849                     PL_regcc = cc;
2850
2851                     if (n >= cc->max) { /* Maximum greed exceeded? */
2852                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2853                             && !(PL_reg_flags & RF_warned)) {
2854                             PL_reg_flags |= RF_warned;
2855                             Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2856                                  "Complex regular subexpression recursion",
2857                                  REG_INFTY - 1);
2858                         }
2859                         sayNO;
2860                     }
2861
2862                     DEBUG_r(
2863                         PerlIO_printf(Perl_debug_log,
2864                                       "%*s  trying longer...\n",
2865                                       REPORT_CODE_OFF+PL_regindent*2, "")
2866                         );
2867                     /* Try scanning more and see if it helps. */
2868                     PL_reginput = locinput;
2869                     cc->cur = n;
2870                     cc->lastloc = locinput;
2871                     cp = regcppush(cc->parenfloor);
2872                     REGCP_SET(lastcp);
2873                     if (regmatch(cc->scan)) {
2874                         regcpblow(cp);
2875                         sayYES;
2876                     }
2877                     REGCP_UNWIND(lastcp);
2878                     regcppop();
2879                     cc->cur = n - 1;
2880                     cc->lastloc = lastloc;
2881                     sayNO;
2882                 }
2883
2884                 /* Prefer scan over next for maximal matching. */
2885
2886                 if (n < cc->max) {      /* More greed allowed? */
2887                     cp = regcppush(cc->parenfloor);
2888                     cc->cur = n;
2889                     cc->lastloc = locinput;
2890                     REGCP_SET(lastcp);
2891                     if (regmatch(cc->scan)) {
2892                         regcpblow(cp);
2893                         sayYES;
2894                     }
2895                     REGCP_UNWIND(lastcp);
2896                     regcppop();         /* Restore some previous $<digit>s? */
2897                     PL_reginput = locinput;
2898                     DEBUG_r(
2899                         PerlIO_printf(Perl_debug_log,
2900                                       "%*s  failed, try continuation...\n",
2901                                       REPORT_CODE_OFF+PL_regindent*2, "")
2902                         );
2903                 }
2904                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2905                         && !(PL_reg_flags & RF_warned)) {
2906                     PL_reg_flags |= RF_warned;
2907                     Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2908                          "Complex regular subexpression recursion",
2909                          REG_INFTY - 1);
2910                 }
2911
2912                 /* Failed deeper matches of scan, so see if this one works. */
2913                 PL_regcc = cc->oldcc;
2914                 if (PL_regcc)
2915                     ln = PL_regcc->cur;
2916                 if (regmatch(cc->next))
2917                     sayYES;
2918                 if (PL_regcc)
2919                     PL_regcc->cur = ln;
2920                 PL_regcc = cc;
2921                 cc->cur = n - 1;
2922                 cc->lastloc = lastloc;
2923                 sayNO;
2924             }
2925             /* NOT REACHED */
2926         case BRANCHJ:
2927             next = scan + ARG(scan);
2928             if (next == scan)
2929                 next = NULL;
2930             inner = NEXTOPER(NEXTOPER(scan));
2931             goto do_branch;
2932         case BRANCH:
2933             inner = NEXTOPER(scan);
2934           do_branch:
2935             {
2936                 CHECKPOINT lastcp;
2937                 c1 = OP(scan);
2938                 if (OP(next) != c1)     /* No choice. */
2939                     next = inner;       /* Avoid recursion. */
2940                 else {
2941                     I32 lastparen = *PL_reglastparen;
2942                     I32 unwind1;
2943                     re_unwind_branch_t *uw;
2944
2945                     /* Put unwinding data on stack */
2946                     unwind1 = SSNEWt(1,re_unwind_branch_t);
2947                     uw = SSPTRt(unwind1,re_unwind_branch_t);
2948                     uw->prev = unwind;
2949                     unwind = unwind1;
2950                     uw->type = ((c1 == BRANCH)
2951                                 ? RE_UNWIND_BRANCH
2952                                 : RE_UNWIND_BRANCHJ);
2953                     uw->lastparen = lastparen;
2954                     uw->next = next;
2955                     uw->locinput = locinput;
2956                     uw->nextchr = nextchr;
2957 #ifdef DEBUGGING
2958                     uw->regindent = ++PL_regindent;
2959 #endif
2960
2961                     REGCP_SET(uw->lastcp);
2962
2963                     /* Now go into the first branch */
2964                     next = inner;
2965                 }
2966             }
2967             break;
2968         case MINMOD:
2969             minmod = 1;
2970             break;
2971         case CURLYM:
2972         {
2973             I32 l = 0;
2974             CHECKPOINT lastcp;
2975
2976             /* We suppose that the next guy does not need
2977                backtracking: in particular, it is of constant length,
2978                and has no parenths to influence future backrefs. */
2979             ln = ARG1(scan);  /* min to match */
2980             n  = ARG2(scan);  /* max to match */
2981             paren = scan->flags;
2982             if (paren) {
2983                 if (paren > PL_regsize)
2984                     PL_regsize = paren;
2985                 if (paren > *PL_reglastparen)
2986                     *PL_reglastparen = paren;
2987             }
2988             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
2989             if (paren)
2990                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
2991             PL_reginput = locinput;
2992             if (minmod) {
2993                 minmod = 0;
2994                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
2995                     sayNO;
2996                 if (ln && l == 0 && n >= ln
2997                     /* In fact, this is tricky.  If paren, then the
2998                        fact that we did/didnot match may influence
2999                        future execution. */
3000                     && !(paren && ln == 0))
3001                     ln = n;
3002                 locinput = PL_reginput;
3003                 if (PL_regkind[(U8)OP(next)] == EXACT) {
3004                     c1 = (U8)*STRING(next);
3005                     if (OP(next) == EXACTF)
3006                         c2 = PL_fold[c1];
3007                     else if (OP(next) == EXACTFL)
3008                         c2 = PL_fold_locale[c1];
3009                     else
3010                         c2 = c1;
3011                 }
3012                 else
3013                     c1 = c2 = -1000;
3014                 REGCP_SET(lastcp);
3015                 /* This may be improved if l == 0.  */
3016                 while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
3017                     /* If it could work, try it. */
3018                     if (c1 == -1000 ||
3019                         UCHARAT(PL_reginput) == c1 ||
3020                         UCHARAT(PL_reginput) == c2)
3021                     {
3022                         if (paren) {
3023                             if (n) {
3024                                 PL_regstartp[paren] =
3025                                     HOPc(PL_reginput, -l) - PL_bostr;
3026                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3027                             }
3028                             else
3029                                 PL_regendp[paren] = -1;
3030                         }
3031                         if (regmatch(next))
3032                             sayYES;
3033                         REGCP_UNWIND(lastcp);
3034                     }
3035                     /* Couldn't or didn't -- move forward. */
3036                     PL_reginput = locinput;
3037                     if (regrepeat_hard(scan, 1, &l)) {
3038                         ln++;
3039                         locinput = PL_reginput;
3040                     }
3041                     else
3042                         sayNO;
3043                 }
3044             }
3045             else {
3046                 n = regrepeat_hard(scan, n, &l);
3047                 if (n != 0 && l == 0
3048                     /* In fact, this is tricky.  If paren, then the
3049                        fact that we did/didnot match may influence
3050                        future execution. */
3051                     && !(paren && ln == 0))
3052                     ln = n;
3053                 locinput = PL_reginput;
3054                 DEBUG_r(
3055                     PerlIO_printf(Perl_debug_log,
3056                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3057                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3058                                   (IV) n, (IV)l)
3059                     );
3060                 if (n >= ln) {
3061                     if (PL_regkind[(U8)OP(next)] == EXACT) {
3062                         c1 = (U8)*STRING(next);
3063                         if (OP(next) == EXACTF)
3064                             c2 = PL_fold[c1];
3065                         else if (OP(next) == EXACTFL)
3066                             c2 = PL_fold_locale[c1];
3067                         else
3068                             c2 = c1;
3069                     }
3070                     else
3071                         c1 = c2 = -1000;
3072                 }
3073                 REGCP_SET(lastcp);
3074                 while (n >= ln) {
3075                     /* If it could work, try it. */
3076                     if (c1 == -1000 ||
3077                         UCHARAT(PL_reginput) == c1 ||
3078                         UCHARAT(PL_reginput) == c2)
3079                     {
3080                         DEBUG_r(
3081                                 PerlIO_printf(Perl_debug_log,
3082                                               "%*s  trying tail with n=%"IVdf"...\n",
3083                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
3084                             );
3085                         if (paren) {
3086                             if (n) {
3087                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
3088                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3089                             }
3090                             else
3091                                 PL_regendp[paren] = -1;
3092                         }
3093                         if (regmatch(next))
3094                             sayYES;
3095                         REGCP_UNWIND(lastcp);
3096                     }
3097                     /* Couldn't or didn't -- back up. */
3098                     n--;
3099                     locinput = HOPc(locinput, -l);
3100                     PL_reginput = locinput;
3101                 }
3102             }
3103             sayNO;
3104             break;
3105         }
3106         case CURLYN:
3107             paren = scan->flags;        /* Which paren to set */
3108             if (paren > PL_regsize)
3109                 PL_regsize = paren;
3110             if (paren > *PL_reglastparen)
3111                 *PL_reglastparen = paren;
3112             ln = ARG1(scan);  /* min to match */
3113             n  = ARG2(scan);  /* max to match */
3114             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3115             goto repeat;
3116         case CURLY:
3117             paren = 0;
3118             ln = ARG1(scan);  /* min to match */
3119             n  = ARG2(scan);  /* max to match */
3120             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3121             goto repeat;
3122         case STAR:
3123             ln = 0;
3124             n = REG_INFTY;
3125             scan = NEXTOPER(scan);
3126             paren = 0;
3127             goto repeat;
3128         case PLUS:
3129             ln = 1;
3130             n = REG_INFTY;
3131             scan = NEXTOPER(scan);
3132             paren = 0;
3133           repeat:
3134             /*
3135             * Lookahead to avoid useless match attempts
3136             * when we know what character comes next.
3137             */
3138             if (PL_regkind[(U8)OP(next)] == EXACT) {
3139                 U8 *s = (U8*)STRING(next);
3140                 if (!UTF) {
3141                     c2 = c1 = *s;
3142                     if (OP(next) == EXACTF)
3143                         c2 = PL_fold[c1];
3144                     else if (OP(next) == EXACTFL)
3145                         c2 = PL_fold_locale[c1];
3146                 }
3147                 else { /* UTF */
3148                     if (OP(next) == EXACTF) {
3149                         c1 = to_utf8_lower(s);
3150                         c2 = to_utf8_upper(s);
3151                     }
3152                     else {
3153                         c2 = c1 = utf8_to_uvchr(s, NULL);
3154                     }
3155                 }
3156             }
3157             else
3158                 c1 = c2 = -1000;
3159             PL_reginput = locinput;
3160             if (minmod) {
3161                 CHECKPOINT lastcp;
3162                 minmod = 0;
3163                 if (ln && regrepeat(scan, ln) < ln)
3164                     sayNO;
3165                 locinput = PL_reginput;
3166                 REGCP_SET(lastcp);
3167                 if (c1 != -1000) {
3168                     char *e; /* Should not check after this */
3169                     char *old = locinput;
3170
3171                     if  (n == REG_INFTY) {
3172                         e = PL_regeol - 1;
3173                         if (do_utf8)
3174                             while (UTF8_IS_CONTINUATION(*(U8*)e))
3175                                 e--;
3176                     }
3177                     else if (do_utf8) {
3178                         int m = n - ln;
3179                         for (e = locinput;
3180                              m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
3181                             e += UTF8SKIP(e);
3182                     }
3183                     else {
3184                         e = locinput + n - ln;
3185                         if (e >= PL_regeol)
3186                             e = PL_regeol - 1;
3187                     }
3188                     while (1) {
3189                         int count;
3190                         /* Find place 'next' could work */
3191                         if (!do_utf8) {
3192                             if (c1 == c2) {
3193                                 while (locinput <= e && *locinput != c1)
3194                                     locinput++;
3195                             } else {
3196                                 while (locinput <= e
3197                                        && *locinput != c1
3198                                        && *locinput != c2)
3199                                     locinput++;
3200                             }
3201                             count = locinput - old;
3202                         }
3203                         else {
3204                             STRLEN len;
3205                             if (c1 == c2) {
3206                                 for (count = 0;
3207                                      locinput <= e &&
3208                                          utf8_to_uvchr((U8*)locinput, &len) != c1;
3209                                      count++)
3210                                     locinput += len;
3211
3212                             } else {
3213                                 for (count = 0; locinput <= e; count++) {
3214                                     UV c = utf8_to_uvchr((U8*)locinput, &len);
3215                                     if (c == c1 || c == c2)
3216                                         break;
3217                                     locinput += len;
3218                                 }
3219                             }
3220                         }
3221                         if (locinput > e)
3222                             sayNO;
3223                         /* PL_reginput == old now */
3224                         if (locinput != old) {
3225                             ln = 1;     /* Did some */
3226                             if (regrepeat(scan, count) < count)
3227                                 sayNO;
3228                         }
3229                         /* PL_reginput == locinput now */
3230                         TRYPAREN(paren, ln, locinput);
3231                         PL_reginput = locinput; /* Could be reset... */
3232                         REGCP_UNWIND(lastcp);
3233                         /* Couldn't or didn't -- move forward. */
3234                         old = locinput;
3235                         if (do_utf8)
3236                             locinput += UTF8SKIP(locinput);
3237                         else
3238                             locinput++;
3239                     }
3240                 }
3241                 else
3242                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3243                     UV c;
3244                     if (c1 != -1000) {
3245                         if (do_utf8)
3246                             c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3247                         else
3248                             c = UCHARAT(PL_reginput);
3249                         /* If it could work, try it. */
3250                         if (c == c1 || c == c2)
3251                         {
3252                             TRYPAREN(paren, n, PL_reginput);
3253                             REGCP_UNWIND(lastcp);
3254                         }
3255                     }
3256                     /* If it could work, try it. */
3257                     else if (c1 == -1000)
3258                     {
3259                         TRYPAREN(paren, n, PL_reginput);
3260                         REGCP_UNWIND(lastcp);
3261                     }
3262                     /* Couldn't or didn't -- move forward. */
3263                     PL_reginput = locinput;
3264                     if (regrepeat(scan, 1)) {
3265                         ln++;
3266                         locinput = PL_reginput;
3267                     }
3268                     else
3269                         sayNO;
3270                 }
3271             }
3272             else {
3273                 CHECKPOINT lastcp;
3274                 n = regrepeat(scan, n);
3275                 locinput = PL_reginput;
3276                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3277                     (!PL_multiline  || OP(next) == SEOL || OP(next) == EOS)) {
3278                     ln = n;                     /* why back off? */
3279                     /* ...because $ and \Z can match before *and* after
3280                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3281                        We should back off by one in this case. */
3282                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3283                         ln--;
3284                 }
3285                 REGCP_SET(lastcp);
3286                 if (paren) {
3287                     UV c;
3288                     while (n >= ln) {
3289                         if (c1 != -1000) {
3290                             if (do_utf8)
3291                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3292                             else
3293                                 c = UCHARAT(PL_reginput);
3294                         }
3295                         /* If it could work, try it. */
3296                         if (c1 == -1000 || c == c1 || c == c2)
3297                             {
3298                                 TRYPAREN(paren, n, PL_reginput);
3299                                 REGCP_UNWIND(lastcp);
3300                             }
3301                         /* Couldn't or didn't -- back up. */
3302                         n--;
3303                         PL_reginput = locinput = HOPc(locinput, -1);
3304                     }
3305                 }
3306                 else {
3307                     UV c;
3308                     while (n >= ln) {
3309                         if (c1 != -1000) {
3310                             if (do_utf8)
3311                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3312                             else
3313                                 c = UCHARAT(PL_reginput);
3314                         }
3315                         /* If it could work, try it. */
3316                         if (c1 == -1000 || c == c1 || c == c2)
3317                             {
3318                                 TRYPAREN(paren, n, PL_reginput);
3319                                 REGCP_UNWIND(lastcp);
3320                             }
3321                         /* Couldn't or didn't -- back up. */
3322                         n--;
3323                         PL_reginput = locinput = HOPc(locinput, -1);
3324                     }
3325                 }
3326             }
3327             sayNO;
3328             break;
3329         case END:
3330             if (PL_reg_call_cc) {
3331                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3332                 CURCUR *cctmp = PL_regcc;
3333                 regexp *re = PL_reg_re;
3334                 CHECKPOINT cp, lastcp;
3335
3336                 cp = regcppush(0);      /* Save *all* the positions. */
3337                 REGCP_SET(lastcp);
3338                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3339                                                     the caller. */
3340                 PL_reginput = locinput; /* Make position available to
3341                                            the callcc. */
3342                 cache_re(PL_reg_call_cc->re);
3343                 PL_regcc = PL_reg_call_cc->cc;
3344                 PL_reg_call_cc = PL_reg_call_cc->prev;
3345                 if (regmatch(cur_call_cc->node)) {
3346                     PL_reg_call_cc = cur_call_cc;
3347                     regcpblow(cp);
3348                     sayYES;
3349                 }
3350                 REGCP_UNWIND(lastcp);
3351                 regcppop();
3352                 PL_reg_call_cc = cur_call_cc;
3353                 PL_regcc = cctmp;
3354                 PL_reg_re = re;
3355                 cache_re(re);
3356
3357                 DEBUG_r(
3358                     PerlIO_printf(Perl_debug_log,
3359                                   "%*s  continuation failed...\n",
3360                                   REPORT_CODE_OFF+PL_regindent*2, "")
3361                     );
3362                 sayNO_SILENT;
3363             }
3364             if (locinput < PL_regtill) {
3365                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3366                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3367                                       PL_colors[4],
3368                                       (long)(locinput - PL_reg_starttry),
3369                                       (long)(PL_regtill - PL_reg_starttry),
3370                                       PL_colors[5]));
3371                 sayNO_FINAL;            /* Cannot match: too short. */
3372             }
3373             PL_reginput = locinput;     /* put where regtry can find it */
3374             sayYES_FINAL;               /* Success! */
3375         case SUCCEED:
3376             PL_reginput = locinput;     /* put where regtry can find it */
3377             sayYES_LOUD;                /* Success! */
3378         case SUSPEND:
3379             n = 1;
3380             PL_reginput = locinput;
3381             goto do_ifmatch;
3382         case UNLESSM:
3383             n = 0;
3384             if (scan->flags) {
3385                 if (UTF) {              /* XXXX This is absolutely
3386                                            broken, we read before
3387                                            start of string. */
3388                     s = HOPMAYBEc(locinput, -scan->flags);
3389                     if (!s)
3390                         goto say_yes;
3391                     PL_reginput = s;
3392                 }
3393                 else {
3394                     if (locinput < PL_bostr + scan->flags)
3395                         goto say_yes;
3396                     PL_reginput = locinput - scan->flags;
3397                     goto do_ifmatch;
3398                 }
3399             }
3400             else
3401                 PL_reginput = locinput;
3402             goto do_ifmatch;
3403         case IFMATCH:
3404             n = 1;
3405             if (scan->flags) {
3406                 if (UTF) {              /* XXXX This is absolutely
3407                                            broken, we read before
3408                                            start of string. */
3409                     s = HOPMAYBEc(locinput, -scan->flags);
3410                     if (!s || s < PL_bostr)
3411                         goto say_no;
3412                     PL_reginput = s;
3413                 }
3414                 else {
3415                     if (locinput < PL_bostr + scan->flags)
3416                         goto say_no;
3417                     PL_reginput = locinput - scan->flags;
3418                     goto do_ifmatch;
3419                 }
3420             }
3421             else
3422                 PL_reginput = locinput;
3423
3424           do_ifmatch:
3425             inner = NEXTOPER(NEXTOPER(scan));
3426             if (regmatch(inner) != n) {
3427               say_no:
3428                 if (logical) {
3429                     logical = 0;
3430                     sw = 0;
3431                     goto do_longjump;
3432                 }
3433                 else
3434                     sayNO;
3435             }
3436           say_yes:
3437             if (logical) {
3438                 logical = 0;
3439                 sw = 1;
3440             }
3441             if (OP(scan) == SUSPEND) {
3442                 locinput = PL_reginput;
3443                 nextchr = UCHARAT(locinput);
3444             }
3445             /* FALL THROUGH. */
3446         case LONGJMP:
3447           do_longjump:
3448             next = scan + ARG(scan);
3449             if (next == scan)
3450                 next = NULL;
3451             break;
3452         default:
3453             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3454                           PTR2UV(scan), OP(scan));
3455             Perl_croak(aTHX_ "regexp memory corruption");
3456         }
3457       reenter:
3458         scan = next;
3459     }
3460
3461     /*
3462     * We get here only if there's trouble -- normally "case END" is
3463     * the terminating point.
3464     */
3465     Perl_croak(aTHX_ "corrupted regexp pointers");
3466     /*NOTREACHED*/
3467     sayNO;
3468
3469 yes_loud:
3470     DEBUG_r(
3471         PerlIO_printf(Perl_debug_log,
3472                       "%*s  %scould match...%s\n",
3473                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3474         );
3475     goto yes;
3476 yes_final:
3477     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3478                           PL_colors[4],PL_colors[5]));
3479 yes:
3480 #ifdef DEBUGGING
3481     PL_regindent--;
3482 #endif
3483
3484 #if 0                                   /* Breaks $^R */
3485     if (unwind)
3486         regcpblow(firstcp);
3487 #endif
3488     return 1;
3489
3490 no:
3491     DEBUG_r(
3492         PerlIO_printf(Perl_debug_log,
3493                       "%*s  %sfailed...%s\n",
3494                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3495         );
3496     goto do_no;
3497 no_final:
3498 do_no:
3499     if (unwind) {
3500         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
3501
3502         switch (uw->type) {
3503         case RE_UNWIND_BRANCH:
3504         case RE_UNWIND_BRANCHJ:
3505         {
3506             re_unwind_branch_t *uwb = &(uw->branch);
3507             I32 lastparen = uwb->lastparen;
3508
3509             REGCP_UNWIND(uwb->lastcp);
3510             for (n = *PL_reglastparen; n > lastparen; n--)
3511                 PL_regendp[n] = -1;
3512             *PL_reglastparen = n;
3513             scan = next = uwb->next;
3514             if ( !scan ||
3515                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
3516                               ? BRANCH : BRANCHJ) ) {           /* Failure */
3517                 unwind = uwb->prev;
3518 #ifdef DEBUGGING
3519                 PL_regindent--;
3520 #endif
3521                 goto do_no;
3522             }
3523             /* Have more choice yet.  Reuse the same uwb.  */
3524             /*SUPPRESS 560*/
3525             if ((n = (uwb->type == RE_UNWIND_BRANCH
3526                       ? NEXT_OFF(next) : ARG(next))))
3527                 next += n;
3528             else
3529                 next = NULL;    /* XXXX Needn't unwinding in this case... */
3530             uwb->next = next;
3531             next = NEXTOPER(scan);
3532             if (uwb->type == RE_UNWIND_BRANCHJ)
3533                 next = NEXTOPER(next);
3534             locinput = uwb->locinput;
3535             nextchr = uwb->nextchr;
3536 #ifdef DEBUGGING
3537             PL_regindent = uwb->regindent;
3538 #endif
3539
3540             goto reenter;
3541         }
3542         /* NOT REACHED */
3543         default:
3544             Perl_croak(aTHX_ "regexp unwind memory corruption");
3545         }
3546         /* NOT REACHED */
3547     }
3548 #ifdef DEBUGGING
3549     PL_regindent--;
3550 #endif
3551     return 0;
3552 }
3553
3554 /*
3555  - regrepeat - repeatedly match something simple, report how many
3556  */
3557 /*
3558  * [This routine now assumes that it will only match on things of length 1.
3559  * That was true before, but now we assume scan - reginput is the count,
3560  * rather than incrementing count on every character.  [Er, except utf8.]]
3561  */
3562 STATIC I32
3563 S_regrepeat(pTHX_ regnode *p, I32 max)
3564 {
3565     register char *scan;
3566     register I32 c;
3567     register char *loceol = PL_regeol;
3568     register I32 hardcount = 0;
3569     register bool do_utf8 = DO_UTF8(PL_reg_sv);
3570
3571     scan = PL_reginput;
3572     if (max != REG_INFTY && max < loceol - scan)
3573       loceol = scan + max;
3574     switch (OP(p)) {
3575     case REG_ANY:
3576         if (do_utf8) {
3577             loceol = PL_regeol;
3578             while (scan < loceol && hardcount < max && *scan != '\n') {
3579                 scan += UTF8SKIP(scan);
3580                 hardcount++;
3581             }
3582         } else {
3583             while (scan < loceol && *scan != '\n')
3584                 scan++;
3585         }
3586         break;
3587     case SANY:
3588         scan = loceol;
3589         break;
3590     case EXACT:         /* length of string is 1 */
3591         c = (U8)*STRING(p);
3592         while (scan < loceol && UCHARAT(scan) == c)
3593             scan++;
3594         break;
3595     case EXACTF:        /* length of string is 1 */
3596         c = (U8)*STRING(p);
3597         while (scan < loceol &&
3598                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
3599             scan++;
3600         break;
3601     case EXACTFL:       /* length of string is 1 */
3602         PL_reg_flags |= RF_tainted;
3603         c = (U8)*STRING(p);
3604         while (scan < loceol &&
3605                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
3606             scan++;
3607         break;
3608     case ANYOF:
3609         if (do_utf8) {
3610             loceol = PL_regeol;
3611             while (hardcount < max && scan < loceol &&
3612                    reginclass(p, (U8*)scan, do_utf8)) {
3613                 scan += UTF8SKIP(scan);
3614                 hardcount++;
3615             }
3616         } else {
3617             while (scan < loceol && reginclass(p, (U8*)scan, do_utf8))
3618                 scan++;
3619         }
3620         break;
3621     case ALNUM:
3622         if (do_utf8) {
3623             loceol = PL_regeol;
3624             LOAD_UTF8_CHARCLASS(alnum,"a");
3625             while (hardcount < max && scan < loceol &&
3626                    swash_fetch(PL_utf8_alnum, (U8*)scan)) {
3627                 scan += UTF8SKIP(scan);
3628                 hardcount++;
3629             }
3630         } else {
3631             while (scan < loceol && isALNUM(*scan))
3632                 scan++;
3633         }
3634         break;
3635     case ALNUML:
3636         PL_reg_flags |= RF_tainted;
3637         if (do_utf8) {
3638             loceol = PL_regeol;
3639             while (hardcount < max && scan < loceol &&
3640                    isALNUM_LC_utf8((U8*)scan)) {
3641                 scan += UTF8SKIP(scan);
3642                 hardcount++;
3643             }
3644         } else {
3645             while (scan < loceol && isALNUM_LC(*scan))
3646                 scan++;
3647         }
3648         break;
3649     case NALNUM:
3650         if (do_utf8) {
3651             loceol = PL_regeol;
3652             LOAD_UTF8_CHARCLASS(alnum,"a");
3653             while (hardcount < max && scan < loceol &&
3654                    !swash_fetch(PL_utf8_alnum, (U8*)scan)) {
3655                 scan += UTF8SKIP(scan);
3656                 hardcount++;
3657             }
3658         } else {
3659             while (scan < loceol && !isALNUM(*scan))
3660                 scan++;
3661         }
3662         break;
3663     case NALNUML:
3664         PL_reg_flags |= RF_tainted;
3665         if (do_utf8) {
3666             loceol = PL_regeol;
3667             while (hardcount < max && scan < loceol &&
3668                    !isALNUM_LC_utf8((U8*)scan)) {
3669                 scan += UTF8SKIP(scan);
3670                 hardcount++;
3671             }
3672         } else {
3673             while (scan < loceol && !isALNUM_LC(*scan))
3674                 scan++;
3675         }
3676         break;
3677     case SPACE:
3678         if (do_utf8) {
3679             loceol = PL_regeol;
3680             LOAD_UTF8_CHARCLASS(space," ");
3681             while (hardcount < max && scan < loceol &&
3682                    (*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
3683                 scan += UTF8SKIP(scan);
3684                 hardcount++;
3685             }
3686         } else {
3687             while (scan < loceol && isSPACE(*scan))
3688                 scan++;
3689         }
3690         break;
3691     case SPACEL:
3692         PL_reg_flags |= RF_tainted;
3693         if (do_utf8) {
3694             loceol = PL_regeol;
3695             while (hardcount < max && scan < loceol &&
3696                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3697                 scan += UTF8SKIP(scan);
3698                 hardcount++;
3699             }
3700         } else {
3701             while (scan < loceol && isSPACE_LC(*scan))
3702                 scan++;
3703         }
3704         break;
3705     case NSPACE:
3706         if (do_utf8) {
3707             loceol = PL_regeol;
3708             LOAD_UTF8_CHARCLASS(space," ");
3709             while (hardcount < max && scan < loceol &&
3710                    !(*scan == ' ' || swash_fetch(PL_utf8_space,(U8*)scan))) {
3711                 scan += UTF8SKIP(scan);
3712                 hardcount++;
3713             }
3714         } else {
3715             while (scan < loceol && !isSPACE(*scan))
3716                 scan++;
3717             break;
3718         }
3719     case NSPACEL:
3720         PL_reg_flags |= RF_tainted;
3721         if (do_utf8) {
3722             loceol = PL_regeol;
3723             while (hardcount < max && scan < loceol &&
3724                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3725                 scan += UTF8SKIP(scan);
3726                 hardcount++;
3727             }
3728         } else {
3729             while (scan < loceol && !isSPACE_LC(*scan))
3730                 scan++;
3731         }
3732         break;
3733     case DIGIT:
3734         if (do_utf8) {
3735             loceol = PL_regeol;
3736             LOAD_UTF8_CHARCLASS(digit,"0");
3737             while (hardcount < max && scan < loceol &&
3738                    swash_fetch(PL_utf8_digit,(U8*)scan)) {
3739                 scan += UTF8SKIP(scan);
3740                 hardcount++;
3741             }
3742         } else {
3743             while (scan < loceol && isDIGIT(*scan))
3744                 scan++;
3745         }
3746         break;
3747     case NDIGIT:
3748         if (do_utf8) {
3749             loceol = PL_regeol;
3750             LOAD_UTF8_CHARCLASS(digit,"0");
3751             while (hardcount < max && scan < loceol &&
3752                    !swash_fetch(PL_utf8_digit,(U8*)scan)) {
3753                 scan += UTF8SKIP(scan);
3754                 hardcount++;
3755             }
3756         } else {
3757             while (scan < loceol && !isDIGIT(*scan))
3758                 scan++;
3759         }
3760         break;
3761     default:            /* Called on something of 0 width. */
3762         break;          /* So match right here or not at all. */
3763     }
3764
3765     if (hardcount)
3766         c = hardcount;
3767     else
3768         c = scan - PL_reginput;
3769     PL_reginput = scan;
3770
3771     DEBUG_r(
3772         {
3773                 SV *prop = sv_newmortal();
3774
3775                 regprop(prop, p);
3776                 PerlIO_printf(Perl_debug_log,
3777                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
3778                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
3779         });
3780
3781     return(c);
3782 }
3783
3784 /*
3785  - regrepeat_hard - repeatedly match something, report total lenth and length
3786  *
3787  * The repeater is supposed to have constant length.
3788  */
3789
3790 STATIC I32
3791 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
3792 {
3793     register char *scan;
3794     register char *start;
3795     register char *loceol = PL_regeol;
3796     I32 l = 0;
3797     I32 count = 0, res = 1;
3798
3799     if (!max)
3800         return 0;
3801
3802     start = PL_reginput;
3803     if (DO_UTF8(PL_reg_sv)) {
3804         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3805             if (!count++) {
3806                 l = 0;
3807                 while (start < PL_reginput) {
3808                     l++;
3809                     start += UTF8SKIP(start);
3810                 }
3811                 *lp = l;
3812                 if (l == 0)
3813                     return max;
3814             }
3815             if (count == max)
3816                 return count;
3817         }
3818     }
3819     else {
3820         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3821             if (!count++) {
3822                 *lp = l = PL_reginput - start;
3823                 if (max != REG_INFTY && l*max < loceol - scan)
3824                     loceol = scan + l*max;
3825                 if (l == 0)
3826                     return max;
3827             }
3828         }
3829     }
3830     if (!res)
3831         PL_reginput = scan;
3832
3833     return count;
3834 }
3835
3836 /*
3837 - regclass_swash - prepare the utf8 swash
3838 */
3839
3840 SV *
3841 Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp)
3842 {
3843     SV *sw = NULL;
3844     SV *si = NULL;
3845
3846     if (PL_regdata && PL_regdata->count) {
3847         U32 n = ARG(node);
3848
3849         if (PL_regdata->what[n] == 's') {
3850             SV *rv = (SV*)PL_regdata->data[n];
3851             AV *av = (AV*)SvRV((SV*)rv);
3852             SV **a;
3853
3854             si = *av_fetch(av, 0, FALSE);
3855             a  =  av_fetch(av, 1, FALSE);
3856
3857             if (a)
3858                 sw = *a;
3859             else if (si && doinit) {
3860                 sw = swash_init("utf8", "", si, 1, 0);
3861                 (void)av_store(av, 1, sw);
3862             }
3863         }
3864     }
3865
3866     if (initsvp)
3867         *initsvp = si;
3868
3869     return sw;
3870 }
3871
3872 /*
3873  - reginclass - determine if a character falls into a character class
3874  */
3875
3876 STATIC bool
3877 S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8)
3878 {
3879     char flags = ANYOF_FLAGS(n);
3880     bool match = FALSE;
3881     UV c;
3882     STRLEN len;
3883
3884     if (do_utf8)
3885         c = utf8_to_uvchr(p, &len);
3886     else
3887         c = *p;
3888
3889     if (do_utf8 || (flags & ANYOF_UNICODE)) {
3890         if (do_utf8 && !ANYOF_RUNTIME(n)) {
3891             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
3892                 match = TRUE;
3893         }
3894         if (do_utf8 && flags & ANYOF_UNICODE_ALL && c >= 256)
3895             match = TRUE;
3896         if (!match) {
3897             SV *sw = regclass_swash(n, TRUE, 0);
3898
3899             if (sw) {
3900                 if (swash_fetch(sw, p))
3901                     match = TRUE;
3902                 else if (flags & ANYOF_FOLD) {
3903                     U8 tmpbuf[UTF8_MAXLEN+1];
3904
3905                     if (flags & ANYOF_LOCALE) {
3906                         PL_reg_flags |= RF_tainted;
3907                         uvchr_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
3908                     }
3909                     else
3910                         uvchr_to_utf8(tmpbuf, toLOWER_utf8(p));
3911                     if (swash_fetch(sw, tmpbuf))
3912                         match = TRUE;
3913                 }
3914             }
3915         }
3916     }
3917     if (!match && c < 256) {
3918         if (ANYOF_BITMAP_TEST(n, c))
3919             match = TRUE;
3920         else if (flags & ANYOF_FOLD) {
3921             I32 f;
3922
3923             if (flags & ANYOF_LOCALE) {
3924                 PL_reg_flags |= RF_tainted;
3925                 f = PL_fold_locale[c];
3926             }
3927             else
3928                 f = PL_fold[c];
3929             if (f != c && ANYOF_BITMAP_TEST(n, f))
3930                 match = TRUE;
3931         }
3932
3933         if (!match && (flags & ANYOF_CLASS)) {
3934             PL_reg_flags |= RF_tainted;
3935             if (
3936                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
3937                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
3938                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
3939                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
3940                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
3941                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
3942                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
3943                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
3944                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
3945                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
3946                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
3947                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
3948                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
3949                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
3950                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
3951                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
3952                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
3953                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
3954                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
3955                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
3956                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
3957                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
3958                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
3959                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
3960                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
3961                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
3962                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
3963                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
3964                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
3965                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
3966                 ) /* How's that for a conditional? */
3967             {
3968                 match = TRUE;
3969             }
3970         }
3971     }
3972
3973     return (flags & ANYOF_INVERT) ? !match : match;
3974 }
3975
3976 STATIC U8 *
3977 S_reghop(pTHX_ U8 *s, I32 off)
3978 {
3979     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
3980 }
3981
3982 STATIC U8 *
3983 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
3984 {
3985     if (off >= 0) {
3986         while (off-- && s < lim) {
3987             /* XXX could check well-formedness here */
3988             s += UTF8SKIP(s);
3989         }
3990     }
3991     else {
3992         while (off++) {
3993             if (s > lim) {
3994                 s--;
3995                 if (UTF8_IS_CONTINUED(*s)) {
3996                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
3997                         s--;
3998                 }
3999                 /* XXX could check well-formedness here */
4000             }
4001         }
4002     }
4003     return s;
4004 }
4005
4006 STATIC U8 *
4007 S_reghopmaybe(pTHX_ U8 *s, I32 off)
4008 {
4009     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4010 }
4011
4012 STATIC U8 *
4013 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
4014 {
4015     if (off >= 0) {
4016         while (off-- && s < lim) {
4017             /* XXX could check well-formedness here */
4018             s += UTF8SKIP(s);
4019         }
4020         if (off >= 0)
4021             return 0;
4022     }
4023     else {
4024         while (off++) {
4025             if (s > lim) {
4026                 s--;
4027                 if (UTF8_IS_CONTINUED(*s)) {
4028                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4029                         s--;
4030                 }
4031                 /* XXX could check well-formedness here */
4032             }
4033             else
4034                 break;
4035         }
4036         if (off <= 0)
4037             return 0;
4038     }
4039     return s;
4040 }
4041
4042 #ifdef PERL_OBJECT
4043 #include "XSUB.h"
4044 #endif
4045
4046 static void
4047 restore_pos(pTHXo_ void *arg)
4048 {
4049     if (PL_reg_eval_set) {
4050         if (PL_reg_oldsaved) {
4051             PL_reg_re->subbeg = PL_reg_oldsaved;
4052             PL_reg_re->sublen = PL_reg_oldsavedlen;
4053             RX_MATCH_COPIED_on(PL_reg_re);
4054         }
4055         PL_reg_magic->mg_len = PL_reg_oldpos;
4056         PL_reg_eval_set = 0;
4057         PL_curpm = PL_reg_oldcurpm;
4058     }
4059 }