regexec.c

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