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