regexec.c

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