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