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