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