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