regexec.c

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