regexec.c

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