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