regexec.c

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