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                 LOAD_UTF8_CHARCLASS(alnum,"a");
2215                 if (!(OP(scan) == ALNUM
2216                       ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2217                       : isALNUM_LC_utf8((U8*)locinput)))
2218                 {
2219                     sayNO;
2220                 }
2221                 locinput += PL_utf8skip[nextchr];
2222                 nextchr = UCHARAT(locinput);
2223                 break;
2224             }
2225             if (!(OP(scan) == ALNUM
2226                   ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
2227                 sayNO;
2228             nextchr = UCHARAT(++locinput);
2229             break;
2230         case NALNUML:
2231             PL_reg_flags |= RF_tainted;
2232             /* FALL THROUGH */
2233         case NALNUM:
2234             if (!nextchr && locinput >= PL_regeol)
2235                 sayNO;
2236             if (do_utf8) {
2237                 LOAD_UTF8_CHARCLASS(alnum,"a");
2238                 if (OP(scan) == NALNUM
2239                     ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2240                     : isALNUM_LC_utf8((U8*)locinput))
2241                 {
2242                     sayNO;
2243                 }
2244                 locinput += PL_utf8skip[nextchr];
2245                 nextchr = UCHARAT(locinput);
2246                 break;
2247             }
2248             if (OP(scan) == NALNUM
2249                 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
2250                 sayNO;
2251             nextchr = UCHARAT(++locinput);
2252             break;
2253         case BOUNDL:
2254         case NBOUNDL:
2255             PL_reg_flags |= RF_tainted;
2256             /* FALL THROUGH */
2257         case BOUND:
2258         case NBOUND:
2259             /* was last char in word? */
2260             if (do_utf8) {
2261                 if (locinput == PL_bostr)
2262                     ln = '\n';
2263                 else {
2264                     U8 *r = reghop((U8*)locinput, -1);
2265
2266                     ln = utf8n_to_uvchr(r, s - (char*)r, 0, 0);
2267                 }
2268                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2269                     ln = isALNUM_uni(ln);
2270                     LOAD_UTF8_CHARCLASS(alnum,"a");
2271                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
2272                 }
2273                 else {
2274                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
2275                     n = isALNUM_LC_utf8((U8*)locinput);
2276                 }
2277             }
2278             else {
2279                 ln = (locinput != PL_bostr) ?
2280                     UCHARAT(locinput - 1) : '\n';
2281                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2282                     ln = isALNUM(ln);
2283                     n = isALNUM(nextchr);
2284                 }
2285                 else {
2286                     ln = isALNUM_LC(ln);
2287                     n = isALNUM_LC(nextchr);
2288                 }
2289             }
2290             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
2291                                     OP(scan) == BOUNDL))
2292                     sayNO;
2293             break;
2294         case SPACEL:
2295             PL_reg_flags |= RF_tainted;
2296             /* FALL THROUGH */
2297         case SPACE:
2298             if (!nextchr)
2299                 sayNO;
2300             if (do_utf8) {
2301                 if (UTF8_IS_CONTINUED(nextchr)) {
2302                     LOAD_UTF8_CHARCLASS(space," ");
2303                     if (!(OP(scan) == SPACE
2304                           ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2305                           : isSPACE_LC_utf8((U8*)locinput)))
2306                     {
2307                         sayNO;
2308                     }
2309                     locinput += PL_utf8skip[nextchr];
2310                     nextchr = UCHARAT(locinput);
2311                     break;
2312                 }
2313                 if (!(OP(scan) == SPACE
2314                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2315                     sayNO;
2316                 nextchr = UCHARAT(++locinput);
2317             }
2318             else {
2319                 if (!(OP(scan) == SPACE
2320                       ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2321                     sayNO;
2322                 nextchr = UCHARAT(++locinput);
2323             }
2324             break;
2325         case NSPACEL:
2326             PL_reg_flags |= RF_tainted;
2327             /* FALL THROUGH */
2328         case NSPACE:
2329             if (!nextchr && locinput >= PL_regeol)
2330                 sayNO;
2331             if (do_utf8) {
2332                 LOAD_UTF8_CHARCLASS(space," ");
2333                 if (OP(scan) == NSPACE
2334                     ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2335                     : isSPACE_LC_utf8((U8*)locinput))
2336                 {
2337                     sayNO;
2338                 }
2339                 locinput += PL_utf8skip[nextchr];
2340                 nextchr = UCHARAT(locinput);
2341                 break;
2342             }
2343             if (OP(scan) == NSPACE
2344                 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
2345                 sayNO;
2346             nextchr = UCHARAT(++locinput);
2347             break;
2348         case DIGITL:
2349             PL_reg_flags |= RF_tainted;
2350             /* FALL THROUGH */
2351         case DIGIT:
2352             if (!nextchr)
2353                 sayNO;
2354             if (do_utf8) {
2355                 LOAD_UTF8_CHARCLASS(digit,"0");
2356                 if (!(OP(scan) == DIGIT
2357                       ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2358                       : isDIGIT_LC_utf8((U8*)locinput)))
2359                 {
2360                     sayNO;
2361                 }
2362                 locinput += PL_utf8skip[nextchr];
2363                 nextchr = UCHARAT(locinput);
2364                 break;
2365             }
2366             if (!(OP(scan) == DIGIT
2367                   ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
2368                 sayNO;
2369             nextchr = UCHARAT(++locinput);
2370             break;
2371         case NDIGITL:
2372             PL_reg_flags |= RF_tainted;
2373             /* FALL THROUGH */
2374         case NDIGIT:
2375             if (!nextchr && locinput >= PL_regeol)
2376                 sayNO;
2377             if (do_utf8) {
2378                 LOAD_UTF8_CHARCLASS(digit,"0");
2379                 if (OP(scan) == NDIGIT
2380                     ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
2381                     : isDIGIT_LC_utf8((U8*)locinput))
2382                 {
2383                     sayNO;
2384                 }
2385                 locinput += PL_utf8skip[nextchr];
2386                 nextchr = UCHARAT(locinput);
2387                 break;
2388             }
2389             if (OP(scan) == NDIGIT
2390                 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
2391                 sayNO;
2392             nextchr = UCHARAT(++locinput);
2393             break;
2394         case CLUMP:
2395             LOAD_UTF8_CHARCLASS(mark,"~");
2396             if (locinput >= PL_regeol ||
2397                 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2398                 sayNO;
2399             locinput += PL_utf8skip[nextchr];
2400             while (locinput < PL_regeol &&
2401                    swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
2402                 locinput += UTF8SKIP(locinput);
2403             if (locinput > PL_regeol)
2404                 sayNO;
2405             nextchr = UCHARAT(locinput);
2406             break;
2407         case REFFL:
2408             PL_reg_flags |= RF_tainted;
2409             /* FALL THROUGH */
2410         case REF:
2411         case REFF:
2412             n = ARG(scan);  /* which paren pair */
2413             ln = PL_regstartp[n];
2414             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2415             if (*PL_reglastparen < n || ln == -1)
2416                 sayNO;                  /* Do not match unless seen CLOSEn. */
2417             if (ln == PL_regendp[n])
2418                 break;
2419
2420             s = PL_bostr + ln;
2421             if (do_utf8 && OP(scan) != REF) {   /* REF can do byte comparison */
2422                 char *l = locinput;
2423                 char *e = PL_bostr + PL_regendp[n];
2424                 /*
2425                  * Note that we can't do the "other character" lookup trick as
2426                  * in the 8-bit case (no pun intended) because in Unicode we
2427                  * have to map both upper and title case to lower case.
2428                  */
2429                 if (OP(scan) == REFF) {
2430                     while (s < e) {
2431                         if (l >= PL_regeol)
2432                             sayNO;
2433                         if (toLOWER_utf8((U8*)s) != toLOWER_utf8((U8*)l))
2434                             sayNO;
2435                         s += UTF8SKIP(s);
2436                         l += UTF8SKIP(l);
2437                     }
2438                 }
2439                 else {
2440                     while (s < e) {
2441                         if (l >= PL_regeol)
2442                             sayNO;
2443                         if (toLOWER_LC_utf8((U8*)s) != toLOWER_LC_utf8((U8*)l))
2444                             sayNO;
2445                         s += UTF8SKIP(s);
2446                         l += UTF8SKIP(l);
2447                     }
2448                 }
2449                 locinput = l;
2450                 nextchr = UCHARAT(locinput);
2451                 break;
2452             }
2453
2454             /* Inline the first character, for speed. */
2455             if (UCHARAT(s) != nextchr &&
2456                 (OP(scan) == REF ||
2457                  (UCHARAT(s) != ((OP(scan) == REFF
2458                                   ? PL_fold : PL_fold_locale)[nextchr]))))
2459                 sayNO;
2460             ln = PL_regendp[n] - ln;
2461             if (locinput + ln > PL_regeol)
2462                 sayNO;
2463             if (ln > 1 && (OP(scan) == REF
2464                            ? memNE(s, locinput, ln)
2465                            : (OP(scan) == REFF
2466                               ? ibcmp(s, locinput, ln)
2467                               : ibcmp_locale(s, locinput, ln))))
2468                 sayNO;
2469             locinput += ln;
2470             nextchr = UCHARAT(locinput);
2471             break;
2472
2473         case NOTHING:
2474         case TAIL:
2475             break;
2476         case BACK:
2477             break;
2478         case EVAL:
2479         {
2480             dSP;
2481             OP_4tree *oop = PL_op;
2482             COP *ocurcop = PL_curcop;
2483             SV **ocurpad = PL_curpad;
2484             SV *ret;
2485
2486             n = ARG(scan);
2487             PL_op = (OP_4tree*)PL_regdata->data[n];
2488             DEBUG_r( PerlIO_printf(Perl_debug_log, "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
2489             PL_curpad = AvARRAY((AV*)PL_regdata->data[n + 2]);
2490             PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
2491
2492             CALLRUNOPS(aTHX);                   /* Scalar context. */
2493             SPAGAIN;
2494             ret = POPs;
2495             PUTBACK;
2496
2497             PL_op = oop;
2498             PL_curpad = ocurpad;
2499             PL_curcop = ocurcop;
2500             if (logical) {
2501                 if (logical == 2) {     /* Postponed subexpression. */
2502                     regexp *re;
2503                     MAGIC *mg = Null(MAGIC*);
2504                     re_cc_state state;
2505                     CHECKPOINT cp, lastcp;
2506
2507                     if(SvROK(ret) || SvRMAGICAL(ret)) {
2508                         SV *sv = SvROK(ret) ? SvRV(ret) : ret;
2509
2510                         if(SvMAGICAL(sv))
2511                             mg = mg_find(sv, PERL_MAGIC_qr);
2512                     }
2513                     if (mg) {
2514                         re = (regexp *)mg->mg_obj;
2515                         (void)ReREFCNT_inc(re);
2516                     }
2517                     else {
2518                         STRLEN len;
2519                         char *t = SvPV(ret, len);
2520                         PMOP pm;
2521                         char *oprecomp = PL_regprecomp;
2522                         I32 osize = PL_regsize;
2523                         I32 onpar = PL_regnpar;
2524
2525                         Zero(&pm, 1, PMOP);
2526                         re = CALLREGCOMP(aTHX_ t, t + len, &pm);
2527                         if (!(SvFLAGS(ret)
2528                               & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)))
2529                             sv_magic(ret,(SV*)ReREFCNT_inc(re),
2530                                         PERL_MAGIC_qr,0,0);
2531                         PL_regprecomp = oprecomp;
2532                         PL_regsize = osize;
2533                         PL_regnpar = onpar;
2534                     }
2535                     DEBUG_r(
2536                         PerlIO_printf(Perl_debug_log,
2537                                       "Entering embedded `%s%.60s%s%s'\n",
2538                                       PL_colors[0],
2539                                       re->precomp,
2540                                       PL_colors[1],
2541                                       (strlen(re->precomp) > 60 ? "..." : ""))
2542                         );
2543                     state.node = next;
2544                     state.prev = PL_reg_call_cc;
2545                     state.cc = PL_regcc;
2546                     state.re = PL_reg_re;
2547
2548                     PL_regcc = 0;
2549
2550                     cp = regcppush(0);  /* Save *all* the positions. */
2551                     REGCP_SET(lastcp);
2552                     cache_re(re);
2553                     state.ss = PL_savestack_ix;
2554                     *PL_reglastparen = 0;
2555                     PL_reg_call_cc = &state;
2556                     PL_reginput = locinput;
2557
2558                     /* XXXX This is too dramatic a measure... */
2559                     PL_reg_maxiter = 0;
2560
2561                     if (regmatch(re->program + 1)) {
2562                         /* Even though we succeeded, we need to restore
2563                            global variables, since we may be wrapped inside
2564                            SUSPEND, thus the match may be not finished yet. */
2565
2566                         /* XXXX Do this only if SUSPENDed? */
2567                         PL_reg_call_cc = state.prev;
2568                         PL_regcc = state.cc;
2569                         PL_reg_re = state.re;
2570                         cache_re(PL_reg_re);
2571
2572                         /* XXXX This is too dramatic a measure... */
2573                         PL_reg_maxiter = 0;
2574
2575                         /* These are needed even if not SUSPEND. */
2576                         ReREFCNT_dec(re);
2577                         regcpblow(cp);
2578                         sayYES;
2579                     }
2580                     ReREFCNT_dec(re);
2581                     REGCP_UNWIND(lastcp);
2582                     regcppop();
2583                     PL_reg_call_cc = state.prev;
2584                     PL_regcc = state.cc;
2585                     PL_reg_re = state.re;
2586                     cache_re(PL_reg_re);
2587
2588                     /* XXXX This is too dramatic a measure... */
2589                     PL_reg_maxiter = 0;
2590
2591                     sayNO;
2592                 }
2593                 sw = SvTRUE(ret);
2594                 logical = 0;
2595             }
2596             else
2597                 sv_setsv(save_scalar(PL_replgv), ret);
2598             break;
2599         }
2600         case OPEN:
2601             n = ARG(scan);  /* which paren pair */
2602             PL_reg_start_tmp[n] = locinput;
2603             if (n > PL_regsize)
2604                 PL_regsize = n;
2605             break;
2606         case CLOSE:
2607             n = ARG(scan);  /* which paren pair */
2608             PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
2609             PL_regendp[n] = locinput - PL_bostr;
2610             if (n > *PL_reglastparen)
2611                 *PL_reglastparen = n;
2612             break;
2613         case GROUPP:
2614             n = ARG(scan);  /* which paren pair */
2615             sw = (*PL_reglastparen >= n && PL_regendp[n] != -1);
2616             break;
2617         case IFTHEN:
2618             PL_reg_leftiter = PL_reg_maxiter;           /* Void cache */
2619             if (sw)
2620                 next = NEXTOPER(NEXTOPER(scan));
2621             else {
2622                 next = scan + ARG(scan);
2623                 if (OP(next) == IFTHEN) /* Fake one. */
2624                     next = NEXTOPER(NEXTOPER(next));
2625             }
2626             break;
2627         case LOGICAL:
2628             logical = scan->flags;
2629             break;
2630 /*******************************************************************
2631  PL_regcc contains infoblock about the innermost (...)* loop, and
2632  a pointer to the next outer infoblock.
2633
2634  Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
2635
2636    1) After matching X, regnode for CURLYX is processed;
2637
2638    2) This regnode creates infoblock on the stack, and calls
2639       regmatch() recursively with the starting point at WHILEM node;
2640
2641    3) Each hit of WHILEM node tries to match A and Z (in the order
2642       depending on the current iteration, min/max of {min,max} and
2643       greediness).  The information about where are nodes for "A"
2644       and "Z" is read from the infoblock, as is info on how many times "A"
2645       was already matched, and greediness.
2646
2647    4) After A matches, the same WHILEM node is hit again.
2648
2649    5) Each time WHILEM is hit, PL_regcc is the infoblock created by CURLYX
2650       of the same pair.  Thus when WHILEM tries to match Z, it temporarily
2651       resets PL_regcc, since this Y(A)*Z can be a part of some other loop:
2652       as in (Y(A)*Z)*.  If Z matches, the automaton will hit the WHILEM node
2653       of the external loop.
2654
2655  Currently present infoblocks form a tree with a stem formed by PL_curcc
2656  and whatever it mentions via ->next, and additional attached trees
2657  corresponding to temporarily unset infoblocks as in "5" above.
2658
2659  In the following picture infoblocks for outer loop of
2660  (Y(A)*?Z)*?T are denoted O, for inner I.  NULL starting block
2661  is denoted by x.  The matched string is YAAZYAZT.  Temporarily postponed
2662  infoblocks are drawn below the "reset" infoblock.
2663
2664  In fact in the picture below we do not show failed matches for Z and T
2665  by WHILEM blocks.  [We illustrate minimal matches, since for them it is
2666  more obvious *why* one needs to *temporary* unset infoblocks.]
2667
2668   Matched       REx position    InfoBlocks      Comment
2669                 (Y(A)*?Z)*?T    x
2670                 Y(A)*?Z)*?T     x <- O
2671   Y             (A)*?Z)*?T      x <- O
2672   Y             A)*?Z)*?T       x <- O <- I
2673   YA            )*?Z)*?T        x <- O <- I
2674   YA            A)*?Z)*?T       x <- O <- I
2675   YAA           )*?Z)*?T        x <- O <- I
2676   YAA           Z)*?T           x <- O          # Temporary unset I
2677                                      I
2678
2679   YAAZ          Y(A)*?Z)*?T     x <- O
2680                                      I
2681
2682   YAAZY         (A)*?Z)*?T      x <- O
2683                                      I
2684
2685   YAAZY         A)*?Z)*?T       x <- O <- I
2686                                      I
2687
2688   YAAZYA        )*?Z)*?T        x <- O <- I
2689                                      I
2690
2691   YAAZYA        Z)*?T           x <- O          # Temporary unset I
2692                                      I,I
2693
2694   YAAZYAZ       )*?T            x <- O
2695                                      I,I
2696
2697   YAAZYAZ       T               x               # Temporary unset O
2698                                 O
2699                                 I,I
2700
2701   YAAZYAZT                      x
2702                                 O
2703                                 I,I
2704  *******************************************************************/
2705         case CURLYX: {
2706                 CURCUR cc;
2707                 CHECKPOINT cp = PL_savestack_ix;
2708                 /* No need to save/restore up to this paren */
2709                 I32 parenfloor = scan->flags;
2710
2711                 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
2712                     next += ARG(next);
2713                 cc.oldcc = PL_regcc;
2714                 PL_regcc = &cc;
2715                 /* XXXX Probably it is better to teach regpush to support
2716                    parenfloor > PL_regsize... */
2717                 if (parenfloor > *PL_reglastparen)
2718                     parenfloor = *PL_reglastparen; /* Pessimization... */
2719                 cc.parenfloor = parenfloor;
2720                 cc.cur = -1;
2721                 cc.min = ARG1(scan);
2722                 cc.max  = ARG2(scan);
2723                 cc.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2724                 cc.next = next;
2725                 cc.minmod = minmod;
2726                 cc.lastloc = 0;
2727                 PL_reginput = locinput;
2728                 n = regmatch(PREVOPER(next));   /* start on the WHILEM */
2729                 regcpblow(cp);
2730                 PL_regcc = cc.oldcc;
2731                 saySAME(n);
2732             }
2733             /* NOT REACHED */
2734         case WHILEM: {
2735                 /*
2736                  * This is really hard to understand, because after we match
2737                  * what we're trying to match, we must make sure the rest of
2738                  * the REx is going to match for sure, and to do that we have
2739                  * to go back UP the parse tree by recursing ever deeper.  And
2740                  * if it fails, we have to reset our parent's current state
2741                  * that we can try again after backing off.
2742                  */
2743
2744                 CHECKPOINT cp, lastcp;
2745                 CURCUR* cc = PL_regcc;
2746                 char *lastloc = cc->lastloc; /* Detection of 0-len. */
2747
2748                 n = cc->cur + 1;        /* how many we know we matched */
2749                 PL_reginput = locinput;
2750
2751                 DEBUG_r(
2752                     PerlIO_printf(Perl_debug_log,
2753                                   "%*s  %ld out of %ld..%ld  cc=%lx\n",
2754                                   REPORT_CODE_OFF+PL_regindent*2, "",
2755                                   (long)n, (long)cc->min,
2756                                   (long)cc->max, (long)cc)
2757                     );
2758
2759                 /* If degenerate scan matches "", assume scan done. */
2760
2761                 if (locinput == cc->lastloc && n >= cc->min) {
2762                     PL_regcc = cc->oldcc;
2763                     if (PL_regcc)
2764                         ln = PL_regcc->cur;
2765                     DEBUG_r(
2766                         PerlIO_printf(Perl_debug_log,
2767                            "%*s  empty match detected, try continuation...\n",
2768                            REPORT_CODE_OFF+PL_regindent*2, "")
2769                         );
2770                     if (regmatch(cc->next))
2771                         sayYES;
2772                     if (PL_regcc)
2773                         PL_regcc->cur = ln;
2774                     PL_regcc = cc;
2775                     sayNO;
2776                 }
2777
2778                 /* First just match a string of min scans. */
2779
2780                 if (n < cc->min) {
2781                     cc->cur = n;
2782                     cc->lastloc = locinput;
2783                     if (regmatch(cc->scan))
2784                         sayYES;
2785                     cc->cur = n - 1;
2786                     cc->lastloc = lastloc;
2787                     sayNO;
2788                 }
2789
2790                 if (scan->flags) {
2791                     /* Check whether we already were at this position.
2792                         Postpone detection until we know the match is not
2793                         *that* much linear. */
2794                 if (!PL_reg_maxiter) {
2795                     PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
2796                     PL_reg_leftiter = PL_reg_maxiter;
2797                 }
2798                 if (PL_reg_leftiter-- == 0) {
2799                     I32 size = (PL_reg_maxiter + 7)/8;
2800                     if (PL_reg_poscache) {
2801                         if (PL_reg_poscache_size < size) {
2802                             Renew(PL_reg_poscache, size, char);
2803                             PL_reg_poscache_size = size;
2804                         }
2805                         Zero(PL_reg_poscache, size, char);
2806                     }
2807                     else {
2808                         PL_reg_poscache_size = size;
2809                         Newz(29, PL_reg_poscache, size, char);
2810                     }
2811                     DEBUG_r(
2812                         PerlIO_printf(Perl_debug_log,
2813               "%sDetected a super-linear match, switching on caching%s...\n",
2814                                       PL_colors[4], PL_colors[5])
2815                         );
2816                 }
2817                 if (PL_reg_leftiter < 0) {
2818                     I32 o = locinput - PL_bostr, b;
2819
2820                     o = (scan->flags & 0xf) - 1 + o * (scan->flags>>4);
2821                     b = o % 8;
2822                     o /= 8;
2823                     if (PL_reg_poscache[o] & (1<<b)) {
2824                     DEBUG_r(
2825                         PerlIO_printf(Perl_debug_log,
2826                                       "%*s  already tried at this position...\n",
2827                                       REPORT_CODE_OFF+PL_regindent*2, "")
2828                         );
2829                         sayNO_SILENT;
2830                     }
2831                     PL_reg_poscache[o] |= (1<<b);
2832                 }
2833                 }
2834
2835                 /* Prefer next over scan for minimal matching. */
2836
2837                 if (cc->minmod) {
2838                     PL_regcc = cc->oldcc;
2839                     if (PL_regcc)
2840                         ln = PL_regcc->cur;
2841                     cp = regcppush(cc->parenfloor);
2842                     REGCP_SET(lastcp);
2843                     if (regmatch(cc->next)) {
2844                         regcpblow(cp);
2845                         sayYES; /* All done. */
2846                     }
2847                     REGCP_UNWIND(lastcp);
2848                     regcppop();
2849                     if (PL_regcc)
2850                         PL_regcc->cur = ln;
2851                     PL_regcc = cc;
2852
2853                     if (n >= cc->max) { /* Maximum greed exceeded? */
2854                         if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2855                             && !(PL_reg_flags & RF_warned)) {
2856                             PL_reg_flags |= RF_warned;
2857                             Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2858                                  "Complex regular subexpression recursion",
2859                                  REG_INFTY - 1);
2860                         }
2861                         sayNO;
2862                     }
2863
2864                     DEBUG_r(
2865                         PerlIO_printf(Perl_debug_log,
2866                                       "%*s  trying longer...\n",
2867                                       REPORT_CODE_OFF+PL_regindent*2, "")
2868                         );
2869                     /* Try scanning more and see if it helps. */
2870                     PL_reginput = locinput;
2871                     cc->cur = n;
2872                     cc->lastloc = locinput;
2873                     cp = regcppush(cc->parenfloor);
2874                     REGCP_SET(lastcp);
2875                     if (regmatch(cc->scan)) {
2876                         regcpblow(cp);
2877                         sayYES;
2878                     }
2879                     REGCP_UNWIND(lastcp);
2880                     regcppop();
2881                     cc->cur = n - 1;
2882                     cc->lastloc = lastloc;
2883                     sayNO;
2884                 }
2885
2886                 /* Prefer scan over next for maximal matching. */
2887
2888                 if (n < cc->max) {      /* More greed allowed? */
2889                     cp = regcppush(cc->parenfloor);
2890                     cc->cur = n;
2891                     cc->lastloc = locinput;
2892                     REGCP_SET(lastcp);
2893                     if (regmatch(cc->scan)) {
2894                         regcpblow(cp);
2895                         sayYES;
2896                     }
2897                     REGCP_UNWIND(lastcp);
2898                     regcppop();         /* Restore some previous $<digit>s? */
2899                     PL_reginput = locinput;
2900                     DEBUG_r(
2901                         PerlIO_printf(Perl_debug_log,
2902                                       "%*s  failed, try continuation...\n",
2903                                       REPORT_CODE_OFF+PL_regindent*2, "")
2904                         );
2905                 }
2906                 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
2907                         && !(PL_reg_flags & RF_warned)) {
2908                     PL_reg_flags |= RF_warned;
2909                     Perl_warner(aTHX_ WARN_REGEXP, "%s limit (%d) exceeded",
2910                          "Complex regular subexpression recursion",
2911                          REG_INFTY - 1);
2912                 }
2913
2914                 /* Failed deeper matches of scan, so see if this one works. */
2915                 PL_regcc = cc->oldcc;
2916                 if (PL_regcc)
2917                     ln = PL_regcc->cur;
2918                 if (regmatch(cc->next))
2919                     sayYES;
2920                 if (PL_regcc)
2921                     PL_regcc->cur = ln;
2922                 PL_regcc = cc;
2923                 cc->cur = n - 1;
2924                 cc->lastloc = lastloc;
2925                 sayNO;
2926             }
2927             /* NOT REACHED */
2928         case BRANCHJ:
2929             next = scan + ARG(scan);
2930             if (next == scan)
2931                 next = NULL;
2932             inner = NEXTOPER(NEXTOPER(scan));
2933             goto do_branch;
2934         case BRANCH:
2935             inner = NEXTOPER(scan);
2936           do_branch:
2937             {
2938                 CHECKPOINT lastcp;
2939                 c1 = OP(scan);
2940                 if (OP(next) != c1)     /* No choice. */
2941                     next = inner;       /* Avoid recursion. */
2942                 else {
2943                     I32 lastparen = *PL_reglastparen;
2944                     I32 unwind1;
2945                     re_unwind_branch_t *uw;
2946
2947                     /* Put unwinding data on stack */
2948                     unwind1 = SSNEWt(1,re_unwind_branch_t);
2949                     uw = SSPTRt(unwind1,re_unwind_branch_t);
2950                     uw->prev = unwind;
2951                     unwind = unwind1;
2952                     uw->type = ((c1 == BRANCH)
2953                                 ? RE_UNWIND_BRANCH
2954                                 : RE_UNWIND_BRANCHJ);
2955                     uw->lastparen = lastparen;
2956                     uw->next = next;
2957                     uw->locinput = locinput;
2958                     uw->nextchr = nextchr;
2959 #ifdef DEBUGGING
2960                     uw->regindent = ++PL_regindent;
2961 #endif
2962
2963                     REGCP_SET(uw->lastcp);
2964
2965                     /* Now go into the first branch */
2966                     next = inner;
2967                 }
2968             }
2969             break;
2970         case MINMOD:
2971             minmod = 1;
2972             break;
2973         case CURLYM:
2974         {
2975             I32 l = 0;
2976             CHECKPOINT lastcp;
2977
2978             /* We suppose that the next guy does not need
2979                backtracking: in particular, it is of constant length,
2980                and has no parenths to influence future backrefs. */
2981             ln = ARG1(scan);  /* min to match */
2982             n  = ARG2(scan);  /* max to match */
2983             paren = scan->flags;
2984             if (paren) {
2985                 if (paren > PL_regsize)
2986                     PL_regsize = paren;
2987                 if (paren > *PL_reglastparen)
2988                     *PL_reglastparen = paren;
2989             }
2990             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
2991             if (paren)
2992                 scan += NEXT_OFF(scan); /* Skip former OPEN. */
2993             PL_reginput = locinput;
2994             if (minmod) {
2995                 minmod = 0;
2996                 if (ln && regrepeat_hard(scan, ln, &l) < ln)
2997                     sayNO;
2998                 if (ln && l == 0 && n >= ln
2999                     /* In fact, this is tricky.  If paren, then the
3000                        fact that we did/didnot match may influence
3001                        future execution. */
3002                     && !(paren && ln == 0))
3003                     ln = n;
3004                 locinput = PL_reginput;
3005                 if (PL_regkind[(U8)OP(next)] == EXACT) {
3006                     c1 = (U8)*STRING(next);
3007                     if (OP(next) == EXACTF)
3008                         c2 = PL_fold[c1];
3009                     else if (OP(next) == EXACTFL)
3010                         c2 = PL_fold_locale[c1];
3011                     else
3012                         c2 = c1;
3013                 }
3014                 else
3015                     c1 = c2 = -1000;
3016                 REGCP_SET(lastcp);
3017                 /* This may be improved if l == 0.  */
3018                 while (n >= ln || (n == REG_INFTY && ln > 0 && l)) { /* ln overflow ? */
3019                     /* If it could work, try it. */
3020                     if (c1 == -1000 ||
3021                         UCHARAT(PL_reginput) == c1 ||
3022                         UCHARAT(PL_reginput) == c2)
3023                     {
3024                         if (paren) {
3025                             if (n) {
3026                                 PL_regstartp[paren] =
3027                                     HOPc(PL_reginput, -l) - PL_bostr;
3028                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3029                             }
3030                             else
3031                                 PL_regendp[paren] = -1;
3032                         }
3033                         if (regmatch(next))
3034                             sayYES;
3035                         REGCP_UNWIND(lastcp);
3036                     }
3037                     /* Couldn't or didn't -- move forward. */
3038                     PL_reginput = locinput;
3039                     if (regrepeat_hard(scan, 1, &l)) {
3040                         ln++;
3041                         locinput = PL_reginput;
3042                     }
3043                     else
3044                         sayNO;
3045                 }
3046             }
3047             else {
3048                 n = regrepeat_hard(scan, n, &l);
3049                 if (n != 0 && l == 0
3050                     /* In fact, this is tricky.  If paren, then the
3051                        fact that we did/didnot match may influence
3052                        future execution. */
3053                     && !(paren && ln == 0))
3054                     ln = n;
3055                 locinput = PL_reginput;
3056                 DEBUG_r(
3057                     PerlIO_printf(Perl_debug_log,
3058                                   "%*s  matched %"IVdf" times, len=%"IVdf"...\n",
3059                                   (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3060                                   (IV) n, (IV)l)
3061                     );
3062                 if (n >= ln) {
3063                     if (PL_regkind[(U8)OP(next)] == EXACT) {
3064                         c1 = (U8)*STRING(next);
3065                         if (OP(next) == EXACTF)
3066                             c2 = PL_fold[c1];
3067                         else if (OP(next) == EXACTFL)
3068                             c2 = PL_fold_locale[c1];
3069                         else
3070                             c2 = c1;
3071                     }
3072                     else
3073                         c1 = c2 = -1000;
3074                 }
3075                 REGCP_SET(lastcp);
3076                 while (n >= ln) {
3077                     /* If it could work, try it. */
3078                     if (c1 == -1000 ||
3079                         UCHARAT(PL_reginput) == c1 ||
3080                         UCHARAT(PL_reginput) == c2)
3081                     {
3082                         DEBUG_r(
3083                                 PerlIO_printf(Perl_debug_log,
3084                                               "%*s  trying tail with n=%"IVdf"...\n",
3085                                               (int)(REPORT_CODE_OFF+PL_regindent*2), "", (IV)n)
3086                             );
3087                         if (paren) {
3088                             if (n) {
3089                                 PL_regstartp[paren] = HOPc(PL_reginput, -l) - PL_bostr;
3090                                 PL_regendp[paren] = PL_reginput - PL_bostr;
3091                             }
3092                             else
3093                                 PL_regendp[paren] = -1;
3094                         }
3095                         if (regmatch(next))
3096                             sayYES;
3097                         REGCP_UNWIND(lastcp);
3098                     }
3099                     /* Couldn't or didn't -- back up. */
3100                     n--;
3101                     locinput = HOPc(locinput, -l);
3102                     PL_reginput = locinput;
3103                 }
3104             }
3105             sayNO;
3106             break;
3107         }
3108         case CURLYN:
3109             paren = scan->flags;        /* Which paren to set */
3110             if (paren > PL_regsize)
3111                 PL_regsize = paren;
3112             if (paren > *PL_reglastparen)
3113                 *PL_reglastparen = paren;
3114             ln = ARG1(scan);  /* min to match */
3115             n  = ARG2(scan);  /* max to match */
3116             scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
3117             goto repeat;
3118         case CURLY:
3119             paren = 0;
3120             ln = ARG1(scan);  /* min to match */
3121             n  = ARG2(scan);  /* max to match */
3122             scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3123             goto repeat;
3124         case STAR:
3125             ln = 0;
3126             n = REG_INFTY;
3127             scan = NEXTOPER(scan);
3128             paren = 0;
3129             goto repeat;
3130         case PLUS:
3131             ln = 1;
3132             n = REG_INFTY;
3133             scan = NEXTOPER(scan);
3134             paren = 0;
3135           repeat:
3136             /*
3137             * Lookahead to avoid useless match attempts
3138             * when we know what character comes next.
3139             */
3140             if (PL_regkind[(U8)OP(next)] == EXACT) {
3141                 U8 *s = (U8*)STRING(next);
3142                 if (!UTF) {
3143                     c2 = c1 = *s;
3144                     if (OP(next) == EXACTF)
3145                         c2 = PL_fold[c1];
3146                     else if (OP(next) == EXACTFL)
3147                         c2 = PL_fold_locale[c1];
3148                 }
3149                 else { /* UTF */
3150                     if (OP(next) == EXACTF) {
3151                         c1 = to_utf8_lower(s);
3152                         c2 = to_utf8_upper(s);
3153                     }
3154                     else {
3155                         c2 = c1 = utf8_to_uvchr(s, NULL);
3156                     }
3157                 }
3158             }
3159             else
3160                 c1 = c2 = -1000;
3161             PL_reginput = locinput;
3162             if (minmod) {
3163                 CHECKPOINT lastcp;
3164                 minmod = 0;
3165                 if (ln && regrepeat(scan, ln) < ln)
3166                     sayNO;
3167                 locinput = PL_reginput;
3168                 REGCP_SET(lastcp);
3169                 if (c1 != -1000) {
3170                     char *e; /* Should not check after this */
3171                     char *old = locinput;
3172
3173                     if  (n == REG_INFTY) {
3174                         e = PL_regeol - 1;
3175                         if (do_utf8)
3176                             while (UTF8_IS_CONTINUATION(*(U8*)e))
3177                                 e--;
3178                     }
3179                     else if (do_utf8) {
3180                         int m = n - ln;
3181                         for (e = locinput;
3182                              m >0 && e + UTF8SKIP(e) <= PL_regeol; m--)
3183                             e += UTF8SKIP(e);
3184                     }
3185                     else {
3186                         e = locinput + n - ln;
3187                         if (e >= PL_regeol)
3188                             e = PL_regeol - 1;
3189                     }
3190                     while (1) {
3191                         int count;
3192                         /* Find place 'next' could work */
3193                         if (!do_utf8) {
3194                             if (c1 == c2) {
3195                                 while (locinput <= e && *locinput != c1)
3196                                     locinput++;
3197                             } else {
3198                                 while (locinput <= e
3199                                        && *locinput != c1
3200                                        && *locinput != c2)
3201                                     locinput++;
3202                             }
3203                             count = locinput - old;
3204                         }
3205                         else {
3206                             STRLEN len;
3207                             if (c1 == c2) {
3208                                 for (count = 0;
3209                                      locinput <= e &&
3210                                          utf8_to_uvchr((U8*)locinput, &len) != c1;
3211                                      count++)
3212                                     locinput += len;
3213
3214                             } else {
3215                                 for (count = 0; locinput <= e; count++) {
3216                                     UV c = utf8_to_uvchr((U8*)locinput, &len);
3217                                     if (c == c1 || c == c2)
3218                                         break;
3219                                     locinput += len;
3220                                 }
3221                             }
3222                         }
3223                         if (locinput > e)
3224                             sayNO;
3225                         /* PL_reginput == old now */
3226                         if (locinput != old) {
3227                             ln = 1;     /* Did some */
3228                             if (regrepeat(scan, count) < count)
3229                                 sayNO;
3230                         }
3231                         /* PL_reginput == locinput now */
3232                         TRYPAREN(paren, ln, locinput);
3233                         PL_reginput = locinput; /* Could be reset... */
3234                         REGCP_UNWIND(lastcp);
3235                         /* Couldn't or didn't -- move forward. */
3236                         old = locinput;
3237                         if (do_utf8)
3238                             locinput += UTF8SKIP(locinput);
3239                         else
3240                             locinput++;
3241                     }
3242                 }
3243                 else
3244                 while (n >= ln || (n == REG_INFTY && ln > 0)) { /* ln overflow ? */
3245                     UV c;
3246                     if (c1 != -1000) {
3247                         if (do_utf8)
3248                             c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3249                         else
3250                             c = UCHARAT(PL_reginput);
3251                         /* If it could work, try it. */
3252                         if (c == c1 || c == c2)
3253                         {
3254                             TRYPAREN(paren, n, PL_reginput);
3255                             REGCP_UNWIND(lastcp);
3256                         }
3257                     }
3258                     /* If it could work, try it. */
3259                     else if (c1 == -1000)
3260                     {
3261                         TRYPAREN(paren, n, PL_reginput);
3262                         REGCP_UNWIND(lastcp);
3263                     }
3264                     /* Couldn't or didn't -- move forward. */
3265                     PL_reginput = locinput;
3266                     if (regrepeat(scan, 1)) {
3267                         ln++;
3268                         locinput = PL_reginput;
3269                     }
3270                     else
3271                         sayNO;
3272                 }
3273             }
3274             else {
3275                 CHECKPOINT lastcp;
3276                 n = regrepeat(scan, n);
3277                 locinput = PL_reginput;
3278                 if (ln < n && PL_regkind[(U8)OP(next)] == EOL &&
3279                     (!PL_multiline  || OP(next) == SEOL || OP(next) == EOS)) {
3280                     ln = n;                     /* why back off? */
3281                     /* ...because $ and \Z can match before *and* after
3282                        newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
3283                        We should back off by one in this case. */
3284                     if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
3285                         ln--;
3286                 }
3287                 REGCP_SET(lastcp);
3288                 if (paren) {
3289                     UV c;
3290                     while (n >= ln) {
3291                         if (c1 != -1000) {
3292                             if (do_utf8)
3293                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3294                             else
3295                                 c = UCHARAT(PL_reginput);
3296                         }
3297                         /* If it could work, try it. */
3298                         if (c1 == -1000 || c == c1 || c == c2)
3299                             {
3300                                 TRYPAREN(paren, n, PL_reginput);
3301                                 REGCP_UNWIND(lastcp);
3302                             }
3303                         /* Couldn't or didn't -- back up. */
3304                         n--;
3305                         PL_reginput = locinput = HOPc(locinput, -1);
3306                     }
3307                 }
3308                 else {
3309                     UV c;
3310                     while (n >= ln) {
3311                         if (c1 != -1000) {
3312                             if (do_utf8)
3313                                 c = utf8_to_uvchr((U8*)PL_reginput, NULL);
3314                             else
3315                                 c = UCHARAT(PL_reginput);
3316                         }
3317                         /* If it could work, try it. */
3318                         if (c1 == -1000 || c == c1 || c == c2)
3319                             {
3320                                 TRYPAREN(paren, n, PL_reginput);
3321                                 REGCP_UNWIND(lastcp);
3322                             }
3323                         /* Couldn't or didn't -- back up. */
3324                         n--;
3325                         PL_reginput = locinput = HOPc(locinput, -1);
3326                     }
3327                 }
3328             }
3329             sayNO;
3330             break;
3331         case END:
3332             if (PL_reg_call_cc) {
3333                 re_cc_state *cur_call_cc = PL_reg_call_cc;
3334                 CURCUR *cctmp = PL_regcc;
3335                 regexp *re = PL_reg_re;
3336                 CHECKPOINT cp, lastcp;
3337
3338                 cp = regcppush(0);      /* Save *all* the positions. */
3339                 REGCP_SET(lastcp);
3340                 regcp_set_to(PL_reg_call_cc->ss); /* Restore parens of
3341                                                     the caller. */
3342                 PL_reginput = locinput; /* Make position available to
3343                                            the callcc. */
3344                 cache_re(PL_reg_call_cc->re);
3345                 PL_regcc = PL_reg_call_cc->cc;
3346                 PL_reg_call_cc = PL_reg_call_cc->prev;
3347                 if (regmatch(cur_call_cc->node)) {
3348                     PL_reg_call_cc = cur_call_cc;
3349                     regcpblow(cp);
3350                     sayYES;
3351                 }
3352                 REGCP_UNWIND(lastcp);
3353                 regcppop();
3354                 PL_reg_call_cc = cur_call_cc;
3355                 PL_regcc = cctmp;
3356                 PL_reg_re = re;
3357                 cache_re(re);
3358
3359                 DEBUG_r(
3360                     PerlIO_printf(Perl_debug_log,
3361                                   "%*s  continuation failed...\n",
3362                                   REPORT_CODE_OFF+PL_regindent*2, "")
3363                     );
3364                 sayNO_SILENT;
3365             }
3366             if (locinput < PL_regtill) {
3367                 DEBUG_r(PerlIO_printf(Perl_debug_log,
3368                                       "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
3369                                       PL_colors[4],
3370                                       (long)(locinput - PL_reg_starttry),
3371                                       (long)(PL_regtill - PL_reg_starttry),
3372                                       PL_colors[5]));
3373                 sayNO_FINAL;            /* Cannot match: too short. */
3374             }
3375             PL_reginput = locinput;     /* put where regtry can find it */
3376             sayYES_FINAL;               /* Success! */
3377         case SUCCEED:
3378             PL_reginput = locinput;     /* put where regtry can find it */
3379             sayYES_LOUD;                /* Success! */
3380         case SUSPEND:
3381             n = 1;
3382             PL_reginput = locinput;
3383             goto do_ifmatch;
3384         case UNLESSM:
3385             n = 0;
3386             if (scan->flags) {
3387                 s = HOPBACKc(locinput, scan->flags);
3388                 if (!s)
3389                     goto say_yes;
3390                 PL_reginput = s;
3391             }
3392             else
3393                 PL_reginput = locinput;
3394             goto do_ifmatch;
3395         case IFMATCH:
3396             n = 1;
3397             if (scan->flags) {
3398                 s = HOPBACKc(locinput, scan->flags);
3399                 if (!s)
3400                     goto say_no;
3401                 PL_reginput = s;
3402             }
3403             else
3404                 PL_reginput = locinput;
3405
3406           do_ifmatch:
3407             inner = NEXTOPER(NEXTOPER(scan));
3408             if (regmatch(inner) != n) {
3409               say_no:
3410                 if (logical) {
3411                     logical = 0;
3412                     sw = 0;
3413                     goto do_longjump;
3414                 }
3415                 else
3416                     sayNO;
3417             }
3418           say_yes:
3419             if (logical) {
3420                 logical = 0;
3421                 sw = 1;
3422             }
3423             if (OP(scan) == SUSPEND) {
3424                 locinput = PL_reginput;
3425                 nextchr = UCHARAT(locinput);
3426             }
3427             /* FALL THROUGH. */
3428         case LONGJMP:
3429           do_longjump:
3430             next = scan + ARG(scan);
3431             if (next == scan)
3432                 next = NULL;
3433             break;
3434         default:
3435             PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
3436                           PTR2UV(scan), OP(scan));
3437             Perl_croak(aTHX_ "regexp memory corruption");
3438         }
3439       reenter:
3440         scan = next;
3441     }
3442
3443     /*
3444     * We get here only if there's trouble -- normally "case END" is
3445     * the terminating point.
3446     */
3447     Perl_croak(aTHX_ "corrupted regexp pointers");
3448     /*NOTREACHED*/
3449     sayNO;
3450
3451 yes_loud:
3452     DEBUG_r(
3453         PerlIO_printf(Perl_debug_log,
3454                       "%*s  %scould match...%s\n",
3455                       REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],PL_colors[5])
3456         );
3457     goto yes;
3458 yes_final:
3459     DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
3460                           PL_colors[4],PL_colors[5]));
3461 yes:
3462 #ifdef DEBUGGING
3463     PL_regindent--;
3464 #endif
3465
3466 #if 0                                   /* Breaks $^R */
3467     if (unwind)
3468         regcpblow(firstcp);
3469 #endif
3470     return 1;
3471
3472 no:
3473     DEBUG_r(
3474         PerlIO_printf(Perl_debug_log,
3475                       "%*s  %sfailed...%s\n",
3476                       REPORT_CODE_OFF+PL_regindent*2, "",PL_colors[4],PL_colors[5])
3477         );
3478     goto do_no;
3479 no_final:
3480 do_no:
3481     if (unwind) {
3482         re_unwind_t *uw = SSPTRt(unwind,re_unwind_t);
3483
3484         switch (uw->type) {
3485         case RE_UNWIND_BRANCH:
3486         case RE_UNWIND_BRANCHJ:
3487         {
3488             re_unwind_branch_t *uwb = &(uw->branch);
3489             I32 lastparen = uwb->lastparen;
3490
3491             REGCP_UNWIND(uwb->lastcp);
3492             for (n = *PL_reglastparen; n > lastparen; n--)
3493                 PL_regendp[n] = -1;
3494             *PL_reglastparen = n;
3495             scan = next = uwb->next;
3496             if ( !scan ||
3497                  OP(scan) != (uwb->type == RE_UNWIND_BRANCH
3498                               ? BRANCH : BRANCHJ) ) {           /* Failure */
3499                 unwind = uwb->prev;
3500 #ifdef DEBUGGING
3501                 PL_regindent--;
3502 #endif
3503                 goto do_no;
3504             }
3505             /* Have more choice yet.  Reuse the same uwb.  */
3506             /*SUPPRESS 560*/
3507             if ((n = (uwb->type == RE_UNWIND_BRANCH
3508                       ? NEXT_OFF(next) : ARG(next))))
3509                 next += n;
3510             else
3511                 next = NULL;    /* XXXX Needn't unwinding in this case... */
3512             uwb->next = next;
3513             next = NEXTOPER(scan);
3514             if (uwb->type == RE_UNWIND_BRANCHJ)
3515                 next = NEXTOPER(next);
3516             locinput = uwb->locinput;
3517             nextchr = uwb->nextchr;
3518 #ifdef DEBUGGING
3519             PL_regindent = uwb->regindent;
3520 #endif
3521
3522             goto reenter;
3523         }
3524         /* NOT REACHED */
3525         default:
3526             Perl_croak(aTHX_ "regexp unwind memory corruption");
3527         }
3528         /* NOT REACHED */
3529     }
3530 #ifdef DEBUGGING
3531     PL_regindent--;
3532 #endif
3533     return 0;
3534 }
3535
3536 /*
3537  - regrepeat - repeatedly match something simple, report how many
3538  */
3539 /*
3540  * [This routine now assumes that it will only match on things of length 1.
3541  * That was true before, but now we assume scan - reginput is the count,
3542  * rather than incrementing count on every character.  [Er, except utf8.]]
3543  */
3544 STATIC I32
3545 S_regrepeat(pTHX_ regnode *p, I32 max)
3546 {
3547     register char *scan;
3548     register I32 c;
3549     register char *loceol = PL_regeol;
3550     register I32 hardcount = 0;
3551     register bool do_utf8 = DO_UTF8(PL_reg_sv);
3552
3553     scan = PL_reginput;
3554     if (max != REG_INFTY && max < loceol - scan)
3555       loceol = scan + max;
3556     switch (OP(p)) {
3557     case REG_ANY:
3558         if (do_utf8) {
3559             loceol = PL_regeol;
3560             while (scan < loceol && hardcount < max && *scan != '\n') {
3561                 scan += UTF8SKIP(scan);
3562                 hardcount++;
3563             }
3564         } else {
3565             while (scan < loceol && *scan != '\n')
3566                 scan++;
3567         }
3568         break;
3569     case SANY:
3570         scan = loceol;
3571         break;
3572     case EXACT:         /* length of string is 1 */
3573         c = (U8)*STRING(p);
3574         while (scan < loceol && UCHARAT(scan) == c)
3575             scan++;
3576         break;
3577     case EXACTF:        /* length of string is 1 */
3578         c = (U8)*STRING(p);
3579         while (scan < loceol &&
3580                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
3581             scan++;
3582         break;
3583     case EXACTFL:       /* length of string is 1 */
3584         PL_reg_flags |= RF_tainted;
3585         c = (U8)*STRING(p);
3586         while (scan < loceol &&
3587                (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
3588             scan++;
3589         break;
3590     case ANYOF:
3591         if (do_utf8) {
3592             loceol = PL_regeol;
3593             while (hardcount < max && scan < loceol &&
3594                    reginclass(p, (U8*)scan, do_utf8)) {
3595                 scan += UTF8SKIP(scan);
3596                 hardcount++;
3597             }
3598         } else {
3599             while (scan < loceol && reginclass(p, (U8*)scan, do_utf8))
3600                 scan++;
3601         }
3602         break;
3603     case ALNUM:
3604         if (do_utf8) {
3605             loceol = PL_regeol;
3606             LOAD_UTF8_CHARCLASS(alnum,"a");
3607             while (hardcount < max && scan < loceol &&
3608                    swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3609                 scan += UTF8SKIP(scan);
3610                 hardcount++;
3611             }
3612         } else {
3613             while (scan < loceol && isALNUM(*scan))
3614                 scan++;
3615         }
3616         break;
3617     case ALNUML:
3618         PL_reg_flags |= RF_tainted;
3619         if (do_utf8) {
3620             loceol = PL_regeol;
3621             while (hardcount < max && scan < loceol &&
3622                    isALNUM_LC_utf8((U8*)scan)) {
3623                 scan += UTF8SKIP(scan);
3624                 hardcount++;
3625             }
3626         } else {
3627             while (scan < loceol && isALNUM_LC(*scan))
3628                 scan++;
3629         }
3630         break;
3631     case NALNUM:
3632         if (do_utf8) {
3633             loceol = PL_regeol;
3634             LOAD_UTF8_CHARCLASS(alnum,"a");
3635             while (hardcount < max && scan < loceol &&
3636                    !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
3637                 scan += UTF8SKIP(scan);
3638                 hardcount++;
3639             }
3640         } else {
3641             while (scan < loceol && !isALNUM(*scan))
3642                 scan++;
3643         }
3644         break;
3645     case NALNUML:
3646         PL_reg_flags |= RF_tainted;
3647         if (do_utf8) {
3648             loceol = PL_regeol;
3649             while (hardcount < max && scan < loceol &&
3650                    !isALNUM_LC_utf8((U8*)scan)) {
3651                 scan += UTF8SKIP(scan);
3652                 hardcount++;
3653             }
3654         } else {
3655             while (scan < loceol && !isALNUM_LC(*scan))
3656                 scan++;
3657         }
3658         break;
3659     case SPACE:
3660         if (do_utf8) {
3661             loceol = PL_regeol;
3662             LOAD_UTF8_CHARCLASS(space," ");
3663             while (hardcount < max && scan < loceol &&
3664                    (*scan == ' ' ||
3665                     swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3666                 scan += UTF8SKIP(scan);
3667                 hardcount++;
3668             }
3669         } else {
3670             while (scan < loceol && isSPACE(*scan))
3671                 scan++;
3672         }
3673         break;
3674     case SPACEL:
3675         PL_reg_flags |= RF_tainted;
3676         if (do_utf8) {
3677             loceol = PL_regeol;
3678             while (hardcount < max && scan < loceol &&
3679                    (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3680                 scan += UTF8SKIP(scan);
3681                 hardcount++;
3682             }
3683         } else {
3684             while (scan < loceol && isSPACE_LC(*scan))
3685                 scan++;
3686         }
3687         break;
3688     case NSPACE:
3689         if (do_utf8) {
3690             loceol = PL_regeol;
3691             LOAD_UTF8_CHARCLASS(space," ");
3692             while (hardcount < max && scan < loceol &&
3693                    !(*scan == ' ' ||
3694                      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
3695                 scan += UTF8SKIP(scan);
3696                 hardcount++;
3697             }
3698         } else {
3699             while (scan < loceol && !isSPACE(*scan))
3700                 scan++;
3701             break;
3702         }
3703     case NSPACEL:
3704         PL_reg_flags |= RF_tainted;
3705         if (do_utf8) {
3706             loceol = PL_regeol;
3707             while (hardcount < max && scan < loceol &&
3708                    !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
3709                 scan += UTF8SKIP(scan);
3710                 hardcount++;
3711             }
3712         } else {
3713             while (scan < loceol && !isSPACE_LC(*scan))
3714                 scan++;
3715         }
3716         break;
3717     case DIGIT:
3718         if (do_utf8) {
3719             loceol = PL_regeol;
3720             LOAD_UTF8_CHARCLASS(digit,"0");
3721             while (hardcount < max && scan < loceol &&
3722                    swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
3723                 scan += UTF8SKIP(scan);
3724                 hardcount++;
3725             }
3726         } else {
3727             while (scan < loceol && isDIGIT(*scan))
3728                 scan++;
3729         }
3730         break;
3731     case NDIGIT:
3732         if (do_utf8) {
3733             loceol = PL_regeol;
3734             LOAD_UTF8_CHARCLASS(digit,"0");
3735             while (hardcount < max && scan < loceol &&
3736                    !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
3737                 scan += UTF8SKIP(scan);
3738                 hardcount++;
3739             }
3740         } else {
3741             while (scan < loceol && !isDIGIT(*scan))
3742                 scan++;
3743         }
3744         break;
3745     default:            /* Called on something of 0 width. */
3746         break;          /* So match right here or not at all. */
3747     }
3748
3749     if (hardcount)
3750         c = hardcount;
3751     else
3752         c = scan - PL_reginput;
3753     PL_reginput = scan;
3754
3755     DEBUG_r(
3756         {
3757                 SV *prop = sv_newmortal();
3758
3759                 regprop(prop, p);
3760                 PerlIO_printf(Perl_debug_log,
3761                               "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
3762                               REPORT_CODE_OFF+1, "", SvPVX(prop),(IV)c,(IV)max);
3763         });
3764
3765     return(c);
3766 }
3767
3768 /*
3769  - regrepeat_hard - repeatedly match something, report total lenth and length
3770  *
3771  * The repeater is supposed to have constant length.
3772  */
3773
3774 STATIC I32
3775 S_regrepeat_hard(pTHX_ regnode *p, I32 max, I32 *lp)
3776 {
3777     register char *scan;
3778     register char *start;
3779     register char *loceol = PL_regeol;
3780     I32 l = 0;
3781     I32 count = 0, res = 1;
3782
3783     if (!max)
3784         return 0;
3785
3786     start = PL_reginput;
3787     if (DO_UTF8(PL_reg_sv)) {
3788         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3789             if (!count++) {
3790                 l = 0;
3791                 while (start < PL_reginput) {
3792                     l++;
3793                     start += UTF8SKIP(start);
3794                 }
3795                 *lp = l;
3796                 if (l == 0)
3797                     return max;
3798             }
3799             if (count == max)
3800                 return count;
3801         }
3802     }
3803     else {
3804         while (PL_reginput < loceol && (scan = PL_reginput, res = regmatch(p))) {
3805             if (!count++) {
3806                 *lp = l = PL_reginput - start;
3807                 if (max != REG_INFTY && l*max < loceol - scan)
3808                     loceol = scan + l*max;
3809                 if (l == 0)
3810                     return max;
3811             }
3812         }
3813     }
3814     if (!res)
3815         PL_reginput = scan;
3816
3817     return count;
3818 }
3819
3820 /*
3821 - regclass_swash - prepare the utf8 swash
3822 */
3823
3824 SV *
3825 Perl_regclass_swash(pTHX_ register regnode* node, bool doinit, SV** initsvp)
3826 {
3827     SV *sw = NULL;
3828     SV *si = NULL;
3829
3830     if (PL_regdata && PL_regdata->count) {
3831         U32 n = ARG(node);
3832
3833         if (PL_regdata->what[n] == 's') {
3834             SV *rv = (SV*)PL_regdata->data[n];
3835             AV *av = (AV*)SvRV((SV*)rv);
3836             SV **a;
3837
3838             si = *av_fetch(av, 0, FALSE);
3839             a  =  av_fetch(av, 1, FALSE);
3840
3841             if (a)
3842                 sw = *a;
3843             else if (si && doinit) {
3844                 sw = swash_init("utf8", "", si, 1, 0);
3845                 (void)av_store(av, 1, sw);
3846             }
3847         }
3848     }
3849
3850     if (initsvp)
3851         *initsvp = si;
3852
3853     return sw;
3854 }
3855
3856 /*
3857  - reginclass - determine if a character falls into a character class
3858  */
3859
3860 STATIC bool
3861 S_reginclass(pTHX_ register regnode *n, register U8* p, register bool do_utf8)
3862 {
3863     char flags = ANYOF_FLAGS(n);
3864     bool match = FALSE;
3865     UV c;
3866     STRLEN len = 0;
3867
3868     c = do_utf8 ? utf8_to_uvchr(p, &len) : *p;
3869
3870     if (do_utf8 || (flags & ANYOF_UNICODE)) {
3871         if (do_utf8 && !ANYOF_RUNTIME(n)) {
3872             if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
3873                 match = TRUE;
3874         }
3875         if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
3876             match = TRUE;
3877         if (!match) {
3878             SV *sw = regclass_swash(n, TRUE, 0);
3879
3880             if (sw) {
3881                 if (swash_fetch(sw, p, do_utf8))
3882                     match = TRUE;
3883                 else if (flags & ANYOF_FOLD) {
3884                     U8 tmpbuf[UTF8_MAXLEN+1];
3885
3886                     if (flags & ANYOF_LOCALE) {
3887                         PL_reg_flags |= RF_tainted;
3888                         uvchr_to_utf8(tmpbuf, toLOWER_LC_utf8(p));
3889                     }
3890                     else
3891                         uvchr_to_utf8(tmpbuf, toLOWER_utf8(p));
3892                     if (swash_fetch(sw, tmpbuf, do_utf8))
3893                         match = TRUE;
3894                 }
3895             }
3896         }
3897     }
3898     if (!match && c < 256) {
3899         if (ANYOF_BITMAP_TEST(n, c))
3900             match = TRUE;
3901         else if (flags & ANYOF_FOLD) {
3902           I32 f;
3903
3904             if (flags & ANYOF_LOCALE) {
3905                 PL_reg_flags |= RF_tainted;
3906                 f = PL_fold_locale[c];
3907             }
3908             else
3909                 f = PL_fold[c];
3910             if (f != c && ANYOF_BITMAP_TEST(n, f))
3911                 match = TRUE;
3912         }
3913
3914         if (!match && (flags & ANYOF_CLASS)) {
3915             PL_reg_flags |= RF_tainted;
3916             if (
3917                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
3918                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
3919                 (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
3920                 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
3921                 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
3922                 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
3923                 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
3924                 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
3925                 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
3926                 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
3927                 (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
3928                 (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
3929                 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
3930                 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
3931                 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
3932                 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
3933                 (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
3934                 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
3935                 (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
3936                 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
3937                 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
3938                 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
3939                 (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
3940                 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
3941                 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
3942                 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
3943                 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
3944                 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
3945                 (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
3946                 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
3947                 ) /* How's that for a conditional? */
3948             {
3949                 match = TRUE;
3950             }
3951         }
3952     }
3953
3954     return (flags & ANYOF_INVERT) ? !match : match;
3955 }
3956
3957 STATIC U8 *
3958 S_reghop(pTHX_ U8 *s, I32 off)
3959 {
3960     return S_reghop3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
3961 }
3962
3963 STATIC U8 *
3964 S_reghop3(pTHX_ U8 *s, I32 off, U8* lim)
3965 {
3966     if (off >= 0) {
3967         while (off-- && s < lim) {
3968             /* XXX could check well-formedness here */
3969             s += UTF8SKIP(s);
3970         }
3971     }
3972     else {
3973         while (off++) {
3974             if (s > lim) {
3975                 s--;
3976                 if (UTF8_IS_CONTINUED(*s)) {
3977                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
3978                         s--;
3979                 }
3980                 /* XXX could check well-formedness here */
3981             }
3982         }
3983     }
3984     return s;
3985 }
3986
3987 STATIC U8 *
3988 S_reghopmaybe(pTHX_ U8 *s, I32 off)
3989 {
3990     return S_reghopmaybe3(aTHX_ s, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr));
3991 }
3992
3993 STATIC U8 *
3994 S_reghopmaybe3(pTHX_ U8* s, I32 off, U8* lim)
3995 {
3996     if (off >= 0) {
3997         while (off-- && s < lim) {
3998             /* XXX could check well-formedness here */
3999             s += UTF8SKIP(s);
4000         }
4001         if (off >= 0)
4002             return 0;
4003     }
4004     else {
4005         while (off++) {
4006             if (s > lim) {
4007                 s--;
4008                 if (UTF8_IS_CONTINUED(*s)) {
4009                     while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
4010                         s--;
4011                 }
4012                 /* XXX could check well-formedness here */
4013             }
4014             else
4015                 break;
4016         }
4017         if (off <= 0)
4018             return 0;
4019     }
4020     return s;
4021 }
4022
4023 #ifdef PERL_OBJECT
4024 #include "XSUB.h"
4025 #endif
4026
4027 static void
4028 restore_pos(pTHXo_ void *arg)
4029 {
4030     if (PL_reg_eval_set) {
4031         if (PL_reg_oldsaved) {
4032             PL_reg_re->subbeg = PL_reg_oldsaved;
4033             PL_reg_re->sublen = PL_reg_oldsavedlen;
4034             RX_MATCH_COPIED_on(PL_reg_re);
4035         }
4036         PL_reg_magic->mg_len = PL_reg_oldpos;
4037         PL_reg_eval_set = 0;
4038         PL_curpm = PL_reg_oldcurpm;
4039     }
4040 }