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