regexec.c

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