regexec.c

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