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