regexec.c

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