regexec.c

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