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                 /* so we know which PL_regex_padav element is PL_curpm */
1859                 SvFLAGS(repointer) |= SVf_BREAK;
1860                 av_push(PL_regex_padav,repointer);
1861                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
1862                 PL_regex_pad = AvARRAY(PL_regex_padav);
1863             }
1864 #endif
1865         }
1866         PM_SETRE(PL_reg_curpm, prog);
1867         PL_reg_oldcurpm = PL_curpm;
1868         PL_curpm = PL_reg_curpm;
1869         if (RX_MATCH_COPIED(prog)) {
1870             /*  Here is a serious problem: we cannot rewrite subbeg,
1871                 since it may be needed if this match fails.  Thus
1872                 $` inside (?{}) could fail... */
1873             PL_reg_oldsaved = prog->subbeg;
1874             PL_reg_oldsavedlen = prog->sublen;
1875             RX_MATCH_COPIED_off(prog);
1876         }
1877         else
1878             PL_reg_oldsaved = Nullch;
1879         prog->subbeg = PL_bostr;
1880         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
1881     }
1882     prog->startp[0] = startpos - PL_bostr;
1883     PL_reginput = startpos;
1884     PL_regstartp = prog->startp;
1885     PL_regendp = prog->endp;
1886     PL_reglastparen = &prog->lastparen;
1887     PL_reglastcloseparen = &prog->lastcloseparen;
1888     prog->lastparen = 0;
1889     PL_regsize = 0;
1890     DEBUG_r(PL_reg_starttry = startpos);
1891     if (PL_reg_start_tmpl <= prog->nparens) {
1892         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
1893         if(PL_reg_start_tmp)
1894             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
1895         else
1896             New(22,PL_reg_start_tmp, PL_reg_start_tmpl, char*);
1897     }
1898
1899     /* XXXX What this code is doing here?!!!  There should be no need
1900        to do this again and again, PL_reglastparen should take care of
1901        this!  --ilya*/
1902
1903     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
1904      * Actually, the code in regcppop() (which Ilya may be meaning by
1905      * PL_reglastparen), is not needed at all by the test suite
1906      * (op/regexp, op/pat, op/split), but that code is needed, oddly
1907      * enough, for building DynaLoader, or otherwise this
1908      * "Error: '*' not in typemap in DynaLoader.xs, line 164"
1909      * will happen.  Meanwhile, this code *is* needed for the
1910      * above-mentioned test suite tests to succeed.  The common theme
1911      * on those tests seems to be returning null fields from matches.
1912      * --jhi */
1913 #if 1
1914     sp = prog->startp;
1915     ep = prog->endp;
1916     if (prog->nparens) {
1917         for (i = prog->nparens; i > *PL_reglastparen; i--) {
1918             *++sp = -1;
1919             *++ep = -1;
1920         }
1921     }
1922 #endif
1923     REGCP_SET(lastcp);
1924     if (regmatch(prog->program + 1)) {
1925         prog->endp[0] = PL_reginput - PL_bostr;
1926         return 1;
1927     }
1928     REGCP_UNWIND(lastcp);
1929     return 0;
1930 }
1931
1932 #define RE_UNWIND_BRANCH        1
1933 #define RE_UNWIND_BRANCHJ       2
1934
1935 union re_unwind_t;
1936
1937 typedef struct {                /* XX: makes sense to enlarge it... */
1938     I32 type;
1939     I32 prev;
1940     CHECKPOINT lastcp;
1941 } re_unwind_generic_t;
1942
1943 typedef struct {
1944     I32 type;
1945     I32 prev;
1946     CHECKPOINT lastcp;
1947     I32 lastparen;
1948     regnode *next;
1949     char *locinput;
1950     I32 nextchr;
1951 #ifdef DEBUGGING
1952     int regindent;
1953 #endif
1954 } re_unwind_branch_t;
1955
1956 typedef union re_unwind_t {
1957     I32 type;
1958     re_unwind_generic_t generic;
1959     re_unwind_branch_t branch;
1960 } re_unwind_t;
1961
1962 #define sayYES goto yes
1963 #define sayNO goto no
1964 #define sayYES_FINAL goto yes_final
1965 #define sayYES_LOUD  goto yes_loud
1966 #define sayNO_FINAL  goto no_final
1967 #define sayNO_SILENT goto do_no
1968 #define saySAME(x) if (x) goto yes; else goto no
1969
1970 #define REPORT_CODE_OFF 24
1971
1972 /*
1973  - regmatch - main matching routine
1974  *
1975  * Conceptually the strategy is simple:  check to see whether the current
1976  * node matches, call self recursively to see whether the rest matches,
1977  * and then act accordingly.  In practice we make some effort to avoid
1978  * recursion, in particular by going through "ordinary" nodes (that don't
1979  * need to know whether the rest of the match failed) by a loop instead of
1980  * by recursion.
1981  */
1982 /* [lwall] I've hoisted the register declarations to the outer block in order to
1983  * maybe save a little bit of pushing and popping on the stack.  It also takes
1984  * advantage of machines that use a register save mask on subroutine entry.
1985  */
1986 STATIC I32                      /* 0 failure, 1 success */
1987 S_regmatch(pTHX_ regnode *prog)
1988 {
1989     register regnode *scan;     /* Current node. */
1990     regnode *next;              /* Next node. */
1991     regnode *inner;             /* Next node in internal branch. */
1992     register I32 nextchr;       /* renamed nextchr - nextchar colides with
1993                                    function of same name */
1994     register I32 n;             /* no or next */
1995     register I32 ln = 0;        /* len or last */
1996     register char *s = Nullch;  /* operand or save */
1997     register char *locinput = PL_reginput;
1998     register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
1999     int minmod = 0, sw = 0, logical = 0;
2000     I32 unwind = 0;
2001 #if 0
2002     I32 firstcp = PL_savestack_ix;
2003 #endif
2004     register bool do_utf8 = DO_UTF8(PL_reg_sv);
2005
2006 #ifdef DEBUGGING
2007     PL_regindent++;
2008 #endif
2009
2010     /* Note that nextchr is a byte even in UTF */
2011     nextchr = UCHARAT(locinput);
2012     scan = prog;
2013     while (scan != NULL) {
2014
2015         DEBUG_r( {
2016             SV *prop = sv_newmortal();
2017             int docolor = *PL_colors[0];
2018             int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2019             int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2020             /* The part of the string before starttry has one color
2021                (pref0_len chars), between starttry and current
2022                position another one (pref_len - pref0_len chars),
2023                after the current position the third one.
2024                We assume that pref0_len <= pref_len, otherwise we
2025                decrease pref0_len.  */
2026             int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2027                 ? (5 + taill) - l : locinput - PL_bostr;
2028             int pref0_len;
2029
2030             while (UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2031                 pref_len++;
2032             pref0_len = pref_len  - (locinput - PL_reg_starttry);
2033             if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2034                 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2035                       ? (5 + taill) - pref_len : PL_regeol - locinput);
2036             while (UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2037                 l--;
2038             if (pref0_len < 0)
2039                 pref0_len = 0;
2040             if (pref0_len > pref_len)
2041                 pref0_len = pref_len;
2042             regprop(prop, scan);
2043             PerlIO_printf(Perl_debug_log,
2044                           "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2045                           (IV)(locinput - PL_bostr),
2046                           PL_colors[4], pref0_len,
2047                           locinput - pref_len, PL_colors[5],
2048                           PL_colors[2], pref_len - pref0_len,
2049                           locinput - pref_len + pref0_len, PL_colors[3],
2050                           (docolor ? "" : "> <"),
2051                           PL_colors[0], l, locinput, PL_colors[1],
2052                           15 - l - pref_len + 1,
2053                           "",
2054                           (IV)(scan - PL_regprogram), PL_regindent*2, "",
2055                           SvPVX(prop));
2056         } );
2057
2058         next = scan + NEXT_OFF(scan);
2059         if (next == scan)
2060             next = NULL;
2061
2062         switch (OP(scan)) {
2063         case BOL:
2064             if (locinput == PL_bostr || (PL_multiline &&
2065                 (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
2066             {
2067                 /* regtill = regbol; */
2068                 break;
2069             }
2070             sayNO;
2071         case MBOL:
2072             if (locinput == PL_bostr ||
2073                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2074             {
2075                 break;
2076             }
2077             sayNO;
2078         case SBOL:
2079             if (locinput == PL_bostr)
2080                 break;
2081             sayNO;
2082         case GPOS:
2083             if (locinput == PL_reg_ganch)
2084                 break;
2085             sayNO;
2086         case EOL:
2087             if (PL_multiline)
2088                 goto meol;
2089             else
2090                 goto seol;
2091         case MEOL:
2092           meol:
2093             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2094                 sayNO;
2095             break;
2096         case SEOL:
2097           seol:
2098             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2099                 sayNO;
2100             if (PL_regeol - locinput > 1)
2101                 sayNO;
2102             break;
2103         case EOS:
2104             if (PL_regeol != locinput)
2105                 sayNO;
2106             break;
2107         case SANY:
2108             if (!nextchr && locinput >= PL_regeol)
2109                 sayNO;
2110             nextchr = UCHARAT(++locinput);
2111             break;
2112         case REG_ANY:
2113             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2114                 sayNO;
2115             if (do_utf8) {
2116                 locinput += PL_utf8skip[nextchr];
2117                 if (locinput > PL_regeol)
2118                     sayNO;
2119                 nextchr = UCHARAT(locinput);
2120             }
2121             else
2122                 nextchr = UCHARAT(++locinput);
2123             break;
2124         case EXACT:
2125             s = STRING(scan);
2126             ln = STR_LEN(scan);
2127             if (do_utf8 != (UTF!=0)) {
2128                 char *l = locinput;
2129                 char *e = s + ln;
2130                 STRLEN len;
2131                 if (do_utf8)
2132                     while (s < e) {
2133                         if (l >= PL_regeol)
2134                             sayNO;
2135                         if (*((U8*)s) != utf8_to_uvchr((U8*)l, &len))
2136                             sayNO;
2137                         s++;
2138                         l += len;
2139                     }
2140                 else
2141                     while (s < e) {
2142                         if (l >= PL_regeol)
2143                             sayNO;
2144                         if (*((U8*)l) != utf8_to_uvchr((U8*)s, &len))
2145                             sayNO;
2146                         s += len;
2147                         l++;
2148                     }
2149                 locinput = l;
2150                 nextchr = UCHARAT(locinput);
2151                 break;
2152             }
2153             /* Inline the first character, for speed. */
2154             if (UCHARAT(s) != nextchr)
2155                 sayNO;
2156             if (PL_regeol - locinput < ln)
2157                 sayNO;
2158             if (ln > 1 && memNE(s, locinput, ln))
2159                 sayNO;
2160             locinput += ln;
2161             nextchr = UCHARAT(locinput);
2162             break;
2163         case EXACTFL:
2164             PL_reg_flags |= RF_tainted;
2165             /* FALL THROUGH */
2166         case EXACTF:
2167             s = STRING(scan);
2168             ln = STR_LEN(scan);
2169
2170             if (do_utf8) {
2171                 char *l = locinput;
2172                 char *e;
2173                 e = s + ln;
2174                 c1 = OP(scan) == EXACTF;
2175                 while (s < e) {
2176                     if (l >= PL_regeol) {
2177                         sayNO;
2178                     }
2179                     if ((UTF ? utf8n_to_uvchr((U8*)s, e - s, 0, 0) : *((U8*)s)) !=
2180                         (c1 ? toLOWER_utf8((U8*)l) : toLOWER_LC_utf8((U8*)l)))
2181                             sayNO;
2182                     s += UTF ? UTF8SKIP(s) : 1;
2183                     l += UTF8SKIP(l);
2184                 }
2185                 locinput = l;
2186                 nextchr = UCHARAT(locinput);
2187                 break;
2188             }
2189
2190             /* Inline the first character, for speed. */
2191             if (UCHARAT(s) != nextchr &&
2192                 UCHARAT(s) != ((OP(scan) == EXACTF)
2193                                ? PL_fold : PL_fold_locale)[nextchr])
2194                 sayNO;
2195             if (PL_regeol - locinput < ln)
2196                 sayNO;
2197             if (ln > 1 && (OP(scan) == EXACTF
2198                            ? ibcmp(s, locinput, ln)
2199                            : ibcmp_locale(s, locinput, ln)))
2200                 sayNO;
2201             locinput += ln;
2202             nextchr = UCHARAT(locinput);
2203             break;
2204         case ANYOF:
2205             if (do_utf8) {
2206                 if (!reginclass(scan, (U8*)locinput, do_utf8))
2207                     sayNO;
2208                 if (locinput >= PL_regeol)
2209                     sayNO;
2210                 locinput += PL_utf8skip[nextchr];
2211                 nextchr = UCHARAT(locinput);
2212             }
2213             else {
2214                 if (nextchr < 0)
2215                     nextchr = UCHARAT(locinput);
2216                 if (!reginclass(scan, (U8*)locinput, do_utf8))
2217                     sayNO;
2218                 if (!nextchr && locinput >= PL_regeol)
2219                     sayNO;
2220                 nextchr = UCHARAT(++locinput);
2221             }
2222             break;
2223         case ALNUML:
2224             PL_reg_flags |= RF_tainted;
2225             /* FALL THROUGH */
2226         case ALNUM:
2227             if (!nextchr)
2228                 sayNO;
2229             if (do_utf8) {
2230                 LOAD_UTF8_CHARCLASS(alnum,"a");
2231                 if (!(OP(scan) == ALNUM
2232                       ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2233                       : isALNUM_LC_utf8((U8*)locinput)))
2234                 {
2235                     sayNO;
2236                 }
2237                 locinput += PL_utf8skip[nextchr];
2238                 nextchr = UCHARAT(locinput);
2239                 break;
2240             }
2241             if (!(OP(scan) == ALNUM
2242                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
2243                 sayNO;
2244             nextchr = UCHARAT(++locinput);
2245             break;
2246         case NALNUML:
2247             PL_reg_flags |= RF_tainted;
2248             /* FALL THROUGH */
2249         case NALNUM:
2250             if (!nextchr && locinput >= PL_regeol)
2251                 sayNO;
2252             if (do_utf8) {
2253                 LOAD_UTF8_CHARCLASS(alnum,"a");
2254                 if (OP(scan) == NALNUM
2255                     ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2256                     : isALNUM_LC_utf8((U8*)locinput))
2257                 {
2258                     sayNO;
2259                 }
2260                 locinput += PL_utf8skip[nextchr];
2261                 nextchr = UCHARAT(locinput);
2262                 break;
2263             }
2264             if (OP(scan) == NALNUM
2265                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
2266                 sayNO;
2267             nextchr = UCHARAT(++locinput);
2268             break;
2269         case BOUNDL:
2270         case NBOUNDL:
2271             PL_reg_flags |= RF_tainted;
2272             /* FALL THROUGH */
2273         case BOUND:
2274         case NBOUND:
2275             /* was last char in word? */
2276             if (do_utf8) {
2277                 if (locinput == PL_bostr)
2278                     ln = '\n';
2279                 else {
2280                     U8 *r = reghop((U8*)locinput, -1);
2281
2282                     ln = utf8n_to_uvchr(r, s - (char*)r, 0, 0);
2283                 }
2284                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2285                     ln = isALNUM_uni(ln);
2286                     LOAD_UTF8_CHARCLASS(alnum,"a");
2287                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
2288                 }
2289                 else {
2290                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
2291                     n = isALNUM_LC_utf8((U8*)locinput);
2292                 }
2293             }
2294             else {
2295                 ln = (locinput != PL_bostr) ?
2296                     UCHARAT(locinput - 1) : '\n';
2297                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2298                     ln = isALNUM(ln);
2299                     n = isALNUM(nextchr);
2300                 }
2301                 else {
2302                     ln = isALNUM_LC(ln);
2303                     n = isALNUM_LC(nextchr);
2304                 }
2305             }
2306             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
2307                                     OP(scan) == BOUNDL))
2308                     sayNO;
2309             break;
2310         case SPACEL:
2311             PL_reg_flags |= RF_tainted;
2312             /* FALL THROUGH */
2313         case SPACE:
2314             if (!nextchr)
2315                 sayNO;
2316             if (do_utf8) {
2317                 if (UTF8_IS_CONTINUED(nextchr)) {
2318                     LOAD_UTF8_CHARCLASS(space," ");
2319                     if (!(OP(scan) == SPACE
2320                           ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2321                           : isSPACE_LC_utf8((U8*)locinput)))
2322                     {
2323                         sayNO;
2324                     }
2325                     locinput += PL_utf8skip[nextchr];
2326                     nextchr = UCHARAT(locinput);
2327                     break;
2328                 }
2329                 if (!(OP(scan) == SPACE
2330                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2331                     sayNO;
2332                 nextchr = UCHARAT(++locinput);
2333             }
2334             else {
2335                 if (!(OP(scan) == SPACE
2336                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2337                     sayNO;
2338                 nextchr = UCHARAT(++locinput);
2339             }
2340             break;
2341         case NSPACEL:
2342             PL_reg_flags |= RF_tainted;
2343             /* FALL THROUGH */
2344         case NSPACE:
2345             if (!nextchr && locinput >= PL_regeol)
2346                 sayNO;
2347             if (do_utf8) {
2348                 LOAD_UTF8_CHARCLASS(space," ");
2349                 if (OP(scan) == NSPACE
2350                     ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2351                     : isSPACE_LC_utf8((U8*)locinput))
2352                 {
2353                     sayNO;
2354                 }
2355                 locinput += PL_utf8skip[nextchr];
2356                 nextchr = UCHARAT(locinput);
2357                 break;
2358             }
2359             if (OP(scan) == NSPACE
2360                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
2361                 sayNO;
2362             nextchr = UCHARAT(++locinput);
2363             break;
2364         case DIGITL:
2365             PL_reg_flags |= RF_tainted;
2366             /* FALL THROUGH */
2367         case DIGIT:
2368             if (!nextchr)
2369                 sayNO;
2370             if (do_utf8) {
2371                 LOAD_UTF8_CHARCLASS(digit,"0");
2372                 if (!(OP(scan) == DIGIT
2373                       ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2374                       : isDIGIT_LC_utf8((U8*)locinput)))
2375                 {
2376                     sayNO;
2377                 }
2378                 locinput += PL_utf8skip[nextchr];
2379                 nextchr = UCHARAT(locinput);
2380                 break;
2381             }
2382             if (!(OP(scan) == DIGIT
2383                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
2384                 sayNO;
2385             nextchr = UCHARAT(++locinput);
2386             break;
2387         case NDIGITL:
2388             PL_reg_flags |= RF_tainted;
2389             /* FALL THROUGH */
2390         case NDIGIT:
2391             if (!nextchr && locinput >= PL_regeol)
2392                 sayNO;
2393             if (do_utf8) {
2394                 LOAD_UTF8_CHARCLASS(digit,"0");
2395                 if (OP(scan) == NDIGIT
2396                     ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2397                     : isDIGIT_LC_utf8((U8*)locinput))
2398                 {
2399                     sayNO;
2400                 }
2401                 locinput += PL_utf8skip[nextchr];
2402                 nextchr = UCHARAT(locinput);
2403                 break;
2404             }
2405             if (OP(scan) == NDIGIT
2406                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
2407                 sayNO;
2408             nextchr = UCHARAT(++locinput);
2409             break;
2410         case CLUMP:
2411             LOAD_UTF8_CHARCLASS(mark,"~");
2412             if (locinput >= PL_regeol ||
2413                 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2414                 sayNO;
2415             locinput += PL_utf8skip[nextchr];
2416             while (locinput < PL_regeol &&
2417                    swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2418                 locinput += UTF8SKIP(locinput);
2419             if (locinput > PL_regeol)
2420                 sayNO;
2421             nextchr = UCHARAT(locinput);
2422             break;
2423         case REFFL:
2424             PL_reg_flags |= RF_tainted;
2425             /* FALL THROUGH */
2426         case REF:
2427         case REFF:
2428             n = ARG(scan);  /* which paren pair */
2429             ln = PL_regstartp[n];
2430             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2431             if (*PL_reglastparen < n || ln == -1)
2432                 sayNO;                  /* Do not match unless seen CLOSEn. */
2433             if (ln == PL_regendp[n])
2434                 break;
2435
2436             s = PL_bostr + ln;
2437             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
2438                 char *l = locinput;
2439                 char *e = PL_bostr + PL_regendp[n];
2440                 /*
2441                  * Note that we can't do the "other character" lookup trick as
2442                  * in the 8-bit case (no pun intended) because in Unicode we
2443                  * have to map both upper and title case to lower case.
2444                  */
2445                 if (OP(scan) == REFF) {
2446                     while (s < e) {
2447                         if (l >= PL_regeol)
2448                             sayNO;
2449                         if (toLOWER_utf8((U8*)s) != toLOWER_utf8((U8*)l))
2450                             sayNO;
2451                         s += UTF8SKIP(s);
2452                         l += UTF8SKIP(l);
2453                     }
2454                 }
2455                 else {
2456                     while (s < e) {
2457                         if (l >= PL_regeol)
2458                             sayNO;
2459                         if (toLOWER_LC_utf8((U8*)s) != toLOWER_LC_utf8((U8*)l))
2460                             sayNO;
2461                         s += UTF8SKIP(s);
2462                         l += UTF8SKIP(l);
2463                     }
2464                 }
2465                 locinput = l;
2466                 nextchr = UCHARAT(locinput);
2467                 break;
2468             }
2469
2470             /* Inline the first character, for speed. */
2471             if (UCHARAT(s) != nextchr &&
2472                 (OP(scan) == REF ||
2473                  (UCHARAT(s) != ((OP(scan) == REFF
2474                                   ? PL_fold : PL_fold_locale)[nextchr]))))
2475                 sayNO;
2476             ln = PL_regendp[n] - ln;
2477             if (locinput + ln > PL_regeol)
2478                 sayNO;
2479             if (ln > 1 && (OP(scan) == REF
2480                            ? memNE(s, locinput, ln)
2481                            : (OP(scan) == REFF
2482                               ? ibcmp(s, locinput, ln)
2483                               : ibcmp_locale(s, locinput, ln))))
2484                 sayNO;
2485             locinput += ln;
2486             nextchr = UCHARAT(locinput);
2487             break;
2488
2489         case NOTHING:
2490         case TAIL:
2491             break;
2492         case BACK:
2493             break;
2494         case EVAL:
2495         {
2496             dSP;
2497             OP_4tree *oop = PL_op;
2498             COP *ocurcop = PL_curcop;
2499             SV **ocurpad = PL_curpad;
2500             SV *ret;
2501
2502             n = ARG(scan);
2503             PL_op = (OP_4tree*)PL_regdata->data[n];
2504             DEBUG_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
2505             PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 2]);
2506             PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
2507
2508             CALLRUNOPS(aTHX);                   /* Scalar context. */
2509             SPAGAIN;
2510             ret = POPs;
2511             PUTBACK;
2512
2513             PL_op = oop;
2514             PL_curpad = ocurpad;
2515             PL_curcop = ocurcop;
2516             if (logical) {
2517                 if (logical == 2) {     /* Postponed subexpression. */
2518                     regexp *re;
2519                     MAGIC *mg = Null(MAGIC*);
2520                     re_cc_state state;
2521                     CHECKPOINT cp, lastcp;
2522
2523                     if(SvROK(ret) || SvRMAGICAL(ret)) {
2524                         SV *sv = SvROK(ret) ? SvRV(ret) : ret;
2525
2526                         if(SvMAGICAL(sv))
2527                             mg = mg_find(sv, PERL_MAGIC_qr);
2528                     }
2529                     if (mg) {
2530                         re = (regexp *)mg->mg_obj;
2531                         (void)ReREFCNT_inc(re);
2532                     }
2533                     else {
2534                         STRLEN len;
2535                         char *t = SvPV(ret, len);
2536                         PMOP pm;
2537                         char *oprecomp = PL_regprecomp;
2538                         I32 osize = PL_regsize;
2539                         I32 onpar = PL_regnpar;
2540
2541                         Zero(&pm, 1, PMOP);
2542                         re = CALLREGCOMP(aTHX_ t, t + len, &pm);
2543                         if (!(SvFLAGS(ret)
2544                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
2545                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
2546                                         PERL_MAGIC_qr,0,0);
2547                         PL_regprecomp = oprecomp;
2548                         PL_regsize = osize;
2549                         PL_regnpar = onpar;
2550                     }
2551                     DEBUG_r(
2552                         PerlIO_printf(Perl_debug_log,
2553                                       "Entering embedded `%s%.60s%s%s'\n",
2554                                       PL_colors[0],
2555                                       re->precomp,
2556                                       PL_colors[1],
2557                                       (strlen(re->precomp) > 60 ? "..." : ""))
2558                         );
2559                     state.node = next;
2560                     state.prev = PL_reg_call_cc;
2561                     state.cc = PL_regcc;
2562                     state.re = PL_reg_re;
2563
2564                     PL_regcc = 0;
2565
2566                     cp = regcppush(0);  /* Save *all* the positions. */
2567                     REGCP_SET(lastcp);
2568                     cache_re(re);
2569                     state.ss = PL_savestack_ix;
2570                     *PL_reglastparen = 0;
2571                     *PL_reglastcloseparen = 0;
2572                     PL_reg_call_cc = &state;
2573                     PL_reginput = locinput;
2574
2575                     /* XXXX This is too dramatic a measure... */
2576                     PL_reg_maxiter = 0;
2577
2578                     if (regmatch(re->program + 1)) {
2579                         /* Even though we succeeded, we need to restore
2580                            global variables, since we may be wrapped inside
2581                            SUSPEND, thus the match may be not finished yet. */
2582
2583                         /* XXXX Do this only if SUSPENDed? */
2584                         PL_reg_call_cc = state.prev;
2585                         PL_regcc = state.cc;
2586                         PL_reg_re = state.re;
2587                         cache_re(PL_reg_re);
2588
2589                         /* XXXX This is too dramatic a measure... */
2590                         PL_reg_maxiter = 0;
2591
2592                         /* These are needed even if not SUSPEND. */
2593                         ReREFCNT_dec(re);
2594                         regcpblow(cp);
2595                         sayYES;
2596                     }
2597                     ReREFCNT_dec(re);
2598                     REGCP_UNWIND(lastcp);
2599                     regcppop();
2600                     PL_reg_call_cc = state.prev;
2601                     PL_regcc = state.cc;
2602                     PL_reg_re = state.re;
2603                     cache_re(PL_reg_re);
2604
2605                     /* XXXX This is too dramatic a measure... */
2606                     PL_reg_maxiter = 0;
2607
2608                     sayNO;
2609                 }
2610                 sw = SvTRUE(ret);
2611                 logical = 0;
2612             }
2613             else
2614                 sv_setsv(save_scalar(PL_replgv), ret);
2615             break;
2616         }
2617         case OPEN:
2618             n = ARG(scan);  /* which paren pair */
2619             PL_reg_start_tmp[n] = locinput;
2620             if (n > PL_regsize)
2621                 PL_regsize = n;
2622             break;
2623         case CLOSE:
2624             n = ARG(scan);  /* which paren pair */
2625             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
2626             PL_regendp[n] = locinput - PL_bostr;
2627             if (n > *PL_reglastparen)
2628                 *PL_reglastparen = n;
2629             *PL_reglastcloseparen = n;
2630             break;
2631         case GROUPP:
2632             n = ARG(scan);  /* which paren pair */
2633             sw = (*PL_reglastparen >= n && PL_regendp[n] != -1);
2634             break;
2635         case IFTHEN:
2636             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2637             if (sw)
2638                 next = NEXTOPER(NEXTOPER(scan));
2639             else {
2640                 next = scan + ARG(scan);
2641                 if (OP(next) == IFTHEN) /* Fake one. */
2642                     next = NEXTOPER(NEXTOPER(next));
2643             }
2644             break;
2645         case LOGICAL:
2646             logical = scan->flags;
2647             break;
2648 /*******************************************************************
2649  PL_regcc contains infoblock about the innermost (...)* loop, and
2650  a pointer to the next outer infoblock.
2651
2652  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
2653
2654    1) After matching X, regnode for CURLYX is processed;
2655
2656    2) This regnode creates infoblock on the stack, and calls
2657       regmatch() recursively with the starting point at WHILEM node;
2658
2659    3) Each hit of WHILEM node tries to match A and Z (in the order
2660       depending on the current iteration, min/max of {min,max} and
2661       greediness).  The information about where are nodes for "A"
2662       and "Z" is read from the infoblock, as is info on how many times "A"
2663       was already matched, and greediness.
2664
2665    4) After A matches, the same WHILEM node is hit again.
2666
2667    5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
2668       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
2669       resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
2670       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
2671       of the external loop.
2672
2673  Currently present infoblocks form a tree with a stem formed by PL_curcc
2674  and whatever it mentions via ->next, and additional attached trees
2675  corresponding to temporarily unset infoblocks as in "5" above.
2676
2677  In the following picture infoblocks for outer loop of
2678  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
2679  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
2680  infoblocks are drawn below the "reset" infoblock.
2681
2682  In fact in the picture below we do not show failed matches for Z and T
2683  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
2684  more obvious *why* one needs to *temporary* unset infoblocks.]
2685
2686   Matched       REx position    InfoBlocks      Comment
2687                 (Y(A)*?Z)*?T    x
2688                 Y(A)*?Z)*?T     x <- O
2689   Y             (A)*?Z)*?T      x <- O
2690   Y             A)*?Z)*?T       x <- O <- I
2691   YA            )*?Z)*?T        x <- O <- I
2692   YA            A)*?Z)*?T       x <- O <- I
2693   YAA           )*?Z)*?T        x <- O <- I
2694   YAA           Z)*?T           x <- O          # Temporary unset I
2695                                      I
2696
2697   YAAZ          Y(A)*?Z)*?T     x <- O
2698                                      I
2699
2700   YAAZY         (A)*?Z)*?T      x <- O
2701                                      I
2702
2703   YAAZY         A)*?Z)*?T       x <- O <- I
2704                                      I
2705
2706   YAAZYA        )*?Z)*?T        x <- O <- I
2707                                      I
2708
2709   YAAZYA        Z)*?T           x <- O          # Temporary unset I
2710                                      I,I
2711
2712   YAAZYAZ       )*?T            x <- O
2713                                      I,I
2714
2715   YAAZYAZ       T               x               # Temporary unset O
2716                                 O
2717                                 I,I
2718
2719   YAAZYAZT                      x
2720                                 O
2721                                 I,I
2722  *******************************************************************/
2723         case CURLYX: {
2724                 CURCUR cc;
2725                 CHECKPOINT cp = PL_savestack_ix;
2726                 /* No need to save/restore up to this paren */
2727                 I32 parenfloor = scan->flags;
2728
2729                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
2730                     next += ARG(next);
2731                 cc.oldcc = PL_regcc;
2732                 PL_regcc = &cc;
2733                 /* XXXX Probably it is better to teach regpush to support
2734                    parenfloor > PL_regsize... */
2735                 if (parenfloor > *PL_reglastparen)
2736                     parenfloor = *PL_reglastparen; /* Pessimization... */
2737                 cc.parenfloor = parenfloor;
2738                 cc.cur = -1;
2739                 cc.min = ARG1(scan);
2740                 cc.max  = ARG2(scan);
2741                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2742                 cc.next = next;
2743                 cc.minmod = minmod;
2744                 cc.lastloc = 0;
2745                 PL_reginput = locinput;
2746                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
2747                 regcpblow(cp);
2748                 PL_regcc = cc.oldcc;
2749                 saySAME(n);
2750             }
2751             /* NOT REACHED */
2752         case WHILEM: {
2753                 /*
2754                  * This is really hard to understand, because after we match
2755                  * what we're trying to match, we must make sure the rest of
2756                  * the REx is going to match for sure, and to do that we have
2757                  * to go back UP the parse tree by recursing ever deeper.  And
2758                  * if it fails, we have to reset our parent's current state
2759                  * that we can try again after backing off.
2760                  */
2761
2762                 CHECKPOINT cp, lastcp;
2763                 CURCUR* cc = PL_regcc;
2764                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
2765
2766                 n = cc->cur + 1;        /* how many we know we matched */
2767                 PL_reginput = locinput;
2768
2769                 DEBUG_r(
2770                     PerlIO_printf(Perl_debug_log,
2771                                   "%*s  %ld out of %ld..%ld  cc=%lx\n",
2772                                   REPORT_CODE_OFF+PL_regindent*2, "",
2773                                   (long)n, (long)cc->min,
2774                                   (long)cc->max, (long)cc)
2775                     );
2776
2777                 /* If degenerate scan matches "", assume scan done. */
2778
2779                 if (locinput == cc->lastloc && n >= cc->min) {
2780                     PL_regcc = cc->oldcc;
2781                     if (PL_regcc)
2782                         ln = PL_regcc->cur;
2783                     DEBUG_r(
2784                         PerlIO_printf(Perl_debug_log,
2785                            "%*s  empty match detected, try continuation...\n",
2786                            REPORT_CODE_OFF+PL_regindent*2, "")
2787                         );
2788                     if (regmatch(cc->next))
2789                         sayYES;
2790                     if (PL_regcc)
2791                         PL_regcc->cur = ln;
2792                     PL_regcc = cc;
2793                     sayNO;
2794                 }
2795
2796                 /* First just match a string of min scans. */
2797
2798                 if (n < cc->min) {
2799                     cc->cur = n;
2800                     cc->lastloc = locinput;
2801                     if (regmatch(cc->scan))
2802                         sayYES;
2803                     cc->cur = n - 1;
2804                     cc->lastloc = lastloc;
2805                     sayNO;
2806                 }
2807
2808                 if (scan->flags) {
2809                     /* Check whether we already were at this position.
2810                         Postpone detection until we know the match is not
2811                         *that* much linear. */
2812                 if (!PL_reg_maxiter) {
2813                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
2814                     PL_reg_leftiter = PL_reg_maxiter;
2815                 }
2816                 if (PL_reg_leftiter-- == 0) {
2817                     I32 size = (PL_reg_maxiter + 7)/8;
2818                     if (PL_reg_poscache) {
2819                         if (PL_reg_poscache_size < size) {
2820                             Renew(PL_reg_poscache, size, char);
2821                             PL_reg_poscache_size = size;
2822                         }
2823                         Zero(PL_reg_poscache, size, char);
2824                     }
2825                     else {
2826                         PL_reg_poscache_size = size;
2827                         Newz(29, PL_reg_poscache, size, char);
2828                     }
2829                     DEBUG_r(
2830                         PerlIO_printf(Perl_debug_log,
2831               "%sDetected a super-linear match, switching on caching%s...\n",
2832                                       PL_colors[4], PL_colors[5])
2833                         );
2834                 }
2835                 if (PL_reg_leftiter < 0) {
2836                     I32 o = locinput - PL_bostr, b;
2837
2838                     o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
2839                     b = o % 8;
2840                     o /= 8;
2841                     if (PL_reg_poscache[o] & (1<<b)) {
2842                     DEBUG_r(
2843                         PerlIO_printf(Perl_debug_log,
2844                                       "%*s  already tried at this position...\n",
2845                                       REPORT_CODE_OFF+PL_regindent*2, "")
2846                         );
2847                         sayNO_SILENT;
2848                     }
2849                     PL_reg_poscache[o] |= (1<<b);
2850                 }
2851                 }
2852
2853                 /* Prefer next over scan for minimal matching. */
2854
2855                 if (cc->minmod) {
2856                     PL_regcc = cc->oldcc;
2857                     if (PL_regcc)
2858                         ln = PL_regcc->cur;
2859                     cp = regcppush(cc->parenfloor);
2860                     REGCP_SET(lastcp);
2861                     if (regmatch(cc->next)) {
2862                         regcpblow(cp);
2863                         sayYES; /* All done. */
2864                     }
2865                     REGCP_UNWIND(lastcp);
2866                     regcppop();
2867                     if (PL_regcc)
2868                         PL_regcc->cur = ln;
2869                     PL_regcc = cc;
2870
2871                     if (n >= cc->max) { /* Maximum greed exceeded? */
2872                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2873                             && !(PL_reg_flags & RF_warned)) {
2874                             PL_reg_flags |= RF_warned;
2875                             Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2876                                  "Complex regular subexpression recursion",
2877                                  REG_INFTY - 1);
2878                         }
2879                         sayNO;
2880                     }
2881
2882                     DEBUG_r(
2883                         PerlIO_printf(Perl_debug_log,
2884                                       "%*s  trying longer...\n",
2885                                       REPORT_CODE_OFF+PL_regindent*2, "")
2886                         );
2887                     /* Try scanning more and see if it helps. */
2888                     PL_reginput = locinput;
2889                     cc->cur = n;
2890                     cc->lastloc = locinput;
2891                     cp = regcppush(cc->parenfloor);
2892                     REGCP_SET(lastcp);
2893                     if (regmatch(cc->scan)) {
2894                         regcpblow(cp);
2895                         sayYES;
2896                     }
2897                     REGCP_UNWIND(lastcp);
2898                     regcppop();
2899                     cc->cur = n - 1;
2900                     cc->lastloc = lastloc;
2901                     sayNO;
2902                 }
2903
2904                 /* Prefer scan over next for maximal matching. */
2905
2906                 if (n < cc->max) {      /* More greed allowed? */
2907                     cp = regcppush(cc->parenfloor);
2908                     cc->cur = n;
2909                     cc->lastloc = locinput;
2910                     REGCP_SET(lastcp);
2911                     if (regmatch(cc->scan)) {
2912                         regcpblow(cp);
2913                         sayYES;
2914                     }
2915                     REGCP_UNWIND(lastcp);
2916                     regcppop();         /* Restore some previous $<digit>s? */
2917                     PL_reginput = locinput;
2918                     DEBUG_r(
2919                         PerlIO_printf(Perl_debug_log,
2920                                       "%*s  failed, try continuation...\n",
2921                                       REPORT_CODE_OFF+PL_regindent*2, "")
2922                         );
2923                 }
2924                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2925                         && !(PL_reg_flags & RF_warned)) {
2926                     PL_reg_flags |= RF_warned;
2927                     Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2928                          "Complex regular subexpression recursion",
2929                          REG_INFTY - 1);
2930                 }
2931
2932                 /* Failed deeper matches of scan, so see if this one works. */
2933                 PL_regcc = cc->oldcc;
2934                 if (PL_regcc)
2935                     ln = PL_regcc->cur;
2936                 if (regmatch(cc->next))
2937                     sayYES;
2938                 if (PL_regcc)
2939                     PL_regcc->cur = ln;
2940                 PL_regcc = cc;
2941                 cc->cur = n - 1;
2942                 cc->lastloc = lastloc;
2943                 sayNO;
2944             }
2945             /* NOT REACHED */
2946         case BRANCHJ:
2947             next = scan + ARG(scan);
2948             if (next == scan)
2949                 next = NULL;
2950             inner = NEXTOPER(NEXTOPER(scan));
2951             goto do_branch;
2952         case BRANCH:
2953             inner = NEXTOPER(scan);
2954           do_branch:
2955             {
2956                 c1 = OP(scan);
2957                 if (OP(next) != c1)     /* No choice. */
2958                     next = inner;       /* Avoid recursion. */
2959                 else {
2960                     I32 lastparen = *PL_reglastparen;
2961                     I32 unwind1;
2962                     re_unwind_branch_t *uw;
2963
2964                     /* Put unwinding data on stack */
2965                     unwind1 = SSNEWt(1,re_unwind_branch_t);
2966                     uw = SSPTRt(unwind1,re_unwind_branch_t);
2967                     uw->prev = unwind;
2968                     unwind = unwind1;
2969                     uw->type = ((c1 == BRANCH)
2970                                 ? RE_UNWIND_BRANCH
2971                                 : RE_UNWIND_BRANCHJ);
2972                     uw->lastparen = lastparen;
2973                     uw->next = next;
2974                     uw->locinput = locinput;
2975                     uw->nextchr = nextchr;
2976 #ifdef DEBUGGING
2977                     uw->regindent = ++PL_regindent;
2978 #endif
2979
2980                     REGCP_SET(uw->lastcp);
2981
2982                     /* Now go into the first branch */
2983                     next = inner;
2984                 }
2985             }
2986             break;
2987         case MINMOD:
2988             minmod = 1;
2989             break;
2990         case CURLYM:
2991         {
2992             I32 l = 0;
2993             CHECKPOINT lastcp;
2994
2995             /* We suppose that the next guy does not need
2996                backtracking: in particular, it is of constant length,
2997                and has no parenths to influence future backrefs. */
2998             ln = ARG1(scan);  /* min to match */
2999             n  = ARG2(scan);  /* max to match */
3000             paren = scan->flags;
3001             if (paren) {
3002                 if (paren > PL_regsize)
3003                     PL_regsize = paren;
3004                 if (paren > *PL_reglastparen)
3005                     *PL_reglastparen = paren;
3006             }
3007             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3008             if (paren)
3009                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3010             PL_reginput = locinput;
3011             if (minmod) {
3012                 minmod = 0;
3013                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
3014                     sayNO;
3015                 if (ln && l == 0 && n >= ln
3016                     /* In fact, this is tricky.  If paren, then the
3017                        fact that we did/didnot match may influence
3018                        future execution. */
3019                     && !(paren && ln == 0))
3020                     ln = n;
3021                 locinput = PL_reginput;
3022                 if (PL_regkind[(U8)OP(next)] == EXACT) {
3023                     c1 = (U8)*STRING(next);
3024                     if (OP(next) == EXACTF)
3025                         c2 = PL_fold[c1];
3026                     else if (OP(next) == EXACTFL)
3027                         c2 = PL_fold_locale[c1];
3028                     else
3029                         c2 = c1;
3030                 }
3031                 else
3032                     c1 = c2 = -1000;
3033                 REGCP_SET(lastcp);
3034                 /* This may be improved if l == 0.  */
3035                 while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
3036                     /* If it could work, try it. */
3037                     if (c1 == -1000 ||
3038                         UCHARAT(PL_reginput) == c1 ||
3039                         UCHARAT(PL_reginput) == c2)
3040                     {
3041                         if (paren) {
3042                             if (n) {
3043                                 PL_regstartp[paren] =
3044                                     HOPc(PL_reginput, -l) - PL_bostr;
3045                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3046                             }
3047                             else
3048                                 PL_regendp[paren] = -1;
3049                         }
3050                         if (regmatch(next))
3051                             sayYES;
3052                         REGCP_UNWIND(lastcp);
3053                     }
3054                     /* Couldn't or didn't -- move forward. */
3055                     PL_reginput = locinput;
3056                     if (regrepeat_hard(scan, 1, &l)) {
3057                         ln++;
3058                         locinput = PL_reginput;
3059                     }
3060                     else
3061                         sayNO;
3062                 }
3063             }
3064             else {
3065                 n = regrepeat_hard(scan, n, &l);
3066                 if (n != 0 && l == 0
3067                     /* In fact, this is tricky.  If paren, then the
3068                        fact that we did/didnot match may influence
3069                        future execution. */
3070                     && !(paren && ln == 0))
3071                     ln = n;
3072                 locinput = PL_reginput;
3073                 DEBUG_r(
3074                     PerlIO_printf(Perl_debug_log,
3075                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3076                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3077                                   (IV) n, (IV)l)
3078                     );
3079                 if (n >= ln) {
3080                     if (PL_regkind[(U8)OP(next)] == EXACT) {
3081                         c1 = (U8)*STRING(next);
3082                         if (OP(next) == EXACTF)
3083                             c2 = PL_fold[c1];
3084                         else if (OP(next) == EXACTFL)
3085                             c2 = PL_fold_locale[c1];
3086                         else
3087                             c2 = c1;
3088                     }
3089                     else
3090                         c1 = c2 = -1000;
3091                 }
3092                 REGCP_SET(lastcp);
3093                 while (n >= ln) {
3094                     /* If it could work, try it. */
3095                     if (c1 == -1000 ||
3096                         UCHARAT(PL_reginput) == c1 ||
3097                         UCHARAT(PL_reginput) == c2)
3098                     {
3099                         DEBUG_r(
3100                                 PerlIO_printf(Perl_debug_log,
3101                                               "%*s  trying tail with n=%"IVdf"...\n",
3102                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
3103                             );
3104                         if (paren) {
3105                             if (n) {
3106                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
3107                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3108                             }
3109                             else
3110                                 PL_regendp[paren] = -1;
3111                         }
3112                         if (regmatch(next))
3113                             sayYES;
3114                         REGCP_UNWIND(lastcp);
3115                     }
3116                     /* Couldn't or didn't -- back up. */
3117                     n--;
3118                     locinput = HOPc(locinput, -l);
3119                     PL_reginput = locinput;
3120                 }
3121             }
3122             sayNO;
3123             break;
3124         }
3125         case CURLYN:
3126             paren = scan->flags;        /* Which paren to set */
3127             if (paren > PL_regsize)
3128                 PL_regsize = paren;
3129             if (paren > *PL_reglastparen)
3130                 *PL_reglastparen = paren;
3131             ln = ARG1(scan);  /* min to match */
3132             n  = ARG2(scan);  /* max to match */
3133             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3134             goto repeat;
3135         case CURLY:
3136             paren = 0;
3137             ln = ARG1(scan);  /* min to match */
3138             n  = ARG2(scan);  /* max to match */
3139             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3140             goto repeat;
3141         case STAR:
3142             ln = 0;
3143             n = REG_INFTY;
3144             scan = NEXTOPER(scan);
3145             paren = 0;
3146             goto repeat;
3147         case PLUS:
3148             ln = 1;
3149             n = REG_INFTY;
3150             scan = NEXTOPER(scan);
3151             paren = 0;
3152           repeat:
3153             /*
3154             * Lookahead to avoid useless match attempts
3155             * when we know what character comes next.
3156             */
3157             if (PL_regkind[(U8)OP(next)] == EXACT) {
3158                 U8 *s = (U8*)STRING(next);
3159                 if (!UTF) {
3160                     c2 = c1 = *s;
3161                     if (OP(next) == EXACTF)
3162                         c2 = PL_fold[c1];
3163                     else if (OP(next) == EXACTFL)
3164                         c2 = PL_fold_locale[c1];
3165                 }
3166                 else { /* UTF */
3167                     if (OP(next) == EXACTF) {
3168                         c1 = to_utf8_lower(s);
3169                         c2 = to_utf8_upper(s);
3170                     }
3171                     else {
3172                         c2 = c1 = utf8_to_uvchr(s, NULL);
3173                     }
3174                 }
3175             }
3176             else
3177                 c1 = c2 = -1000;
3178             PL_reginput = locinput;
3179             if (minmod) {
3180                 CHECKPOINT lastcp;
3181                 minmod = 0;
3182                 if (ln && regrepeat(scan, ln) < ln)
3183                     sayNO;
3184                 locinput = PL_reginput;
3185                 REGCP_SET(lastcp);
3186                 if (c1 != -1000) {
3187                     char *e; /* Should not check after this */
3188                     char *old = locinput;
3189
3190                     if  (n == REG_INFTY) {
3191                         e = PL_regeol - 1;
3192                         if (do_utf8)
3193                             while (UTF8_IS_CONTINUATION(*(U8*)e))
3194                                 e--;
3195                     }
3196                     else if (do_utf8) {
3197                         int m = n - ln;
3198                         for (e = locinput;
3199                              m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
3200                             e += UTF8SKIP(e);
3201                     }
3202                     else {
3203                         e = locinput + n - ln;
3204                         if (e >= PL_regeol)
3205                             e = PL_regeol - 1;
3206                     }
3207                     while (1) {
3208                         int count;
3209                         /* Find place 'next' could work */
3210                         if (!do_utf8) {
3211                             if (c1 == c2) {
3212                                 while (locinput <= e && *locinput != c1)
3213                                     locinput++;
3214                             } else {
3215                                 while (locinput <= e
3216                                        && *locinput != c1
3217                                        && *locinput != c2)
3218                                     locinput++;
3219                             }
3220                             count = locinput - old;
3221                         }
3222                         else {
3223                             STRLEN len;
3224                             if (c1 == c2) {
3225                                 for (count = 0;
3226                                      locinput <= e &&
3227                                          utf8_to_uvchr((U8*)locinput, &len) != c1;
3228                                      count++)
3229                                     locinput += len;
3230
3231                             } else {
3232                                 for (count = 0; locinput <= e; count++) {
3233                                     UV c = utf8_to_uvchr((U8*)locinput, &len);
3234                                     if (c == c1 || c == c2)
3235                                         break;
3236                                     locinput += len;
3237                                 }
3238                             }
3239                         }
3240                         if (locinput > e)
3241                             sayNO;
3242                         /* PL_reginput == old now */
3243                         if (locinput != old) {
3244                             ln = 1;     /* Did some */
3245                             if (regrepeat(scan, count) < count)
3246                                 sayNO;
3247                         }
3248                         /* PL_reginput == locinput now */
3249                         TRYPAREN(paren, ln, locinput);
3250                         PL_reginput = locinput; /* Could be reset... */
3251                         REGCP_UNWIND(lastcp);
3252                         /* Couldn't or didn't -- move forward. */
3253                         old = locinput;
3254                         if (do_utf8)
3255                             locinput += UTF8SKIP(locinput);
3256                         else
3257                             locinput++;
3258                     }
3259                 }
3260                 else
3261                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3262                     UV c;
3263                     if (c1 != -1000) {
3264                         if (do_utf8)
3265                             c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3266                         else
3267                             c = UCHARAT(PL_reginput);
3268                         /* If it could work, try it. */
3269                         if (c == c1 || c == c2)
3270                         {
3271                             TRYPAREN(paren, n, PL_reginput);
3272                             REGCP_UNWIND(lastcp);
3273                         }
3274                     }
3275                     /* If it could work, try it. */
3276                     else if (c1 == -1000)
3277                     {
3278                         TRYPAREN(paren, n, PL_reginput);
3279                         REGCP_UNWIND(lastcp);
3280                     }
3281                     /* Couldn't or didn't -- move forward. */
3282                     PL_reginput = locinput;
3283                     if (regrepeat(scan, 1)) {
3284                         ln++;
3285                         locinput = PL_reginput;
3286                     }
3287                     else
3288                         sayNO;
3289                 }
3290             }
3291             else {
3292                 CHECKPOINT lastcp;
3293                 n = regrepeat(scan, n);
3294                 locinput = PL_reginput;
3295                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3296                     (!PL_multiline  || OP(next) == SEOL || OP(next) == EOS)) {
3297                     ln = n;                     /* why back off? */
3298                     /* ...because $ and \Z can match before *and* after
3299                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3300                        We should back off by one in this case. */
3301                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3302                         ln--;
3303                 }
3304                 REGCP_SET(lastcp);
3305                 if (paren) {
3306                     UV c = 0;
3307                     while (n >= ln) {
3308                         if (c1 != -1000) {
3309                             if (do_utf8)
3310                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3311                             else
3312                                 c = UCHARAT(PL_reginput);
3313                         }
3314                         /* If it could work, try it. */
3315                         if (c1 == -1000 || c == c1 || c == c2)
3316                             {
3317                                 TRYPAREN(paren, n, PL_reginput);
3318                                 REGCP_UNWIND(lastcp);
3319                             }
3320                         /* Couldn't or didn't -- back up. */
3321                         n--;
3322                         PL_reginput = locinput = HOPc(locinput, -1);
3323                     }
3324                 }
3325                 else {
3326                     UV c = 0;
3327                     while (n >= ln) {
3328                         if (c1 != -1000) {
3329                             if (do_utf8)
3330                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3331                             else
3332                                 c = UCHARAT(PL_reginput);
3333                         }
3334                         /* If it could work, try it. */
3335                         if (c1 == -1000 || c == c1 || c == c2)
3336                             {
3337                                 TRYPAREN(paren, n, PL_reginput);
3338                                 REGCP_UNWIND(lastcp);
3339                             }
3340                         /* Couldn't or didn't -- back up. */
3341                         n--;
3342                         PL_reginput = locinput = HOPc(locinput, -1);
3343                     }
3344                 }
3345             }
3346             sayNO;
3347             break;
3348         case END:
3349             if (PL_reg_call_cc) {
3350                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3351                 CURCUR *cctmp = PL_regcc;
3352                 regexp *re = PL_reg_re;
3353                 CHECKPOINT cp, lastcp;
3354
3355                 cp = regcppush(0);      /* Save *all* the positions. */
3356                 REGCP_SET(lastcp);
3357                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3358                                                     the caller. */
3359                 PL_reginput = locinput; /* Make position available to
3360                                            the callcc. */
3361                 cache_re(PL_reg_call_cc->re);
3362                 PL_regcc = PL_reg_call_cc->cc;
3363                 PL_reg_call_cc = PL_reg_call_cc->prev;
3364                 if (regmatch(cur_call_cc->node)) {
3365                     PL_reg_call_cc = cur_call_cc;
3366                     regcpblow(cp);
3367                     sayYES;
3368                 }
3369                 REGCP_UNWIND(lastcp);
3370                 regcppop();
3371                 PL_reg_call_cc = cur_call_cc;
3372                 PL_regcc = cctmp;
3373                 PL_reg_re = re;
3374                 cache_re(re);
3375
3376                 DEBUG_r(
3377                     PerlIO_printf(Perl_debug_log,
3378                                   "%*s  continuation failed...\n",
3379                                   REPORT_CODE_OFF+PL_regindent*2, "")
3380                     );
3381                 sayNO_SILENT;
3382             }
3383             if (locinput < PL_regtill) {
3384                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3385                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3386                                       PL_colors[4],
3387                                       (long)(locinput - PL_reg_starttry),
3388                                       (long)(PL_regtill - PL_reg_starttry),
3389                                       PL_colors[5]));
3390                 sayNO_FINAL;            /* Cannot match: too short. */
3391             }
3392             PL_reginput = locinput;     /* put where regtry can find it */
3393             sayYES_FINAL;               /* Success! */
3394         case SUCCEED:
3395             PL_reginput = locinput;     /* put where regtry can find it */
3396             sayYES_LOUD;                /* Success! */
3397         case SUSPEND:
3398             n = 1;
3399             PL_reginput = locinput;
3400             goto do_ifmatch;
3401         case UNLESSM:
3402             n = 0;
3403             if (scan->flags) {
3404                 s = HOPBACKc(locinput, scan->flags);
3405                 if (!s)
3406                     goto say_yes;
3407                 PL_reginput = s;
3408             }
3409             else
3410                 PL_reginput = locinput;
3411             goto do_ifmatch;
3412         case IFMATCH:
3413             n = 1;
3414             if (scan->flags) {
3415                 s = HOPBACKc(locinput, scan->flags);
3416                 if (!s)
3417                     goto say_no;
3418                 PL_reginput = s;
3419             }
3420             else
3421                 PL_reginput = locinput;
3422
3423           do_ifmatch:
3424             inner = NEXTOPER(NEXTOPER(scan));
3425             if (regmatch(inner) != n) {
3426               say_no:
3427                 if (logical) {
3428                     logical = 0;
3429                     sw = 0;
3430                     goto do_longjump;
3431                 }
3432                 else
3433                     sayNO;
3434             }
3435           say_yes:
3436             if (logical) {
3437                 logical = 0;
3438                 sw = 1;
3439             }
3440             if (OP(scan) == SUSPEND) {
3441                 locinput = PL_reginput;
3442                 nextchr = UCHARAT(locinput);
3443             }
3444             /* FALL THROUGH. */
3445         case LONGJMP:
3446           do_longjump:
3447             next = scan + ARG(scan);
3448             if (next == scan)
3449                 next = NULL;
3450             break;
3451         default:
3452             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3453                           PTR2UV(scan), OP(scan));
3454             Perl_croak(aTHX_ "regexp memory corruption");
3455         }
3456       reenter:
3457         scan = next;
3458     }
3459
3460     /*
3461     * We get here only if there's trouble -- normally "case END" is
3462     * the terminating point.
3463     */
3464     Perl_croak(aTHX_ "corrupted regexp pointers");
3465     /*NOTREACHED*/
3466     sayNO;
3467
3468 yes_loud:
3469     DEBUG_r(
3470         PerlIO_printf(Perl_debug_log,
3471                       "%*s  %scould match...%s\n",
3472                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3473         );
3474     goto yes;
3475 yes_final:
3476     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3477                           PL_colors[4],PL_colors[5]));
3478 yes:
3479 #ifdef DEBUGGING
3480     PL_regindent--;
3481 #endif
3482
3483 #if 0                                   /* Breaks $^R */
3484     if (unwind)
3485         regcpblow(firstcp);
3486 #endif
3487     return 1;
3488
3489 no:
3490     DEBUG_r(
3491         PerlIO_printf(Perl_debug_log,
3492                       "%*s  %sfailed...%s\n",
3493                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3494         );
3495     goto do_no;
3496 no_final:
3497 do_no:
3498     if (unwind) {
3499         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
3500
3501         switch (uw->type) {
3502         case RE_UNWIND_BRANCH:
3503         case RE_UNWIND_BRANCHJ:
3504         {
3505             re_unwind_branch_t *uwb = &(uw->branch);
3506             I32 lastparen = uwb->lastparen;
3507
3508             REGCP_UNWIND(uwb->lastcp);
3509             for (n = *PL_reglastparen; n > lastparen; n--)
3510                 PL_regendp[n] = -1;
3511             *PL_reglastparen = n;
3512             scan = next = uwb->next;
3513             if ( !scan ||
3514                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
3515                               ? BRANCH : BRANCHJ) ) {           /* Failure */
3516                 unwind = uwb->prev;
3517 #ifdef DEBUGGING
3518                 PL_regindent--;
3519 #endif
3520                 goto do_no;
3521             }
3522             /* Have more choice yet.  Reuse the same uwb.  */
3523             /*SUPPRESS 560*/
3524             if ((n = (uwb->type == RE_UNWIND_BRANCH
3525                       ? NEXT_OFF(next) : ARG(next))))
3526                 next += n;
3527             else
3528                 next = NULL;    /* XXXX Needn't unwinding in this case... */
3529             uwb->next = next;
3530             next = NEXTOPER(scan);
3531             if (uwb->type == RE_UNWIND_BRANCHJ)
3532                 next = NEXTOPER(next);
3533             locinput = uwb->locinput;
3534             nextchr = uwb->nextchr;
3535 #ifdef DEBUGGING
3536             PL_regindent = uwb->regindent;
3537 #endif
3538
3539             goto reenter;
3540         }
3541         /* NOT REACHED */
3542         default:
3543             Perl_croak(aTHX_ "regexp unwind memory corruption");
3544         }
3545         /* NOT REACHED */
3546     }
3547 #ifdef DEBUGGING
3548     PL_regindent--;
3549 #endif
3550     return 0;
3551 }
3552
3553 /*
3554  - regrepeat - repeatedly match something simple, report how many
3555  */
3556 /*
3557  * [This routine now assumes that it will only match on things of length 1.
3558  * That was true before, but now we assume scan - reginput is the count,
3559  * rather than incrementing count on every character.  [Er, except utf8.]]
3560  */
3561 STATIC I32
3562 S_regrepeat(pTHX_ regnode *p, I32 max)
3563 {
3564     register char *scan;
3565     register I32 c;
3566     register char *loceol = PL_regeol;
3567     register I32 hardcount = 0;
3568     register bool do_utf8 = DO_UTF8(PL_reg_sv);
3569
3570     scan = PL_reginput;
3571     if (max != REG_INFTY && max < loceol - scan)
3572       loceol = scan + max;
3573     switch (OP(p)) {
3574     case REG_ANY:
3575         if (do_utf8) {
3576             loceol = PL_regeol;
3577             while (scan < loceol && hardcount < max && *scan != '\n') {
3578                 scan += UTF8SKIP(scan);
3579                 hardcount++;
3580             }
3581         } else {
3582             while (scan < loceol && *scan != '\n')
3583                 scan++;
3584         }
3585         break;
3586     case SANY:
3587         scan = loceol;
3588         break;
3589     case EXACT:         /* length of string is 1 */
3590         c = (U8)*STRING(p);
3591         while (scan < loceol && UCHARAT(scan) == c)
3592             scan++;
3593         break;
3594     case EXACTF:        /* length of string is 1 */
3595         c = (U8)*STRING(p);
3596         while (scan < loceol &&
3597                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
3598             scan++;
3599         break;
3600     case EXACTFL:       /* length of string is 1 */
3601         PL_reg_flags |= RF_tainted;
3602         c = (U8)*STRING(p);
3603         while (scan < loceol &&
3604                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
3605             scan++;
3606         break;
3607     case ANYOF:
3608         if (do_utf8) {
3609             loceol = PL_regeol;
3610             while (hardcount < max && scan < loceol &&
3611                    reginclass(p, (U8*)scan, do_utf8)) {
3612                 scan += UTF8SKIP(scan);
3613                 hardcount++;
3614             }
3615         } else {
3616             while (scan < loceol && reginclass(p, (U8*)scan, do_utf8))
3617                 scan++;
3618         }
3619         break;
3620     case ALNUM:
3621         if (do_utf8) {
3622             loceol = PL_regeol;
3623             LOAD_UTF8_CHARCLASS(alnum,"a");
3624             while (hardcount < max && scan < loceol &&
3625                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3626                 scan += UTF8SKIP(scan);
3627                 hardcount++;
3628             }
3629         } else {
3630             while (scan < loceol && isALNUM(*scan))
3631                 scan++;
3632         }
3633         break;
3634     case ALNUML:
3635         PL_reg_flags |= RF_tainted;
3636         if (do_utf8) {
3637             loceol = PL_regeol;
3638             while (hardcount < max && scan < loceol &&
3639                    isALNUM_LC_utf8((U8*)scan)) {
3640                 scan += UTF8SKIP(scan);
3641                 hardcount++;
3642             }
3643         } else {
3644             while (scan < loceol && isALNUM_LC(*scan))
3645                 scan++;
3646         }
3647         break;
3648     case NALNUM:
3649         if (do_utf8) {
3650             loceol = PL_regeol;
3651             LOAD_UTF8_CHARCLASS(alnum,"a");
3652             while (hardcount < max && scan < loceol &&
3653                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3654                 scan += UTF8SKIP(scan);
3655                 hardcount++;
3656             }
3657         } else {
3658             while (scan < loceol && !isALNUM(*scan))
3659                 scan++;
3660         }
3661         break;
3662     case NALNUML:
3663         PL_reg_flags |= RF_tainted;
3664         if (do_utf8) {
3665             loceol = PL_regeol;
3666             while (hardcount < max && scan < loceol &&
3667                    !isALNUM_LC_utf8((U8*)scan)) {
3668                 scan += UTF8SKIP(scan);
3669                 hardcount++;
3670             }
3671         } else {
3672             while (scan < loceol && !isALNUM_LC(*scan))
3673                 scan++;
3674         }
3675         break;
3676     case SPACE:
3677         if (do_utf8) {
3678             loceol = PL_regeol;
3679             LOAD_UTF8_CHARCLASS(space," ");
3680             while (hardcount < max && scan < loceol &&
3681                    (*scan == ' ' ||
3682                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3683                 scan += UTF8SKIP(scan);
3684                 hardcount++;
3685             }
3686         } else {
3687             while (scan < loceol && isSPACE(*scan))
3688                 scan++;
3689         }
3690         break;
3691     case SPACEL:
3692         PL_reg_flags |= RF_tainted;
3693         if (do_utf8) {
3694             loceol = PL_regeol;
3695             while (hardcount < max && scan < loceol &&
3696                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3697                 scan += UTF8SKIP(scan);
3698                 hardcount++;
3699             }
3700         } else {
3701             while (scan < loceol && isSPACE_LC(*scan))
3702                 scan++;
3703         }
3704         break;
3705     case NSPACE:
3706         if (do_utf8) {
3707             loceol = PL_regeol;
3708             LOAD_UTF8_CHARCLASS(space," ");
3709             while (hardcount < max && scan < loceol &&
3710                    !(*scan == ' ' ||
3711                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3712                 scan += UTF8SKIP(scan);
3713                 hardcount++;
3714             }
3715         } else {
3716             while (scan < loceol && !isSPACE(*scan))
3717                 scan++;
3718             break;
3719         }
3720     case NSPACEL:
3721         PL_reg_flags |= RF_tainted;
3722         if (do_utf8) {
3723             loceol = PL_regeol;
3724             while (hardcount < max && scan < loceol &&
3725                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3726                 scan += UTF8SKIP(scan);
3727                 hardcount++;
3728             }
3729         } else {
3730             while (scan < loceol && !isSPACE_LC(*scan))
3731                 scan++;
3732         }
3733         break;
3734     case DIGIT:
3735         if (do_utf8) {
3736             loceol = PL_regeol;
3737             LOAD_UTF8_CHARCLASS(digit,"0");
3738             while (hardcount < max && scan < loceol &&
3739                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
3740                 scan += UTF8SKIP(scan);
3741                 hardcount++;
3742             }
3743         } else {
3744             while (scan < loceol && isDIGIT(*scan))
3745                 scan++;
3746         }
3747         break;
3748     case NDIGIT:
3749         if (do_utf8) {
3750             loceol = PL_regeol;
3751             LOAD_UTF8_CHARCLASS(digit,"0");
3752             while (hardcount < max && scan < loceol &&
3753                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
3754                 scan += UTF8SKIP(scan);
3755                 hardcount++;
3756             }
3757         } else {
3758             while (scan < loceol && !isDIGIT(*scan))
3759                 scan++;
3760         }
3761         break;
3762     default:            /* Called on something of 0 width. */
3763         break;          /* So match right here or not at all. */
3764     }
3765
3766     if (hardcount)
3767         c = hardcount;
3768     else
3769         c = scan - PL_reginput;
3770     PL_reginput = scan;
3771
3772     DEBUG_r(
3773         {
3774                 SV *prop = sv_newmortal();
3775
3776                 regprop(prop, p);
3777                 PerlIO_printf(Perl_debug_log,
3778                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
3779                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
3780         });
3781
3782     return(c);
3783 }
3784
3785 /*
3786  - regrepeat_hard - repeatedly match something, report total lenth and length
3787  *
3788  * The repeater is supposed to have constant length.
3789  */
3790
3791 STATIC I32
3792 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
3793 {
3794     register char *scan = Nullch;
3795     register char *start;
3796     register char *loceol = PL_regeol;
3797     I32 l = 0;
3798     I32 count = 0, res = 1;
3799
3800     if (!max)
3801         return 0;
3802
3803     start = PL_reginput;
3804     if (DO_UTF8(PL_reg_sv)) {
3805         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3806             if (!count++) {
3807                 l = 0;
3808                 while (start < PL_reginput) {
3809                     l++;
3810                     start += UTF8SKIP(start);
3811                 }
3812                 *lp = l;
3813                 if (l == 0)
3814                     return max;
3815             }
3816             if (count == max)
3817                 return count;
3818         }
3819     }
3820     else {
3821         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3822             if (!count++) {
3823                 *lp = l = PL_reginput - start;
3824                 if (max != REG_INFTY && l*max < loceol - scan)
3825                     loceol = scan + l*max;
3826                 if (l == 0)
3827                     return max;
3828             }
3829         }
3830     }
3831     if (!res)
3832         PL_reginput = scan;
3833
3834     return count;
3835 }
3836
3837 /*
3838 - regclass_swash - prepare the utf8 swash
3839 */
3840
3841 SV *
3842 Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp)
3843 {
3844     SV *sw = NULL;
3845     SV *si = NULL;
3846
3847     if (PL_regdata && PL_regdata->count) {
3848         U32 n = ARG(node);
3849
3850         if (PL_regdata->what[n] == 's') {
3851             SV *rv = (SV*)PL_regdata->data[n];
3852             AV *av = (AV*)SvRV((SV*)rv);
3853             SV **a;
3854
3855             si = *av_fetch(av, 0, FALSE);
3856             a  =  av_fetch(av, 1, FALSE);
3857
3858             if (a)
3859                 sw = *a;
3860             else if (si && doinit) {
3861                 sw = swash_init("utf8", "", si, 1, 0);
3862                 (void)av_store(av, 1, sw);
3863             }
3864         }
3865     }
3866
3867     if (initsvp)
3868         *initsvp = si;
3869
3870     return sw;
3871 }
3872
3873 /*
3874  - reginclass - determine if a character falls into a character class
3875  */
3876
3877 STATIC bool
3878 S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8)
3879 {
3880     char flags = ANYOF_FLAGS(n);
3881     bool match = FALSE;
3882     UV c;
3883     STRLEN len = 0;
3884
3885     c = do_utf8 ? utf8_to_uvchr(p, &len) : *p;
3886
3887     if (do_utf8 || (flags & ANYOF_UNICODE)) {
3888         if (do_utf8 && !ANYOF_RUNTIME(n)) {
3889             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
3890                 match = TRUE;
3891         }
3892         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
3893             match = TRUE;
3894         if (!match) {
3895             SV *sw = regclass_swash(n, TRUE, 0);
3896
3897             if (sw) {
3898                 if (swash_fetch(sw, p, do_utf8))
3899                     match = TRUE;
3900                 else if (flags & ANYOF_FOLD) {
3901                     U8 tmpbuf[UTF8_MAXLEN+1];
3902
3903                     if (flags & ANYOF_LOCALE) {
3904                         PL_reg_flags |= RF_tainted;
3905                         uvchr_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
3906                     }
3907                     else
3908                         uvchr_to_utf8(tmpbuf, toLOWER_utf8(p));
3909                     if (swash_fetch(sw, tmpbuf, do_utf8))
3910                         match = TRUE;
3911                 }
3912             }
3913         }
3914     }
3915     if (!match && c < 256) {
3916         if (ANYOF_BITMAP_TEST(n, c))
3917             match = TRUE;
3918         else if (flags & ANYOF_FOLD) {
3919           I32 f;
3920
3921             if (flags & ANYOF_LOCALE) {
3922                 PL_reg_flags |= RF_tainted;
3923                 f = PL_fold_locale[c];
3924             }
3925             else
3926                 f = PL_fold[c];
3927             if (f != c && ANYOF_BITMAP_TEST(n, f))
3928                 match = TRUE;
3929         }
3930
3931         if (!match && (flags & ANYOF_CLASS)) {
3932             PL_reg_flags |= RF_tainted;
3933             if (
3934                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
3935                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
3936                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
3937                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
3938                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
3939                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
3940                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
3941                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
3942                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
3943                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
3944                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
3945                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
3946                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
3947                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
3948                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
3949                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
3950                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
3951                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
3952                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
3953                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
3954                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
3955                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
3956                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
3957                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
3958                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
3959                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
3960                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
3961                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
3962                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
3963                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
3964                 ) /* How's that for a conditional? */
3965             {
3966                 match = TRUE;
3967             }
3968         }
3969     }
3970
3971     return (flags & ANYOF_INVERT) ? !match : match;
3972 }
3973
3974 STATIC U8 *
3975 S_reghop(pTHX_ U8 *s, I32 off)
3976 {
3977     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
3978 }
3979
3980 STATIC U8 *
3981 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
3982 {
3983     if (off >= 0) {
3984         while (off-- && s < lim) {
3985             /* XXX could check well-formedness here */
3986             s += UTF8SKIP(s);
3987         }
3988     }
3989     else {
3990         while (off++) {
3991             if (s > lim) {
3992                 s--;
3993                 if (UTF8_IS_CONTINUED(*s)) {
3994                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
3995                         s--;
3996                 }
3997                 /* XXX could check well-formedness here */
3998             }
3999         }
4000     }
4001     return s;
4002 }
4003
4004 STATIC U8 *
4005 S_reghopmaybe(pTHX_ U8 *s, I32 off)
4006 {
4007     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4008 }
4009
4010 STATIC U8 *
4011 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
4012 {
4013     if (off >= 0) {
4014         while (off-- && s < lim) {
4015             /* XXX could check well-formedness here */
4016             s += UTF8SKIP(s);
4017         }
4018         if (off >= 0)
4019             return 0;
4020     }
4021     else {
4022         while (off++) {
4023             if (s > lim) {
4024                 s--;
4025                 if (UTF8_IS_CONTINUED(*s)) {
4026                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4027                         s--;
4028                 }
4029                 /* XXX could check well-formedness here */
4030             }
4031             else
4032                 break;
4033         }
4034         if (off <= 0)
4035             return 0;
4036     }
4037     return s;
4038 }
4039
4040 #ifdef PERL_OBJECT
4041 #include "XSUB.h"
4042 #endif
4043
4044 static void
4045 restore_pos(pTHXo_ void *arg)
4046 {
4047     if (PL_reg_eval_set) {
4048         if (PL_reg_oldsaved) {
4049             PL_reg_re->subbeg = PL_reg_oldsaved;
4050             PL_reg_re->sublen = PL_reg_oldsavedlen;
4051             RX_MATCH_COPIED_on(PL_reg_re);
4052         }
4053         PL_reg_magic->mg_len = PL_reg_oldpos;
4054         PL_reg_eval_set = 0;
4055         PL_curpm = PL_reg_oldcurpm;
4056     }
4057 }