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