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