regexec.c

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