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             {
2540                 SV **before = SP;
2541                 CALLRUNOPS(aTHX);                       /* Scalar context. */
2542                 SPAGAIN;
2543                 if (SP == before)
2544                     ret = Nullsv;   /* protect against empty (?{}) blocks. */
2545                 else {
2546                     ret = POPs;
2547                     PUTBACK;
2548                 }
2549             }
2550
2551             PL_op = oop;
2552             PL_curpad = ocurpad;
2553             PL_curcop = ocurcop;
2554             if (logical) {
2555                 if (logical == 2) {     /* Postponed subexpression. */
2556                     regexp *re;
2557                     MAGIC *mg = Null(MAGIC*);
2558                     re_cc_state state;
2559                     CHECKPOINT cp, lastcp;
2560
2561                     if(SvROK(ret) || SvRMAGICAL(ret)) {
2562                         SV *sv = SvROK(ret) ? SvRV(ret) : ret;
2563
2564                         if(SvMAGICAL(sv))
2565                             mg = mg_find(sv, PERL_MAGIC_qr);
2566                     }
2567                     if (mg) {
2568                         re = (regexp *)mg->mg_obj;
2569                         (void)ReREFCNT_inc(re);
2570                     }
2571                     else {
2572                         STRLEN len;
2573                         char *t = SvPV(ret, len);
2574                         PMOP pm;
2575                         char *oprecomp = PL_regprecomp;
2576                         I32 osize = PL_regsize;
2577                         I32 onpar = PL_regnpar;
2578
2579                         Zero(&pm, 1, PMOP);
2580                         re = CALLREGCOMP(aTHX_ t, t + len, &pm);
2581                         if (!(SvFLAGS(ret)
2582                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
2583                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
2584                                         PERL_MAGIC_qr,0,0);
2585                         PL_regprecomp = oprecomp;
2586                         PL_regsize = osize;
2587                         PL_regnpar = onpar;
2588                     }
2589                     DEBUG_r(
2590                         PerlIO_printf(Perl_debug_log,
2591                                       "Entering embedded `%s%.60s%s%s'\n",
2592                                       PL_colors[0],
2593                                       re->precomp,
2594                                       PL_colors[1],
2595                                       (strlen(re->precomp) > 60 ? "..." : ""))
2596                         );
2597                     state.node = next;
2598                     state.prev = PL_reg_call_cc;
2599                     state.cc = PL_regcc;
2600                     state.re = PL_reg_re;
2601
2602                     PL_regcc = 0;
2603
2604                     cp = regcppush(0);  /* Save *all* the positions. */
2605                     REGCP_SET(lastcp);
2606                     cache_re(re);
2607                     state.ss = PL_savestack_ix;
2608                     *PL_reglastparen = 0;
2609                     *PL_reglastcloseparen = 0;
2610                     PL_reg_call_cc = &state;
2611                     PL_reginput = locinput;
2612
2613                     /* XXXX This is too dramatic a measure... */
2614                     PL_reg_maxiter = 0;
2615
2616                     if (regmatch(re->program + 1)) {
2617                         /* Even though we succeeded, we need to restore
2618                            global variables, since we may be wrapped inside
2619                            SUSPEND, thus the match may be not finished yet. */
2620
2621                         /* XXXX Do this only if SUSPENDed? */
2622                         PL_reg_call_cc = state.prev;
2623                         PL_regcc = state.cc;
2624                         PL_reg_re = state.re;
2625                         cache_re(PL_reg_re);
2626
2627                         /* XXXX This is too dramatic a measure... */
2628                         PL_reg_maxiter = 0;
2629
2630                         /* These are needed even if not SUSPEND. */
2631                         ReREFCNT_dec(re);
2632                         regcpblow(cp);
2633                         sayYES;
2634                     }
2635                     ReREFCNT_dec(re);
2636                     REGCP_UNWIND(lastcp);
2637                     regcppop();
2638                     PL_reg_call_cc = state.prev;
2639                     PL_regcc = state.cc;
2640                     PL_reg_re = state.re;
2641                     cache_re(PL_reg_re);
2642
2643                     /* XXXX This is too dramatic a measure... */
2644                     PL_reg_maxiter = 0;
2645
2646                     logical = 0;
2647                     sayNO;
2648                 }
2649                 sw = SvTRUE(ret);
2650                 logical = 0;
2651             }
2652             else
2653                 sv_setsv(save_scalar(PL_replgv), ret);
2654             break;
2655         }
2656         case OPEN:
2657             n = ARG(scan);  /* which paren pair */
2658             PL_reg_start_tmp[n] = locinput;
2659             if (n > PL_regsize)
2660                 PL_regsize = n;
2661             break;
2662         case CLOSE:
2663             n = ARG(scan);  /* which paren pair */
2664             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
2665             PL_regendp[n] = locinput - PL_bostr;
2666             if (n > *PL_reglastparen)
2667                 *PL_reglastparen = n;
2668             *PL_reglastcloseparen = n;
2669             break;
2670         case GROUPP:
2671             n = ARG(scan);  /* which paren pair */
2672             sw = (*PL_reglastparen >= n && PL_regendp[n] != -1);
2673             break;
2674         case IFTHEN:
2675             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2676             if (sw)
2677                 next = NEXTOPER(NEXTOPER(scan));
2678             else {
2679                 next = scan + ARG(scan);
2680                 if (OP(next) == IFTHEN) /* Fake one. */
2681                     next = NEXTOPER(NEXTOPER(next));
2682             }
2683             break;
2684         case LOGICAL:
2685             logical = scan->flags;
2686             break;
2687 /*******************************************************************
2688  PL_regcc contains infoblock about the innermost (...)* loop, and
2689  a pointer to the next outer infoblock.
2690
2691  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
2692
2693    1) After matching X, regnode for CURLYX is processed;
2694
2695    2) This regnode creates infoblock on the stack, and calls
2696       regmatch() recursively with the starting point at WHILEM node;
2697
2698    3) Each hit of WHILEM node tries to match A and Z (in the order
2699       depending on the current iteration, min/max of {min,max} and
2700       greediness).  The information about where are nodes for "A"
2701       and "Z" is read from the infoblock, as is info on how many times "A"
2702       was already matched, and greediness.
2703
2704    4) After A matches, the same WHILEM node is hit again.
2705
2706    5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
2707       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
2708       resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
2709       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
2710       of the external loop.
2711
2712  Currently present infoblocks form a tree with a stem formed by PL_curcc
2713  and whatever it mentions via ->next, and additional attached trees
2714  corresponding to temporarily unset infoblocks as in "5" above.
2715
2716  In the following picture infoblocks for outer loop of
2717  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
2718  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
2719  infoblocks are drawn below the "reset" infoblock.
2720
2721  In fact in the picture below we do not show failed matches for Z and T
2722  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
2723  more obvious *why* one needs to *temporary* unset infoblocks.]
2724
2725   Matched       REx position    InfoBlocks      Comment
2726                 (Y(A)*?Z)*?T    x
2727                 Y(A)*?Z)*?T     x <- O
2728   Y             (A)*?Z)*?T      x <- O
2729   Y             A)*?Z)*?T       x <- O <- I
2730   YA            )*?Z)*?T        x <- O <- I
2731   YA            A)*?Z)*?T       x <- O <- I
2732   YAA           )*?Z)*?T        x <- O <- I
2733   YAA           Z)*?T           x <- O          # Temporary unset I
2734                                      I
2735
2736   YAAZ          Y(A)*?Z)*?T     x <- O
2737                                      I
2738
2739   YAAZY         (A)*?Z)*?T      x <- O
2740                                      I
2741
2742   YAAZY         A)*?Z)*?T       x <- O <- I
2743                                      I
2744
2745   YAAZYA        )*?Z)*?T        x <- O <- I
2746                                      I
2747
2748   YAAZYA        Z)*?T           x <- O          # Temporary unset I
2749                                      I,I
2750
2751   YAAZYAZ       )*?T            x <- O
2752                                      I,I
2753
2754   YAAZYAZ       T               x               # Temporary unset O
2755                                 O
2756                                 I,I
2757
2758   YAAZYAZT                      x
2759                                 O
2760                                 I,I
2761  *******************************************************************/
2762         case CURLYX: {
2763                 CURCUR cc;
2764                 CHECKPOINT cp = PL_savestack_ix;
2765                 /* No need to save/restore up to this paren */
2766                 I32 parenfloor = scan->flags;
2767
2768                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
2769                     next += ARG(next);
2770                 cc.oldcc = PL_regcc;
2771                 PL_regcc = &cc;
2772                 /* XXXX Probably it is better to teach regpush to support
2773                    parenfloor > PL_regsize... */
2774                 if (parenfloor > *PL_reglastparen)
2775                     parenfloor = *PL_reglastparen; /* Pessimization... */
2776                 cc.parenfloor = parenfloor;
2777                 cc.cur = -1;
2778                 cc.min = ARG1(scan);
2779                 cc.max  = ARG2(scan);
2780                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2781                 cc.next = next;
2782                 cc.minmod = minmod;
2783                 cc.lastloc = 0;
2784                 PL_reginput = locinput;
2785                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
2786                 regcpblow(cp);
2787                 PL_regcc = cc.oldcc;
2788                 saySAME(n);
2789             }
2790             /* NOT REACHED */
2791         case WHILEM: {
2792                 /*
2793                  * This is really hard to understand, because after we match
2794                  * what we're trying to match, we must make sure the rest of
2795                  * the REx is going to match for sure, and to do that we have
2796                  * to go back UP the parse tree by recursing ever deeper.  And
2797                  * if it fails, we have to reset our parent's current state
2798                  * that we can try again after backing off.
2799                  */
2800
2801                 CHECKPOINT cp, lastcp;
2802                 CURCUR* cc = PL_regcc;
2803                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
2804
2805                 n = cc->cur + 1;        /* how many we know we matched */
2806                 PL_reginput = locinput;
2807
2808                 DEBUG_r(
2809                     PerlIO_printf(Perl_debug_log,
2810                                   "%*s  %ld out of %ld..%ld  cc=%lx\n",
2811                                   REPORT_CODE_OFF+PL_regindent*2, "",
2812                                   (long)n, (long)cc->min,
2813                                   (long)cc->max, (long)cc)
2814                     );
2815
2816                 /* If degenerate scan matches "", assume scan done. */
2817
2818                 if (locinput == cc->lastloc && n >= cc->min) {
2819                     PL_regcc = cc->oldcc;
2820                     if (PL_regcc)
2821                         ln = PL_regcc->cur;
2822                     DEBUG_r(
2823                         PerlIO_printf(Perl_debug_log,
2824                            "%*s  empty match detected, try continuation...\n",
2825                            REPORT_CODE_OFF+PL_regindent*2, "")
2826                         );
2827                     if (regmatch(cc->next))
2828                         sayYES;
2829                     if (PL_regcc)
2830                         PL_regcc->cur = ln;
2831                     PL_regcc = cc;
2832                     sayNO;
2833                 }
2834
2835                 /* First just match a string of min scans. */
2836
2837                 if (n < cc->min) {
2838                     cc->cur = n;
2839                     cc->lastloc = locinput;
2840                     if (regmatch(cc->scan))
2841                         sayYES;
2842                     cc->cur = n - 1;
2843                     cc->lastloc = lastloc;
2844                     sayNO;
2845                 }
2846
2847                 if (scan->flags) {
2848                     /* Check whether we already were at this position.
2849                         Postpone detection until we know the match is not
2850                         *that* much linear. */
2851                 if (!PL_reg_maxiter) {
2852                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
2853                     PL_reg_leftiter = PL_reg_maxiter;
2854                 }
2855                 if (PL_reg_leftiter-- == 0) {
2856                     I32 size = (PL_reg_maxiter + 7)/8;
2857                     if (PL_reg_poscache) {
2858                         if (PL_reg_poscache_size < size) {
2859                             Renew(PL_reg_poscache, size, char);
2860                             PL_reg_poscache_size = size;
2861                         }
2862                         Zero(PL_reg_poscache, size, char);
2863                     }
2864                     else {
2865                         PL_reg_poscache_size = size;
2866                         Newz(29, PL_reg_poscache, size, char);
2867                     }
2868                     DEBUG_r(
2869                         PerlIO_printf(Perl_debug_log,
2870               "%sDetected a super-linear match, switching on caching%s...\n",
2871                                       PL_colors[4], PL_colors[5])
2872                         );
2873                 }
2874                 if (PL_reg_leftiter < 0) {
2875                     I32 o = locinput - PL_bostr, b;
2876
2877                     o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
2878                     b = o % 8;
2879                     o /= 8;
2880                     if (PL_reg_poscache[o] & (1<<b)) {
2881                     DEBUG_r(
2882                         PerlIO_printf(Perl_debug_log,
2883                                       "%*s  already tried at this position...\n",
2884                                       REPORT_CODE_OFF+PL_regindent*2, "")
2885                         );
2886                         sayNO_SILENT;
2887                     }
2888                     PL_reg_poscache[o] |= (1<<b);
2889                 }
2890                 }
2891
2892                 /* Prefer next over scan for minimal matching. */
2893
2894                 if (cc->minmod) {
2895                     PL_regcc = cc->oldcc;
2896                     if (PL_regcc)
2897                         ln = PL_regcc->cur;
2898                     cp = regcppush(cc->parenfloor);
2899                     REGCP_SET(lastcp);
2900                     if (regmatch(cc->next)) {
2901                         regcpblow(cp);
2902                         sayYES; /* All done. */
2903                     }
2904                     REGCP_UNWIND(lastcp);
2905                     regcppop();
2906                     if (PL_regcc)
2907                         PL_regcc->cur = ln;
2908                     PL_regcc = cc;
2909
2910                     if (n >= cc->max) { /* Maximum greed exceeded? */
2911                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2912                             && !(PL_reg_flags & RF_warned)) {
2913                             PL_reg_flags |= RF_warned;
2914                             Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2915                                  "Complex regular subexpression recursion",
2916                                  REG_INFTY - 1);
2917                         }
2918                         sayNO;
2919                     }
2920
2921                     DEBUG_r(
2922                         PerlIO_printf(Perl_debug_log,
2923                                       "%*s  trying longer...\n",
2924                                       REPORT_CODE_OFF+PL_regindent*2, "")
2925                         );
2926                     /* Try scanning more and see if it helps. */
2927                     PL_reginput = locinput;
2928                     cc->cur = n;
2929                     cc->lastloc = locinput;
2930                     cp = regcppush(cc->parenfloor);
2931                     REGCP_SET(lastcp);
2932                     if (regmatch(cc->scan)) {
2933                         regcpblow(cp);
2934                         sayYES;
2935                     }
2936                     REGCP_UNWIND(lastcp);
2937                     regcppop();
2938                     cc->cur = n - 1;
2939                     cc->lastloc = lastloc;
2940                     sayNO;
2941                 }
2942
2943                 /* Prefer scan over next for maximal matching. */
2944
2945                 if (n < cc->max) {      /* More greed allowed? */
2946                     cp = regcppush(cc->parenfloor);
2947                     cc->cur = n;
2948                     cc->lastloc = locinput;
2949                     REGCP_SET(lastcp);
2950                     if (regmatch(cc->scan)) {
2951                         regcpblow(cp);
2952                         sayYES;
2953                     }
2954                     REGCP_UNWIND(lastcp);
2955                     regcppop();         /* Restore some previous $<digit>s? */
2956                     PL_reginput = locinput;
2957                     DEBUG_r(
2958                         PerlIO_printf(Perl_debug_log,
2959                                       "%*s  failed, try continuation...\n",
2960                                       REPORT_CODE_OFF+PL_regindent*2, "")
2961                         );
2962                 }
2963                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2964                         && !(PL_reg_flags & RF_warned)) {
2965                     PL_reg_flags |= RF_warned;
2966                     Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2967                          "Complex regular subexpression recursion",
2968                          REG_INFTY - 1);
2969                 }
2970
2971                 /* Failed deeper matches of scan, so see if this one works. */
2972                 PL_regcc = cc->oldcc;
2973                 if (PL_regcc)
2974                     ln = PL_regcc->cur;
2975                 if (regmatch(cc->next))
2976                     sayYES;
2977                 if (PL_regcc)
2978                     PL_regcc->cur = ln;
2979                 PL_regcc = cc;
2980                 cc->cur = n - 1;
2981                 cc->lastloc = lastloc;
2982                 sayNO;
2983             }
2984             /* NOT REACHED */
2985         case BRANCHJ:
2986             next = scan + ARG(scan);
2987             if (next == scan)
2988                 next = NULL;
2989             inner = NEXTOPER(NEXTOPER(scan));
2990             goto do_branch;
2991         case BRANCH:
2992             inner = NEXTOPER(scan);
2993           do_branch:
2994             {
2995                 c1 = OP(scan);
2996                 if (OP(next) != c1)     /* No choice. */
2997                     next = inner;       /* Avoid recursion. */
2998                 else {
2999                     I32 lastparen = *PL_reglastparen;
3000                     I32 unwind1;
3001                     re_unwind_branch_t *uw;
3002
3003                     /* Put unwinding data on stack */
3004                     unwind1 = SSNEWt(1,re_unwind_branch_t);
3005                     uw = SSPTRt(unwind1,re_unwind_branch_t);
3006                     uw->prev = unwind;
3007                     unwind = unwind1;
3008                     uw->type = ((c1 == BRANCH)
3009                                 ? RE_UNWIND_BRANCH
3010                                 : RE_UNWIND_BRANCHJ);
3011                     uw->lastparen = lastparen;
3012                     uw->next = next;
3013                     uw->locinput = locinput;
3014                     uw->nextchr = nextchr;
3015 #ifdef DEBUGGING
3016                     uw->regindent = ++PL_regindent;
3017 #endif
3018
3019                     REGCP_SET(uw->lastcp);
3020
3021                     /* Now go into the first branch */
3022                     next = inner;
3023                 }
3024             }
3025             break;
3026         case MINMOD:
3027             minmod = 1;
3028             break;
3029         case CURLYM:
3030         {
3031             I32 l = 0;
3032             CHECKPOINT lastcp;
3033
3034             /* We suppose that the next guy does not need
3035                backtracking: in particular, it is of constant length,
3036                and has no parenths to influence future backrefs. */
3037             ln = ARG1(scan);  /* min to match */
3038             n  = ARG2(scan);  /* max to match */
3039             paren = scan->flags;
3040             if (paren) {
3041                 if (paren > PL_regsize)
3042                     PL_regsize = paren;
3043                 if (paren > *PL_reglastparen)
3044                     *PL_reglastparen = paren;
3045             }
3046             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3047             if (paren)
3048                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3049             PL_reginput = locinput;
3050             if (minmod) {
3051                 minmod = 0;
3052                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
3053                     sayNO;
3054                 /* if we matched something zero-length we don't need to
3055                    backtrack - capturing parens are already defined, so
3056                    the caveat in the maximal case doesn't apply
3057
3058                    XXXX if ln == 0, we can redo this check first time
3059                    through the following loop
3060                 */
3061                 if (ln && l == 0)
3062                     n = ln;     /* don't backtrack */
3063                 locinput = PL_reginput;
3064                 if (NEAR_EXACT(next)) {
3065                     regnode *text_node = next;
3066
3067                     if (PL_regkind[(U8)OP(next)] != EXACT)
3068                         NEXT_IMPT(text_node);
3069
3070                     if (PL_regkind[(U8)OP(text_node)] != EXACT) {
3071                         c1 = c2 = -1000;
3072                     }
3073                     else {
3074                         c1 = (U8)*STRING(text_node);
3075                         if (OP(next) == EXACTF)
3076                             c2 = PL_fold[c1];
3077                         else if (OP(text_node) == EXACTFL)
3078                             c2 = PL_fold_locale[c1];
3079                         else
3080                             c2 = c1;
3081                     }
3082                 }
3083                 else
3084                     c1 = c2 = -1000;
3085                 REGCP_SET(lastcp);
3086                 /* This may be improved if l == 0.  */
3087                 while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
3088                     /* If it could work, try it. */
3089                     if (c1 == -1000 ||
3090                         UCHARAT(PL_reginput) == c1 ||
3091                         UCHARAT(PL_reginput) == c2)
3092                     {
3093                         if (paren) {
3094                             if (ln) {
3095                                 PL_regstartp[paren] =
3096                                     HOPc(PL_reginput, -l) - PL_bostr;
3097                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3098                             }
3099                             else
3100                                 PL_regendp[paren] = -1;
3101                         }
3102                         if (regmatch(next))
3103                             sayYES;
3104                         REGCP_UNWIND(lastcp);
3105                     }
3106                     /* Couldn't or didn't -- move forward. */
3107                     PL_reginput = locinput;
3108                     if (regrepeat_hard(scan, 1, &l)) {
3109                         ln++;
3110                         locinput = PL_reginput;
3111                     }
3112                     else
3113                         sayNO;
3114                 }
3115             }
3116             else {
3117                 n = regrepeat_hard(scan, n, &l);
3118                 /* if we matched something zero-length we don't need to
3119                    backtrack, unless the minimum count is zero and we
3120                    are capturing the result - in that case the capture
3121                    being defined or not may affect later execution
3122                 */
3123                 if (n != 0 && l == 0 && !(paren && ln == 0))
3124                     ln = n;     /* don't backtrack */
3125                 locinput = PL_reginput;
3126                 DEBUG_r(
3127                     PerlIO_printf(Perl_debug_log,
3128                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3129                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3130                                   (IV) n, (IV)l)
3131                     );
3132                 if (n >= ln) {
3133                     if (NEAR_EXACT(next)) {
3134                         regnode *text_node = next;
3135
3136                         if (PL_regkind[(U8)OP(next)] != EXACT)
3137                             NEXT_IMPT(text_node);
3138
3139                         if (PL_regkind[(U8)OP(text_node)] != EXACT) {
3140                             c1 = c2 = -1000;
3141                         }
3142                         else {
3143                             c1 = (U8)*STRING(text_node);
3144                             if (OP(text_node) == EXACTF)
3145                                 c2 = PL_fold[c1];
3146                             else if (OP(text_node) == EXACTFL)
3147                                 c2 = PL_fold_locale[c1];
3148                             else
3149                                 c2 = c1;
3150                         }
3151                     }
3152                     else
3153                         c1 = c2 = -1000;
3154                 }
3155                 REGCP_SET(lastcp);
3156                 while (n >= ln) {
3157                     /* If it could work, try it. */
3158                     if (c1 == -1000 ||
3159                         UCHARAT(PL_reginput) == c1 ||
3160                         UCHARAT(PL_reginput) == c2)
3161                     {
3162                         DEBUG_r(
3163                                 PerlIO_printf(Perl_debug_log,
3164                                               "%*s  trying tail with n=%"IVdf"...\n",
3165                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
3166                             );
3167                         if (paren) {
3168                             if (n) {
3169                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
3170                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3171                             }
3172                             else
3173                                 PL_regendp[paren] = -1;
3174                         }
3175                         if (regmatch(next))
3176                             sayYES;
3177                         REGCP_UNWIND(lastcp);
3178                     }
3179                     /* Couldn't or didn't -- back up. */
3180                     n--;
3181                     locinput = HOPc(locinput, -l);
3182                     PL_reginput = locinput;
3183                 }
3184             }
3185             sayNO;
3186             break;
3187         }
3188         case CURLYN:
3189             paren = scan->flags;        /* Which paren to set */
3190             if (paren > PL_regsize)
3191                 PL_regsize = paren;
3192             if (paren > *PL_reglastparen)
3193                 *PL_reglastparen = paren;
3194             ln = ARG1(scan);  /* min to match */
3195             n  = ARG2(scan);  /* max to match */
3196             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3197             goto repeat;
3198         case CURLY:
3199             paren = 0;
3200             ln = ARG1(scan);  /* min to match */
3201             n  = ARG2(scan);  /* max to match */
3202             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3203             goto repeat;
3204         case STAR:
3205             ln = 0;
3206             n = REG_INFTY;
3207             scan = NEXTOPER(scan);
3208             paren = 0;
3209             goto repeat;
3210         case PLUS:
3211             ln = 1;
3212             n = REG_INFTY;
3213             scan = NEXTOPER(scan);
3214             paren = 0;
3215           repeat:
3216             /*
3217             * Lookahead to avoid useless match attempts
3218             * when we know what character comes next.
3219             */
3220
3221             /*
3222             * Used to only do .*x and .*?x, but now it allows
3223             * for )'s, ('s and (?{ ... })'s to be in the way
3224             * of the quantifier and the EXACT-like node.  -- japhy
3225             */
3226
3227             if (NEAR_EXACT(next)) {
3228                 U8 *s;
3229                 regnode *text_node = next;
3230
3231                 if (PL_regkind[(U8)OP(next)] != EXACT)
3232                     NEXT_IMPT(text_node);
3233
3234                 if (PL_regkind[(U8)OP(text_node)] != EXACT) {
3235                     c1 = c2 = -1000;
3236                 }
3237                 else {
3238                     s = (U8*)STRING(text_node);
3239
3240                     if (!UTF) {
3241                         c2 = c1 = *s;
3242                         if (OP(text_node) == EXACTF)
3243                             c2 = PL_fold[c1];
3244                         else if (OP(text_node) == EXACTFL)
3245                             c2 = PL_fold_locale[c1];
3246                     }
3247                     else { /* UTF */
3248                         if (OP(text_node) == EXACTF) {
3249                              STRLEN ulen1, ulen2;
3250                              U8 tmpbuf1[UTF8_MAXLEN*2+1];
3251                              U8 tmpbuf2[UTF8_MAXLEN*2+1];
3252
3253                              to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
3254                              to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
3255
3256                              c1 = utf8_to_uvuni(tmpbuf1, 0);
3257                              c2 = utf8_to_uvuni(tmpbuf2, 0);
3258                         }
3259                         else {
3260                             c2 = c1 = utf8_to_uvchr(s, NULL);
3261                         }
3262                     }
3263                 }
3264             }
3265             else
3266                 c1 = c2 = -1000;
3267             PL_reginput = locinput;
3268             if (minmod) {
3269                 CHECKPOINT lastcp;
3270                 minmod = 0;
3271                 if (ln && regrepeat(scan, ln) < ln)
3272                     sayNO;
3273                 locinput = PL_reginput;
3274                 REGCP_SET(lastcp);
3275                 if (c1 != -1000) {
3276                     char *e; /* Should not check after this */
3277                     char *old = locinput;
3278
3279                     if  (n == REG_INFTY) {
3280                         e = PL_regeol - 1;
3281                         if (do_utf8)
3282                             while (UTF8_IS_CONTINUATION(*(U8*)e))
3283                                 e--;
3284                     }
3285                     else if (do_utf8) {
3286                         int m = n - ln;
3287                         for (e = locinput;
3288                              m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
3289                             e += UTF8SKIP(e);
3290                     }
3291                     else {
3292                         e = locinput + n - ln;
3293                         if (e >= PL_regeol)
3294                             e = PL_regeol - 1;
3295                     }
3296                     while (1) {
3297                         int count;
3298                         /* Find place 'next' could work */
3299                         if (!do_utf8) {
3300                             if (c1 == c2) {
3301                                 while (locinput <= e &&
3302                                        UCHARAT(locinput) != c1)
3303                                     locinput++;
3304                             } else {
3305                                 while (locinput <= e
3306                                        && UCHARAT(locinput) != c1
3307                                        && UCHARAT(locinput) != c2)
3308                                     locinput++;
3309                             }
3310                             count = locinput - old;
3311                         }
3312                         else {
3313                             STRLEN len;
3314                             if (c1 == c2) {
3315                                 for (count = 0;
3316                                      locinput <= e &&
3317                                          utf8_to_uvchr((U8*)locinput, &len) != c1;
3318                                      count++)
3319                                     locinput += len;
3320
3321                             } else {
3322                                 for (count = 0; locinput <= e; count++) {
3323                                     UV c = utf8_to_uvchr((U8*)locinput, &len);
3324                                     if (c == c1 || c == c2)
3325                                         break;
3326                                     locinput += len;
3327                                 }
3328                             }
3329                         }
3330                         if (locinput > e)
3331                             sayNO;
3332                         /* PL_reginput == old now */
3333                         if (locinput != old) {
3334                             ln = 1;     /* Did some */
3335                             if (regrepeat(scan, count) < count)
3336                                 sayNO;
3337                         }
3338                         /* PL_reginput == locinput now */
3339                         TRYPAREN(paren, ln, locinput);
3340                         PL_reginput = locinput; /* Could be reset... */
3341                         REGCP_UNWIND(lastcp);
3342                         /* Couldn't or didn't -- move forward. */
3343                         old = locinput;
3344                         if (do_utf8)
3345                             locinput += UTF8SKIP(locinput);
3346                         else
3347                             locinput++;
3348                     }
3349                 }
3350                 else
3351                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3352                     UV c;
3353                     if (c1 != -1000) {
3354                         if (do_utf8)
3355                             c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3356                         else
3357                             c = UCHARAT(PL_reginput);
3358                         /* If it could work, try it. */
3359                         if (c == c1 || c == c2)
3360                         {
3361                             TRYPAREN(paren, n, PL_reginput);
3362                             REGCP_UNWIND(lastcp);
3363                         }
3364                     }
3365                     /* If it could work, try it. */
3366                     else if (c1 == -1000)
3367                     {
3368                         TRYPAREN(paren, n, PL_reginput);
3369                         REGCP_UNWIND(lastcp);
3370                     }
3371                     /* Couldn't or didn't -- move forward. */
3372                     PL_reginput = locinput;
3373                     if (regrepeat(scan, 1)) {
3374                         ln++;
3375                         locinput = PL_reginput;
3376                     }
3377                     else
3378                         sayNO;
3379                 }
3380             }
3381             else {
3382                 CHECKPOINT lastcp;
3383                 n = regrepeat(scan, n);
3384                 locinput = PL_reginput;
3385                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3386                     (!PL_multiline  || OP(next) == SEOL || OP(next) == EOS)) {
3387                     ln = n;                     /* why back off? */
3388                     /* ...because $ and \Z can match before *and* after
3389                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3390                        We should back off by one in this case. */
3391                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3392                         ln--;
3393                 }
3394                 REGCP_SET(lastcp);
3395                 if (paren) {
3396                     UV c = 0;
3397                     while (n >= ln) {
3398                         if (c1 != -1000) {
3399                             if (do_utf8)
3400                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3401                             else
3402                                 c = UCHARAT(PL_reginput);
3403                         }
3404                         /* If it could work, try it. */
3405                         if (c1 == -1000 || c == c1 || c == c2)
3406                             {
3407                                 TRYPAREN(paren, n, PL_reginput);
3408                                 REGCP_UNWIND(lastcp);
3409                             }
3410                         /* Couldn't or didn't -- back up. */
3411                         n--;
3412                         PL_reginput = locinput = HOPc(locinput, -1);
3413                     }
3414                 }
3415                 else {
3416                     UV c = 0;
3417                     while (n >= ln) {
3418                         if (c1 != -1000) {
3419                             if (do_utf8)
3420                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3421                             else
3422                                 c = UCHARAT(PL_reginput);
3423                         }
3424                         /* If it could work, try it. */
3425                         if (c1 == -1000 || c == c1 || c == c2)
3426                             {
3427                                 TRYPAREN(paren, n, PL_reginput);
3428                                 REGCP_UNWIND(lastcp);
3429                             }
3430                         /* Couldn't or didn't -- back up. */
3431                         n--;
3432                         PL_reginput = locinput = HOPc(locinput, -1);
3433                     }
3434                 }
3435             }
3436             sayNO;
3437             break;
3438         case END:
3439             if (PL_reg_call_cc) {
3440                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3441                 CURCUR *cctmp = PL_regcc;
3442                 regexp *re = PL_reg_re;
3443                 CHECKPOINT cp, lastcp;
3444
3445                 cp = regcppush(0);      /* Save *all* the positions. */
3446                 REGCP_SET(lastcp);
3447                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3448                                                     the caller. */
3449                 PL_reginput = locinput; /* Make position available to
3450                                            the callcc. */
3451                 cache_re(PL_reg_call_cc->re);
3452                 PL_regcc = PL_reg_call_cc->cc;
3453                 PL_reg_call_cc = PL_reg_call_cc->prev;
3454                 if (regmatch(cur_call_cc->node)) {
3455                     PL_reg_call_cc = cur_call_cc;
3456                     regcpblow(cp);
3457                     sayYES;
3458                 }
3459                 REGCP_UNWIND(lastcp);
3460                 regcppop();
3461                 PL_reg_call_cc = cur_call_cc;
3462                 PL_regcc = cctmp;
3463                 PL_reg_re = re;
3464                 cache_re(re);
3465
3466                 DEBUG_r(
3467                     PerlIO_printf(Perl_debug_log,
3468                                   "%*s  continuation failed...\n",
3469                                   REPORT_CODE_OFF+PL_regindent*2, "")
3470                     );
3471                 sayNO_SILENT;
3472             }
3473             if (locinput < PL_regtill) {
3474                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3475                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3476                                       PL_colors[4],
3477                                       (long)(locinput - PL_reg_starttry),
3478                                       (long)(PL_regtill - PL_reg_starttry),
3479                                       PL_colors[5]));
3480                 sayNO_FINAL;            /* Cannot match: too short. */
3481             }
3482             PL_reginput = locinput;     /* put where regtry can find it */
3483             sayYES_FINAL;               /* Success! */
3484         case SUCCEED:
3485             PL_reginput = locinput;     /* put where regtry can find it */
3486             sayYES_LOUD;                /* Success! */
3487         case SUSPEND:
3488             n = 1;
3489             PL_reginput = locinput;
3490             goto do_ifmatch;
3491         case UNLESSM:
3492             n = 0;
3493             if (scan->flags) {
3494                 s = HOPBACKc(locinput, scan->flags);
3495                 if (!s)
3496                     goto say_yes;
3497                 PL_reginput = s;
3498             }
3499             else
3500                 PL_reginput = locinput;
3501             goto do_ifmatch;
3502         case IFMATCH:
3503             n = 1;
3504             if (scan->flags) {
3505                 s = HOPBACKc(locinput, scan->flags);
3506                 if (!s)
3507                     goto say_no;
3508                 PL_reginput = s;
3509             }
3510             else
3511                 PL_reginput = locinput;
3512
3513           do_ifmatch:
3514             inner = NEXTOPER(NEXTOPER(scan));
3515             if (regmatch(inner) != n) {
3516               say_no:
3517                 if (logical) {
3518                     logical = 0;
3519                     sw = 0;
3520                     goto do_longjump;
3521                 }
3522                 else
3523                     sayNO;
3524             }
3525           say_yes:
3526             if (logical) {
3527                 logical = 0;
3528                 sw = 1;
3529             }
3530             if (OP(scan) == SUSPEND) {
3531                 locinput = PL_reginput;
3532                 nextchr = UCHARAT(locinput);
3533             }
3534             /* FALL THROUGH. */
3535         case LONGJMP:
3536           do_longjump:
3537             next = scan + ARG(scan);
3538             if (next == scan)
3539                 next = NULL;
3540             break;
3541         default:
3542             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3543                           PTR2UV(scan), OP(scan));
3544             Perl_croak(aTHX_ "regexp memory corruption");
3545         }
3546       reenter:
3547         scan = next;
3548     }
3549
3550     /*
3551     * We get here only if there's trouble -- normally "case END" is
3552     * the terminating point.
3553     */
3554     Perl_croak(aTHX_ "corrupted regexp pointers");
3555     /*NOTREACHED*/
3556     sayNO;
3557
3558 yes_loud:
3559     DEBUG_r(
3560         PerlIO_printf(Perl_debug_log,
3561                       "%*s  %scould match...%s\n",
3562                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3563         );
3564     goto yes;
3565 yes_final:
3566     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3567                           PL_colors[4],PL_colors[5]));
3568 yes:
3569 #ifdef DEBUGGING
3570     PL_regindent--;
3571 #endif
3572
3573 #if 0                                   /* Breaks $^R */
3574     if (unwind)
3575         regcpblow(firstcp);
3576 #endif
3577     return 1;
3578
3579 no:
3580     DEBUG_r(
3581         PerlIO_printf(Perl_debug_log,
3582                       "%*s  %sfailed...%s\n",
3583                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3584         );
3585     goto do_no;
3586 no_final:
3587 do_no:
3588     if (unwind) {
3589         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
3590
3591         switch (uw->type) {
3592         case RE_UNWIND_BRANCH:
3593         case RE_UNWIND_BRANCHJ:
3594         {
3595             re_unwind_branch_t *uwb = &(uw->branch);
3596             I32 lastparen = uwb->lastparen;
3597
3598             REGCP_UNWIND(uwb->lastcp);
3599             for (n = *PL_reglastparen; n > lastparen; n--)
3600                 PL_regendp[n] = -1;
3601             *PL_reglastparen = n;
3602             scan = next = uwb->next;
3603             if ( !scan ||
3604                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
3605                               ? BRANCH : BRANCHJ) ) {           /* Failure */
3606                 unwind = uwb->prev;
3607 #ifdef DEBUGGING
3608                 PL_regindent--;
3609 #endif
3610                 goto do_no;
3611             }
3612             /* Have more choice yet.  Reuse the same uwb.  */
3613             /*SUPPRESS 560*/
3614             if ((n = (uwb->type == RE_UNWIND_BRANCH
3615                       ? NEXT_OFF(next) : ARG(next))))
3616                 next += n;
3617             else
3618                 next = NULL;    /* XXXX Needn't unwinding in this case... */
3619             uwb->next = next;
3620             next = NEXTOPER(scan);
3621             if (uwb->type == RE_UNWIND_BRANCHJ)
3622                 next = NEXTOPER(next);
3623             locinput = uwb->locinput;
3624             nextchr = uwb->nextchr;
3625 #ifdef DEBUGGING
3626             PL_regindent = uwb->regindent;
3627 #endif
3628
3629             goto reenter;
3630         }
3631         /* NOT REACHED */
3632         default:
3633             Perl_croak(aTHX_ "regexp unwind memory corruption");
3634         }
3635         /* NOT REACHED */
3636     }
3637 #ifdef DEBUGGING
3638     PL_regindent--;
3639 #endif
3640     return 0;
3641 }
3642
3643 /*
3644  - regrepeat - repeatedly match something simple, report how many
3645  */
3646 /*
3647  * [This routine now assumes that it will only match on things of length 1.
3648  * That was true before, but now we assume scan - reginput is the count,
3649  * rather than incrementing count on every character.  [Er, except utf8.]]
3650  */
3651 STATIC I32
3652 S_regrepeat(pTHX_ regnode *p, I32 max)
3653 {
3654     register char *scan;
3655     register I32 c;
3656     register char *loceol = PL_regeol;
3657     register I32 hardcount = 0;
3658     register bool do_utf8 = PL_reg_match_utf8;
3659
3660     scan = PL_reginput;
3661     if (max != REG_INFTY && max < loceol - scan)
3662       loceol = scan + max;
3663     switch (OP(p)) {
3664     case REG_ANY:
3665         if (do_utf8) {
3666             loceol = PL_regeol;
3667             while (scan < loceol && hardcount < max && *scan != '\n') {
3668                 scan += UTF8SKIP(scan);
3669                 hardcount++;
3670             }
3671         } else {
3672             while (scan < loceol && *scan != '\n')
3673                 scan++;
3674         }
3675         break;
3676     case SANY:
3677         scan = loceol;
3678         break;
3679     case CANY:
3680         scan = loceol;
3681         break;
3682     case EXACT:         /* length of string is 1 */
3683         c = (U8)*STRING(p);
3684         while (scan < loceol && UCHARAT(scan) == c)
3685             scan++;
3686         break;
3687     case EXACTF:        /* length of string is 1 */
3688         c = (U8)*STRING(p);
3689         while (scan < loceol &&
3690                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
3691             scan++;
3692         break;
3693     case EXACTFL:       /* length of string is 1 */
3694         PL_reg_flags |= RF_tainted;
3695         c = (U8)*STRING(p);
3696         while (scan < loceol &&
3697                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
3698             scan++;
3699         break;
3700     case ANYOF:
3701         if (do_utf8) {
3702             loceol = PL_regeol;
3703             while (hardcount < max && scan < loceol &&
3704                    reginclass(p, (U8*)scan, do_utf8)) {
3705                 scan += UTF8SKIP(scan);
3706                 hardcount++;
3707             }
3708         } else {
3709             while (scan < loceol && reginclass(p, (U8*)scan, do_utf8))
3710                 scan++;
3711         }
3712         break;
3713     case ALNUM:
3714         if (do_utf8) {
3715             loceol = PL_regeol;
3716             LOAD_UTF8_CHARCLASS(alnum,"a");
3717             while (hardcount < max && scan < loceol &&
3718                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3719                 scan += UTF8SKIP(scan);
3720                 hardcount++;
3721             }
3722         } else {
3723             while (scan < loceol && isALNUM(*scan))
3724                 scan++;
3725         }
3726         break;
3727     case ALNUML:
3728         PL_reg_flags |= RF_tainted;
3729         if (do_utf8) {
3730             loceol = PL_regeol;
3731             while (hardcount < max && scan < loceol &&
3732                    isALNUM_LC_utf8((U8*)scan)) {
3733                 scan += UTF8SKIP(scan);
3734                 hardcount++;
3735             }
3736         } else {
3737             while (scan < loceol && isALNUM_LC(*scan))
3738                 scan++;
3739         }
3740         break;
3741     case NALNUM:
3742         if (do_utf8) {
3743             loceol = PL_regeol;
3744             LOAD_UTF8_CHARCLASS(alnum,"a");
3745             while (hardcount < max && scan < loceol &&
3746                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3747                 scan += UTF8SKIP(scan);
3748                 hardcount++;
3749             }
3750         } else {
3751             while (scan < loceol && !isALNUM(*scan))
3752                 scan++;
3753         }
3754         break;
3755     case NALNUML:
3756         PL_reg_flags |= RF_tainted;
3757         if (do_utf8) {
3758             loceol = PL_regeol;
3759             while (hardcount < max && scan < loceol &&
3760                    !isALNUM_LC_utf8((U8*)scan)) {
3761                 scan += UTF8SKIP(scan);
3762                 hardcount++;
3763             }
3764         } else {
3765             while (scan < loceol && !isALNUM_LC(*scan))
3766                 scan++;
3767         }
3768         break;
3769     case SPACE:
3770         if (do_utf8) {
3771             loceol = PL_regeol;
3772             LOAD_UTF8_CHARCLASS(space," ");
3773             while (hardcount < max && scan < loceol &&
3774                    (*scan == ' ' ||
3775                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3776                 scan += UTF8SKIP(scan);
3777                 hardcount++;
3778             }
3779         } else {
3780             while (scan < loceol && isSPACE(*scan))
3781                 scan++;
3782         }
3783         break;
3784     case SPACEL:
3785         PL_reg_flags |= RF_tainted;
3786         if (do_utf8) {
3787             loceol = PL_regeol;
3788             while (hardcount < max && scan < loceol &&
3789                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3790                 scan += UTF8SKIP(scan);
3791                 hardcount++;
3792             }
3793         } else {
3794             while (scan < loceol && isSPACE_LC(*scan))
3795                 scan++;
3796         }
3797         break;
3798     case NSPACE:
3799         if (do_utf8) {
3800             loceol = PL_regeol;
3801             LOAD_UTF8_CHARCLASS(space," ");
3802             while (hardcount < max && scan < loceol &&
3803                    !(*scan == ' ' ||
3804                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3805                 scan += UTF8SKIP(scan);
3806                 hardcount++;
3807             }
3808         } else {
3809             while (scan < loceol && !isSPACE(*scan))
3810                 scan++;
3811             break;
3812         }
3813     case NSPACEL:
3814         PL_reg_flags |= RF_tainted;
3815         if (do_utf8) {
3816             loceol = PL_regeol;
3817             while (hardcount < max && scan < loceol &&
3818                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3819                 scan += UTF8SKIP(scan);
3820                 hardcount++;
3821             }
3822         } else {
3823             while (scan < loceol && !isSPACE_LC(*scan))
3824                 scan++;
3825         }
3826         break;
3827     case DIGIT:
3828         if (do_utf8) {
3829             loceol = PL_regeol;
3830             LOAD_UTF8_CHARCLASS(digit,"0");
3831             while (hardcount < max && scan < loceol &&
3832                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
3833                 scan += UTF8SKIP(scan);
3834                 hardcount++;
3835             }
3836         } else {
3837             while (scan < loceol && isDIGIT(*scan))
3838                 scan++;
3839         }
3840         break;
3841     case NDIGIT:
3842         if (do_utf8) {
3843             loceol = PL_regeol;
3844             LOAD_UTF8_CHARCLASS(digit,"0");
3845             while (hardcount < max && scan < loceol &&
3846                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
3847                 scan += UTF8SKIP(scan);
3848                 hardcount++;
3849             }
3850         } else {
3851             while (scan < loceol && !isDIGIT(*scan))
3852                 scan++;
3853         }
3854         break;
3855     default:            /* Called on something of 0 width. */
3856         break;          /* So match right here or not at all. */
3857     }
3858
3859     if (hardcount)
3860         c = hardcount;
3861     else
3862         c = scan - PL_reginput;
3863     PL_reginput = scan;
3864
3865     DEBUG_r(
3866         {
3867                 SV *prop = sv_newmortal();
3868
3869                 regprop(prop, p);
3870                 PerlIO_printf(Perl_debug_log,
3871                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
3872                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
3873         });
3874
3875     return(c);
3876 }
3877
3878 /*
3879  - regrepeat_hard - repeatedly match something, report total lenth and length
3880  *
3881  * The repeater is supposed to have constant length.
3882  */
3883
3884 STATIC I32
3885 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
3886 {
3887     register char *scan = Nullch;
3888     register char *start;
3889     register char *loceol = PL_regeol;
3890     I32 l = 0;
3891     I32 count = 0, res = 1;
3892
3893     if (!max)
3894         return 0;
3895
3896     start = PL_reginput;
3897     if (PL_reg_match_utf8) {
3898         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3899             if (!count++) {
3900                 l = 0;
3901                 while (start < PL_reginput) {
3902                     l++;
3903                     start += UTF8SKIP(start);
3904                 }
3905                 *lp = l;
3906                 if (l == 0)
3907                     return max;
3908             }
3909             if (count == max)
3910                 return count;
3911         }
3912     }
3913     else {
3914         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3915             if (!count++) {
3916                 *lp = l = PL_reginput - start;
3917                 if (max != REG_INFTY && l*max < loceol - scan)
3918                     loceol = scan + l*max;
3919                 if (l == 0)
3920                     return max;
3921             }
3922         }
3923     }
3924     if (!res)
3925         PL_reginput = scan;
3926
3927     return count;
3928 }
3929
3930 /*
3931 - regclass_swash - prepare the utf8 swash
3932 */
3933
3934 SV *
3935 Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp)
3936 {
3937     SV *sw = NULL;
3938     SV *si = NULL;
3939
3940     if (PL_regdata && PL_regdata->count) {
3941         U32 n = ARG(node);
3942
3943         if (PL_regdata->what[n] == 's') {
3944             SV *rv = (SV*)PL_regdata->data[n];
3945             AV *av = (AV*)SvRV((SV*)rv);
3946             SV **a;
3947
3948             si = *av_fetch(av, 0, FALSE);
3949             a  =  av_fetch(av, 1, FALSE);
3950
3951             if (a)
3952                 sw = *a;
3953             else if (si && doinit) {
3954                 sw = swash_init("utf8", "", si, 1, 0);
3955                 (void)av_store(av, 1, sw);
3956             }
3957         }
3958     }
3959
3960     if (initsvp)
3961         *initsvp = si;
3962
3963     return sw;
3964 }
3965
3966 /*
3967  - reginclass - determine if a character falls into a character class
3968  */
3969
3970 STATIC bool
3971 S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8)
3972 {
3973     char flags = ANYOF_FLAGS(n);
3974     bool match = FALSE;
3975     UV c;
3976     STRLEN len = 0;
3977
3978     c = do_utf8 ? utf8_to_uvchr(p, &len) : *p;
3979
3980     if (do_utf8 || (flags & ANYOF_UNICODE)) {
3981         if (do_utf8 && !ANYOF_RUNTIME(n)) {
3982             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
3983                 match = TRUE;
3984         }
3985         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
3986             match = TRUE;
3987         if (!match) {
3988             SV *sw = regclass_swash(n, TRUE, 0);
3989
3990             if (sw) {
3991                 if (swash_fetch(sw, p, do_utf8))
3992                     match = TRUE;
3993                 else if (flags & ANYOF_FOLD) {
3994                     STRLEN ulen;
3995                     U8 tmpbuf[UTF8_MAXLEN*2+1];
3996
3997                     toLOWER_utf8(p, tmpbuf, &ulen);
3998                     if (swash_fetch(sw, tmpbuf, do_utf8))
3999                         match = TRUE;
4000                 }
4001             }
4002         }
4003     }
4004     if (!match && c < 256) {
4005         if (ANYOF_BITMAP_TEST(n, c))
4006             match = TRUE;
4007         else if (flags & ANYOF_FOLD) {
4008           I32 f;
4009
4010             if (flags & ANYOF_LOCALE) {
4011                 PL_reg_flags |= RF_tainted;
4012                 f = PL_fold_locale[c];
4013             }
4014             else
4015                 f = PL_fold[c];
4016             if (f != c && ANYOF_BITMAP_TEST(n, f))
4017                 match = TRUE;
4018         }
4019
4020         if (!match && (flags & ANYOF_CLASS)) {
4021             PL_reg_flags |= RF_tainted;
4022             if (
4023                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
4024                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
4025                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
4026                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
4027                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
4028                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
4029                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
4030                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
4031                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
4032                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
4033                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
4034                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
4035                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
4036                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
4037                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
4038                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
4039                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
4040                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
4041                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
4042                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
4043                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
4044                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
4045                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
4046                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
4047                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
4048                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
4049                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
4050                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
4051                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
4052                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
4053                 ) /* How's that for a conditional? */
4054             {
4055                 match = TRUE;
4056             }
4057         }
4058     }
4059
4060     return (flags & ANYOF_INVERT) ? !match : match;
4061 }
4062
4063 STATIC U8 *
4064 S_reghop(pTHX_ U8 *s, I32 off)
4065 {
4066     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4067 }
4068
4069 STATIC U8 *
4070 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
4071 {
4072     if (off >= 0) {
4073         while (off-- && s < lim) {
4074             /* XXX could check well-formedness here */
4075             s += UTF8SKIP(s);
4076         }
4077     }
4078     else {
4079         while (off++) {
4080             if (s > lim) {
4081                 s--;
4082                 if (UTF8_IS_CONTINUED(*s)) {
4083                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4084                         s--;
4085                 }
4086                 /* XXX could check well-formedness here */
4087             }
4088         }
4089     }
4090     return s;
4091 }
4092
4093 STATIC U8 *
4094 S_reghopmaybe(pTHX_ U8 *s, I32 off)
4095 {
4096     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
4097 }
4098
4099 STATIC U8 *
4100 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
4101 {
4102     if (off >= 0) {
4103         while (off-- && s < lim) {
4104             /* XXX could check well-formedness here */
4105             s += UTF8SKIP(s);
4106         }
4107         if (off >= 0)
4108             return 0;
4109     }
4110     else {
4111         while (off++) {
4112             if (s > lim) {
4113                 s--;
4114                 if (UTF8_IS_CONTINUED(*s)) {
4115                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4116                         s--;
4117                 }
4118                 /* XXX could check well-formedness here */
4119             }
4120             else
4121                 break;
4122         }
4123         if (off <= 0)
4124             return 0;
4125     }
4126     return s;
4127 }
4128
4129 static void
4130 restore_pos(pTHX_ void *arg)
4131 {
4132     if (PL_reg_eval_set) {
4133         if (PL_reg_oldsaved) {
4134             PL_reg_re->subbeg = PL_reg_oldsaved;
4135             PL_reg_re->sublen = PL_reg_oldsavedlen;
4136             RX_MATCH_COPIED_on(PL_reg_re);
4137         }
4138         PL_reg_magic->mg_len = PL_reg_oldpos;
4139         PL_reg_eval_set = 0;
4140         PL_curpm = PL_reg_oldcurpm;
4141     }
4142 }