regexec.c

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