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