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