src/5012004/regexec.c

   1 /*    regexec.c
   2  */
   3
   4 /*
   5  *  One Ring to rule them all, One Ring to find them
   6  &
   7  *     [p.v of _The Lord of the Rings_, opening poem]
   8  *     [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
   9  *     [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
  10  */
  11
  12 /* This file contains functions for executing a regular expression.  See
  13  * also regcomp.c which funnily enough, contains functions for compiling
  14  * a regular expression.
  15  *
  16  * This file is also copied at build time to ext/re/re_exec.c, where
  17  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
  18  * This causes the main functions to be compiled under new names and with
  19  * debugging support added, which makes "use re 'debug'" work.
  20  */
  21
  22 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
  23  * confused with the original package (see point 3 below).  Thanks, Henry!
  24  */
  25
  26 /* Additional note: this code is very heavily munged from Henry's version
  27  * in places.  In some spots I've traded clarity for efficiency, so don't
  28  * blame Henry for some of the lack of readability.
  29  */
  30
  31 /* The names of the functions have been changed from regcomp and
  32  * regexec to  pregcomp and pregexec in order to avoid conflicts
  33  * with the POSIX routines of the same names.
  34 */
  35
  36 #ifdef PERL_EXT_RE_BUILD
  37 #include "re_top.h"
  38 #endif
  39
  40 /*
  41  * pregcomp and pregexec -- regsub and regerror are not used in perl
  42  *
  43  * Copyright (c) 1986 by University of Toronto.
  44  * Written by Henry Spencer.  Not derived from licensed software.
  45  *
  46  * Permission is granted to anyone to use this software for any
  47  * purpose on any computer system, and to redistribute it freely,
  48  * subject to the following restrictions:
  49  *
  50  * 1. The author is not responsible for the consequences of use of
  51  *  this software, no matter how awful, even if they arise
  52  *  from defects in it.
  53  *
  54  * 2. The origin of this software must not be misrepresented, either
  55  *  by explicit claim or by omission.
  56  *
  57  * 3. Altered versions must be plainly marked as such, and must not
  58  *  be misrepresented as being the original software.
  59  *
  60  ****    Alterations to Henry's code are...
  61  ****
  62  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
  63  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
  64  ****    by Larry Wall and others
  65  ****
  66  ****    You may distribute under the terms of either the GNU General Public
  67  ****    License or the Artistic License, as specified in the README file.
  68  *
  69  * Beware that some of this code is subtly aware of the way operator
  70  * precedence is structured in regular expressions.  Serious changes in
  71  * regular-expression syntax might require a total rethink.
  72  */
  73 #include "EXTERN.h"
  74 #define PERL_IN_REGEXEC_C
  75 #include "perl.h"
  76 #include "re_defs.h"
  77
  78 #ifdef PERL_IN_XSUB_RE
  79 #  include "re_comp.h"
  80 #else
  81 #  include "regcomp.h"
  82 #endif
  83
  84 #define RF_tainted 1  /* tainted information used? */
  85 #define RF_warned 2  /* warned about big count? */
  86
  87 #define RF_utf8  8  /* Pattern contains multibyte chars? */
  88
  89 #define UTF ((PL_reg_flags & RF_utf8) != 0)
  90
  91 #define RS_init  1  /* eval environment created */
  92 #define RS_set  2  /* replsv value is set */
  93
  94 #ifndef STATIC
  95 #define STATIC static
  96 #endif
  97
  98 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
  99
 100 /*
 101  * Forwards.
 102  */
 103
 104 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
 105 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
 106
 107 #define HOPc(pos,off) \
 108   (char *)(PL_reg_match_utf8 \
 109    ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
 110    : (U8*)(pos + off))
 111 #define HOPBACKc(pos, off) \
 112   (char*)(PL_reg_match_utf8\
 113    ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
 114    : (pos - off >= PL_bostr)  \
 115     ? (U8*)pos - off  \
 116     : NULL)
 117
 118 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
 119 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
 120
 121 /* these are unrolled below in the CCC_TRY_XXX defined */
 122 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
 123  if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
 124
 125 /* Doesn't do an assert to verify that is correct */
 126 #define LOAD_UTF8_CHARCLASS_NO_CHECK(class) STMT_START { \
 127  if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)" "); LEAVE; } } STMT_END
 128
 129 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
 130 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
 131 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
 132
 133 #define LOAD_UTF8_CHARCLASS_GCB()  /* Grapheme cluster boundaries */        \
 134   LOAD_UTF8_CHARCLASS(X_begin, " ");                                  \
 135   LOAD_UTF8_CHARCLASS(X_non_hangul, "A");                             \
 136   /* These are utf8 constants, and not utf-ebcdic constants, so the   \
 137    * assert should likely and hopefully fail on an EBCDIC machine */ \
 138   LOAD_UTF8_CHARCLASS(X_extend, "\xcc\x80"); /* U+0300 */             \
 139                    \
 140   /* No asserts are done for these, in case called on an early        \
 141    * Unicode version in which they map to nothing */               \
 142   LOAD_UTF8_CHARCLASS_NO_CHECK(X_prepend);/* U+0E40 "\xe0\xb9\x80" */ \
 143   LOAD_UTF8_CHARCLASS_NO_CHECK(X_L);     /* U+1100 "\xe1\x84\x80" */ \
 144   LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV);     /* U+AC00 "\xea\xb0\x80" */ \
 145   LOAD_UTF8_CHARCLASS_NO_CHECK(X_LVT);    /* U+AC01 "\xea\xb0\x81" */ \
 146   LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV_LVT_V);/* U+AC01 "\xea\xb0\x81" */\
 147   LOAD_UTF8_CHARCLASS_NO_CHECK(X_T);      /* U+11A8 "\xe1\x86\xa8" */ \
 148   LOAD_UTF8_CHARCLASS_NO_CHECK(X_V)       /* U+1160 "\xe1\x85\xa0" */
 149
 150 /*
 151    We dont use PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS as the direct test
 152    so that it is possible to override the option here without having to
 153    rebuild the entire core. as we are required to do if we change regcomp.h
 154    which is where PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS is defined.
 155 */
 156 #if PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS
 157 #define BROKEN_UNICODE_CHARCLASS_MAPPINGS
 158 #endif
 159
 160 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
 161 #define LOAD_UTF8_CHARCLASS_PERL_WORD()   LOAD_UTF8_CHARCLASS_ALNUM()
 162 #define LOAD_UTF8_CHARCLASS_PERL_SPACE()  LOAD_UTF8_CHARCLASS_SPACE()
 163 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS_DIGIT()
 164 #define RE_utf8_perl_word   PL_utf8_alnum
 165 #define RE_utf8_perl_space  PL_utf8_space
 166 #define RE_utf8_posix_digit PL_utf8_digit
 167 #define perl_word  alnum
 168 #define perl_space space
 169 #define posix_digit digit
 170 #else
 171 #define LOAD_UTF8_CHARCLASS_PERL_WORD()   LOAD_UTF8_CHARCLASS(perl_word,"a")
 172 #define LOAD_UTF8_CHARCLASS_PERL_SPACE()  LOAD_UTF8_CHARCLASS(perl_space," ")
 173 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS(posix_digit,"0")
 174 #define RE_utf8_perl_word   PL_utf8_perl_word
 175 #define RE_utf8_perl_space  PL_utf8_perl_space
 176 #define RE_utf8_posix_digit PL_utf8_posix_digit
 177 #endif
 178
 179
 180 #define CCC_TRY_AFF(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC)                          \
 181   case NAMEL:                                                              \
 182    PL_reg_flags |= RF_tainted;                                                 \
 183    /* FALL THROUGH */                                                          \
 184   case NAME:                                                                     \
 185    if (!nextchr)                                                               \
 186     sayNO;                                                                  \
 187    if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) {                                \
 188     if (!CAT2(PL_utf8_,CLASS)) {                                            \
 189      bool ok;                                                            \
 190      ENTER;                                                              \
 191      save_re_context();                                                  \
 192      ok=CAT2(is_utf8_,CLASS)((const U8*)STR);                            \
 193      assert(ok);                                                         \
 194      LEAVE;                                                              \
 195     }                                                                       \
 196     if (!(OP(scan) == NAME                                                  \
 197      ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)   \
 198      : LCFUNC_utf8((U8*)locinput)))                                      \
 199     {                                                                       \
 200      sayNO;                                                              \
 201     }                                                                       \
 202     locinput += PL_utf8skip[nextchr];                                       \
 203     nextchr = UCHARAT(locinput);                                            \
 204     break;                                                                  \
 205    }                                                                           \
 206    if (!(OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr)))                  \
 207     sayNO;                                                                  \
 208    nextchr = UCHARAT(++locinput);                                              \
 209    break
 210
 211 #define CCC_TRY_NEG(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC)                        \
 212   case NAMEL:                                                              \
 213    PL_reg_flags |= RF_tainted;                                                 \
 214    /* FALL THROUGH */                                                          \
 215   case NAME :                                                                     \
 216    if (!nextchr && locinput >= PL_regeol)                                      \
 217     sayNO;                                                                  \
 218    if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) {                                \
 219     if (!CAT2(PL_utf8_,CLASS)) {                                            \
 220      bool ok;                                                            \
 221      ENTER;                                                              \
 222      save_re_context();                                                  \
 223      ok=CAT2(is_utf8_,CLASS)((const U8*)STR);                            \
 224      assert(ok);                                                         \
 225      LEAVE;                                                              \
 226     }                                                                       \
 227     if ((OP(scan) == NAME                                                  \
 228      ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)    \
 229      : LCFUNC_utf8((U8*)locinput)))                                      \
 230     {                                                                       \
 231      sayNO;                                                              \
 232     }                                                                       \
 233     locinput += PL_utf8skip[nextchr];                                       \
 234     nextchr = UCHARAT(locinput);                                            \
 235     break;                                                                  \
 236    }                                                                           \
 237    if ((OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr)))                   \
 238     sayNO;                                                                  \
 239    nextchr = UCHARAT(++locinput);                                              \
 240    break
 241
 242
 243
 244
 245
 246 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
 247
 248 /* for use after a quantifier and before an EXACT-like node -- japhy */
 249 /* it would be nice to rework regcomp.sym to generate this stuff. sigh */
 250 #define JUMPABLE(rn) (      \
 251  OP(rn) == OPEN ||       \
 252  (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
 253  OP(rn) == EVAL ||   \
 254  OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
 255  OP(rn) == PLUS || OP(rn) == MINMOD || \
 256  OP(rn) == KEEPS || (PL_regkind[OP(rn)] == VERB) || \
 257  (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
 258 )
 259 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
 260
 261 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
 262
 263 #if 0
 264 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
 265    we don't need this definition. */
 266 #define IS_TEXT(rn)   ( OP(rn)==EXACT   || OP(rn)==REF   || OP(rn)==NREF   )
 267 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  || OP(rn)==REFF  || OP(rn)==NREFF  )
 268 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
 269
 270 #else
 271 /* ... so we use this as its faster. */
 272 #define IS_TEXT(rn)   ( OP(rn)==EXACT   )
 273 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  )
 274 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
 275
 276 #endif
 277
 278 /*
 279   Search for mandatory following text node; for lookahead, the text must
 280   follow but for lookbehind (rn->flags != 0) we skip to the next step.
 281 */
 282 #define FIND_NEXT_IMPT(rn) STMT_START { \
 283  while (JUMPABLE(rn)) { \
 284   const OPCODE type = OP(rn); \
 285   if (type == SUSPEND || PL_regkind[type] == CURLY) \
 286    rn = NEXTOPER(NEXTOPER(rn)); \
 287   else if (type == PLUS) \
 288    rn = NEXTOPER(rn); \
 289   else if (type == IFMATCH) \
 290    rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
 291   else rn += NEXT_OFF(rn); \
 292  } \
 293 } STMT_END
 294
 295
 296 static void restore_pos(pTHX_ void *arg);
 297
 298 STATIC CHECKPOINT
 299 S_regcppush(pTHX_ I32 parenfloor)
 300 {
 301  dVAR;
 302  const int retval = PL_savestack_ix;
 303 #define REGCP_PAREN_ELEMS 4
 304  const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
 305  int p;
 306  GET_RE_DEBUG_FLAGS_DECL;
 307
 308  if (paren_elems_to_push < 0)
 309   Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
 310
 311 #define REGCP_OTHER_ELEMS 7
 312  SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
 313
 314  for (p = PL_regsize; p > parenfloor; p--) {
 315 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
 316   SSPUSHINT(PL_regoffs[p].end);
 317   SSPUSHINT(PL_regoffs[p].start);
 318   SSPUSHPTR(PL_reg_start_tmp[p]);
 319   SSPUSHINT(p);
 320   DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
 321   "     saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
 322      (UV)p, (IV)PL_regoffs[p].start,
 323      (IV)(PL_reg_start_tmp[p] - PL_bostr),
 324      (IV)PL_regoffs[p].end
 325   ));
 326  }
 327 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
 328  SSPUSHPTR(PL_regoffs);
 329  SSPUSHINT(PL_regsize);
 330  SSPUSHINT(*PL_reglastparen);
 331  SSPUSHINT(*PL_reglastcloseparen);
 332  SSPUSHPTR(PL_reginput);
 333 #define REGCP_FRAME_ELEMS 2
 334 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
 335  * are needed for the regexp context stack bookkeeping. */
 336  SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 337  SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
 338
 339  return retval;
 340 }
 341
 342 /* These are needed since we do not localize EVAL nodes: */
 343 #define REGCP_SET(cp)                                           \
 344  DEBUG_STATE_r(                                              \
 345    PerlIO_printf(Perl_debug_log,          \
 346     "  Setting an EVAL scope, savestack=%"IVdf"\n", \
 347     (IV)PL_savestack_ix));                          \
 348  cp = PL_savestack_ix
 349
 350 #define REGCP_UNWIND(cp)                                        \
 351  DEBUG_STATE_r(                                              \
 352   if (cp != PL_savestack_ix)                   \
 353     PerlIO_printf(Perl_debug_log,          \
 354     "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
 355     (IV)(cp), (IV)PL_savestack_ix));                \
 356  regcpblow(cp)
 357
 358 STATIC char *
 359 S_regcppop(pTHX_ const regexp *rex)
 360 {
 361  dVAR;
 362  U32 i;
 363  char *input;
 364  GET_RE_DEBUG_FLAGS_DECL;
 365
 366  PERL_ARGS_ASSERT_REGCPPOP;
 367
 368  /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
 369  i = SSPOPINT;
 370  assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
 371  i = SSPOPINT; /* Parentheses elements to pop. */
 372  input = (char *) SSPOPPTR;
 373  *PL_reglastcloseparen = SSPOPINT;
 374  *PL_reglastparen = SSPOPINT;
 375  PL_regsize = SSPOPINT;
 376  PL_regoffs=(regexp_paren_pair *) SSPOPPTR;
 377
 378
 379  /* Now restore the parentheses context. */
 380  for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
 381   i > 0; i -= REGCP_PAREN_ELEMS) {
 382   I32 tmps;
 383   U32 paren = (U32)SSPOPINT;
 384   PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
 385   PL_regoffs[paren].start = SSPOPINT;
 386   tmps = SSPOPINT;
 387   if (paren <= *PL_reglastparen)
 388    PL_regoffs[paren].end = tmps;
 389   DEBUG_BUFFERS_r(
 390    PerlIO_printf(Perl_debug_log,
 391       "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
 392       (UV)paren, (IV)PL_regoffs[paren].start,
 393       (IV)(PL_reg_start_tmp[paren] - PL_bostr),
 394       (IV)PL_regoffs[paren].end,
 395       (paren > *PL_reglastparen ? "(no)" : ""));
 396   );
 397  }
 398  DEBUG_BUFFERS_r(
 399   if (*PL_reglastparen + 1 <= rex->nparens) {
 400    PerlIO_printf(Perl_debug_log,
 401       "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
 402       (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
 403   }
 404  );
 405 #if 1
 406  /* It would seem that the similar code in regtry()
 407  * already takes care of this, and in fact it is in
 408  * a better location to since this code can #if 0-ed out
 409  * but the code in regtry() is needed or otherwise tests
 410  * requiring null fields (pat.t#187 and split.t#{13,14}
 411  * (as of patchlevel 7877)  will fail.  Then again,
 412  * this code seems to be necessary or otherwise
 413  * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
 414  * --jhi updated by dapm */
 415  for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
 416   if (i > PL_regsize)
 417    PL_regoffs[i].start = -1;
 418   PL_regoffs[i].end = -1;
 419  }
 420 #endif
 421  return input;
 422 }
 423
 424 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
 425
 426 /*
 427  * pregexec and friends
 428  */
 429
 430 #ifndef PERL_IN_XSUB_RE
 431 /*
 432  - pregexec - match a regexp against a string
 433  */
 434 I32
 435 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
 436   char *strbeg, I32 minend, SV *screamer, U32 nosave)
 437 /* strend: pointer to null at end of string */
 438 /* strbeg: real beginning of string */
 439 /* minend: end of match must be >=minend after stringarg. */
 440 /* nosave: For optimizations. */
 441 {
 442  PERL_ARGS_ASSERT_PREGEXEC;
 443
 444  return
 445   regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
 446      nosave ? 0 : REXEC_COPY_STR);
 447 }
 448 #endif
 449
 450 /*
 451  * Need to implement the following flags for reg_anch:
 452  *
 453  * USE_INTUIT_NOML  - Useful to call re_intuit_start() first
 454  * USE_INTUIT_ML
 455  * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
 456  * INTUIT_AUTORITATIVE_ML
 457  * INTUIT_ONCE_NOML  - Intuit can match in one location only.
 458  * INTUIT_ONCE_ML
 459  *
 460  * Another flag for this function: SECOND_TIME (so that float substrs
 461  * with giant delta may be not rechecked).
 462  */
 463
 464 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
 465
 466 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
 467    Otherwise, only SvCUR(sv) is used to get strbeg. */
 468
 469 /* XXXX We assume that strpos is strbeg unless sv. */
 470
 471 /* XXXX Some places assume that there is a fixed substring.
 472   An update may be needed if optimizer marks as "INTUITable"
 473   RExen without fixed substrings.  Similarly, it is assumed that
 474   lengths of all the strings are no more than minlen, thus they
 475   cannot come from lookahead.
 476   (Or minlen should take into account lookahead.)
 477   NOTE: Some of this comment is not correct. minlen does now take account
 478   of lookahead/behind. Further research is required. -- demerphq
 479
 480 */
 481
 482 /* A failure to find a constant substring means that there is no need to make
 483    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
 484    finding a substring too deep into the string means that less calls to
 485    regtry() should be needed.
 486
 487    REx compiler's optimizer found 4 possible hints:
 488   a) Anchored substring;
 489   b) Fixed substring;
 490   c) Whether we are anchored (beginning-of-line or \G);
 491   d) First node (of those at offset 0) which may distingush positions;
 492    We use a)b)d) and multiline-part of c), and try to find a position in the
 493    string which does not contradict any of them.
 494  */
 495
 496 /* Most of decisions we do here should have been done at compile time.
 497    The nodes of the REx which we used for the search should have been
 498    deleted from the finite automaton. */
 499
 500 char *
 501 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
 502      char *strend, const U32 flags, re_scream_pos_data *data)
 503 {
 504  dVAR;
 505  struct regexp *const prog = (struct regexp *)SvANY(rx);
 506  register I32 start_shift = 0;
 507  /* Should be nonnegative! */
 508  register I32 end_shift   = 0;
 509  register char *s;
 510  register SV *check;
 511  char *strbeg;
 512  char *t;
 513  const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
 514  I32 ml_anch;
 515  register char *other_last = NULL; /* other substr checked before this */
 516  char *check_at = NULL;  /* check substr found at this pos */
 517  const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
 518  RXi_GET_DECL(prog,progi);
 519 #ifdef DEBUGGING
 520  const char * const i_strpos = strpos;
 521 #endif
 522  GET_RE_DEBUG_FLAGS_DECL;
 523
 524  PERL_ARGS_ASSERT_RE_INTUIT_START;
 525
 526  RX_MATCH_UTF8_set(rx,do_utf8);
 527
 528  if (RX_UTF8(rx)) {
 529   PL_reg_flags |= RF_utf8;
 530  }
 531  DEBUG_EXECUTE_r(
 532   debug_start_match(rx, do_utf8, strpos, strend,
 533    sv ? "Guessing start of match in sv for"
 534    : "Guessing start of match in string for");
 535    );
 536
 537  /* CHR_DIST() would be more correct here but it makes things slow. */
 538  if (prog->minlen > strend - strpos) {
 539   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 540        "String too short... [re_intuit_start]\n"));
 541   goto fail;
 542  }
 543
 544  strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
 545  PL_regeol = strend;
 546  if (do_utf8) {
 547   if (!prog->check_utf8 && prog->check_substr)
 548    to_utf8_substr(prog);
 549   check = prog->check_utf8;
 550  } else {
 551   if (!prog->check_substr && prog->check_utf8)
 552    to_byte_substr(prog);
 553   check = prog->check_substr;
 554  }
 555  if (check == &PL_sv_undef) {
 556   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 557     "Non-utf8 string cannot match utf8 check string\n"));
 558   goto fail;
 559  }
 560  if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */
 561   ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
 562      || ( (prog->extflags & RXf_ANCH_BOL)
 563       && !multiline ) ); /* Check after \n? */
 564
 565   if (!ml_anch) {
 566   if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
 567     && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
 568    /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
 569    && sv && !SvROK(sv)
 570    && (strpos != strbeg)) {
 571    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
 572    goto fail;
 573   }
 574   if (prog->check_offset_min == prog->check_offset_max &&
 575    !(prog->extflags & RXf_CANY_SEEN)) {
 576    /* Substring at constant offset from beg-of-str... */
 577    I32 slen;
 578
 579    s = HOP3c(strpos, prog->check_offset_min, strend);
 580
 581    if (SvTAIL(check)) {
 582     slen = SvCUR(check); /* >= 1 */
 583
 584     if ( strend - s > slen || strend - s < slen - 1
 585      || (strend - s == slen && strend[-1] != '\n')) {
 586      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
 587      goto fail_finish;
 588     }
 589     /* Now should match s[0..slen-2] */
 590     slen--;
 591     if (slen && (*SvPVX_const(check) != *s
 592        || (slen > 1
 593         && memNE(SvPVX_const(check), s, slen)))) {
 594     report_neq:
 595      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
 596      goto fail_finish;
 597     }
 598    }
 599    else if (*SvPVX_const(check) != *s
 600      || ((slen = SvCUR(check)) > 1
 601       && memNE(SvPVX_const(check), s, slen)))
 602     goto report_neq;
 603    check_at = s;
 604    goto success_at_start;
 605   }
 606   }
 607   /* Match is anchored, but substr is not anchored wrt beg-of-str. */
 608   s = strpos;
 609   start_shift = prog->check_offset_min; /* okay to underestimate on CC */
 610   end_shift = prog->check_end_shift;
 611
 612   if (!ml_anch) {
 613    const I32 end = prog->check_offset_max + CHR_SVLEN(check)
 614           - (SvTAIL(check) != 0);
 615    const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
 616
 617    if (end_shift < eshift)
 618     end_shift = eshift;
 619   }
 620  }
 621  else {    /* Can match at random position */
 622   ml_anch = 0;
 623   s = strpos;
 624   start_shift = prog->check_offset_min;  /* okay to underestimate on CC */
 625   end_shift = prog->check_end_shift;
 626
 627   /* end shift should be non negative here */
 628  }
 629
 630 #ifdef QDEBUGGING /* 7/99: reports of failure (with the older version) */
 631  if (end_shift < 0)
 632   Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
 633     (IV)end_shift, RX_PRECOMP(prog));
 634 #endif
 635
 636   restart:
 637  /* Find a possible match in the region s..strend by looking for
 638  the "check" substring in the region corrected by start/end_shift. */
 639
 640  {
 641   I32 srch_start_shift = start_shift;
 642   I32 srch_end_shift = end_shift;
 643   if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
 644    srch_end_shift -= ((strbeg - s) - srch_start_shift);
 645    srch_start_shift = strbeg - s;
 646   }
 647  DEBUG_OPTIMISE_MORE_r({
 648   PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
 649    (IV)prog->check_offset_min,
 650    (IV)srch_start_shift,
 651    (IV)srch_end_shift,
 652    (IV)prog->check_end_shift);
 653  });
 654
 655  if (flags & REXEC_SCREAM) {
 656   I32 p = -1;   /* Internal iterator of scream. */
 657   I32 * const pp = data ? data->scream_pos : &p;
 658
 659   if (PL_screamfirst[BmRARE(check)] >= 0
 660    || ( BmRARE(check) == '\n'
 661     && (BmPREVIOUS(check) == SvCUR(check) - 1)
 662     && SvTAIL(check) ))
 663    s = screaminstr(sv, check,
 664        srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
 665   else
 666    goto fail_finish;
 667   /* we may be pointing at the wrong string */
 668   if (s && RXp_MATCH_COPIED(prog))
 669    s = strbeg + (s - SvPVX_const(sv));
 670   if (data)
 671    *data->scream_olds = s;
 672  }
 673  else {
 674   U8* start_point;
 675   U8* end_point;
 676   if (prog->extflags & RXf_CANY_SEEN) {
 677    start_point= (U8*)(s + srch_start_shift);
 678    end_point= (U8*)(strend - srch_end_shift);
 679   } else {
 680    start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
 681    end_point= HOP3(strend, -srch_end_shift, strbeg);
 682   }
 683   DEBUG_OPTIMISE_MORE_r({
 684    PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
 685     (int)(end_point - start_point),
 686     (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
 687     start_point);
 688   });
 689
 690   s = fbm_instr( start_point, end_point,
 691      check, multiline ? FBMrf_MULTILINE : 0);
 692  }
 693  }
 694  /* Update the count-of-usability, remove useless subpatterns,
 695   unshift s.  */
 696
 697  DEBUG_EXECUTE_r({
 698   RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 699    SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
 700   PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
 701       (s ? "Found" : "Did not find"),
 702    (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)
 703     ? "anchored" : "floating"),
 704    quoted,
 705    RE_SV_TAIL(check),
 706    (s ? " at offset " : "...\n") );
 707  });
 708
 709  if (!s)
 710   goto fail_finish;
 711  /* Finish the diagnostic message */
 712  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
 713
 714  /* XXX dmq: first branch is for positive lookbehind...
 715  Our check string is offset from the beginning of the pattern.
 716  So we need to do any stclass tests offset forward from that
 717  point. I think. :-(
 718  */
 719
 720
 721
 722  check_at=s;
 723
 724
 725  /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
 726  Start with the other substr.
 727  XXXX no SCREAM optimization yet - and a very coarse implementation
 728  XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
 729     *always* match.  Probably should be marked during compile...
 730  Probably it is right to do no SCREAM here...
 731  */
 732
 733  if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
 734     : (prog->float_substr && prog->anchored_substr))
 735  {
 736   /* Take into account the "other" substring. */
 737   /* XXXX May be hopelessly wrong for UTF... */
 738   if (!other_last)
 739    other_last = strpos;
 740   if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
 741   do_other_anchored:
 742    {
 743     char * const last = HOP3c(s, -start_shift, strbeg);
 744     char *last1, *last2;
 745     char * const saved_s = s;
 746     SV* must;
 747
 748     t = s - prog->check_offset_max;
 749     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 750      && (!do_utf8
 751       || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
 752        && t > strpos)))
 753      NOOP;
 754     else
 755      t = strpos;
 756     t = HOP3c(t, prog->anchored_offset, strend);
 757     if (t < other_last) /* These positions already checked */
 758      t = other_last;
 759     last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
 760     if (last < last1)
 761      last1 = last;
 762     /* XXXX It is not documented what units *_offsets are in.
 763     We assume bytes, but this is clearly wrong.
 764     Meaning this code needs to be carefully reviewed for errors.
 765     dmq.
 766     */
 767
 768     /* On end-of-str: see comment below. */
 769     must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
 770     if (must == &PL_sv_undef) {
 771      s = (char*)NULL;
 772      DEBUG_r(must = prog->anchored_utf8); /* for debug */
 773     }
 774     else
 775      s = fbm_instr(
 776       (unsigned char*)t,
 777       HOP3(HOP3(last1, prog->anchored_offset, strend)
 778         + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
 779       must,
 780       multiline ? FBMrf_MULTILINE : 0
 781      );
 782     DEBUG_EXECUTE_r({
 783      RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 784       SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 785      PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
 786       (s ? "Found" : "Contradicts"),
 787       quoted, RE_SV_TAIL(must));
 788     });
 789
 790
 791     if (!s) {
 792      if (last1 >= last2) {
 793       DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 794             ", giving up...\n"));
 795       goto fail_finish;
 796      }
 797      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 798       ", trying floating at offset %ld...\n",
 799       (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
 800      other_last = HOP3c(last1, prog->anchored_offset+1, strend);
 801      s = HOP3c(last, 1, strend);
 802      goto restart;
 803     }
 804     else {
 805      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 806       (long)(s - i_strpos)));
 807      t = HOP3c(s, -prog->anchored_offset, strbeg);
 808      other_last = HOP3c(s, 1, strend);
 809      s = saved_s;
 810      if (t == strpos)
 811       goto try_at_start;
 812      goto try_at_offset;
 813     }
 814    }
 815   }
 816   else {  /* Take into account the floating substring. */
 817    char *last, *last1;
 818    char * const saved_s = s;
 819    SV* must;
 820
 821    t = HOP3c(s, -start_shift, strbeg);
 822    last1 = last =
 823     HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
 824    if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
 825     last = HOP3c(t, prog->float_max_offset, strend);
 826    s = HOP3c(t, prog->float_min_offset, strend);
 827    if (s < other_last)
 828     s = other_last;
 829  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
 830    must = do_utf8 ? prog->float_utf8 : prog->float_substr;
 831    /* fbm_instr() takes into account exact value of end-of-str
 832    if the check is SvTAIL(ed).  Since false positives are OK,
 833    and end-of-str is not later than strend we are OK. */
 834    if (must == &PL_sv_undef) {
 835     s = (char*)NULL;
 836     DEBUG_r(must = prog->float_utf8); /* for debug message */
 837    }
 838    else
 839     s = fbm_instr((unsigned char*)s,
 840        (unsigned char*)last + SvCUR(must)
 841         - (SvTAIL(must)!=0),
 842        must, multiline ? FBMrf_MULTILINE : 0);
 843    DEBUG_EXECUTE_r({
 844     RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
 845      SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
 846     PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
 847      (s ? "Found" : "Contradicts"),
 848      quoted, RE_SV_TAIL(must));
 849    });
 850    if (!s) {
 851     if (last1 == last) {
 852      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 853            ", giving up...\n"));
 854      goto fail_finish;
 855     }
 856     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
 857      ", trying anchored starting at offset %ld...\n",
 858      (long)(saved_s + 1 - i_strpos)));
 859     other_last = last;
 860     s = HOP3c(t, 1, strend);
 861     goto restart;
 862    }
 863    else {
 864     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
 865      (long)(s - i_strpos)));
 866     other_last = s; /* Fix this later. --Hugo */
 867     s = saved_s;
 868     if (t == strpos)
 869      goto try_at_start;
 870     goto try_at_offset;
 871    }
 872   }
 873  }
 874
 875
 876  t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
 877
 878  DEBUG_OPTIMISE_MORE_r(
 879   PerlIO_printf(Perl_debug_log,
 880    "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
 881    (IV)prog->check_offset_min,
 882    (IV)prog->check_offset_max,
 883    (IV)(s-strpos),
 884    (IV)(t-strpos),
 885    (IV)(t-s),
 886    (IV)(strend-strpos)
 887   )
 888  );
 889
 890  if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
 891   && (!do_utf8
 892    || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
 893     && t > strpos)))
 894  {
 895   /* Fixed substring is found far enough so that the match
 896   cannot start at strpos. */
 897  try_at_offset:
 898   if (ml_anch && t[-1] != '\n') {
 899    /* Eventually fbm_*() should handle this, but often
 900    anchored_offset is not 0, so this check will not be wasted. */
 901    /* XXXX In the code below we prefer to look for "^" even in
 902    presence of anchored substrings.  And we search even
 903    beyond the found float position.  These pessimizations
 904    are historical artefacts only.  */
 905   find_anchor:
 906    while (t < strend - prog->minlen) {
 907     if (*t == '\n') {
 908      if (t < check_at - prog->check_offset_min) {
 909       if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
 910        /* Since we moved from the found position,
 911        we definitely contradict the found anchored
 912        substr.  Due to the above check we do not
 913        contradict "check" substr.
 914        Thus we can arrive here only if check substr
 915        is float.  Redo checking for "other"=="fixed".
 916        */
 917        strpos = t + 1;
 918        DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
 919         PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
 920        goto do_other_anchored;
 921       }
 922       /* We don't contradict the found floating substring. */
 923       /* XXXX Why not check for STCLASS? */
 924       s = t + 1;
 925       DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
 926        PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
 927       goto set_useful;
 928      }
 929      /* Position contradicts check-string */
 930      /* XXXX probably better to look for check-string
 931      than for "\n", so one should lower the limit for t? */
 932      DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
 933       PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
 934      other_last = strpos = s = t + 1;
 935      goto restart;
 936     }
 937     t++;
 938    }
 939    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
 940       PL_colors[0], PL_colors[1]));
 941    goto fail_finish;
 942   }
 943   else {
 944    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
 945       PL_colors[0], PL_colors[1]));
 946   }
 947   s = t;
 948  set_useful:
 949   ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
 950  }
 951  else {
 952   /* The found string does not prohibit matching at strpos,
 953   - no optimization of calling REx engine can be performed,
 954   unless it was an MBOL and we are not after MBOL,
 955   or a future STCLASS check will fail this. */
 956  try_at_start:
 957   /* Even in this situation we may use MBOL flag if strpos is offset
 958   wrt the start of the string. */
 959   if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
 960    && (strpos != strbeg) && strpos[-1] != '\n'
 961    /* May be due to an implicit anchor of m{.*foo}  */
 962    && !(prog->intflags & PREGf_IMPLICIT))
 963   {
 964    t = strpos;
 965    goto find_anchor;
 966   }
 967   DEBUG_EXECUTE_r( if (ml_anch)
 968    PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
 969       (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
 970   );
 971  success_at_start:
 972   if (!(prog->intflags & PREGf_NAUGHTY) /* XXXX If strpos moved? */
 973    && (do_utf8 ? (
 974     prog->check_utf8  /* Could be deleted already */
 975     && --BmUSEFUL(prog->check_utf8) < 0
 976     && (prog->check_utf8 == prog->float_utf8)
 977    ) : (
 978     prog->check_substr  /* Could be deleted already */
 979     && --BmUSEFUL(prog->check_substr) < 0
 980     && (prog->check_substr == prog->float_substr)
 981    )))
 982   {
 983    /* If flags & SOMETHING - do not do it many times on the same match */
 984    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
 985    /* XXX Does the destruction order has to change with do_utf8? */
 986    SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
 987    SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
 988    prog->check_substr = prog->check_utf8 = NULL; /* disable */
 989    prog->float_substr = prog->float_utf8 = NULL; /* clear */
 990    check = NULL;   /* abort */
 991    s = strpos;
 992    /* XXXX This is a remnant of the old implementation.  It
 993      looks wasteful, since now INTUIT can use many
 994      other heuristics. */
 995    prog->extflags &= ~RXf_USE_INTUIT;
 996   }
 997   else
 998    s = strpos;
 999  }
1000
1001  /* Last resort... */
1002  /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
1003  /* trie stclasses are too expensive to use here, we are better off to
1004  leave it to regmatch itself */
1005  if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1006   /* minlen == 0 is possible if regstclass is \b or \B,
1007   and the fixed substr is ''$.
1008   Since minlen is already taken into account, s+1 is before strend;
1009   accidentally, minlen >= 1 guaranties no false positives at s + 1
1010   even for \b or \B.  But (minlen? 1 : 0) below assumes that
1011   regstclass does not come from lookahead...  */
1012   /* If regstclass takes bytelength more than 1: If charlength==1, OK.
1013   This leaves EXACTF only, which is dealt with in find_byclass().  */
1014   const U8* const str = (U8*)STRING(progi->regstclass);
1015   const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1016      ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
1017      : 1);
1018   char * endpos;
1019   if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1020    endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
1021   else if (prog->float_substr || prog->float_utf8)
1022    endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
1023   else
1024    endpos= strend;
1025
1026   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
1027          (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
1028
1029   t = s;
1030   s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
1031   if (!s) {
1032 #ifdef DEBUGGING
1033    const char *what = NULL;
1034 #endif
1035    if (endpos == strend) {
1036     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1037         "Could not match STCLASS...\n") );
1038     goto fail;
1039    }
1040    DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1041         "This position contradicts STCLASS...\n") );
1042    if ((prog->extflags & RXf_ANCH) && !ml_anch)
1043     goto fail;
1044    /* Contradict one of substrings */
1045    if (prog->anchored_substr || prog->anchored_utf8) {
1046     if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
1047      DEBUG_EXECUTE_r( what = "anchored" );
1048     hop_and_restart:
1049      s = HOP3c(t, 1, strend);
1050      if (s + start_shift + end_shift > strend) {
1051       /* XXXX Should be taken into account earlier? */
1052       DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1053            "Could not match STCLASS...\n") );
1054       goto fail;
1055      }
1056      if (!check)
1057       goto giveup;
1058      DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1059         "Looking for %s substr starting at offset %ld...\n",
1060         what, (long)(s + start_shift - i_strpos)) );
1061      goto restart;
1062     }
1063     /* Have both, check_string is floating */
1064     if (t + start_shift >= check_at) /* Contradicts floating=check */
1065      goto retry_floating_check;
1066     /* Recheck anchored substring, but not floating... */
1067     s = check_at;
1068     if (!check)
1069      goto giveup;
1070     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1071       "Looking for anchored substr starting at offset %ld...\n",
1072       (long)(other_last - i_strpos)) );
1073     goto do_other_anchored;
1074    }
1075    /* Another way we could have checked stclass at the
1076    current position only: */
1077    if (ml_anch) {
1078     s = t = t + 1;
1079     if (!check)
1080      goto giveup;
1081     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1082       "Looking for /%s^%s/m starting at offset %ld...\n",
1083       PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
1084     goto try_at_offset;
1085    }
1086    if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
1087     goto fail;
1088    /* Check is floating subtring. */
1089   retry_floating_check:
1090    t = check_at - start_shift;
1091    DEBUG_EXECUTE_r( what = "floating" );
1092    goto hop_and_restart;
1093   }
1094   if (t != s) {
1095    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1096       "By STCLASS: moving %ld --> %ld\n",
1097         (long)(t - i_strpos), (long)(s - i_strpos))
1098     );
1099   }
1100   else {
1101    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1102         "Does not contradict STCLASS...\n");
1103     );
1104   }
1105  }
1106   giveup:
1107  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
1108       PL_colors[4], (check ? "Guessed" : "Giving up"),
1109       PL_colors[5], (long)(s - i_strpos)) );
1110  return s;
1111
1112   fail_finish:    /* Substring not found */
1113  if (prog->check_substr || prog->check_utf8)  /* could be removed already */
1114   BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1115   fail:
1116  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1117       PL_colors[4], PL_colors[5]));
1118  return NULL;
1119 }
1120
1121 #define DECL_TRIE_TYPE(scan) \
1122  const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
1123      trie_type = (scan->flags != EXACT) \
1124        ? (do_utf8 ? trie_utf8_fold : (UTF ? trie_latin_utf8_fold : trie_plain)) \
1125        : (do_utf8 ? trie_utf8 : trie_plain)
1126
1127 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len,  \
1128 uvc, charid, foldlen, foldbuf, uniflags) STMT_START {                       \
1129  switch (trie_type) {                                                    \
1130  case trie_utf8_fold:                                                    \
1131   if ( foldlen>0 ) {                                                  \
1132    uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1133    foldlen -= len;                                                 \
1134    uscan += len;                                                   \
1135    len=0;                                                          \
1136   } else {                                                            \
1137    uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1138    uvc = to_uni_fold( uvc, foldbuf, &foldlen );                    \
1139    foldlen -= UNISKIP( uvc );                                      \
1140    uscan = foldbuf + UNISKIP( uvc );                               \
1141   }                                                                   \
1142   break;                                                              \
1143  case trie_latin_utf8_fold:                                              \
1144   if ( foldlen>0 ) {                                                  \
1145    uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );     \
1146    foldlen -= len;                                                 \
1147    uscan += len;                                                   \
1148    len=0;                                                          \
1149   } else {                                                            \
1150    len = 1;                                                        \
1151    uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen );               \
1152    foldlen -= UNISKIP( uvc );                                      \
1153    uscan = foldbuf + UNISKIP( uvc );                               \
1154   }                                                                   \
1155   break;                                                              \
1156  case trie_utf8:                                                         \
1157   uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );       \
1158   break;                                                              \
1159  case trie_plain:                                                        \
1160   uvc = (UV)*uc;                                                      \
1161   len = 1;                                                            \
1162  }                                                                       \
1163  if (uvc < 256) {                                                        \
1164   charid = trie->charmap[ uvc ];                                      \
1165  }                                                                       \
1166  else {                                                                  \
1167   charid = 0;                                                         \
1168   if (widecharmap) {                                                  \
1169    SV** const svpp = hv_fetch(widecharmap,                         \
1170       (char*)&uvc, sizeof(UV), 0);                        \
1171    if (svpp)                                                       \
1172     charid = (U16)SvIV(*svpp);                                  \
1173   }                                                                   \
1174  }                                                                       \
1175 } STMT_END
1176
1177 #define REXEC_FBC_EXACTISH_CHECK(CoNd)                 \
1178 {                                                      \
1179  char *my_strend= (char *)strend;                   \
1180  if ( (CoNd)                                        \
1181   && (ln == len ||                              \
1182    !ibcmp_utf8(s, &my_strend, 0,  do_utf8,   \
1183       m, NULL, ln, (bool)UTF))       \
1184   && (!reginfo || regtry(reginfo, &s)) )        \
1185   goto got_it;                                   \
1186  else {                                             \
1187   U8 foldbuf[UTF8_MAXBYTES_CASE+1];             \
1188   uvchr_to_utf8(tmpbuf, c);                     \
1189   f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);  \
1190   if ( f != c                                   \
1191    && (f == c1 || f == c2)                  \
1192    && (ln == len ||                         \
1193     !ibcmp_utf8(s, &my_strend, 0,  do_utf8,\
1194        m, NULL, ln, (bool)UTF)) \
1195    && (!reginfo || regtry(reginfo, &s)) )   \
1196    goto got_it;                             \
1197  }                                                  \
1198 }                                                      \
1199 s += len
1200
1201 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1202 STMT_START {                                              \
1203  while (s <= e) {                                      \
1204   if ( (CoNd)                                       \
1205    && (ln == 1 || !(OP(c) == EXACTF             \
1206        ? ibcmp(s, m, ln)           \
1207        : ibcmp_locale(s, m, ln)))  \
1208    && (!reginfo || regtry(reginfo, &s)) )        \
1209    goto got_it;                                  \
1210   s++;                                              \
1211  }                                                     \
1212 } STMT_END
1213
1214 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1215 STMT_START {                                          \
1216  while (s + (uskip = UTF8SKIP(s)) <= strend) {     \
1217   CoDe                                          \
1218   s += uskip;                                   \
1219  }                                                 \
1220 } STMT_END
1221
1222 #define REXEC_FBC_SCAN(CoDe)                          \
1223 STMT_START {                                          \
1224  while (s < strend) {                              \
1225   CoDe                                          \
1226   s++;                                          \
1227  }                                                 \
1228 } STMT_END
1229
1230 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1231 REXEC_FBC_UTF8_SCAN(                                  \
1232  if (CoNd) {                                       \
1233   if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1234    goto got_it;                              \
1235   else                                          \
1236    tmp = doevery;                            \
1237  }                                                 \
1238  else                                              \
1239   tmp = 1;                                      \
1240 )
1241
1242 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1243 REXEC_FBC_SCAN(                                       \
1244  if (CoNd) {                                       \
1245   if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1246    goto got_it;                              \
1247   else                                          \
1248    tmp = doevery;                            \
1249  }                                                 \
1250  else                                              \
1251   tmp = 1;                                      \
1252 )
1253
1254 #define REXEC_FBC_TRYIT               \
1255 if ((!reginfo || regtry(reginfo, &s))) \
1256  goto got_it
1257
1258 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd)                         \
1259  if (do_utf8) {                                             \
1260   REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1261  }                                                          \
1262  else {                                                     \
1263   REXEC_FBC_CLASS_SCAN(CoNd);                            \
1264  }                                                          \
1265  break
1266
1267 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd)      \
1268  if (do_utf8) {                                             \
1269   UtFpReLoAd;                                            \
1270   REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1271  }                                                          \
1272  else {                                                     \
1273   REXEC_FBC_CLASS_SCAN(CoNd);                            \
1274  }                                                          \
1275  break
1276
1277 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd)                   \
1278  PL_reg_flags |= RF_tainted;                                \
1279  if (do_utf8) {                                             \
1280   REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1281  }                                                          \
1282  else {                                                     \
1283   REXEC_FBC_CLASS_SCAN(CoNd);                            \
1284  }                                                          \
1285  break
1286
1287 #define DUMP_EXEC_POS(li,s,doutf8) \
1288  dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1289
1290 /* We know what class REx starts with.  Try to find this position... */
1291 /* if reginfo is NULL, its a dryrun */
1292 /* annoyingly all the vars in this routine have different names from their counterparts
1293    in regmatch. /grrr */
1294
1295 STATIC char *
1296 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1297  const char *strend, regmatch_info *reginfo)
1298 {
1299   dVAR;
1300   const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1301   char *m;
1302   STRLEN ln;
1303   STRLEN lnc;
1304   register STRLEN uskip;
1305   unsigned int c1;
1306   unsigned int c2;
1307   char *e;
1308   register I32 tmp = 1; /* Scratch variable? */
1309   register const bool do_utf8 = PL_reg_match_utf8;
1310   RXi_GET_DECL(prog,progi);
1311
1312   PERL_ARGS_ASSERT_FIND_BYCLASS;
1313
1314   /* We know what class it must start with. */
1315   switch (OP(c)) {
1316   case ANYOF:
1317    if (do_utf8) {
1318     REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1319       !UTF8_IS_INVARIANT((U8)s[0]) ?
1320       reginclass(prog, c, (U8*)s, 0, do_utf8) :
1321       REGINCLASS(prog, c, (U8*)s));
1322    }
1323    else {
1324     while (s < strend) {
1325      STRLEN skip = 1;
1326
1327      if (REGINCLASS(prog, c, (U8*)s) ||
1328       (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1329       /* The assignment of 2 is intentional:
1330        * for the folded sharp s, the skip is 2. */
1331       (skip = SHARP_S_SKIP))) {
1332       if (tmp && (!reginfo || regtry(reginfo, &s)))
1333         goto got_it;
1334       else
1335         tmp = doevery;
1336      }
1337      else
1338       tmp = 1;
1339      s += skip;
1340     }
1341    }
1342    break;
1343   case CANY:
1344    REXEC_FBC_SCAN(
1345     if (tmp && (!reginfo || regtry(reginfo, &s)))
1346      goto got_it;
1347     else
1348      tmp = doevery;
1349    );
1350    break;
1351   case EXACTF:
1352    m   = STRING(c);
1353    ln  = STR_LEN(c); /* length to match in octets/bytes */
1354    lnc = (I32) ln; /* length to match in characters */
1355    if (UTF) {
1356     STRLEN ulen1, ulen2;
1357     U8 *sm = (U8 *) m;
1358     U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1359     U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1360     /* used by commented-out code below */
1361     /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1362
1363     /* XXX: Since the node will be case folded at compile
1364     time this logic is a little odd, although im not
1365     sure that its actually wrong. --dmq */
1366
1367     c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1368     c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1369
1370     /* XXX: This is kinda strange. to_utf8_XYZ returns the
1371     codepoint of the first character in the converted
1372     form, yet originally we did the extra step.
1373     No tests fail by commenting this code out however
1374     so Ive left it out. -- dmq.
1375
1376     c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1377          0, uniflags);
1378     c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1379          0, uniflags);
1380     */
1381
1382     lnc = 0;
1383     while (sm < ((U8 *) m + ln)) {
1384      lnc++;
1385      sm += UTF8SKIP(sm);
1386     }
1387    }
1388    else {
1389     c1 = *(U8*)m;
1390     c2 = PL_fold[c1];
1391    }
1392    goto do_exactf;
1393   case EXACTFL:
1394    m   = STRING(c);
1395    ln  = STR_LEN(c);
1396    lnc = (I32) ln;
1397    c1 = *(U8*)m;
1398    c2 = PL_fold_locale[c1];
1399   do_exactf:
1400    e = HOP3c(strend, -((I32)lnc), s);
1401
1402    if (!reginfo && e < s)
1403     e = s;   /* Due to minlen logic of intuit() */
1404
1405    /* The idea in the EXACTF* cases is to first find the
1406    * first character of the EXACTF* node and then, if
1407    * necessary, case-insensitively compare the full
1408    * text of the node.  The c1 and c2 are the first
1409    * characters (though in Unicode it gets a bit
1410    * more complicated because there are more cases
1411    * than just upper and lower: one needs to use
1412    * the so-called folding case for case-insensitive
1413    * matching (called "loose matching" in Unicode).
1414    * ibcmp_utf8() will do just that. */
1415
1416    if (do_utf8 || UTF) {
1417     UV c, f;
1418     U8 tmpbuf [UTF8_MAXBYTES+1];
1419     STRLEN len = 1;
1420     STRLEN foldlen;
1421     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1422     if (c1 == c2) {
1423      /* Upper and lower of 1st char are equal -
1424      * probably not a "letter". */
1425      while (s <= e) {
1426       if (do_utf8) {
1427        c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1428           uniflags);
1429       } else {
1430        c = *((U8*)s);
1431       }
1432       REXEC_FBC_EXACTISH_CHECK(c == c1);
1433      }
1434     }
1435     else {
1436      while (s <= e) {
1437       if (do_utf8) {
1438        c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1439           uniflags);
1440       } else {
1441        c = *((U8*)s);
1442       }
1443
1444       /* Handle some of the three Greek sigmas cases.
1445       * Note that not all the possible combinations
1446       * are handled here: some of them are handled
1447       * by the standard folding rules, and some of
1448       * them (the character class or ANYOF cases)
1449       * are handled during compiletime in
1450       * regexec.c:S_regclass(). */
1451       if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1452        c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1453        c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1454
1455       REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1456      }
1457     }
1458    }
1459    else {
1460     /* Neither pattern nor string are UTF8 */
1461     if (c1 == c2)
1462      REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1463     else
1464      REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1465    }
1466    break;
1467   case BOUNDL:
1468    PL_reg_flags |= RF_tainted;
1469    /* FALL THROUGH */
1470   case BOUND:
1471    if (do_utf8) {
1472     if (s == PL_bostr)
1473      tmp = '\n';
1474     else {
1475      U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1476      tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1477     }
1478     tmp = ((OP(c) == BOUND ?
1479       isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1480     LOAD_UTF8_CHARCLASS_ALNUM();
1481     REXEC_FBC_UTF8_SCAN(
1482      if (tmp == !(OP(c) == BOUND ?
1483         (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1484         isALNUM_LC_utf8((U8*)s)))
1485      {
1486       tmp = !tmp;
1487       REXEC_FBC_TRYIT;
1488     }
1489     );
1490    }
1491    else {
1492     tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1493     tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1494     REXEC_FBC_SCAN(
1495      if (tmp ==
1496       !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1497       tmp = !tmp;
1498       REXEC_FBC_TRYIT;
1499     }
1500     );
1501    }
1502    if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1503     goto got_it;
1504    break;
1505   case NBOUNDL:
1506    PL_reg_flags |= RF_tainted;
1507    /* FALL THROUGH */
1508   case NBOUND:
1509    if (do_utf8) {
1510     if (s == PL_bostr)
1511      tmp = '\n';
1512     else {
1513      U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1514      tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1515     }
1516     tmp = ((OP(c) == NBOUND ?
1517       isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1518     LOAD_UTF8_CHARCLASS_ALNUM();
1519     REXEC_FBC_UTF8_SCAN(
1520      if (tmp == !(OP(c) == NBOUND ?
1521         (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1522         isALNUM_LC_utf8((U8*)s)))
1523       tmp = !tmp;
1524      else REXEC_FBC_TRYIT;
1525     );
1526    }
1527    else {
1528     tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1529     tmp = ((OP(c) == NBOUND ?
1530       isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1531     REXEC_FBC_SCAN(
1532      if (tmp ==
1533       !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1534       tmp = !tmp;
1535      else REXEC_FBC_TRYIT;
1536     );
1537    }
1538    if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1539     goto got_it;
1540    break;
1541   case ALNUM:
1542    REXEC_FBC_CSCAN_PRELOAD(
1543     LOAD_UTF8_CHARCLASS_PERL_WORD(),
1544     swash_fetch(RE_utf8_perl_word, (U8*)s, do_utf8),
1545     isALNUM(*s)
1546    );
1547   case ALNUML:
1548    REXEC_FBC_CSCAN_TAINT(
1549     isALNUM_LC_utf8((U8*)s),
1550     isALNUM_LC(*s)
1551    );
1552   case NALNUM:
1553    REXEC_FBC_CSCAN_PRELOAD(
1554     LOAD_UTF8_CHARCLASS_PERL_WORD(),
1555     !swash_fetch(RE_utf8_perl_word, (U8*)s, do_utf8),
1556     !isALNUM(*s)
1557    );
1558   case NALNUML:
1559    REXEC_FBC_CSCAN_TAINT(
1560     !isALNUM_LC_utf8((U8*)s),
1561     !isALNUM_LC(*s)
1562    );
1563   case SPACE:
1564    REXEC_FBC_CSCAN_PRELOAD(
1565     LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1566     *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, do_utf8),
1567     isSPACE(*s)
1568    );
1569   case SPACEL:
1570    REXEC_FBC_CSCAN_TAINT(
1571     *s == ' ' || isSPACE_LC_utf8((U8*)s),
1572     isSPACE_LC(*s)
1573    );
1574   case NSPACE:
1575    REXEC_FBC_CSCAN_PRELOAD(
1576     LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1577     !(*s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, do_utf8)),
1578     !isSPACE(*s)
1579    );
1580   case NSPACEL:
1581    REXEC_FBC_CSCAN_TAINT(
1582     !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1583     !isSPACE_LC(*s)
1584    );
1585   case DIGIT:
1586    REXEC_FBC_CSCAN_PRELOAD(
1587     LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1588     swash_fetch(RE_utf8_posix_digit,(U8*)s, do_utf8),
1589     isDIGIT(*s)
1590    );
1591   case DIGITL:
1592    REXEC_FBC_CSCAN_TAINT(
1593     isDIGIT_LC_utf8((U8*)s),
1594     isDIGIT_LC(*s)
1595    );
1596   case NDIGIT:
1597    REXEC_FBC_CSCAN_PRELOAD(
1598     LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1599     !swash_fetch(RE_utf8_posix_digit,(U8*)s, do_utf8),
1600     !isDIGIT(*s)
1601    );
1602   case NDIGITL:
1603    REXEC_FBC_CSCAN_TAINT(
1604     !isDIGIT_LC_utf8((U8*)s),
1605     !isDIGIT_LC(*s)
1606    );
1607   case LNBREAK:
1608    REXEC_FBC_CSCAN(
1609     is_LNBREAK_utf8(s),
1610     is_LNBREAK_latin1(s)
1611    );
1612   case VERTWS:
1613    REXEC_FBC_CSCAN(
1614     is_VERTWS_utf8(s),
1615     is_VERTWS_latin1(s)
1616    );
1617   case NVERTWS:
1618    REXEC_FBC_CSCAN(
1619     !is_VERTWS_utf8(s),
1620     !is_VERTWS_latin1(s)
1621    );
1622   case HORIZWS:
1623    REXEC_FBC_CSCAN(
1624     is_HORIZWS_utf8(s),
1625     is_HORIZWS_latin1(s)
1626    );
1627   case NHORIZWS:
1628    REXEC_FBC_CSCAN(
1629     !is_HORIZWS_utf8(s),
1630     !is_HORIZWS_latin1(s)
1631    );
1632   case AHOCORASICKC:
1633   case AHOCORASICK:
1634    {
1635     DECL_TRIE_TYPE(c);
1636     /* what trie are we using right now */
1637     reg_ac_data *aho
1638      = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1639     reg_trie_data *trie
1640      = (reg_trie_data*)progi->data->data[ aho->trie ];
1641     HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1642
1643     const char *last_start = strend - trie->minlen;
1644 #ifdef DEBUGGING
1645     const char *real_start = s;
1646 #endif
1647     STRLEN maxlen = trie->maxlen;
1648     SV *sv_points;
1649     U8 **points; /* map of where we were in the input string
1650         when reading a given char. For ASCII this
1651         is unnecessary overhead as the relationship
1652         is always 1:1, but for Unicode, especially
1653         case folded Unicode this is not true. */
1654     U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1655     U8 *bitmap=NULL;
1656
1657
1658     GET_RE_DEBUG_FLAGS_DECL;
1659
1660     /* We can't just allocate points here. We need to wrap it in
1661     * an SV so it gets freed properly if there is a croak while
1662     * running the match */
1663     ENTER;
1664     SAVETMPS;
1665     sv_points=newSV(maxlen * sizeof(U8 *));
1666     SvCUR_set(sv_points,
1667      maxlen * sizeof(U8 *));
1668     SvPOK_on(sv_points);
1669     sv_2mortal(sv_points);
1670     points=(U8**)SvPV_nolen(sv_points );
1671     if ( trie_type != trie_utf8_fold
1672      && (trie->bitmap || OP(c)==AHOCORASICKC) )
1673     {
1674      if (trie->bitmap)
1675       bitmap=(U8*)trie->bitmap;
1676      else
1677       bitmap=(U8*)ANYOF_BITMAP(c);
1678     }
1679     /* this is the Aho-Corasick algorithm modified a touch
1680     to include special handling for long "unknown char"
1681     sequences. The basic idea being that we use AC as long
1682     as we are dealing with a possible matching char, when
1683     we encounter an unknown char (and we have not encountered
1684     an accepting state) we scan forward until we find a legal
1685     starting char.
1686     AC matching is basically that of trie matching, except
1687     that when we encounter a failing transition, we fall back
1688     to the current states "fail state", and try the current char
1689     again, a process we repeat until we reach the root state,
1690     state 1, or a legal transition. If we fail on the root state
1691     then we can either terminate if we have reached an accepting
1692     state previously, or restart the entire process from the beginning
1693     if we have not.
1694
1695     */
1696     while (s <= last_start) {
1697      const U32 uniflags = UTF8_ALLOW_DEFAULT;
1698      U8 *uc = (U8*)s;
1699      U16 charid = 0;
1700      U32 base = 1;
1701      U32 state = 1;
1702      UV uvc = 0;
1703      STRLEN len = 0;
1704      STRLEN foldlen = 0;
1705      U8 *uscan = (U8*)NULL;
1706      U8 *leftmost = NULL;
1707 #ifdef DEBUGGING
1708      U32 accepted_word= 0;
1709 #endif
1710      U32 pointpos = 0;
1711
1712      while ( state && uc <= (U8*)strend ) {
1713       int failed=0;
1714       U32 word = aho->states[ state ].wordnum;
1715
1716       if( state==1 ) {
1717        if ( bitmap ) {
1718         DEBUG_TRIE_EXECUTE_r(
1719          if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1720           dump_exec_pos( (char *)uc, c, strend, real_start,
1721            (char *)uc, do_utf8 );
1722           PerlIO_printf( Perl_debug_log,
1723            " Scanning for legal start char...\n");
1724          }
1725         );
1726         while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1727          uc++;
1728         }
1729         s= (char *)uc;
1730        }
1731        if (uc >(U8*)last_start) break;
1732       }
1733
1734       if ( word ) {
1735        U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1736        if (!leftmost || lpos < leftmost) {
1737         DEBUG_r(accepted_word=word);
1738         leftmost= lpos;
1739        }
1740        if (base==0) break;
1741
1742       }
1743       points[pointpos++ % maxlen]= uc;
1744       REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1745            uscan, len, uvc, charid, foldlen,
1746            foldbuf, uniflags);
1747       DEBUG_TRIE_EXECUTE_r({
1748        dump_exec_pos( (char *)uc, c, strend, real_start,
1749         s,   do_utf8 );
1750        PerlIO_printf(Perl_debug_log,
1751         " Charid:%3u CP:%4"UVxf" ",
1752         charid, uvc);
1753       });
1754
1755       do {
1756 #ifdef DEBUGGING
1757        word = aho->states[ state ].wordnum;
1758 #endif
1759        base = aho->states[ state ].trans.base;
1760
1761        DEBUG_TRIE_EXECUTE_r({
1762         if (failed)
1763          dump_exec_pos( (char *)uc, c, strend, real_start,
1764           s,   do_utf8 );
1765         PerlIO_printf( Perl_debug_log,
1766          "%sState: %4"UVxf", word=%"UVxf,
1767          failed ? " Fail transition to " : "",
1768          (UV)state, (UV)word);
1769        });
1770        if ( base ) {
1771         U32 tmp;
1772         if (charid &&
1773          (base + charid > trie->uniquecharcount )
1774          && (base + charid - 1 - trie->uniquecharcount
1775            < trie->lasttrans)
1776          && trie->trans[base + charid - 1 -
1777            trie->uniquecharcount].check == state
1778          && (tmp=trie->trans[base + charid - 1 -
1779           trie->uniquecharcount ].next))
1780         {
1781          DEBUG_TRIE_EXECUTE_r(
1782           PerlIO_printf( Perl_debug_log," - legal\n"));
1783          state = tmp;
1784          break;
1785         }
1786         else {
1787          DEBUG_TRIE_EXECUTE_r(
1788           PerlIO_printf( Perl_debug_log," - fail\n"));
1789          failed = 1;
1790          state = aho->fail[state];
1791         }
1792        }
1793        else {
1794         /* we must be accepting here */
1795         DEBUG_TRIE_EXECUTE_r(
1796           PerlIO_printf( Perl_debug_log," - accepting\n"));
1797         failed = 1;
1798         break;
1799        }
1800       } while(state);
1801       uc += len;
1802       if (failed) {
1803        if (leftmost)
1804         break;
1805        if (!state) state = 1;
1806       }
1807      }
1808      if ( aho->states[ state ].wordnum ) {
1809       U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1810       if (!leftmost || lpos < leftmost) {
1811        DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1812        leftmost = lpos;
1813       }
1814      }
1815      if (leftmost) {
1816       s = (char*)leftmost;
1817       DEBUG_TRIE_EXECUTE_r({
1818        PerlIO_printf(
1819         Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1820         (UV)accepted_word, (IV)(s - real_start)
1821        );
1822       });
1823       if (!reginfo || regtry(reginfo, &s)) {
1824        FREETMPS;
1825        LEAVE;
1826        goto got_it;
1827       }
1828       s = HOPc(s,1);
1829       DEBUG_TRIE_EXECUTE_r({
1830        PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1831       });
1832      } else {
1833       DEBUG_TRIE_EXECUTE_r(
1834        PerlIO_printf( Perl_debug_log,"No match.\n"));
1835       break;
1836      }
1837     }
1838     FREETMPS;
1839     LEAVE;
1840    }
1841    break;
1842   default:
1843    Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1844    break;
1845   }
1846   return 0;
1847  got_it:
1848   return s;
1849 }
1850
1851
1852 /*
1853  - regexec_flags - match a regexp against a string
1854  */
1855 I32
1856 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
1857    char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1858 /* strend: pointer to null at end of string */
1859 /* strbeg: real beginning of string */
1860 /* minend: end of match must be >=minend after stringarg. */
1861 /* data: May be used for some additional optimizations.
1862   Currently its only used, with a U32 cast, for transmitting
1863   the ganch offset when doing a /g match. This will change */
1864 /* nosave: For optimizations. */
1865 {
1866  dVAR;
1867  struct regexp *const prog = (struct regexp *)SvANY(rx);
1868  /*register*/ char *s;
1869  register regnode *c;
1870  /*register*/ char *startpos = stringarg;
1871  I32 minlen;  /* must match at least this many chars */
1872  I32 dontbother = 0; /* how many characters not to try at end */
1873  I32 end_shift = 0;   /* Same for the end. */  /* CC */
1874  I32 scream_pos = -1;  /* Internal iterator of scream. */
1875  char *scream_olds = NULL;
1876  const bool do_utf8 = (bool)DO_UTF8(sv);
1877  I32 multiline;
1878  RXi_GET_DECL(prog,progi);
1879  regmatch_info reginfo;  /* create some info to pass to regtry etc */
1880  regexp_paren_pair *swap = NULL;
1881  GET_RE_DEBUG_FLAGS_DECL;
1882
1883  PERL_ARGS_ASSERT_REGEXEC_FLAGS;
1884  PERL_UNUSED_ARG(data);
1885
1886  /* Be paranoid... */
1887  if (prog == NULL || startpos == NULL) {
1888   Perl_croak(aTHX_ "NULL regexp parameter");
1889   return 0;
1890  }
1891
1892  multiline = prog->extflags & RXf_PMf_MULTILINE;
1893  reginfo.prog = rx;  /* Yes, sorry that this is confusing.  */
1894
1895  RX_MATCH_UTF8_set(rx, do_utf8);
1896  DEBUG_EXECUTE_r(
1897   debug_start_match(rx, do_utf8, startpos, strend,
1898   "Matching");
1899  );
1900
1901  minlen = prog->minlen;
1902
1903  if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1904   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1905        "String too short [regexec_flags]...\n"));
1906   goto phooey;
1907  }
1908
1909
1910  /* Check validity of program. */
1911  if (UCHARAT(progi->program) != REG_MAGIC) {
1912   Perl_croak(aTHX_ "corrupted regexp program");
1913  }
1914
1915  PL_reg_flags = 0;
1916  PL_reg_eval_set = 0;
1917  PL_reg_maxiter = 0;
1918
1919  if (RX_UTF8(rx))
1920   PL_reg_flags |= RF_utf8;
1921
1922  /* Mark beginning of line for ^ and lookbehind. */
1923  reginfo.bol = startpos; /* XXX not used ??? */
1924  PL_bostr  = strbeg;
1925  reginfo.sv = sv;
1926
1927  /* Mark end of line for $ (and such) */
1928  PL_regeol = strend;
1929
1930  /* see how far we have to get to not match where we matched before */
1931  reginfo.till = startpos+minend;
1932
1933  /* If there is a "must appear" string, look for it. */
1934  s = startpos;
1935
1936  if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
1937   MAGIC *mg;
1938   if (flags & REXEC_IGNOREPOS){ /* Means: check only at start */
1939    reginfo.ganch = startpos + prog->gofs;
1940    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1941    "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
1942   } else if (sv && SvTYPE(sv) >= SVt_PVMG
1943     && SvMAGIC(sv)
1944     && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1945     && mg->mg_len >= 0) {
1946    reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
1947    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1948     "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
1949
1950    if (prog->extflags & RXf_ANCH_GPOS) {
1951     if (s > reginfo.ganch)
1952      goto phooey;
1953     s = reginfo.ganch - prog->gofs;
1954     DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1955      "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
1956     if (s < strbeg)
1957      goto phooey;
1958    }
1959   }
1960   else if (data) {
1961    reginfo.ganch = strbeg + PTR2UV(data);
1962    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1963     "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
1964
1965   } else {    /* pos() not defined */
1966    reginfo.ganch = strbeg;
1967    DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1968     "GPOS: reginfo.ganch = strbeg\n"));
1969   }
1970  }
1971  if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
1972   /* We have to be careful. If the previous successful match
1973   was from this regex we don't want a subsequent partially
1974   successful match to clobber the old results.
1975   So when we detect this possibility we add a swap buffer
1976   to the re, and switch the buffer each match. If we fail
1977   we switch it back, otherwise we leave it swapped.
1978   */
1979   swap = prog->offs;
1980   /* do we need a save destructor here for eval dies? */
1981   Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
1982  }
1983  if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1984   re_scream_pos_data d;
1985
1986   d.scream_olds = &scream_olds;
1987   d.scream_pos = &scream_pos;
1988   s = re_intuit_start(rx, sv, s, strend, flags, &d);
1989   if (!s) {
1990    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1991    goto phooey; /* not present */
1992   }
1993  }
1994
1995
1996
1997  /* Simplest case:  anchored match need be tried only once. */
1998  /*  [unless only anchor is BOL and multiline is set] */
1999  if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
2000   if (s == startpos && regtry(&reginfo, &startpos))
2001    goto got_it;
2002   else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2003     || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
2004   {
2005    char *end;
2006
2007    if (minlen)
2008     dontbother = minlen - 1;
2009    end = HOP3c(strend, -dontbother, strbeg) - 1;
2010    /* for multiline we only have to try after newlines */
2011    if (prog->check_substr || prog->check_utf8) {
2012     /* because of the goto we can not easily reuse the macros for bifurcating the
2013     unicode/non-unicode match modes here like we do elsewhere - demerphq */
2014     if (do_utf8) {
2015      if (s == startpos)
2016       goto after_try_utf8;
2017      while (1) {
2018       if (regtry(&reginfo, &s)) {
2019        goto got_it;
2020       }
2021      after_try_utf8:
2022       if (s > end) {
2023        goto phooey;
2024       }
2025       if (prog->extflags & RXf_USE_INTUIT) {
2026        s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL);
2027        if (!s) {
2028         goto phooey;
2029        }
2030       }
2031       else {
2032        s += UTF8SKIP(s);
2033       }
2034      }
2035     } /* end search for check string in unicode */
2036     else {
2037      if (s == startpos) {
2038       goto after_try_latin;
2039      }
2040      while (1) {
2041       if (regtry(&reginfo, &s)) {
2042        goto got_it;
2043       }
2044      after_try_latin:
2045       if (s > end) {
2046        goto phooey;
2047       }
2048       if (prog->extflags & RXf_USE_INTUIT) {
2049        s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2050        if (!s) {
2051         goto phooey;
2052        }
2053       }
2054       else {
2055        s++;
2056       }
2057      }
2058     } /* end search for check string in latin*/
2059    } /* end search for check string */
2060    else { /* search for newline */
2061     if (s > startpos) {
2062      /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
2063      s--;
2064     }
2065     /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
2066     while (s < end) {
2067      if (*s++ == '\n') { /* don't need PL_utf8skip here */
2068       if (regtry(&reginfo, &s))
2069        goto got_it;
2070      }
2071     }
2072    } /* end search for newline */
2073   } /* end anchored/multiline check string search */
2074   goto phooey;
2075  } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
2076  {
2077   /* the warning about reginfo.ganch being used without intialization
2078   is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
2079   and we only enter this block when the same bit is set. */
2080   char *tmp_s = reginfo.ganch - prog->gofs;
2081
2082   if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
2083    goto got_it;
2084   goto phooey;
2085  }
2086
2087  /* Messy cases:  unanchored match. */
2088  if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2089   /* we have /x+whatever/ */
2090   /* it must be a one character string (XXXX Except UTF?) */
2091   char ch;
2092 #ifdef DEBUGGING
2093   int did_match = 0;
2094 #endif
2095   if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2096    do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2097   ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
2098
2099   if (do_utf8) {
2100    REXEC_FBC_SCAN(
2101     if (*s == ch) {
2102      DEBUG_EXECUTE_r( did_match = 1 );
2103      if (regtry(&reginfo, &s)) goto got_it;
2104      s += UTF8SKIP(s);
2105      while (s < strend && *s == ch)
2106       s += UTF8SKIP(s);
2107     }
2108    );
2109   }
2110   else {
2111    REXEC_FBC_SCAN(
2112     if (*s == ch) {
2113      DEBUG_EXECUTE_r( did_match = 1 );
2114      if (regtry(&reginfo, &s)) goto got_it;
2115      s++;
2116      while (s < strend && *s == ch)
2117       s++;
2118     }
2119    );
2120   }
2121   DEBUG_EXECUTE_r(if (!did_match)
2122     PerlIO_printf(Perl_debug_log,
2123         "Did not find anchored character...\n")
2124    );
2125  }
2126  else if (prog->anchored_substr != NULL
2127    || prog->anchored_utf8 != NULL
2128    || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2129     && prog->float_max_offset < strend - s)) {
2130   SV *must;
2131   I32 back_max;
2132   I32 back_min;
2133   char *last;
2134   char *last1;  /* Last position checked before */
2135 #ifdef DEBUGGING
2136   int did_match = 0;
2137 #endif
2138   if (prog->anchored_substr || prog->anchored_utf8) {
2139    if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2140     do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2141    must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
2142    back_max = back_min = prog->anchored_offset;
2143   } else {
2144    if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2145     do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2146    must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2147    back_max = prog->float_max_offset;
2148    back_min = prog->float_min_offset;
2149   }
2150
2151
2152   if (must == &PL_sv_undef)
2153    /* could not downgrade utf8 check substring, so must fail */
2154    goto phooey;
2155
2156   if (back_min<0) {
2157    last = strend;
2158   } else {
2159    last = HOP3c(strend, /* Cannot start after this */
2160     -(I32)(CHR_SVLEN(must)
2161       - (SvTAIL(must) != 0) + back_min), strbeg);
2162   }
2163   if (s > PL_bostr)
2164    last1 = HOPc(s, -1);
2165   else
2166    last1 = s - 1; /* bogus */
2167
2168   /* XXXX check_substr already used to find "s", can optimize if
2169   check_substr==must. */
2170   scream_pos = -1;
2171   dontbother = end_shift;
2172   strend = HOPc(strend, -dontbother);
2173   while ( (s <= last) &&
2174     ((flags & REXEC_SCREAM)
2175     ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2176          end_shift, &scream_pos, 0))
2177     : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2178         (unsigned char*)strend, must,
2179         multiline ? FBMrf_MULTILINE : 0))) ) {
2180    /* we may be pointing at the wrong string */
2181    if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2182     s = strbeg + (s - SvPVX_const(sv));
2183    DEBUG_EXECUTE_r( did_match = 1 );
2184    if (HOPc(s, -back_max) > last1) {
2185     last1 = HOPc(s, -back_min);
2186     s = HOPc(s, -back_max);
2187    }
2188    else {
2189     char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2190
2191     last1 = HOPc(s, -back_min);
2192     s = t;
2193    }
2194    if (do_utf8) {
2195     while (s <= last1) {
2196      if (regtry(&reginfo, &s))
2197       goto got_it;
2198      s += UTF8SKIP(s);
2199     }
2200    }
2201    else {
2202     while (s <= last1) {
2203      if (regtry(&reginfo, &s))
2204       goto got_it;
2205      s++;
2206     }
2207    }
2208   }
2209   DEBUG_EXECUTE_r(if (!did_match) {
2210    RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
2211     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2212    PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2213        ((must == prog->anchored_substr || must == prog->anchored_utf8)
2214        ? "anchored" : "floating"),
2215     quoted, RE_SV_TAIL(must));
2216   });
2217   goto phooey;
2218  }
2219  else if ( (c = progi->regstclass) ) {
2220   if (minlen) {
2221    const OPCODE op = OP(progi->regstclass);
2222    /* don't bother with what can't match */
2223    if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2224     strend = HOPc(strend, -(minlen - 1));
2225   }
2226   DEBUG_EXECUTE_r({
2227    SV * const prop = sv_newmortal();
2228    regprop(prog, prop, c);
2229    {
2230     RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
2231      s,strend-s,60);
2232     PerlIO_printf(Perl_debug_log,
2233      "Matching stclass %.*s against %s (%d chars)\n",
2234      (int)SvCUR(prop), SvPVX_const(prop),
2235      quoted, (int)(strend - s));
2236    }
2237   });
2238   if (find_byclass(prog, c, s, strend, &reginfo))
2239    goto got_it;
2240   DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2241  }
2242  else {
2243   dontbother = 0;
2244   if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2245    /* Trim the end. */
2246    char *last;
2247    SV* float_real;
2248
2249    if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2250     do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2251    float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2252
2253    if (flags & REXEC_SCREAM) {
2254     last = screaminstr(sv, float_real, s - strbeg,
2255         end_shift, &scream_pos, 1); /* last one */
2256     if (!last)
2257      last = scream_olds; /* Only one occurrence. */
2258     /* we may be pointing at the wrong string */
2259     else if (RXp_MATCH_COPIED(prog))
2260      s = strbeg + (s - SvPVX_const(sv));
2261    }
2262    else {
2263     STRLEN len;
2264     const char * const little = SvPV_const(float_real, len);
2265
2266     if (SvTAIL(float_real)) {
2267      if (memEQ(strend - len + 1, little, len - 1))
2268       last = strend - len + 1;
2269      else if (!multiline)
2270       last = memEQ(strend - len, little, len)
2271        ? strend - len : NULL;
2272      else
2273       goto find_last;
2274     } else {
2275     find_last:
2276      if (len)
2277       last = rninstr(s, strend, little, little + len);
2278      else
2279       last = strend; /* matching "$" */
2280     }
2281    }
2282    if (last == NULL) {
2283     DEBUG_EXECUTE_r(
2284      PerlIO_printf(Perl_debug_log,
2285       "%sCan't trim the tail, match fails (should not happen)%s\n",
2286       PL_colors[4], PL_colors[5]));
2287     goto phooey; /* Should not happen! */
2288    }
2289    dontbother = strend - last + prog->float_min_offset;
2290   }
2291   if (minlen && (dontbother < minlen))
2292    dontbother = minlen - 1;
2293   strend -= dontbother;      /* this one's always in bytes! */
2294   /* We don't know much -- general case. */
2295   if (do_utf8) {
2296    for (;;) {
2297     if (regtry(&reginfo, &s))
2298      goto got_it;
2299     if (s >= strend)
2300      break;
2301     s += UTF8SKIP(s);
2302    };
2303   }
2304   else {
2305    do {
2306     if (regtry(&reginfo, &s))
2307      goto got_it;
2308    } while (s++ < strend);
2309   }
2310  }
2311
2312  /* Failure. */
2313  goto phooey;
2314
2315 got_it:
2316  Safefree(swap);
2317  RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2318
2319  if (PL_reg_eval_set)
2320   restore_pos(aTHX_ prog);
2321  if (RXp_PAREN_NAMES(prog))
2322   (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2323
2324  /* make sure $`, $&, $', and $digit will work later */
2325  if ( !(flags & REXEC_NOT_FIRST) ) {
2326   RX_MATCH_COPY_FREE(rx);
2327   if (flags & REXEC_COPY_STR) {
2328    const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2329 #ifdef PERL_OLD_COPY_ON_WRITE
2330    if ((SvIsCOW(sv)
2331     || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2332     if (DEBUG_C_TEST) {
2333      PerlIO_printf(Perl_debug_log,
2334         "Copy on write: regexp capture, type %d\n",
2335         (int) SvTYPE(sv));
2336     }
2337     prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2338     prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2339     assert (SvPOKp(prog->saved_copy));
2340    } else
2341 #endif
2342    {
2343     RX_MATCH_COPIED_on(rx);
2344     s = savepvn(strbeg, i);
2345     prog->subbeg = s;
2346    }
2347    prog->sublen = i;
2348   }
2349   else {
2350    prog->subbeg = strbeg;
2351    prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2352   }
2353  }
2354
2355  return 1;
2356
2357 phooey:
2358  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2359       PL_colors[4], PL_colors[5]));
2360  if (PL_reg_eval_set)
2361   restore_pos(aTHX_ prog);
2362  if (swap) {
2363   /* we failed :-( roll it back */
2364   Safefree(prog->offs);
2365   prog->offs = swap;
2366  }
2367
2368  return 0;
2369 }
2370
2371
2372 /*
2373  - regtry - try match at specific point
2374  */
2375 STATIC I32   /* 0 failure, 1 success */
2376 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2377 {
2378  dVAR;
2379  CHECKPOINT lastcp;
2380  REGEXP *const rx = reginfo->prog;
2381  regexp *const prog = (struct regexp *)SvANY(rx);
2382  RXi_GET_DECL(prog,progi);
2383  GET_RE_DEBUG_FLAGS_DECL;
2384
2385  PERL_ARGS_ASSERT_REGTRY;
2386
2387  reginfo->cutpoint=NULL;
2388
2389  if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2390   MAGIC *mg;
2391
2392   PL_reg_eval_set = RS_init;
2393   DEBUG_EXECUTE_r(DEBUG_s(
2394    PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2395       (IV)(PL_stack_sp - PL_stack_base));
2396    ));
2397   SAVESTACK_CXPOS();
2398   cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2399   /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2400   SAVETMPS;
2401   /* Apparently this is not needed, judging by wantarray. */
2402   /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2403   cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2404
2405   if (reginfo->sv) {
2406    /* Make $_ available to executed code. */
2407    if (reginfo->sv != DEFSV) {
2408     SAVE_DEFSV;
2409     DEFSV_set(reginfo->sv);
2410    }
2411
2412    if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2413     && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2414     /* prepare for quick setting of pos */
2415 #ifdef PERL_OLD_COPY_ON_WRITE
2416     if (SvIsCOW(reginfo->sv))
2417      sv_force_normal_flags(reginfo->sv, 0);
2418 #endif
2419     mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2420         &PL_vtbl_mglob, NULL, 0);
2421     mg->mg_len = -1;
2422    }
2423    PL_reg_magic    = mg;
2424    PL_reg_oldpos   = mg->mg_len;
2425    SAVEDESTRUCTOR_X(restore_pos, prog);
2426   }
2427   if (!PL_reg_curpm) {
2428    Newxz(PL_reg_curpm, 1, PMOP);
2429 #ifdef USE_ITHREADS
2430    {
2431     SV* const repointer = &PL_sv_undef;
2432     /* this regexp is also owned by the new PL_reg_curpm, which
2433     will try to free it.  */
2434     av_push(PL_regex_padav, repointer);
2435     PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2436     PL_regex_pad = AvARRAY(PL_regex_padav);
2437    }
2438 #endif
2439   }
2440 #ifdef USE_ITHREADS
2441   /* It seems that non-ithreads works both with and without this code.
2442   So for efficiency reasons it seems best not to have the code
2443   compiled when it is not needed.  */
2444   /* This is safe against NULLs: */
2445   ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2446   /* PM_reg_curpm owns a reference to this regexp.  */
2447   ReREFCNT_inc(rx);
2448 #endif
2449   PM_SETRE(PL_reg_curpm, rx);
2450   PL_reg_oldcurpm = PL_curpm;
2451   PL_curpm = PL_reg_curpm;
2452   if (RXp_MATCH_COPIED(prog)) {
2453    /*  Here is a serious problem: we cannot rewrite subbeg,
2454     since it may be needed if this match fails.  Thus
2455     $` inside (?{}) could fail... */
2456    PL_reg_oldsaved = prog->subbeg;
2457    PL_reg_oldsavedlen = prog->sublen;
2458 #ifdef PERL_OLD_COPY_ON_WRITE
2459    PL_nrs = prog->saved_copy;
2460 #endif
2461    RXp_MATCH_COPIED_off(prog);
2462   }
2463   else
2464    PL_reg_oldsaved = NULL;
2465   prog->subbeg = PL_bostr;
2466   prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2467  }
2468  DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2469  prog->offs[0].start = *startpos - PL_bostr;
2470  PL_reginput = *startpos;
2471  PL_reglastparen = &prog->lastparen;
2472  PL_reglastcloseparen = &prog->lastcloseparen;
2473  prog->lastparen = 0;
2474  prog->lastcloseparen = 0;
2475  PL_regsize = 0;
2476  PL_regoffs = prog->offs;
2477  if (PL_reg_start_tmpl <= prog->nparens) {
2478   PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2479   if(PL_reg_start_tmp)
2480    Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2481   else
2482    Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2483  }
2484
2485  /* XXXX What this code is doing here?!!!  There should be no need
2486  to do this again and again, PL_reglastparen should take care of
2487  this!  --ilya*/
2488
2489  /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2490  * Actually, the code in regcppop() (which Ilya may be meaning by
2491  * PL_reglastparen), is not needed at all by the test suite
2492  * (op/regexp, op/pat, op/split), but that code is needed otherwise
2493  * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2494  * Meanwhile, this code *is* needed for the
2495  * above-mentioned test suite tests to succeed.  The common theme
2496  * on those tests seems to be returning null fields from matches.
2497  * --jhi updated by dapm */
2498 #if 1
2499  if (prog->nparens) {
2500   regexp_paren_pair *pp = PL_regoffs;
2501   register I32 i;
2502   for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2503    ++pp;
2504    pp->start = -1;
2505    pp->end = -1;
2506   }
2507  }
2508 #endif
2509  REGCP_SET(lastcp);
2510  if (regmatch(reginfo, progi->program + 1)) {
2511   PL_regoffs[0].end = PL_reginput - PL_bostr;
2512   return 1;
2513  }
2514  if (reginfo->cutpoint)
2515   *startpos= reginfo->cutpoint;
2516  REGCP_UNWIND(lastcp);
2517  return 0;
2518 }
2519
2520
2521 #define sayYES goto yes
2522 #define sayNO goto no
2523 #define sayNO_SILENT goto no_silent
2524
2525 /* we dont use STMT_START/END here because it leads to
2526    "unreachable code" warnings, which are bogus, but distracting. */
2527 #define CACHEsayNO \
2528  if (ST.cache_mask) \
2529  PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2530  sayNO
2531
2532 /* this is used to determine how far from the left messages like
2533    'failed...' are printed. It should be set such that messages
2534    are inline with the regop output that created them.
2535 */
2536 #define REPORT_CODE_OFF 32
2537
2538
2539 /* Make sure there is a test for this +1 options in re_tests */
2540 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2541
2542 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2543 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2544
2545 #define SLAB_FIRST(s) (&(s)->states[0])
2546 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2547
2548 /* grab a new slab and return the first slot in it */
2549
2550 STATIC regmatch_state *
2551 S_push_slab(pTHX)
2552 {
2553 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2554  dMY_CXT;
2555 #endif
2556  regmatch_slab *s = PL_regmatch_slab->next;
2557  if (!s) {
2558   Newx(s, 1, regmatch_slab);
2559   s->prev = PL_regmatch_slab;
2560   s->next = NULL;
2561   PL_regmatch_slab->next = s;
2562  }
2563  PL_regmatch_slab = s;
2564  return SLAB_FIRST(s);
2565 }
2566
2567
2568 /* push a new state then goto it */
2569
2570 #define PUSH_STATE_GOTO(state, node) \
2571  scan = node; \
2572  st->resume_state = state; \
2573  goto push_state;
2574
2575 /* push a new state with success backtracking, then goto it */
2576
2577 #define PUSH_YES_STATE_GOTO(state, node) \
2578  scan = node; \
2579  st->resume_state = state; \
2580  goto push_yes_state;
2581
2582
2583
2584 /*
2585
2586 regmatch() - main matching routine
2587
2588 This is basically one big switch statement in a loop. We execute an op,
2589 set 'next' to point the next op, and continue. If we come to a point which
2590 we may need to backtrack to on failure such as (A|B|C), we push a
2591 backtrack state onto the backtrack stack. On failure, we pop the top
2592 state, and re-enter the loop at the state indicated. If there are no more
2593 states to pop, we return failure.
2594
2595 Sometimes we also need to backtrack on success; for example /A+/, where
2596 after successfully matching one A, we need to go back and try to
2597 match another one; similarly for lookahead assertions: if the assertion
2598 completes successfully, we backtrack to the state just before the assertion
2599 and then carry on.  In these cases, the pushed state is marked as
2600 'backtrack on success too'. This marking is in fact done by a chain of
2601 pointers, each pointing to the previous 'yes' state. On success, we pop to
2602 the nearest yes state, discarding any intermediate failure-only states.
2603 Sometimes a yes state is pushed just to force some cleanup code to be
2604 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2605 it to free the inner regex.
2606
2607 Note that failure backtracking rewinds the cursor position, while
2608 success backtracking leaves it alone.
2609
2610 A pattern is complete when the END op is executed, while a subpattern
2611 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2612 ops trigger the "pop to last yes state if any, otherwise return true"
2613 behaviour.
2614
2615 A common convention in this function is to use A and B to refer to the two
2616 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2617 the subpattern to be matched possibly multiple times, while B is the entire
2618 rest of the pattern. Variable and state names reflect this convention.
2619
2620 The states in the main switch are the union of ops and failure/success of
2621 substates associated with with that op.  For example, IFMATCH is the op
2622 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2623 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2624 successfully matched A and IFMATCH_A_fail is a state saying that we have
2625 just failed to match A. Resume states always come in pairs. The backtrack
2626 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2627 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2628 on success or failure.
2629
2630 The struct that holds a backtracking state is actually a big union, with
2631 one variant for each major type of op. The variable st points to the
2632 top-most backtrack struct. To make the code clearer, within each
2633 block of code we #define ST to alias the relevant union.
2634
2635 Here's a concrete example of a (vastly oversimplified) IFMATCH
2636 implementation:
2637
2638  switch (state) {
2639  ....
2640
2641 #define ST st->u.ifmatch
2642
2643  case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2644   ST.foo = ...; // some state we wish to save
2645   ...
2646   // push a yes backtrack state with a resume value of
2647   // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2648   // first node of A:
2649   PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2650   // NOTREACHED
2651
2652  case IFMATCH_A: // we have successfully executed A; now continue with B
2653   next = B;
2654   bar = ST.foo; // do something with the preserved value
2655   break;
2656
2657  case IFMATCH_A_fail: // A failed, so the assertion failed
2658   ...;   // do some housekeeping, then ...
2659   sayNO; // propagate the failure
2660
2661 #undef ST
2662
2663  ...
2664  }
2665
2666 For any old-timers reading this who are familiar with the old recursive
2667 approach, the code above is equivalent to:
2668
2669  case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2670  {
2671   int foo = ...
2672   ...
2673   if (regmatch(A)) {
2674    next = B;
2675    bar = foo;
2676    break;
2677   }
2678   ...;   // do some housekeeping, then ...
2679   sayNO; // propagate the failure
2680  }
2681
2682 The topmost backtrack state, pointed to by st, is usually free. If you
2683 want to claim it, populate any ST.foo fields in it with values you wish to
2684 save, then do one of
2685
2686   PUSH_STATE_GOTO(resume_state, node);
2687   PUSH_YES_STATE_GOTO(resume_state, node);
2688
2689 which sets that backtrack state's resume value to 'resume_state', pushes a
2690 new free entry to the top of the backtrack stack, then goes to 'node'.
2691 On backtracking, the free slot is popped, and the saved state becomes the
2692 new free state. An ST.foo field in this new top state can be temporarily
2693 accessed to retrieve values, but once the main loop is re-entered, it
2694 becomes available for reuse.
2695
2696 Note that the depth of the backtrack stack constantly increases during the
2697 left-to-right execution of the pattern, rather than going up and down with
2698 the pattern nesting. For example the stack is at its maximum at Z at the
2699 end of the pattern, rather than at X in the following:
2700
2701  /(((X)+)+)+....(Y)+....Z/
2702
2703 The only exceptions to this are lookahead/behind assertions and the cut,
2704 (?>A), which pop all the backtrack states associated with A before
2705 continuing.
2706
2707 Bascktrack state structs are allocated in slabs of about 4K in size.
2708 PL_regmatch_state and st always point to the currently active state,
2709 and PL_regmatch_slab points to the slab currently containing
2710 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2711 allocated, and is never freed until interpreter destruction. When the slab
2712 is full, a new one is allocated and chained to the end. At exit from
2713 regmatch(), slabs allocated since entry are freed.
2714
2715 */
2716
2717
2718 #define DEBUG_STATE_pp(pp)        \
2719  DEBUG_STATE_r({         \
2720   DUMP_EXEC_POS(locinput, scan, do_utf8);      \
2721   PerlIO_printf(Perl_debug_log,       \
2722    "    %*s"pp" %s%s%s%s%s\n",       \
2723    depth*2, "",        \
2724    PL_reg_name[st->resume_state],                     \
2725    ((st==yes_state||st==mark_state) ? "[" : ""),   \
2726    ((st==yes_state) ? "Y" : ""),                   \
2727    ((st==mark_state) ? "M" : ""),                  \
2728    ((st==yes_state||st==mark_state) ? "]" : "")    \
2729   );                                                  \
2730  });
2731
2732
2733 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2734
2735 #ifdef DEBUGGING
2736
2737 STATIC void
2738 S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8,
2739  const char *start, const char *end, const char *blurb)
2740 {
2741  const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2742
2743  PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2744
2745  if (!PL_colorset)
2746    reginitcolors();
2747  {
2748   RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2749    RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
2750
2751   RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2752    start, end - start, 60);
2753
2754   PerlIO_printf(Perl_debug_log,
2755    "%s%s REx%s %s against %s\n",
2756      PL_colors[4], blurb, PL_colors[5], s0, s1);
2757
2758   if (do_utf8||utf8_pat)
2759    PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2760     utf8_pat ? "pattern" : "",
2761     utf8_pat && do_utf8 ? " and " : "",
2762     do_utf8 ? "string" : ""
2763    );
2764  }
2765 }
2766
2767 STATIC void
2768 S_dump_exec_pos(pTHX_ const char *locinput,
2769      const regnode *scan,
2770      const char *loc_regeol,
2771      const char *loc_bostr,
2772      const char *loc_reg_starttry,
2773      const bool do_utf8)
2774 {
2775  const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2776  const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2777  int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2778  /* The part of the string before starttry has one color
2779  (pref0_len chars), between starttry and current
2780  position another one (pref_len - pref0_len chars),
2781  after the current position the third one.
2782  We assume that pref0_len <= pref_len, otherwise we
2783  decrease pref0_len.  */
2784  int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2785   ? (5 + taill) - l : locinput - loc_bostr;
2786  int pref0_len;
2787
2788  PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2789
2790  while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2791   pref_len++;
2792  pref0_len = pref_len  - (locinput - loc_reg_starttry);
2793  if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2794   l = ( loc_regeol - locinput > (5 + taill) - pref_len
2795    ? (5 + taill) - pref_len : loc_regeol - locinput);
2796  while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2797   l--;
2798  if (pref0_len < 0)
2799   pref0_len = 0;
2800  if (pref0_len > pref_len)
2801   pref0_len = pref_len;
2802  {
2803   const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2804
2805   RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2806    (locinput - pref_len),pref0_len, 60, 4, 5);
2807
2808   RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2809      (locinput - pref_len + pref0_len),
2810      pref_len - pref0_len, 60, 2, 3);
2811
2812   RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2813      locinput, loc_regeol - locinput, 10, 0, 1);
2814
2815   const STRLEN tlen=len0+len1+len2;
2816   PerlIO_printf(Perl_debug_log,
2817      "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2818      (IV)(locinput - loc_bostr),
2819      len0, s0,
2820      len1, s1,
2821      (docolor ? "" : "> <"),
2822      len2, s2,
2823      (int)(tlen > 19 ? 0 :  19 - tlen),
2824      "");
2825  }
2826 }
2827
2828 #endif
2829
2830 /* reg_check_named_buff_matched()
2831  * Checks to see if a named buffer has matched. The data array of
2832  * buffer numbers corresponding to the buffer is expected to reside
2833  * in the regexp->data->data array in the slot stored in the ARG() of
2834  * node involved. Note that this routine doesn't actually care about the
2835  * name, that information is not preserved from compilation to execution.
2836  * Returns the index of the leftmost defined buffer with the given name
2837  * or 0 if non of the buffers matched.
2838  */
2839 STATIC I32
2840 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2841 {
2842  I32 n;
2843  RXi_GET_DECL(rex,rexi);
2844  SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
2845  I32 *nums=(I32*)SvPVX(sv_dat);
2846
2847  PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
2848
2849  for ( n=0; n<SvIVX(sv_dat); n++ ) {
2850   if ((I32)*PL_reglastparen >= nums[n] &&
2851    PL_regoffs[nums[n]].end != -1)
2852   {
2853    return nums[n];
2854   }
2855  }
2856  return 0;
2857 }
2858
2859
2860 /* free all slabs above current one  - called during LEAVE_SCOPE */
2861
2862 STATIC void
2863 S_clear_backtrack_stack(pTHX_ void *p)
2864 {
2865  regmatch_slab *s = PL_regmatch_slab->next;
2866  PERL_UNUSED_ARG(p);
2867
2868  if (!s)
2869   return;
2870  PL_regmatch_slab->next = NULL;
2871  while (s) {
2872   regmatch_slab * const osl = s;
2873   s = s->next;
2874   Safefree(osl);
2875  }
2876 }
2877
2878
2879 #define SETREX(Re1,Re2) \
2880  if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2881  Re1 = (Re2)
2882
2883 STATIC I32   /* 0 failure, 1 success */
2884 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2885 {
2886 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2887  dMY_CXT;
2888 #endif
2889  dVAR;
2890  register const bool do_utf8 = PL_reg_match_utf8;
2891  const U32 uniflags = UTF8_ALLOW_DEFAULT;
2892  REGEXP *rex_sv = reginfo->prog;
2893  regexp *rex = (struct regexp *)SvANY(rex_sv);
2894  RXi_GET_DECL(rex,rexi);
2895  I32 oldsave;
2896  /* the current state. This is a cached copy of PL_regmatch_state */
2897  register regmatch_state *st;
2898  /* cache heavy used fields of st in registers */
2899  register regnode *scan;
2900  register regnode *next;
2901  register U32 n = 0; /* general value; init to avoid compiler warning */
2902  register I32 ln = 0; /* len or last;  init to avoid compiler warning */
2903  register char *locinput = PL_reginput;
2904  register I32 nextchr;   /* is always set to UCHARAT(locinput) */
2905
2906  bool result = 0;     /* return value of S_regmatch */
2907  int depth = 0;     /* depth of backtrack stack */
2908  U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
2909  const U32 max_nochange_depth =
2910   (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
2911   3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
2912  regmatch_state *yes_state = NULL; /* state to pop to on success of
2913                subpattern */
2914  /* mark_state piggy backs on the yes_state logic so that when we unwind
2915  the stack on success we can update the mark_state as we go */
2916  regmatch_state *mark_state = NULL; /* last mark state we have seen */
2917  regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2918  struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
2919  U32 state_num;
2920  bool no_final = 0;      /* prevent failure from backtracking? */
2921  bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
2922  char *startpoint = PL_reginput;
2923  SV *popmark = NULL;     /* are we looking for a mark? */
2924  SV *sv_commit = NULL;   /* last mark name seen in failure */
2925  SV *sv_yes_mark = NULL; /* last mark name we have seen
2926        during a successfull match */
2927  U32 lastopen = 0;       /* last open we saw */
2928  bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2929  SV* const oreplsv = GvSV(PL_replgv);
2930  /* these three flags are set by various ops to signal information to
2931  * the very next op. They have a useful lifetime of exactly one loop
2932  * iteration, and are not preserved or restored by state pushes/pops
2933  */
2934  bool sw = 0;     /* the condition value in (?(cond)a|b) */
2935  bool minmod = 0;     /* the next "{n,m}" is a "{n,m}?" */
2936  int logical = 0;     /* the following EVAL is:
2937         0: (?{...})
2938         1: (?(?{...})X|Y)
2939         2: (??{...})
2940        or the following IFMATCH/UNLESSM is:
2941         false: plain (?=foo)
2942         true:  used as a condition: (?(?=foo))
2943        */
2944 #ifdef DEBUGGING
2945  GET_RE_DEBUG_FLAGS_DECL;
2946 #endif
2947
2948  PERL_ARGS_ASSERT_REGMATCH;
2949
2950  DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
2951    PerlIO_printf(Perl_debug_log,"regmatch start\n");
2952  }));
2953  /* on first ever call to regmatch, allocate first slab */
2954  if (!PL_regmatch_slab) {
2955   Newx(PL_regmatch_slab, 1, regmatch_slab);
2956   PL_regmatch_slab->prev = NULL;
2957   PL_regmatch_slab->next = NULL;
2958   PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2959  }
2960
2961  oldsave = PL_savestack_ix;
2962  SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
2963  SAVEVPTR(PL_regmatch_slab);
2964  SAVEVPTR(PL_regmatch_state);
2965
2966  /* grab next free state slot */
2967  st = ++PL_regmatch_state;
2968  if (st >  SLAB_LAST(PL_regmatch_slab))
2969   st = PL_regmatch_state = S_push_slab(aTHX);
2970
2971  /* Note that nextchr is a byte even in UTF */
2972  nextchr = UCHARAT(locinput);
2973  scan = prog;
2974  while (scan != NULL) {
2975
2976   DEBUG_EXECUTE_r( {
2977    SV * const prop = sv_newmortal();
2978    regnode *rnext=regnext(scan);
2979    DUMP_EXEC_POS( locinput, scan, do_utf8 );
2980    regprop(rex, prop, scan);
2981
2982    PerlIO_printf(Perl_debug_log,
2983      "%3"IVdf":%*s%s(%"IVdf")\n",
2984      (IV)(scan - rexi->program), depth*2, "",
2985      SvPVX_const(prop),
2986      (PL_regkind[OP(scan)] == END || !rnext) ?
2987       0 : (IV)(rnext - rexi->program));
2988   });
2989
2990   next = scan + NEXT_OFF(scan);
2991   if (next == scan)
2992    next = NULL;
2993   state_num = OP(scan);
2994
2995   REH_CALL_EXEC_NODE_HOOK(rex, scan, reginfo, st);
2996  reenter_switch:
2997
2998   assert(PL_reglastparen == &rex->lastparen);
2999   assert(PL_reglastcloseparen == &rex->lastcloseparen);
3000   assert(PL_regoffs == rex->offs);
3001
3002   switch (state_num) {
3003   case BOL:
3004    if (locinput == PL_bostr)
3005    {
3006     /* reginfo->till = reginfo->bol; */
3007     break;
3008    }
3009    sayNO;
3010   case MBOL:
3011    if (locinput == PL_bostr ||
3012     ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
3013    {
3014     break;
3015    }
3016    sayNO;
3017   case SBOL:
3018    if (locinput == PL_bostr)
3019     break;
3020    sayNO;
3021   case GPOS:
3022    if (locinput == reginfo->ganch)
3023     break;
3024    sayNO;
3025
3026   case KEEPS:
3027    /* update the startpoint */
3028    st->u.keeper.val = PL_regoffs[0].start;
3029    PL_reginput = locinput;
3030    PL_regoffs[0].start = locinput - PL_bostr;
3031    PUSH_STATE_GOTO(KEEPS_next, next);
3032    /*NOT-REACHED*/
3033   case KEEPS_next_fail:
3034    /* rollback the start point change */
3035    PL_regoffs[0].start = st->u.keeper.val;
3036    sayNO_SILENT;
3037    /*NOT-REACHED*/
3038   case EOL:
3039     goto seol;
3040   case MEOL:
3041    if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3042     sayNO;
3043    break;
3044   case SEOL:
3045   seol:
3046    if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3047     sayNO;
3048    if (PL_regeol - locinput > 1)
3049     sayNO;
3050    break;
3051   case EOS:
3052    if (PL_regeol != locinput)
3053     sayNO;
3054    break;
3055   case SANY:
3056    if (!nextchr && locinput >= PL_regeol)
3057     sayNO;
3058    if (do_utf8) {
3059     locinput += PL_utf8skip[nextchr];
3060     if (locinput > PL_regeol)
3061      sayNO;
3062     nextchr = UCHARAT(locinput);
3063    }
3064    else
3065     nextchr = UCHARAT(++locinput);
3066    break;
3067   case CANY:
3068    if (!nextchr && locinput >= PL_regeol)
3069     sayNO;
3070    nextchr = UCHARAT(++locinput);
3071    break;
3072   case REG_ANY:
3073    if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
3074     sayNO;
3075    if (do_utf8) {
3076     locinput += PL_utf8skip[nextchr];
3077     if (locinput > PL_regeol)
3078      sayNO;
3079     nextchr = UCHARAT(locinput);
3080    }
3081    else
3082     nextchr = UCHARAT(++locinput);
3083    break;
3084
3085 #undef  ST
3086 #define ST st->u.trie
3087   case TRIEC:
3088    /* In this case the charclass data is available inline so
3089    we can fail fast without a lot of extra overhead.
3090    */
3091    if (scan->flags == EXACT || !do_utf8) {
3092     if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3093      DEBUG_EXECUTE_r(
3094       PerlIO_printf(Perl_debug_log,
3095          "%*s  %sfailed to match trie start class...%s\n",
3096          REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3097      );
3098      sayNO_SILENT;
3099      /* NOTREACHED */
3100     }
3101    }
3102    /* FALL THROUGH */
3103   case TRIE:
3104    {
3105     /* what type of TRIE am I? (utf8 makes this contextual) */
3106     DECL_TRIE_TYPE(scan);
3107
3108     /* what trie are we using right now */
3109     reg_trie_data * const trie
3110      = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3111     HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3112     U32 state = trie->startstate;
3113
3114     if (trie->bitmap && trie_type != trie_utf8_fold &&
3115      !TRIE_BITMAP_TEST(trie,*locinput)
3116     ) {
3117      if (trie->states[ state ].wordnum) {
3118       DEBUG_EXECUTE_r(
3119        PerlIO_printf(Perl_debug_log,
3120           "%*s  %smatched empty string...%s\n",
3121           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3122       );
3123       break;
3124      } else {
3125       DEBUG_EXECUTE_r(
3126        PerlIO_printf(Perl_debug_log,
3127           "%*s  %sfailed to match trie start class...%s\n",
3128           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3129       );
3130       sayNO_SILENT;
3131     }
3132     }
3133
3134    {
3135     U8 *uc = ( U8* )locinput;
3136
3137     STRLEN len = 0;
3138     STRLEN foldlen = 0;
3139     U8 *uscan = (U8*)NULL;
3140     STRLEN bufflen=0;
3141     SV *sv_accept_buff = NULL;
3142     U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3143
3144      ST.accepted = 0; /* how many accepting states we have seen */
3145     ST.B = next;
3146     ST.jump = trie->jump;
3147     ST.me = scan;
3148     /*
3149     traverse the TRIE keeping track of all accepting states
3150     we transition through until we get to a failing node.
3151     */
3152
3153     while ( state && uc <= (U8*)PL_regeol ) {
3154      U32 base = trie->states[ state ].trans.base;
3155      UV uvc = 0;
3156      U16 charid;
3157      /* We use charid to hold the wordnum as we don't use it
3158      for charid until after we have done the wordnum logic.
3159      We define an alias just so that the wordnum logic reads
3160      more naturally. */
3161
3162 #define got_wordnum charid
3163      got_wordnum = trie->states[ state ].wordnum;
3164
3165      if ( got_wordnum ) {
3166       if ( ! ST.accepted ) {
3167        ENTER;
3168        SAVETMPS; /* XXX is this necessary? dmq */
3169        bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
3170        sv_accept_buff=newSV(bufflen *
3171            sizeof(reg_trie_accepted) - 1);
3172        SvCUR_set(sv_accept_buff, 0);
3173        SvPOK_on(sv_accept_buff);
3174        sv_2mortal(sv_accept_buff);
3175        SAVETMPS;
3176        ST.accept_buff =
3177         (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
3178       }
3179       do {
3180        if (ST.accepted >= bufflen) {
3181         bufflen *= 2;
3182         ST.accept_buff =(reg_trie_accepted*)
3183          SvGROW(sv_accept_buff,
3184            bufflen * sizeof(reg_trie_accepted));
3185        }
3186        SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
3187         + sizeof(reg_trie_accepted));
3188
3189
3190        ST.accept_buff[ST.accepted].wordnum = got_wordnum;
3191        ST.accept_buff[ST.accepted].endpos = uc;
3192        ++ST.accepted;
3193       } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
3194      }
3195 #undef got_wordnum
3196
3197      DEBUG_TRIE_EXECUTE_r({
3198         DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
3199         PerlIO_printf( Perl_debug_log,
3200          "%*s  %sState: %4"UVxf" Accepted: %4"UVxf" ",
3201          2+depth * 2, "", PL_colors[4],
3202          (UV)state, (UV)ST.accepted );
3203      });
3204
3205      if ( base ) {
3206       REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3207            uscan, len, uvc, charid, foldlen,
3208            foldbuf, uniflags);
3209
3210       if (charid &&
3211        (base + charid > trie->uniquecharcount )
3212        && (base + charid - 1 - trie->uniquecharcount
3213          < trie->lasttrans)
3214        && trie->trans[base + charid - 1 -
3215          trie->uniquecharcount].check == state)
3216       {
3217        state = trie->trans[base + charid - 1 -
3218         trie->uniquecharcount ].next;
3219       }
3220       else {
3221        state = 0;
3222       }
3223       uc += len;
3224
3225      }
3226      else {
3227       state = 0;
3228      }
3229      DEBUG_TRIE_EXECUTE_r(
3230       PerlIO_printf( Perl_debug_log,
3231        "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3232        charid, uvc, (UV)state, PL_colors[5] );
3233      );
3234     }
3235     if (!ST.accepted )
3236     sayNO;
3237
3238     DEBUG_EXECUTE_r(
3239      PerlIO_printf( Perl_debug_log,
3240       "%*s  %sgot %"IVdf" possible matches%s\n",
3241       REPORT_CODE_OFF + depth * 2, "",
3242       PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3243     );
3244    }}
3245    goto trie_first_try; /* jump into the fail handler */
3246    /* NOTREACHED */
3247   case TRIE_next_fail: /* we failed - try next alterative */
3248    if ( ST.jump) {
3249     REGCP_UNWIND(ST.cp);
3250     for (n = *PL_reglastparen; n > ST.lastparen; n--)
3251      PL_regoffs[n].end = -1;
3252     *PL_reglastparen = n;
3253    }
3254   trie_first_try:
3255    if (do_cutgroup) {
3256     do_cutgroup = 0;
3257     no_final = 0;
3258    }
3259
3260    if ( ST.jump) {
3261     ST.lastparen = *PL_reglastparen;
3262     REGCP_SET(ST.cp);
3263    }
3264    if ( ST.accepted == 1 ) {
3265     /* only one choice left - just continue */
3266     DEBUG_EXECUTE_r({
3267      AV *const trie_words
3268       = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3269      SV ** const tmp = av_fetch( trie_words,
3270       ST.accept_buff[ 0 ].wordnum-1, 0 );
3271      SV *sv= tmp ? sv_newmortal() : NULL;
3272
3273      PerlIO_printf( Perl_debug_log,
3274       "%*s  %sonly one match left: #%d <%s>%s\n",
3275       REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3276       ST.accept_buff[ 0 ].wordnum,
3277       tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3278         PL_colors[0], PL_colors[1],
3279         (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3280        )
3281       : "not compiled under -Dr",
3282       PL_colors[5] );
3283     });
3284     PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3285     /* in this case we free tmps/leave before we call regmatch
3286     as we wont be using accept_buff again. */
3287
3288     locinput = PL_reginput;
3289     nextchr = UCHARAT(locinput);
3290      if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
3291       scan = ST.B;
3292      else
3293       scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3294     if (!has_cutgroup) {
3295      FREETMPS;
3296      LEAVE;
3297     } else {
3298      ST.accepted--;
3299      PUSH_YES_STATE_GOTO(TRIE_next, scan);
3300     }
3301
3302     continue; /* execute rest of RE */
3303    }
3304
3305    if ( !ST.accepted-- ) {
3306     DEBUG_EXECUTE_r({
3307      PerlIO_printf( Perl_debug_log,
3308       "%*s  %sTRIE failed...%s\n",
3309       REPORT_CODE_OFF+depth*2, "",
3310       PL_colors[4],
3311       PL_colors[5] );
3312     });
3313     FREETMPS;
3314     LEAVE;
3315     sayNO_SILENT;
3316     /*NOTREACHED*/
3317    }
3318
3319    /*
3320    There are at least two accepting states left.  Presumably
3321    the number of accepting states is going to be low,
3322    typically two. So we simply scan through to find the one
3323    with lowest wordnum.  Once we find it, we swap the last
3324    state into its place and decrement the size. We then try to
3325    match the rest of the pattern at the point where the word
3326    ends. If we succeed, control just continues along the
3327    regex; if we fail we return here to try the next accepting
3328    state
3329    */
3330
3331    {
3332     U32 best = 0;
3333     U32 cur;
3334     for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3335      DEBUG_TRIE_EXECUTE_r(
3336       PerlIO_printf( Perl_debug_log,
3337        "%*s  %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3338        REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3339        (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3340        ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3341      );
3342
3343      if (ST.accept_buff[cur].wordnum <
3344        ST.accept_buff[best].wordnum)
3345       best = cur;
3346     }
3347
3348     DEBUG_EXECUTE_r({
3349      AV *const trie_words
3350       = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3351      SV ** const tmp = av_fetch( trie_words,
3352       ST.accept_buff[ best ].wordnum - 1, 0 );
3353      regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
3354          ST.B :
3355          ST.me + ST.jump[ST.accept_buff[best].wordnum];
3356      SV *sv= tmp ? sv_newmortal() : NULL;
3357
3358      PerlIO_printf( Perl_debug_log,
3359       "%*s  %strying alternation #%d <%s> at node #%d %s\n",
3360       REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3361       ST.accept_buff[best].wordnum,
3362       tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3363         PL_colors[0], PL_colors[1],
3364         (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3365        ) : "not compiled under -Dr",
3366        REG_NODE_NUM(nextop),
3367       PL_colors[5] );
3368     });
3369
3370     if ( best<ST.accepted ) {
3371      reg_trie_accepted tmp = ST.accept_buff[ best ];
3372      ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3373      ST.accept_buff[ ST.accepted ] = tmp;
3374      best = ST.accepted;
3375     }
3376     PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3377     if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3378      scan = ST.B;
3379     } else {
3380      scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3381     }
3382     PUSH_YES_STATE_GOTO(TRIE_next, scan);
3383     /* NOTREACHED */
3384    }
3385    /* NOTREACHED */
3386   case TRIE_next:
3387    /* we dont want to throw this away, see bug 57042*/
3388    if (oreplsv != GvSV(PL_replgv))
3389     sv_setsv(oreplsv, GvSV(PL_replgv));
3390    FREETMPS;
3391    LEAVE;
3392    sayYES;
3393 #undef  ST
3394
3395   case EXACT: {
3396    char *s = STRING(scan);
3397    ln = STR_LEN(scan);
3398    if (do_utf8 != UTF) {
3399     /* The target and the pattern have differing utf8ness. */
3400     char *l = locinput;
3401     const char * const e = s + ln;
3402
3403     if (do_utf8) {
3404      /* The target is utf8, the pattern is not utf8. */
3405      while (s < e) {
3406       STRLEN ulen;
3407       if (l >= PL_regeol)
3408        sayNO;
3409       if (NATIVE_TO_UNI(*(U8*)s) !=
3410        utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3411            uniflags))
3412        sayNO;
3413       l += ulen;
3414       s ++;
3415      }
3416     }
3417     else {
3418      /* The target is not utf8, the pattern is utf8. */
3419      while (s < e) {
3420       STRLEN ulen;
3421       if (l >= PL_regeol)
3422        sayNO;
3423       if (NATIVE_TO_UNI(*((U8*)l)) !=
3424        utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3425           uniflags))
3426        sayNO;
3427       s += ulen;
3428       l ++;
3429      }
3430     }
3431     locinput = l;
3432     nextchr = UCHARAT(locinput);
3433     break;
3434    }
3435    /* The target and the pattern have the same utf8ness. */
3436    /* Inline the first character, for speed. */
3437    if (UCHARAT(s) != nextchr)
3438     sayNO;
3439    if (PL_regeol - locinput < ln)
3440     sayNO;
3441    if (ln > 1 && memNE(s, locinput, ln))
3442     sayNO;
3443    locinput += ln;
3444    nextchr = UCHARAT(locinput);
3445    break;
3446    }
3447   case EXACTFL:
3448    PL_reg_flags |= RF_tainted;
3449    /* FALL THROUGH */
3450   case EXACTF: {
3451    char * const s = STRING(scan);
3452    ln = STR_LEN(scan);
3453
3454    if (do_utf8 || UTF) {
3455    /* Either target or the pattern are utf8. */
3456     const char * const l = locinput;
3457     char *e = PL_regeol;
3458
3459     if (ibcmp_utf8(s, 0,  ln, (bool)UTF,
3460        l, &e, 0,  do_utf8)) {
3461      /* One more case for the sharp s:
3462      * pack("U0U*", 0xDF) =~ /ss/i,
3463      * the 0xC3 0x9F are the UTF-8
3464      * byte sequence for the U+00DF. */
3465
3466      if (!(do_utf8 &&
3467       toLOWER(s[0]) == 's' &&
3468       ln >= 2 &&
3469       toLOWER(s[1]) == 's' &&
3470       (U8)l[0] == 0xC3 &&
3471       e - l >= 2 &&
3472       (U8)l[1] == 0x9F))
3473       sayNO;
3474     }
3475     locinput = e;
3476     nextchr = UCHARAT(locinput);
3477     break;
3478    }
3479
3480    /* Neither the target and the pattern are utf8. */
3481
3482    /* Inline the first character, for speed. */
3483    if (UCHARAT(s) != nextchr &&
3484     UCHARAT(s) != ((OP(scan) == EXACTF)
3485        ? PL_fold : PL_fold_locale)[nextchr])
3486     sayNO;
3487    if (PL_regeol - locinput < ln)
3488     sayNO;
3489    if (ln > 1 && (OP(scan) == EXACTF
3490       ? ibcmp(s, locinput, ln)
3491       : ibcmp_locale(s, locinput, ln)))
3492     sayNO;
3493    locinput += ln;
3494    nextchr = UCHARAT(locinput);
3495    break;
3496    }
3497   case BOUNDL:
3498   case NBOUNDL:
3499    PL_reg_flags |= RF_tainted;
3500    /* FALL THROUGH */
3501   case BOUND:
3502   case NBOUND:
3503    /* was last char in word? */
3504    if (do_utf8) {
3505     if (locinput == PL_bostr)
3506      ln = '\n';
3507     else {
3508      const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3509
3510      ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3511     }
3512     if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3513      ln = isALNUM_uni(ln);
3514      LOAD_UTF8_CHARCLASS_ALNUM();
3515      n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3516     }
3517     else {
3518      ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3519      n = isALNUM_LC_utf8((U8*)locinput);
3520     }
3521    }
3522    else {
3523     ln = (locinput != PL_bostr) ?
3524      UCHARAT(locinput - 1) : '\n';
3525     if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3526      ln = isALNUM(ln);
3527      n = isALNUM(nextchr);
3528     }
3529     else {
3530      ln = isALNUM_LC(ln);
3531      n = isALNUM_LC(nextchr);
3532     }
3533    }
3534    if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3535          OP(scan) == BOUNDL))
3536      sayNO;
3537    break;
3538   case ANYOF:
3539    if (do_utf8) {
3540     STRLEN inclasslen = PL_regeol - locinput;
3541
3542     if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3543      goto anyof_fail;
3544     if (locinput >= PL_regeol)
3545      sayNO;
3546     locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3547     nextchr = UCHARAT(locinput);
3548     break;
3549    }
3550    else {
3551     if (nextchr < 0)
3552      nextchr = UCHARAT(locinput);
3553     if (!REGINCLASS(rex, scan, (U8*)locinput))
3554      goto anyof_fail;
3555     if (!nextchr && locinput >= PL_regeol)
3556      sayNO;
3557     nextchr = UCHARAT(++locinput);
3558     break;
3559    }
3560   anyof_fail:
3561    /* If we might have the case of the German sharp s
3562    * in a casefolding Unicode character class. */
3563
3564    if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3565     locinput += SHARP_S_SKIP;
3566     nextchr = UCHARAT(locinput);
3567    }
3568    else
3569     sayNO;
3570    break;
3571   /* Special char classes - The defines start on line 129 or so */
3572   CCC_TRY_AFF( ALNUM,  ALNUML, perl_word,   "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3573   CCC_TRY_NEG(NALNUM, NALNUML, perl_word,   "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3574
3575   CCC_TRY_AFF( SPACE,  SPACEL, perl_space,  " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3576   CCC_TRY_NEG(NSPACE, NSPACEL, perl_space,  " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3577
3578   CCC_TRY_AFF( DIGIT,  DIGITL, posix_digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3579   CCC_TRY_NEG(NDIGIT, NDIGITL, posix_digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3580
3581   case CLUMP: /* Match \X: logical Unicode character.  This is defined as
3582      a Unicode extended Grapheme Cluster */
3583    /* From http://www.unicode.org/reports/tr29 (5.2 version).  An
3584    extended Grapheme Cluster is:
3585
3586    CR LF
3587    | Prepend* Begin Extend*
3588    | .
3589
3590    Begin is (Hangul-syllable | ! Control)
3591    Extend is (Grapheme_Extend | Spacing_Mark)
3592    Control is [ GCB_Control CR LF ]
3593
3594    The discussion below shows how the code for CLUMP is derived
3595    from this regex.  Note that most of these concepts are from
3596    property values of the Grapheme Cluster Boundary (GCB) property.
3597    No code point can have multiple property values for a given
3598    property.  Thus a code point in Prepend can't be in Control, but
3599    it must be in !Control.  This is why Control above includes
3600    GCB_Control plus CR plus LF.  The latter two are used in the GCB
3601    property separately, and so can't be in GCB_Control, even though
3602    they logically are controls.  Control is not the same as gc=cc,
3603    but includes format and other characters as well.
3604
3605    The Unicode definition of Hangul-syllable is:
3606     L+
3607     | (L* ( ( V | LV ) V* | LVT ) T*)
3608     | T+
3609     )
3610    Each of these is a value for the GCB property, and hence must be
3611    disjoint, so the order they are tested is immaterial, so the
3612    above can safely be changed to
3613     T+
3614     | L+
3615     | (L* ( LVT | ( V | LV ) V*) T*)
3616
3617    The last two terms can be combined like this:
3618     L* ( L
3619       | (( LVT | ( V | LV ) V*) T*))
3620
3621    And refactored into this:
3622     L* (L | LVT T* | V  V* T* | LV  V* T*)
3623
3624    That means that if we have seen any L's at all we can quit
3625    there, but if the next character is a LVT, a V or and LV we
3626    should keep going.
3627
3628    There is a subtlety with Prepend* which showed up in testing.
3629    Note that the Begin, and only the Begin is required in:
3630     | Prepend* Begin Extend*
3631    Also, Begin contains '! Control'.  A Prepend must be a '!
3632    Control', which means it must be a Begin.  What it comes down to
3633    is that if we match Prepend* and then find no suitable Begin
3634    afterwards, that if we backtrack the last Prepend, that one will
3635    be a suitable Begin.
3636    */
3637
3638    if (locinput >= PL_regeol)
3639     sayNO;
3640    if  (! do_utf8) {
3641
3642     /* Match either CR LF  or '.', as all the other possibilities
3643     * require utf8 */
3644     locinput++;     /* Match the . or CR */
3645     if (nextchr == '\r'
3646      && locinput < PL_regeol
3647      && UCHARAT(locinput) == '\n') locinput++;
3648    }
3649    else {
3650
3651     /* Utf8: See if is ( CR LF ); already know that locinput <
3652     * PL_regeol, so locinput+1 is in bounds */
3653     if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
3654      locinput += 2;
3655     }
3656     else {
3657      /* In case have to backtrack to beginning, then match '.' */
3658      char *starting = locinput;
3659
3660      /* In case have to backtrack the last prepend */
3661      char *previous_prepend = 0;
3662
3663      LOAD_UTF8_CHARCLASS_GCB();
3664
3665      /* Match (prepend)* */
3666      while (locinput < PL_regeol
3667       && swash_fetch(PL_utf8_X_prepend,
3668           (U8*)locinput, do_utf8))
3669      {
3670       previous_prepend = locinput;
3671       locinput += UTF8SKIP(locinput);
3672      }
3673
3674      /* As noted above, if we matched a prepend character, but
3675      * the next thing won't match, back off the last prepend we
3676      * matched, as it is guaranteed to match the begin */
3677      if (previous_prepend
3678       && (locinput >=  PL_regeol
3679        || ! swash_fetch(PL_utf8_X_begin,
3680            (U8*)locinput, do_utf8)))
3681      {
3682       locinput = previous_prepend;
3683      }
3684
3685      /* Note that here we know PL_regeol > locinput, as we
3686      * tested that upon input to this switch case, and if we
3687      * moved locinput forward, we tested the result just above
3688      * and it either passed, or we backed off so that it will
3689      * now pass */
3690      if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, do_utf8)) {
3691
3692       /* Here did not match the required 'Begin' in the
3693       * second term.  So just match the very first
3694       * character, the '.' of the final term of the regex */
3695       locinput = starting + UTF8SKIP(starting);
3696      } else {
3697
3698       /* Here is the beginning of a character that can have
3699       * an extender.  It is either a hangul syllable, or a
3700       * non-control */
3701       if (swash_fetch(PL_utf8_X_non_hangul,
3702           (U8*)locinput, do_utf8))
3703       {
3704
3705        /* Here not a Hangul syllable, must be a
3706        * ('!  * Control') */
3707        locinput += UTF8SKIP(locinput);
3708       } else {
3709
3710        /* Here is a Hangul syllable.  It can be composed
3711        * of several individual characters.  One
3712        * possibility is T+ */
3713        if (swash_fetch(PL_utf8_X_T,
3714            (U8*)locinput, do_utf8))
3715        {
3716         while (locinput < PL_regeol
3717           && swash_fetch(PL_utf8_X_T,
3718               (U8*)locinput, do_utf8))
3719         {
3720          locinput += UTF8SKIP(locinput);
3721         }
3722        } else {
3723
3724         /* Here, not T+, but is a Hangul.  That means
3725         * it is one of the others: L, LV, LVT or V,
3726         * and matches:
3727         * L* (L | LVT T* | V  V* T* | LV  V* T*) */
3728
3729         /* Match L*           */
3730         while (locinput < PL_regeol
3731           && swash_fetch(PL_utf8_X_L,
3732               (U8*)locinput, do_utf8))
3733         {
3734          locinput += UTF8SKIP(locinput);
3735         }
3736
3737         /* Here, have exhausted L*.  If the next
3738         * character is not an LV, LVT nor V, it means
3739         * we had to have at least one L, so matches L+
3740         * in the original equation, we have a complete
3741         * hangul syllable.  Are done. */
3742
3743         if (locinput < PL_regeol
3744          && swash_fetch(PL_utf8_X_LV_LVT_V,
3745              (U8*)locinput, do_utf8))
3746         {
3747
3748          /* Otherwise keep going.  Must be LV, LVT
3749          * or V.  See if LVT */
3750          if (swash_fetch(PL_utf8_X_LVT,
3751              (U8*)locinput, do_utf8))
3752          {
3753           locinput += UTF8SKIP(locinput);
3754          } else {
3755
3756           /* Must be  V or LV.  Take it, then
3757           * match V*     */
3758           locinput += UTF8SKIP(locinput);
3759           while (locinput < PL_regeol
3760             && swash_fetch(PL_utf8_X_V,
3761               (U8*)locinput, do_utf8))
3762           {
3763            locinput += UTF8SKIP(locinput);
3764           }
3765          }
3766
3767          /* And any of LV, LVT, or V can be followed
3768          * by T*            */
3769          while (locinput < PL_regeol
3770           && swash_fetch(PL_utf8_X_T,
3771               (U8*)locinput,
3772               do_utf8))
3773          {
3774           locinput += UTF8SKIP(locinput);
3775          }
3776         }
3777        }
3778       }
3779
3780       /* Match any extender */
3781       while (locinput < PL_regeol
3782         && swash_fetch(PL_utf8_X_extend,
3783             (U8*)locinput, do_utf8))
3784       {
3785        locinput += UTF8SKIP(locinput);
3786       }
3787      }
3788     }
3789     if (locinput > PL_regeol) sayNO;
3790    }
3791    nextchr = UCHARAT(locinput);
3792    break;
3793
3794   case NREFFL:
3795   {
3796    char *s;
3797    char type;
3798    PL_reg_flags |= RF_tainted;
3799    /* FALL THROUGH */
3800   case NREF:
3801   case NREFF:
3802    type = OP(scan);
3803    n = reg_check_named_buff_matched(rex,scan);
3804
3805    if ( n ) {
3806     type = REF + ( type - NREF );
3807     goto do_ref;
3808    } else {
3809     sayNO;
3810    }
3811    /* unreached */
3812   case REFFL:
3813    PL_reg_flags |= RF_tainted;
3814    /* FALL THROUGH */
3815   case REF:
3816   case REFF:
3817    n = ARG(scan);  /* which paren pair */
3818    type = OP(scan);
3819   do_ref:
3820    ln = PL_regoffs[n].start;
3821    PL_reg_leftiter = PL_reg_maxiter;  /* Void cache */
3822    if (*PL_reglastparen < n || ln == -1)
3823     sayNO;   /* Do not match unless seen CLOSEn. */
3824    if (ln == PL_regoffs[n].end)
3825     break;
3826
3827    s = PL_bostr + ln;
3828    if (do_utf8 && type != REF) { /* REF can do byte comparison */
3829     char *l = locinput;
3830     const char *e = PL_bostr + PL_regoffs[n].end;
3831     /*
3832     * Note that we can't do the "other character" lookup trick as
3833     * in the 8-bit case (no pun intended) because in Unicode we
3834     * have to map both upper and title case to lower case.
3835     */
3836     if (type == REFF) {
3837      while (s < e) {
3838       STRLEN ulen1, ulen2;
3839       U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3840       U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3841
3842       if (l >= PL_regeol)
3843        sayNO;
3844       toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3845       toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3846       if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3847        sayNO;
3848       s += ulen1;
3849       l += ulen2;
3850      }
3851     }
3852     locinput = l;
3853     nextchr = UCHARAT(locinput);
3854     break;
3855    }
3856
3857    /* Inline the first character, for speed. */
3858    if (UCHARAT(s) != nextchr &&
3859     (type == REF ||
3860     (UCHARAT(s) != (type == REFF
3861         ? PL_fold : PL_fold_locale)[nextchr])))
3862     sayNO;
3863    ln = PL_regoffs[n].end - ln;
3864    if (locinput + ln > PL_regeol)
3865     sayNO;
3866    if (ln > 1 && (type == REF
3867       ? memNE(s, locinput, ln)
3868       : (type == REFF
3869        ? ibcmp(s, locinput, ln)
3870        : ibcmp_locale(s, locinput, ln))))
3871     sayNO;
3872    locinput += ln;
3873    nextchr = UCHARAT(locinput);
3874    break;
3875   }
3876   case NOTHING:
3877   case TAIL:
3878    break;
3879   case BACK:
3880    break;
3881
3882 #undef  ST
3883 #define ST st->u.eval
3884   {
3885    SV *ret;
3886    REGEXP *re_sv;
3887    regexp *re;
3888    regexp_internal *rei;
3889    regnode *startpoint;
3890
3891   case GOSTART:
3892   case GOSUB: /*    /(...(?1))/   /(...(?&foo))/   */
3893    if (cur_eval && cur_eval->locinput==locinput) {
3894     if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3895      Perl_croak(aTHX_ "Infinite recursion in regex");
3896     if ( ++nochange_depth > max_nochange_depth )
3897      Perl_croak(aTHX_
3898       "Pattern subroutine nesting without pos change"
3899       " exceeded limit in regex");
3900    } else {
3901     nochange_depth = 0;
3902    }
3903    re_sv = rex_sv;
3904    re = rex;
3905    rei = rexi;
3906    (void)ReREFCNT_inc(rex_sv);
3907    if (OP(scan)==GOSUB) {
3908     startpoint = scan + ARG2L(scan);
3909     ST.close_paren = ARG(scan);
3910    } else {
3911     startpoint = rei->program+1;
3912     ST.close_paren = 0;
3913    }
3914    goto eval_recurse_doit;
3915    /* NOTREACHED */
3916   case EVAL:  /*   /(?{A})B/   /(??{A})B/  and /(?(?{A})X|Y)B/   */
3917    if (cur_eval && cur_eval->locinput==locinput) {
3918     if ( ++nochange_depth > max_nochange_depth )
3919      Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3920    } else {
3921     nochange_depth = 0;
3922    }
3923    {
3924     /* execute the code in the {...} */
3925     dSP;
3926     SV ** const before = SP;
3927     OP_4tree * const oop = PL_op;
3928     COP * const ocurcop = PL_curcop;
3929     PAD *old_comppad;
3930     char *saved_regeol = PL_regeol;
3931
3932     n = ARG(scan);
3933     PL_op = (OP_4tree*)rexi->data->data[n];
3934     DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3935      "  re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3936     PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3937     PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3938
3939     if (sv_yes_mark) {
3940      SV *sv_mrk = get_sv("REGMARK", 1);
3941      sv_setsv(sv_mrk, sv_yes_mark);
3942     }
3943
3944     CALLRUNOPS(aTHX);   /* Scalar context. */
3945     SPAGAIN;
3946     if (SP == before)
3947      ret = &PL_sv_undef;   /* protect against empty (?{}) blocks. */
3948     else {
3949      ret = POPs;
3950      PUTBACK;
3951     }
3952
3953     PL_op = oop;
3954     PAD_RESTORE_LOCAL(old_comppad);
3955     PL_curcop = ocurcop;
3956     PL_regeol = saved_regeol;
3957     if (!logical) {
3958      /* /(?{...})/ */
3959      sv_setsv(save_scalar(PL_replgv), ret);
3960      break;
3961     }
3962    }
3963    if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3964     logical = 0;
3965     {
3966      /* extract RE object from returned value; compiling if
3967      * necessary */
3968      MAGIC *mg = NULL;
3969      REGEXP *rx = NULL;
3970
3971      if (SvROK(ret)) {
3972       SV *const sv = SvRV(ret);
3973
3974       if (SvTYPE(sv) == SVt_REGEXP) {
3975        rx = (REGEXP*) sv;
3976       } else if (SvSMAGICAL(sv)) {
3977        mg = mg_find(sv, PERL_MAGIC_qr);
3978        assert(mg);
3979       }
3980      } else if (SvTYPE(ret) == SVt_REGEXP) {
3981       rx = (REGEXP*) ret;
3982      } else if (SvSMAGICAL(ret)) {
3983       if (SvGMAGICAL(ret)) {
3984        /* I don't believe that there is ever qr magic
3985        here.  */
3986        assert(!mg_find(ret, PERL_MAGIC_qr));
3987        sv_unmagic(ret, PERL_MAGIC_qr);
3988       }
3989       else {
3990        mg = mg_find(ret, PERL_MAGIC_qr);
3991        /* testing suggests mg only ends up non-NULL for
3992        scalars who were upgraded and compiled in the
3993        else block below. In turn, this is only
3994        triggered in the "postponed utf8 string" tests
3995        in t/op/pat.t  */
3996       }
3997      }
3998
3999      if (mg) {
4000       rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
4001       assert(rx);
4002      }
4003      if (rx) {
4004       rx = reg_temp_copy(NULL, rx);
4005      }
4006      else {
4007       U32 pm_flags = 0;
4008       const I32 osize = PL_regsize;
4009
4010       if (DO_UTF8(ret)) {
4011        assert (SvUTF8(ret));
4012       } else if (SvUTF8(ret)) {
4013        /* Not doing UTF-8, despite what the SV says. Is
4014        this only if we're trapped in use 'bytes'?  */
4015        /* Make a copy of the octet sequence, but without
4016        the flag on, as the compiler now honours the
4017        SvUTF8 flag on ret.  */
4018        STRLEN len;
4019        const char *const p = SvPV(ret, len);
4020        ret = newSVpvn_flags(p, len, SVs_TEMP);
4021       }
4022       rx = CALLREGCOMP(ret, pm_flags);
4023       if (!(SvFLAGS(ret)
4024        & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
4025         | SVs_GMG))) {
4026        /* This isn't a first class regexp. Instead, it's
4027        caching a regexp onto an existing, Perl visible
4028        scalar.  */
4029        sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
4030       }
4031       PL_regsize = osize;
4032      }
4033      re_sv = rx;
4034      re = (struct regexp *)SvANY(rx);
4035     }
4036     RXp_MATCH_COPIED_off(re);
4037     re->subbeg = rex->subbeg;
4038     re->sublen = rex->sublen;
4039     rei = RXi_GET(re);
4040     DEBUG_EXECUTE_r(
4041      debug_start_match(re_sv, do_utf8, locinput, PL_regeol,
4042       "Matching embedded");
4043     );
4044     startpoint = rei->program + 1;
4045      ST.close_paren = 0; /* only used for GOSUB */
4046      /* borrowed from regtry */
4047     if (PL_reg_start_tmpl <= re->nparens) {
4048      PL_reg_start_tmpl = re->nparens*3/2 + 3;
4049      if(PL_reg_start_tmp)
4050       Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4051      else
4052       Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4053     }
4054
4055   eval_recurse_doit: /* Share code with GOSUB below this line */
4056     /* run the pattern returned from (??{...}) */
4057     ST.cp = regcppush(0); /* Save *all* the positions. */
4058     REGCP_SET(ST.lastcp);
4059
4060     PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
4061
4062     /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
4063     PL_reglastparen = &re->lastparen;
4064     PL_reglastcloseparen = &re->lastcloseparen;
4065     re->lastparen = 0;
4066     re->lastcloseparen = 0;
4067
4068     PL_reginput = locinput;
4069     PL_regsize = 0;
4070
4071     /* XXXX This is too dramatic a measure... */
4072     PL_reg_maxiter = 0;
4073
4074     ST.toggle_reg_flags = PL_reg_flags;
4075     if (RX_UTF8(re_sv))
4076      PL_reg_flags |= RF_utf8;
4077     else
4078      PL_reg_flags &= ~RF_utf8;
4079     ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
4080
4081     ST.prev_rex = rex_sv;
4082     ST.prev_curlyx = cur_curlyx;
4083     SETREX(rex_sv,re_sv);
4084     rex = re;
4085     rexi = rei;
4086     cur_curlyx = NULL;
4087     ST.B = next;
4088     ST.prev_eval = cur_eval;
4089     cur_eval = st;
4090     /* now continue from first node in postoned RE */
4091     PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
4092     /* NOTREACHED */
4093    }
4094    /* logical is 1,   /(?(?{...})X|Y)/ */
4095    sw = (bool)SvTRUE(ret);
4096    logical = 0;
4097    break;
4098   }
4099
4100   case EVAL_AB: /* cleanup after a successful (??{A})B */
4101    /* note: this is called twice; first after popping B, then A */
4102    PL_reg_flags ^= ST.toggle_reg_flags;
4103    ReREFCNT_dec(rex_sv);
4104    SETREX(rex_sv,ST.prev_rex);
4105    rex = (struct regexp *)SvANY(rex_sv);
4106    rexi = RXi_GET(rex);
4107    regcpblow(ST.cp);
4108    cur_eval = ST.prev_eval;
4109    cur_curlyx = ST.prev_curlyx;
4110
4111    /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4112    PL_reglastparen = &rex->lastparen;
4113    PL_reglastcloseparen = &rex->lastcloseparen;
4114    /* also update PL_regoffs */
4115    PL_regoffs = rex->offs;
4116
4117    /* XXXX This is too dramatic a measure... */
4118    PL_reg_maxiter = 0;
4119    if ( nochange_depth )
4120     nochange_depth--;
4121    sayYES;
4122
4123
4124   case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
4125    /* note: this is called twice; first after popping B, then A */
4126    PL_reg_flags ^= ST.toggle_reg_flags;
4127    ReREFCNT_dec(rex_sv);
4128    SETREX(rex_sv,ST.prev_rex);
4129    rex = (struct regexp *)SvANY(rex_sv);
4130    rexi = RXi_GET(rex);
4131    /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4132    PL_reglastparen = &rex->lastparen;
4133    PL_reglastcloseparen = &rex->lastcloseparen;
4134
4135    PL_reginput = locinput;
4136    REGCP_UNWIND(ST.lastcp);
4137    regcppop(rex);
4138    cur_eval = ST.prev_eval;
4139    cur_curlyx = ST.prev_curlyx;
4140    /* XXXX This is too dramatic a measure... */
4141    PL_reg_maxiter = 0;
4142    if ( nochange_depth )
4143     nochange_depth--;
4144    sayNO_SILENT;
4145 #undef ST
4146
4147   case OPEN:
4148    n = ARG(scan);  /* which paren pair */
4149    PL_reg_start_tmp[n] = locinput;
4150    if (n > PL_regsize)
4151     PL_regsize = n;
4152    lastopen = n;
4153    break;
4154   case CLOSE:
4155    n = ARG(scan);  /* which paren pair */
4156    PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
4157    PL_regoffs[n].end = locinput - PL_bostr;
4158    /*if (n > PL_regsize)
4159     PL_regsize = n;*/
4160    if (n > *PL_reglastparen)
4161     *PL_reglastparen = n;
4162    *PL_reglastcloseparen = n;
4163    if (cur_eval && cur_eval->u.eval.close_paren == n) {
4164     goto fake_end;
4165    }
4166    break;
4167   case ACCEPT:
4168    if (ARG(scan)){
4169     regnode *cursor;
4170     for (cursor=scan;
4171      cursor && OP(cursor)!=END;
4172      cursor=regnext(cursor))
4173     {
4174      if ( OP(cursor)==CLOSE ){
4175       n = ARG(cursor);
4176       if ( n <= lastopen ) {
4177        PL_regoffs[n].start
4178         = PL_reg_start_tmp[n] - PL_bostr;
4179        PL_regoffs[n].end = locinput - PL_bostr;
4180        /*if (n > PL_regsize)
4181        PL_regsize = n;*/
4182        if (n > *PL_reglastparen)
4183         *PL_reglastparen = n;
4184        *PL_reglastcloseparen = n;
4185        if ( n == ARG(scan) || (cur_eval &&
4186         cur_eval->u.eval.close_paren == n))
4187         break;
4188       }
4189      }
4190     }
4191    }
4192    goto fake_end;
4193    /*NOTREACHED*/
4194   case GROUPP:
4195    n = ARG(scan);  /* which paren pair */
4196    sw = (bool)(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
4197    break;
4198   case NGROUPP:
4199    /* reg_check_named_buff_matched returns 0 for no match */
4200    sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
4201    break;
4202   case INSUBP:
4203    n = ARG(scan);
4204    sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
4205    break;
4206   case DEFINEP:
4207    sw = 0;
4208    break;
4209   case IFTHEN:
4210    PL_reg_leftiter = PL_reg_maxiter;  /* Void cache */
4211    if (sw)
4212     next = NEXTOPER(NEXTOPER(scan));
4213    else {
4214     next = scan + ARG(scan);
4215     if (OP(next) == IFTHEN) /* Fake one. */
4216      next = NEXTOPER(NEXTOPER(next));
4217    }
4218    break;
4219   case LOGICAL:
4220    logical = scan->flags;
4221    break;
4222
4223 /*******************************************************************
4224
4225 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
4226 pattern, where A and B are subpatterns. (For simple A, CURLYM or
4227 STAR/PLUS/CURLY/CURLYN are used instead.)
4228
4229 A*B is compiled as <CURLYX><A><WHILEM><B>
4230
4231 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
4232 state, which contains the current count, initialised to -1. It also sets
4233 cur_curlyx to point to this state, with any previous value saved in the
4234 state block.
4235
4236 CURLYX then jumps straight to the WHILEM op, rather than executing A,
4237 since the pattern may possibly match zero times (i.e. it's a while {} loop
4238 rather than a do {} while loop).
4239
4240 Each entry to WHILEM represents a successful match of A. The count in the
4241 CURLYX block is incremented, another WHILEM state is pushed, and execution
4242 passes to A or B depending on greediness and the current count.
4243
4244 For example, if matching against the string a1a2a3b (where the aN are
4245 substrings that match /A/), then the match progresses as follows: (the
4246 pushed states are interspersed with the bits of strings matched so far):
4247
4248  <CURLYX cnt=-1>
4249  <CURLYX cnt=0><WHILEM>
4250  <CURLYX cnt=1><WHILEM> a1 <WHILEM>
4251  <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
4252  <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
4253  <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
4254
4255 (Contrast this with something like CURLYM, which maintains only a single
4256 backtrack state:
4257
4258  <CURLYM cnt=0> a1
4259  a1 <CURLYM cnt=1> a2
4260  a1 a2 <CURLYM cnt=2> a3
4261  a1 a2 a3 <CURLYM cnt=3> b
4262 )
4263
4264 Each WHILEM state block marks a point to backtrack to upon partial failure
4265 of A or B, and also contains some minor state data related to that
4266 iteration.  The CURLYX block, pointed to by cur_curlyx, contains the
4267 overall state, such as the count, and pointers to the A and B ops.
4268
4269 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
4270 must always point to the *current* CURLYX block, the rules are:
4271
4272 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
4273 and set cur_curlyx to point the new block.
4274
4275 When popping the CURLYX block after a successful or unsuccessful match,
4276 restore the previous cur_curlyx.
4277
4278 When WHILEM is about to execute B, save the current cur_curlyx, and set it
4279 to the outer one saved in the CURLYX block.
4280
4281 When popping the WHILEM block after a successful or unsuccessful B match,
4282 restore the previous cur_curlyx.
4283
4284 Here's an example for the pattern (AI* BI)*BO
4285 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
4286
4287 cur_
4288 curlyx backtrack stack
4289 ------ ---------------
4290 NULL
4291 CO     <CO prev=NULL> <WO>
4292 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4293 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4294 NULL   <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
4295
4296 At this point the pattern succeeds, and we work back down the stack to
4297 clean up, restoring as we go:
4298
4299 CO     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4300 CI     <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4301 CO     <CO prev=NULL> <WO>
4302 NULL
4303
4304 *******************************************************************/
4305
4306 #define ST st->u.curlyx
4307
4308   case CURLYX:    /* start of /A*B/  (for complex A) */
4309   {
4310    /* No need to save/restore up to this paren */
4311    I32 parenfloor = scan->flags;
4312
4313    assert(next); /* keep Coverity happy */
4314    if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4315     next += ARG(next);
4316
4317    /* XXXX Probably it is better to teach regpush to support
4318    parenfloor > PL_regsize... */
4319    if (parenfloor > (I32)*PL_reglastparen)
4320     parenfloor = *PL_reglastparen; /* Pessimization... */
4321
4322    ST.prev_curlyx= cur_curlyx;
4323    cur_curlyx = st;
4324    ST.cp = PL_savestack_ix;
4325
4326    /* these fields contain the state of the current curly.
4327    * they are accessed by subsequent WHILEMs */
4328    ST.parenfloor = parenfloor;
4329    ST.min = ARG1(scan);
4330    ST.max = ARG2(scan);
4331    ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4332    ST.B = next;
4333    ST.minmod = minmod;
4334    minmod = 0;
4335    ST.count = -1; /* this will be updated by WHILEM */
4336    ST.lastloc = NULL;  /* this will be updated by WHILEM */
4337
4338    PL_reginput = locinput;
4339    PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4340    /* NOTREACHED */
4341   }
4342
4343   case CURLYX_end: /* just finished matching all of A*B */
4344    cur_curlyx = ST.prev_curlyx;
4345    sayYES;
4346    /* NOTREACHED */
4347
4348   case CURLYX_end_fail: /* just failed to match all of A*B */
4349    regcpblow(ST.cp);
4350    cur_curlyx = ST.prev_curlyx;
4351    sayNO;
4352    /* NOTREACHED */
4353
4354
4355 #undef ST
4356 #define ST st->u.whilem
4357
4358   case WHILEM:     /* just matched an A in /A*B/  (for complex A) */
4359   {
4360    /* see the discussion above about CURLYX/WHILEM */
4361    I32 n;
4362    assert(cur_curlyx); /* keep Coverity happy */
4363    n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4364    ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4365    ST.cache_offset = 0;
4366    ST.cache_mask = 0;
4367
4368    PL_reginput = locinput;
4369
4370    DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4371     "%*s  whilem: matched %ld out of %ld..%ld\n",
4372     REPORT_CODE_OFF+depth*2, "", (long)n,
4373     (long)cur_curlyx->u.curlyx.min,
4374     (long)cur_curlyx->u.curlyx.max)
4375    );
4376
4377    /* First just match a string of min A's. */
4378
4379    if (n < cur_curlyx->u.curlyx.min) {
4380     cur_curlyx->u.curlyx.lastloc = locinput;
4381     PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
4382     /* NOTREACHED */
4383    }
4384
4385    /* If degenerate A matches "", assume A done. */
4386
4387    if (locinput == cur_curlyx->u.curlyx.lastloc) {
4388     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4389     "%*s  whilem: empty match detected, trying continuation...\n",
4390     REPORT_CODE_OFF+depth*2, "")
4391     );
4392     goto do_whilem_B_max;
4393    }
4394
4395    /* super-linear cache processing */
4396
4397    if (scan->flags) {
4398
4399     if (!PL_reg_maxiter) {
4400      /* start the countdown: Postpone detection until we
4401      * know the match is not *that* much linear. */
4402      PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4403      /* possible overflow for long strings and many CURLYX's */
4404      if (PL_reg_maxiter < 0)
4405       PL_reg_maxiter = I32_MAX;
4406      PL_reg_leftiter = PL_reg_maxiter;
4407     }
4408
4409     if (PL_reg_leftiter-- == 0) {
4410      /* initialise cache */
4411      const I32 size = (PL_reg_maxiter + 7)/8;
4412      if (PL_reg_poscache) {
4413       if ((I32)PL_reg_poscache_size < size) {
4414        Renew(PL_reg_poscache, size, char);
4415        PL_reg_poscache_size = size;
4416       }
4417       Zero(PL_reg_poscache, size, char);
4418      }
4419      else {
4420       PL_reg_poscache_size = size;
4421       Newxz(PL_reg_poscache, size, char);
4422      }
4423      DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4424  "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4425        PL_colors[4], PL_colors[5])
4426      );
4427     }
4428
4429     if (PL_reg_leftiter < 0) {
4430      /* have we already failed at this position? */
4431      I32 offset, mask;
4432      offset  = (scan->flags & 0xf) - 1
4433         + (locinput - PL_bostr)  * (scan->flags>>4);
4434      mask    = 1 << (offset % 8);
4435      offset /= 8;
4436      if (PL_reg_poscache[offset] & mask) {
4437       DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4438        "%*s  whilem: (cache) already tried at this position...\n",
4439        REPORT_CODE_OFF+depth*2, "")
4440       );
4441       sayNO; /* cache records failure */
4442      }
4443      ST.cache_offset = offset;
4444      ST.cache_mask   = mask;
4445     }
4446    }
4447
4448    /* Prefer B over A for minimal matching. */
4449
4450    if (cur_curlyx->u.curlyx.minmod) {
4451     ST.save_curlyx = cur_curlyx;
4452     cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4453     ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4454     REGCP_SET(ST.lastcp);
4455     PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4456     /* NOTREACHED */
4457    }
4458
4459    /* Prefer A over B for maximal matching. */
4460
4461    if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
4462     ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4463     cur_curlyx->u.curlyx.lastloc = locinput;
4464     REGCP_SET(ST.lastcp);
4465     PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
4466     /* NOTREACHED */
4467    }
4468    goto do_whilem_B_max;
4469   }
4470   /* NOTREACHED */
4471
4472   case WHILEM_B_min: /* just matched B in a minimal match */
4473   case WHILEM_B_max: /* just matched B in a maximal match */
4474    cur_curlyx = ST.save_curlyx;
4475    sayYES;
4476    /* NOTREACHED */
4477
4478   case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4479    cur_curlyx = ST.save_curlyx;
4480    cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4481    cur_curlyx->u.curlyx.count--;
4482    CACHEsayNO;
4483    /* NOTREACHED */
4484
4485   case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4486    REGCP_UNWIND(ST.lastcp);
4487    regcppop(rex);
4488    /* FALL THROUGH */
4489   case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4490    cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4491    cur_curlyx->u.curlyx.count--;
4492    CACHEsayNO;
4493    /* NOTREACHED */
4494
4495   case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4496    REGCP_UNWIND(ST.lastcp);
4497    regcppop(rex); /* Restore some previous $<digit>s? */
4498    PL_reginput = locinput;
4499    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4500     "%*s  whilem: failed, trying continuation...\n",
4501     REPORT_CODE_OFF+depth*2, "")
4502    );
4503   do_whilem_B_max:
4504    if (cur_curlyx->u.curlyx.count >= REG_INFTY
4505     && ckWARN(WARN_REGEXP)
4506     && !(PL_reg_flags & RF_warned))
4507    {
4508     PL_reg_flags |= RF_warned;
4509     Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4510      "Complex regular subexpression recursion",
4511      REG_INFTY - 1);
4512    }
4513
4514    /* now try B */
4515    ST.save_curlyx = cur_curlyx;
4516    cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4517    PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4518    /* NOTREACHED */
4519
4520   case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4521    cur_curlyx = ST.save_curlyx;
4522    REGCP_UNWIND(ST.lastcp);
4523    regcppop(rex);
4524
4525    if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
4526     /* Maximum greed exceeded */
4527     if (cur_curlyx->u.curlyx.count >= REG_INFTY
4528      && ckWARN(WARN_REGEXP)
4529      && !(PL_reg_flags & RF_warned))
4530     {
4531      PL_reg_flags |= RF_warned;
4532      Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4533       "%s limit (%d) exceeded",
4534       "Complex regular subexpression recursion",
4535       REG_INFTY - 1);
4536     }
4537     cur_curlyx->u.curlyx.count--;
4538     CACHEsayNO;
4539    }
4540
4541    DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4542     "%*s  trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4543    );
4544    /* Try grabbing another A and see if it helps. */
4545    PL_reginput = locinput;
4546    cur_curlyx->u.curlyx.lastloc = locinput;
4547    ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4548    REGCP_SET(ST.lastcp);
4549    PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
4550    /* NOTREACHED */
4551
4552 #undef  ST
4553 #define ST st->u.branch
4554
4555   case BRANCHJ:     /*  /(...|A|...)/ with long next pointer */
4556    next = scan + ARG(scan);
4557    if (next == scan)
4558     next = NULL;
4559    scan = NEXTOPER(scan);
4560    /* FALL THROUGH */
4561
4562   case BRANCH:     /*  /(...|A|...)/ */
4563    scan = NEXTOPER(scan); /* scan now points to inner node */
4564    ST.lastparen = *PL_reglastparen;
4565    ST.next_branch = next;
4566    REGCP_SET(ST.cp);
4567    PL_reginput = locinput;
4568
4569    /* Now go into the branch */
4570    if (has_cutgroup) {
4571     PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4572    } else {
4573     PUSH_STATE_GOTO(BRANCH_next, scan);
4574    }
4575    /* NOTREACHED */
4576   case CUTGROUP:
4577    PL_reginput = locinput;
4578    sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4579     MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4580    PUSH_STATE_GOTO(CUTGROUP_next,next);
4581    /* NOTREACHED */
4582   case CUTGROUP_next_fail:
4583    do_cutgroup = 1;
4584    no_final = 1;
4585    if (st->u.mark.mark_name)
4586     sv_commit = st->u.mark.mark_name;
4587    sayNO;
4588    /* NOTREACHED */
4589   case BRANCH_next:
4590    sayYES;
4591    /* NOTREACHED */
4592   case BRANCH_next_fail: /* that branch failed; try the next, if any */
4593    if (do_cutgroup) {
4594     do_cutgroup = 0;
4595     no_final = 0;
4596    }
4597    REGCP_UNWIND(ST.cp);
4598    for (n = *PL_reglastparen; n > ST.lastparen; n--)
4599     PL_regoffs[n].end = -1;
4600    *PL_reglastparen = n;
4601    /*dmq: *PL_reglastcloseparen = n; */
4602    scan = ST.next_branch;
4603    /* no more branches? */
4604    if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4605     DEBUG_EXECUTE_r({
4606      PerlIO_printf( Perl_debug_log,
4607       "%*s  %sBRANCH failed...%s\n",
4608       REPORT_CODE_OFF+depth*2, "",
4609       PL_colors[4],
4610       PL_colors[5] );
4611     });
4612     sayNO_SILENT;
4613    }
4614    continue; /* execute next BRANCH[J] op */
4615    /* NOTREACHED */
4616
4617   case MINMOD:
4618    minmod = 1;
4619    break;
4620
4621 #undef  ST
4622 #define ST st->u.curlym
4623
4624   case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4625
4626    /* This is an optimisation of CURLYX that enables us to push
4627    * only a single backtracking state, no matter how many matches
4628    * there are in {m,n}. It relies on the pattern being constant
4629    * length, with no parens to influence future backrefs
4630    */
4631
4632    ST.me = scan;
4633    scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4634
4635    /* if paren positive, emulate an OPEN/CLOSE around A */
4636    if (ST.me->flags) {
4637     U32 paren = ST.me->flags;
4638     if (paren > PL_regsize)
4639      PL_regsize = paren;
4640     if (paren > *PL_reglastparen)
4641      *PL_reglastparen = paren;
4642     scan += NEXT_OFF(scan); /* Skip former OPEN. */
4643    }
4644    ST.A = scan;
4645    ST.B = next;
4646    ST.alen = 0;
4647    ST.count = 0;
4648    ST.minmod = minmod;
4649    minmod = 0;
4650    ST.c1 = CHRTEST_UNINIT;
4651    REGCP_SET(ST.cp);
4652
4653    if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4654     goto curlym_do_B;
4655
4656   curlym_do_A: /* execute the A in /A{m,n}B/  */
4657    PL_reginput = locinput;
4658    PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4659    /* NOTREACHED */
4660
4661   case CURLYM_A: /* we've just matched an A */
4662    locinput = st->locinput;
4663    nextchr = UCHARAT(locinput);
4664
4665    ST.count++;
4666    /* after first match, determine A's length: u.curlym.alen */
4667    if (ST.count == 1) {
4668     if (PL_reg_match_utf8) {
4669      char *s = locinput;
4670      while (s < PL_reginput) {
4671       ST.alen++;
4672       s += UTF8SKIP(s);
4673      }
4674     }
4675     else {
4676      ST.alen = PL_reginput - locinput;
4677     }
4678     if (ST.alen == 0)
4679      ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4680    }
4681    DEBUG_EXECUTE_r(
4682     PerlIO_printf(Perl_debug_log,
4683       "%*s  CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4684       (int)(REPORT_CODE_OFF+(depth*2)), "",
4685       (IV) ST.count, (IV)ST.alen)
4686    );
4687
4688    locinput = PL_reginput;
4689
4690    if (cur_eval && cur_eval->u.eval.close_paren &&
4691     cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4692     goto fake_end;
4693
4694    {
4695     I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
4696     if ( max == REG_INFTY || ST.count < max )
4697      goto curlym_do_A; /* try to match another A */
4698    }
4699    goto curlym_do_B; /* try to match B */
4700
4701   case CURLYM_A_fail: /* just failed to match an A */
4702    REGCP_UNWIND(ST.cp);
4703
4704    if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4705     || (cur_eval && cur_eval->u.eval.close_paren &&
4706      cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4707     sayNO;
4708
4709   curlym_do_B: /* execute the B in /A{m,n}B/  */
4710    PL_reginput = locinput;
4711    if (ST.c1 == CHRTEST_UNINIT) {
4712     /* calculate c1 and c2 for possible match of 1st char
4713     * following curly */
4714     ST.c1 = ST.c2 = CHRTEST_VOID;
4715     if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4716      regnode *text_node = ST.B;
4717      if (! HAS_TEXT(text_node))
4718       FIND_NEXT_IMPT(text_node);
4719      /* this used to be
4720
4721       (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4722
4723        But the former is redundant in light of the latter.
4724
4725        if this changes back then the macro for
4726        IS_TEXT and friends need to change.
4727      */
4728      if (PL_regkind[OP(text_node)] == EXACT)
4729      {
4730
4731       ST.c1 = (U8)*STRING(text_node);
4732       ST.c2 =
4733        (IS_TEXTF(text_node))
4734        ? PL_fold[ST.c1]
4735        : (IS_TEXTFL(text_node))
4736         ? PL_fold_locale[ST.c1]
4737         : ST.c1;
4738      }
4739     }
4740    }
4741
4742    DEBUG_EXECUTE_r(
4743     PerlIO_printf(Perl_debug_log,
4744      "%*s  CURLYM trying tail with matches=%"IVdf"...\n",
4745      (int)(REPORT_CODE_OFF+(depth*2)),
4746      "", (IV)ST.count)
4747     );
4748    if (ST.c1 != CHRTEST_VOID
4749      && UCHARAT(PL_reginput) != ST.c1
4750      && UCHARAT(PL_reginput) != ST.c2)
4751    {
4752     /* simulate B failing */
4753     DEBUG_OPTIMISE_r(
4754      PerlIO_printf(Perl_debug_log,
4755       "%*s  CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
4756       (int)(REPORT_CODE_OFF+(depth*2)),"",
4757       (IV)ST.c1,(IV)ST.c2
4758     ));
4759     state_num = CURLYM_B_fail;
4760     goto reenter_switch;
4761    }
4762
4763    if (ST.me->flags) {
4764     /* mark current A as captured */
4765     I32 paren = ST.me->flags;
4766     if (ST.count) {
4767      PL_regoffs[paren].start
4768       = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4769      PL_regoffs[paren].end = PL_reginput - PL_bostr;
4770      /*dmq: *PL_reglastcloseparen = paren; */
4771     }
4772     else
4773      PL_regoffs[paren].end = -1;
4774     if (cur_eval && cur_eval->u.eval.close_paren &&
4775      cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4776     {
4777      if (ST.count)
4778       goto fake_end;
4779      else
4780       sayNO;
4781     }
4782    }
4783
4784    PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4785    /* NOTREACHED */
4786
4787   case CURLYM_B_fail: /* just failed to match a B */
4788    REGCP_UNWIND(ST.cp);
4789    if (ST.minmod) {
4790     I32 max = ARG2(ST.me);
4791     if (max != REG_INFTY && ST.count == max)
4792      sayNO;
4793     goto curlym_do_A; /* try to match a further A */
4794    }
4795    /* backtrack one A */
4796    if (ST.count == ARG1(ST.me) /* min */)
4797     sayNO;
4798    ST.count--;
4799    locinput = HOPc(locinput, -ST.alen);
4800    goto curlym_do_B; /* try to match B */
4801
4802 #undef ST
4803 #define ST st->u.curly
4804
4805 #define CURLY_SETPAREN(paren, success) \
4806  if (paren) { \
4807   if (success) { \
4808    PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
4809    PL_regoffs[paren].end = locinput - PL_bostr; \
4810    *PL_reglastcloseparen = paren; \
4811   } \
4812   else \
4813    PL_regoffs[paren].end = -1; \
4814  }
4815
4816   case STAR:  /*  /A*B/ where A is width 1 */
4817    ST.paren = 0;
4818    ST.min = 0;
4819    ST.max = REG_INFTY;
4820    scan = NEXTOPER(scan);
4821    goto repeat;
4822   case PLUS:  /*  /A+B/ where A is width 1 */
4823    ST.paren = 0;
4824    ST.min = 1;
4825    ST.max = REG_INFTY;
4826    scan = NEXTOPER(scan);
4827    goto repeat;
4828   case CURLYN:  /*  /(A){m,n}B/ where A is width 1 */
4829    ST.paren = scan->flags; /* Which paren to set */
4830    if (ST.paren > PL_regsize)
4831     PL_regsize = ST.paren;
4832    if (ST.paren > *PL_reglastparen)
4833     *PL_reglastparen = ST.paren;
4834    ST.min = ARG1(scan);  /* min to match */
4835    ST.max = ARG2(scan);  /* max to match */
4836    if (cur_eval && cur_eval->u.eval.close_paren &&
4837     cur_eval->u.eval.close_paren == (U32)ST.paren) {
4838     ST.min=1;
4839     ST.max=1;
4840    }
4841    scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4842    goto repeat;
4843   case CURLY:  /*  /A{m,n}B/ where A is width 1 */
4844    ST.paren = 0;
4845    ST.min = ARG1(scan);  /* min to match */
4846    ST.max = ARG2(scan);  /* max to match */
4847    scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4848   repeat:
4849    /*
4850    * Lookahead to avoid useless match attempts
4851    * when we know what character comes next.
4852    *
4853    * Used to only do .*x and .*?x, but now it allows
4854    * for )'s, ('s and (?{ ... })'s to be in the way
4855    * of the quantifier and the EXACT-like node.  -- japhy
4856    */
4857
4858    if (ST.min > ST.max) /* XXX make this a compile-time check? */
4859     sayNO;
4860    if (HAS_TEXT(next) || JUMPABLE(next)) {
4861     U8 *s;
4862     regnode *text_node = next;
4863
4864     if (! HAS_TEXT(text_node))
4865      FIND_NEXT_IMPT(text_node);
4866
4867     if (! HAS_TEXT(text_node))
4868      ST.c1 = ST.c2 = CHRTEST_VOID;
4869     else {
4870      if ( PL_regkind[OP(text_node)] != EXACT ) {
4871       ST.c1 = ST.c2 = CHRTEST_VOID;
4872       goto assume_ok_easy;
4873      }
4874      else
4875       s = (U8*)STRING(text_node);
4876
4877      /*  Currently we only get here when
4878
4879       PL_rekind[OP(text_node)] == EXACT
4880
4881       if this changes back then the macro for IS_TEXT and
4882       friends need to change. */
4883      if (!UTF) {
4884       ST.c2 = ST.c1 = *s;
4885       if (IS_TEXTF(text_node))
4886        ST.c2 = PL_fold[ST.c1];
4887       else if (IS_TEXTFL(text_node))
4888        ST.c2 = PL_fold_locale[ST.c1];
4889      }
4890      else { /* UTF */
4891       if (IS_TEXTF(text_node)) {
4892        STRLEN ulen1, ulen2;
4893        U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4894        U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4895
4896        to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4897        to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4898 #ifdef EBCDIC
4899        ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4900              ckWARN(WARN_UTF8) ?
4901              0 : UTF8_ALLOW_ANY);
4902        ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4903              ckWARN(WARN_UTF8) ?
4904              0 : UTF8_ALLOW_ANY);
4905 #else
4906        ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4907              uniflags);
4908        ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4909              uniflags);
4910 #endif
4911       }
4912       else {
4913        ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4914              uniflags);
4915       }
4916      }
4917     }
4918    }
4919    else
4920     ST.c1 = ST.c2 = CHRTEST_VOID;
4921   assume_ok_easy:
4922
4923    ST.A = scan;
4924    ST.B = next;
4925    PL_reginput = locinput;
4926    if (minmod) {
4927     minmod = 0;
4928     if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4929      sayNO;
4930     ST.count = ST.min;
4931     locinput = PL_reginput;
4932     REGCP_SET(ST.cp);
4933     if (ST.c1 == CHRTEST_VOID)
4934      goto curly_try_B_min;
4935
4936     ST.oldloc = locinput;
4937
4938     /* set ST.maxpos to the furthest point along the
4939     * string that could possibly match */
4940     if  (ST.max == REG_INFTY) {
4941      ST.maxpos = PL_regeol - 1;
4942      if (do_utf8)
4943       while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4944        ST.maxpos--;
4945     }
4946     else if (do_utf8) {
4947      int m = ST.max - ST.min;
4948      for (ST.maxpos = locinput;
4949       m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4950       ST.maxpos += UTF8SKIP(ST.maxpos);
4951     }
4952     else {
4953      ST.maxpos = locinput + ST.max - ST.min;
4954      if (ST.maxpos >= PL_regeol)
4955       ST.maxpos = PL_regeol - 1;
4956     }
4957     goto curly_try_B_min_known;
4958
4959    }
4960    else {
4961     ST.count = regrepeat(rex, ST.A, ST.max, depth);
4962     locinput = PL_reginput;
4963     if (ST.count < ST.min)
4964      sayNO;
4965     if ((ST.count > ST.min)
4966      && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4967     {
4968      /* A{m,n} must come at the end of the string, there's
4969      * no point in backing off ... */
4970      ST.min = ST.count;
4971      /* ...except that $ and \Z can match before *and* after
4972      newline at the end.  Consider "\n\n" =~ /\n+\Z\n/.
4973      We may back off by one in this case. */
4974      if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4975       ST.min--;
4976     }
4977     REGCP_SET(ST.cp);
4978     goto curly_try_B_max;
4979    }
4980    /* NOTREACHED */
4981
4982
4983   case CURLY_B_min_known_fail:
4984    /* failed to find B in a non-greedy match where c1,c2 valid */
4985    if (ST.paren && ST.count)
4986     PL_regoffs[ST.paren].end = -1;
4987
4988    PL_reginput = locinput; /* Could be reset... */
4989    REGCP_UNWIND(ST.cp);
4990    /* Couldn't or didn't -- move forward. */
4991    ST.oldloc = locinput;
4992    if (do_utf8)
4993     locinput += UTF8SKIP(locinput);
4994    else
4995     locinput++;
4996    ST.count++;
4997   curly_try_B_min_known:
4998    /* find the next place where 'B' could work, then call B */
4999    {
5000     int n;
5001     if (do_utf8) {
5002      n = (ST.oldloc == locinput) ? 0 : 1;
5003      if (ST.c1 == ST.c2) {
5004       STRLEN len;
5005       /* set n to utf8_distance(oldloc, locinput) */
5006       while (locinput <= ST.maxpos &&
5007        utf8n_to_uvchr((U8*)locinput,
5008            UTF8_MAXBYTES, &len,
5009            uniflags) != (UV)ST.c1) {
5010        locinput += len;
5011        n++;
5012       }
5013      }
5014      else {
5015       /* set n to utf8_distance(oldloc, locinput) */
5016       while (locinput <= ST.maxpos) {
5017        STRLEN len;
5018        const UV c = utf8n_to_uvchr((U8*)locinput,
5019             UTF8_MAXBYTES, &len,
5020             uniflags);
5021        if (c == (UV)ST.c1 || c == (UV)ST.c2)
5022         break;
5023        locinput += len;
5024        n++;
5025       }
5026      }
5027     }
5028     else {
5029      if (ST.c1 == ST.c2) {
5030       while (locinput <= ST.maxpos &&
5031        UCHARAT(locinput) != ST.c1)
5032        locinput++;
5033      }
5034      else {
5035       while (locinput <= ST.maxpos
5036        && UCHARAT(locinput) != ST.c1
5037        && UCHARAT(locinput) != ST.c2)
5038        locinput++;
5039      }
5040      n = locinput - ST.oldloc;
5041     }
5042     if (locinput > ST.maxpos)
5043      sayNO;
5044     /* PL_reginput == oldloc now */
5045     if (n) {
5046      ST.count += n;
5047      if (regrepeat(rex, ST.A, n, depth) < n)
5048       sayNO;
5049     }
5050     PL_reginput = locinput;
5051     CURLY_SETPAREN(ST.paren, ST.count);
5052     if (cur_eval && cur_eval->u.eval.close_paren &&
5053      cur_eval->u.eval.close_paren == (U32)ST.paren) {
5054      goto fake_end;
5055     }
5056     PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
5057    }
5058    /* NOTREACHED */
5059
5060
5061   case CURLY_B_min_fail:
5062    /* failed to find B in a non-greedy match where c1,c2 invalid */
5063    if (ST.paren && ST.count)
5064     PL_regoffs[ST.paren].end = -1;
5065
5066    REGCP_UNWIND(ST.cp);
5067    /* failed -- move forward one */
5068    PL_reginput = locinput;
5069    if (regrepeat(rex, ST.A, 1, depth)) {
5070     ST.count++;
5071     locinput = PL_reginput;
5072     if (ST.count <= ST.max || (ST.max == REG_INFTY &&
5073       ST.count > 0)) /* count overflow ? */
5074     {
5075     curly_try_B_min:
5076      CURLY_SETPAREN(ST.paren, ST.count);
5077      if (cur_eval && cur_eval->u.eval.close_paren &&
5078       cur_eval->u.eval.close_paren == (U32)ST.paren) {
5079       goto fake_end;
5080      }
5081      PUSH_STATE_GOTO(CURLY_B_min, ST.B);
5082     }
5083    }
5084    sayNO;
5085    /* NOTREACHED */
5086
5087
5088   curly_try_B_max:
5089    /* a successful greedy match: now try to match B */
5090    if (cur_eval && cur_eval->u.eval.close_paren &&
5091     cur_eval->u.eval.close_paren == (U32)ST.paren) {
5092     goto fake_end;
5093    }
5094    {
5095     UV c = 0;
5096     if (ST.c1 != CHRTEST_VOID)
5097      c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
5098           UTF8_MAXBYTES, 0, uniflags)
5099         : (UV) UCHARAT(PL_reginput);
5100     /* If it could work, try it. */
5101     if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
5102      CURLY_SETPAREN(ST.paren, ST.count);
5103      PUSH_STATE_GOTO(CURLY_B_max, ST.B);
5104      /* NOTREACHED */
5105     }
5106    }
5107    /* FALL THROUGH */
5108   case CURLY_B_max_fail:
5109    /* failed to find B in a greedy match */
5110    if (ST.paren && ST.count)
5111     PL_regoffs[ST.paren].end = -1;
5112
5113    REGCP_UNWIND(ST.cp);
5114    /*  back up. */
5115    if (--ST.count < ST.min)
5116     sayNO;
5117    PL_reginput = locinput = HOPc(locinput, -1);
5118    goto curly_try_B_max;
5119
5120 #undef ST
5121
5122   case END:
5123    fake_end:
5124    if (cur_eval) {
5125     /* we've just finished A in /(??{A})B/; now continue with B */
5126     I32 tmpix;
5127     st->u.eval.toggle_reg_flags
5128        = cur_eval->u.eval.toggle_reg_flags;
5129     PL_reg_flags ^= st->u.eval.toggle_reg_flags;
5130
5131     st->u.eval.prev_rex = rex_sv;  /* inner */
5132     SETREX(rex_sv,cur_eval->u.eval.prev_rex);
5133     rex = (struct regexp *)SvANY(rex_sv);
5134     rexi = RXi_GET(rex);
5135     cur_curlyx = cur_eval->u.eval.prev_curlyx;
5136     ReREFCNT_inc(rex_sv);
5137     st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
5138
5139     /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
5140     PL_reglastparen = &rex->lastparen;
5141     PL_reglastcloseparen = &rex->lastcloseparen;
5142
5143     REGCP_SET(st->u.eval.lastcp);
5144     PL_reginput = locinput;
5145
5146     /* Restore parens of the outer rex without popping the
5147     * savestack */
5148     tmpix = PL_savestack_ix;
5149     PL_savestack_ix = cur_eval->u.eval.lastcp;
5150     regcppop(rex);
5151     PL_savestack_ix = tmpix;
5152
5153     st->u.eval.prev_eval = cur_eval;
5154     cur_eval = cur_eval->u.eval.prev_eval;
5155     DEBUG_EXECUTE_r(
5156      PerlIO_printf(Perl_debug_log, "%*s  EVAL trying tail ... %"UVxf"\n",
5157          REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
5158     if ( nochange_depth )
5159      nochange_depth--;
5160
5161     PUSH_YES_STATE_GOTO(EVAL_AB,
5162       st->u.eval.prev_eval->u.eval.B); /* match B */
5163    }
5164
5165    if (locinput < reginfo->till) {
5166     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5167          "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
5168          PL_colors[4],
5169          (long)(locinput - PL_reg_starttry),
5170          (long)(reginfo->till - PL_reg_starttry),
5171          PL_colors[5]));
5172
5173     sayNO_SILENT;  /* Cannot match: too short. */
5174    }
5175    PL_reginput = locinput; /* put where regtry can find it */
5176    sayYES;   /* Success! */
5177
5178   case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
5179    DEBUG_EXECUTE_r(
5180    PerlIO_printf(Perl_debug_log,
5181     "%*s  %ssubpattern success...%s\n",
5182     REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
5183    PL_reginput = locinput; /* put where regtry can find it */
5184    sayYES;   /* Success! */
5185
5186 #undef  ST
5187 #define ST st->u.ifmatch
5188
5189   case SUSPEND: /* (?>A) */
5190    ST.wanted = 1;
5191    PL_reginput = locinput;
5192    goto do_ifmatch;
5193
5194   case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
5195    ST.wanted = 0;
5196    goto ifmatch_trivial_fail_test;
5197
5198   case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
5199    ST.wanted = 1;
5200   ifmatch_trivial_fail_test:
5201    if (scan->flags) {
5202     char * const s = HOPBACKc(locinput, scan->flags);
5203     if (!s) {
5204      /* trivial fail */
5205      if (logical) {
5206       logical = 0;
5207       sw = 1 - (bool)ST.wanted;
5208      }
5209      else if (ST.wanted)
5210       sayNO;
5211      next = scan + ARG(scan);
5212      if (next == scan)
5213       next = NULL;
5214      break;
5215     }
5216     PL_reginput = s;
5217    }
5218    else
5219     PL_reginput = locinput;
5220
5221   do_ifmatch:
5222    ST.me = scan;
5223    ST.logical = logical;
5224    logical = 0; /* XXX: reset state of logical once it has been saved into ST */
5225
5226    /* execute body of (?...A) */
5227    PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
5228    /* NOTREACHED */
5229
5230   case IFMATCH_A_fail: /* body of (?...A) failed */
5231    ST.wanted = !ST.wanted;
5232    /* FALL THROUGH */
5233
5234   case IFMATCH_A: /* body of (?...A) succeeded */
5235    if (ST.logical) {
5236     sw = (bool)ST.wanted;
5237    }
5238    else if (!ST.wanted)
5239     sayNO;
5240
5241    if (OP(ST.me) == SUSPEND)
5242     locinput = PL_reginput;
5243    else {
5244     locinput = PL_reginput = st->locinput;
5245     nextchr = UCHARAT(locinput);
5246    }
5247    scan = ST.me + ARG(ST.me);
5248    if (scan == ST.me)
5249     scan = NULL;
5250    continue; /* execute B */
5251
5252 #undef ST
5253
5254   case LONGJMP:
5255    next = scan + ARG(scan);
5256    if (next == scan)
5257     next = NULL;
5258    break;
5259   case COMMIT:
5260    reginfo->cutpoint = PL_regeol;
5261    /* FALLTHROUGH */
5262   case PRUNE:
5263    PL_reginput = locinput;
5264    if (!scan->flags)
5265     sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5266    PUSH_STATE_GOTO(COMMIT_next,next);
5267    /* NOTREACHED */
5268   case COMMIT_next_fail:
5269    no_final = 1;
5270    /* FALLTHROUGH */
5271   case OPFAIL:
5272    sayNO;
5273    /* NOTREACHED */
5274
5275 #define ST st->u.mark
5276   case MARKPOINT:
5277    ST.prev_mark = mark_state;
5278    ST.mark_name = sv_commit = sv_yes_mark
5279     = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5280    mark_state = st;
5281    ST.mark_loc = PL_reginput = locinput;
5282    PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5283    /* NOTREACHED */
5284   case MARKPOINT_next:
5285    mark_state = ST.prev_mark;
5286    sayYES;
5287    /* NOTREACHED */
5288   case MARKPOINT_next_fail:
5289    if (popmark && sv_eq(ST.mark_name,popmark))
5290    {
5291     if (ST.mark_loc > startpoint)
5292      reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5293     popmark = NULL; /* we found our mark */
5294     sv_commit = ST.mark_name;
5295
5296     DEBUG_EXECUTE_r({
5297       PerlIO_printf(Perl_debug_log,
5298        "%*s  %ssetting cutpoint to mark:%"SVf"...%s\n",
5299        REPORT_CODE_OFF+depth*2, "",
5300        PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
5301     });
5302    }
5303    mark_state = ST.prev_mark;
5304    sv_yes_mark = mark_state ?
5305     mark_state->u.mark.mark_name : NULL;
5306    sayNO;
5307    /* NOTREACHED */
5308   case SKIP:
5309    PL_reginput = locinput;
5310    if (scan->flags) {
5311     /* (*SKIP) : if we fail we cut here*/
5312     ST.mark_name = NULL;
5313     ST.mark_loc = locinput;
5314     PUSH_STATE_GOTO(SKIP_next,next);
5315    } else {
5316     /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5317     otherwise do nothing.  Meaning we need to scan
5318     */
5319     regmatch_state *cur = mark_state;
5320     SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5321
5322     while (cur) {
5323      if ( sv_eq( cur->u.mark.mark_name,
5324         find ) )
5325      {
5326       ST.mark_name = find;
5327       PUSH_STATE_GOTO( SKIP_next, next );
5328      }
5329      cur = cur->u.mark.prev_mark;
5330     }
5331    }
5332    /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5333    break;
5334   case SKIP_next_fail:
5335    if (ST.mark_name) {
5336     /* (*CUT:NAME) - Set up to search for the name as we
5337     collapse the stack*/
5338     popmark = ST.mark_name;
5339    } else {
5340     /* (*CUT) - No name, we cut here.*/
5341     if (ST.mark_loc > startpoint)
5342      reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5343     /* but we set sv_commit to latest mark_name if there
5344     is one so they can test to see how things lead to this
5345     cut */
5346     if (mark_state)
5347      sv_commit=mark_state->u.mark.mark_name;
5348    }
5349    no_final = 1;
5350    sayNO;
5351    /* NOTREACHED */
5352 #undef ST
5353   case FOLDCHAR:
5354    n = ARG(scan);
5355    if ( n == (U32)what_len_TRICKYFOLD(locinput,do_utf8,ln) ) {
5356     locinput += ln;
5357    } else if ( 0xDF == n && !do_utf8 && !UTF ) {
5358     sayNO;
5359    } else  {
5360     U8 folded[UTF8_MAXBYTES_CASE+1];
5361     STRLEN foldlen;
5362     const char * const l = locinput;
5363     char *e = PL_regeol;
5364     to_uni_fold(n, folded, &foldlen);
5365
5366     if (ibcmp_utf8((const char*) folded, 0,  foldlen, 1,
5367        l, &e, 0,  do_utf8)) {
5368       sayNO;
5369     }
5370     locinput = e;
5371    }
5372    nextchr = UCHARAT(locinput);
5373    break;
5374   case LNBREAK:
5375    if ((n=is_LNBREAK(locinput,do_utf8))) {
5376     locinput += n;
5377     nextchr = UCHARAT(locinput);
5378    } else
5379     sayNO;
5380    break;
5381
5382 #define CASE_CLASS(nAmE)                              \
5383   case nAmE:                                    \
5384    if ((n=is_##nAmE(locinput,do_utf8))) {    \
5385     locinput += n;                        \
5386     nextchr = UCHARAT(locinput);          \
5387    } else                                    \
5388     sayNO;                                \
5389    break;                                    \
5390   case N##nAmE:                                 \
5391    if ((n=is_##nAmE(locinput,do_utf8))) {    \
5392     sayNO;                                \
5393    } else {                                  \
5394     locinput += UTF8SKIP(locinput);       \
5395     nextchr = UCHARAT(locinput);          \
5396    }                                         \
5397    break
5398
5399   CASE_CLASS(VERTWS);
5400   CASE_CLASS(HORIZWS);
5401 #undef CASE_CLASS
5402
5403   default:
5404    PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5405       PTR2UV(scan), OP(scan));
5406    Perl_croak(aTHX_ "regexp memory corruption");
5407
5408   } /* end switch */
5409
5410   /* switch break jumps here */
5411   scan = next; /* prepare to execute the next op and ... */
5412   continue;    /* ... jump back to the top, reusing st */
5413   /* NOTREACHED */
5414
5415  push_yes_state:
5416   /* push a state that backtracks on success */
5417   st->u.yes.prev_yes_state = yes_state;
5418   yes_state = st;
5419   /* FALL THROUGH */
5420  push_state:
5421   /* push a new regex state, then continue at scan  */
5422   {
5423    regmatch_state *newst;
5424
5425    DEBUG_STACK_r({
5426     regmatch_state *cur = st;
5427     regmatch_state *curyes = yes_state;
5428     int curd = depth;
5429     regmatch_slab *slab = PL_regmatch_slab;
5430     for (;curd > -1;cur--,curd--) {
5431      if (cur < SLAB_FIRST(slab)) {
5432       slab = slab->prev;
5433       cur = SLAB_LAST(slab);
5434      }
5435      PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5436       REPORT_CODE_OFF + 2 + depth * 2,"",
5437       curd, PL_reg_name[cur->resume_state],
5438       (curyes == cur) ? "yes" : ""
5439      );
5440      if (curyes == cur)
5441       curyes = cur->u.yes.prev_yes_state;
5442     }
5443    } else
5444     DEBUG_STATE_pp("push")
5445    );
5446    depth++;
5447    st->locinput = locinput;
5448    newst = st+1;
5449    if (newst >  SLAB_LAST(PL_regmatch_slab))
5450     newst = S_push_slab(aTHX);
5451    PL_regmatch_state = newst;
5452
5453    locinput = PL_reginput;
5454    nextchr = UCHARAT(locinput);
5455    st = newst;
5456    continue;
5457    /* NOTREACHED */
5458   }
5459  }
5460
5461  /*
5462  * We get here only if there's trouble -- normally "case END" is
5463  * the terminating point.
5464  */
5465  Perl_croak(aTHX_ "corrupted regexp pointers");
5466  /*NOTREACHED*/
5467  sayNO;
5468
5469 yes:
5470  if (yes_state) {
5471   /* we have successfully completed a subexpression, but we must now
5472   * pop to the state marked by yes_state and continue from there */
5473   assert(st != yes_state);
5474 #ifdef DEBUGGING
5475   while (st != yes_state) {
5476    st--;
5477    if (st < SLAB_FIRST(PL_regmatch_slab)) {
5478     PL_regmatch_slab = PL_regmatch_slab->prev;
5479     st = SLAB_LAST(PL_regmatch_slab);
5480    }
5481    DEBUG_STATE_r({
5482     if (no_final) {
5483      DEBUG_STATE_pp("pop (no final)");
5484     } else {
5485      DEBUG_STATE_pp("pop (yes)");
5486     }
5487    });
5488    depth--;
5489   }
5490 #else
5491   while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5492    || yes_state > SLAB_LAST(PL_regmatch_slab))
5493   {
5494    /* not in this slab, pop slab */
5495    depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5496    PL_regmatch_slab = PL_regmatch_slab->prev;
5497    st = SLAB_LAST(PL_regmatch_slab);
5498   }
5499   depth -= (st - yes_state);
5500 #endif
5501   st = yes_state;
5502   yes_state = st->u.yes.prev_yes_state;
5503   PL_regmatch_state = st;
5504
5505   if (no_final) {
5506    locinput= st->locinput;
5507    nextchr = UCHARAT(locinput);
5508   }
5509   state_num = st->resume_state + no_final;
5510   goto reenter_switch;
5511  }
5512
5513  DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5514       PL_colors[4], PL_colors[5]));
5515
5516  if (PL_reg_eval_set) {
5517   /* each successfully executed (?{...}) block does the equivalent of
5518   *   local $^R = do {...}
5519   * When popping the save stack, all these locals would be undone;
5520   * bypass this by setting the outermost saved $^R to the latest
5521   * value */
5522   if (oreplsv != GvSV(PL_replgv))
5523    sv_setsv(oreplsv, GvSV(PL_replgv));
5524  }
5525  result = 1;
5526  goto final_exit;
5527
5528 no:
5529  DEBUG_EXECUTE_r(
5530   PerlIO_printf(Perl_debug_log,
5531    "%*s  %sfailed...%s\n",
5532    REPORT_CODE_OFF+depth*2, "",
5533    PL_colors[4], PL_colors[5])
5534   );
5535
5536 no_silent:
5537  if (no_final) {
5538   if (yes_state) {
5539    goto yes;
5540   } else {
5541    goto final_exit;
5542   }
5543  }
5544  if (depth) {
5545   /* there's a previous state to backtrack to */
5546   st--;
5547   if (st < SLAB_FIRST(PL_regmatch_slab)) {
5548    PL_regmatch_slab = PL_regmatch_slab->prev;
5549    st = SLAB_LAST(PL_regmatch_slab);
5550   }
5551   PL_regmatch_state = st;
5552   locinput= st->locinput;
5553   nextchr = UCHARAT(locinput);
5554
5555   DEBUG_STATE_pp("pop");
5556   depth--;
5557   if (yes_state == st)
5558    yes_state = st->u.yes.prev_yes_state;
5559
5560   state_num = st->resume_state + 1; /* failure = success + 1 */
5561   goto reenter_switch;
5562  }
5563  result = 0;
5564
5565   final_exit:
5566  if (rex->intflags & PREGf_VERBARG_SEEN) {
5567   SV *sv_err = get_sv("REGERROR", 1);
5568   SV *sv_mrk = get_sv("REGMARK", 1);
5569   if (result) {
5570    sv_commit = &PL_sv_no;
5571    if (!sv_yes_mark)
5572     sv_yes_mark = &PL_sv_yes;
5573   } else {
5574    if (!sv_commit)
5575     sv_commit = &PL_sv_yes;
5576    sv_yes_mark = &PL_sv_no;
5577   }
5578   sv_setsv(sv_err, sv_commit);
5579   sv_setsv(sv_mrk, sv_yes_mark);
5580  }
5581
5582  /* clean up; in particular, free all slabs above current one */
5583  LEAVE_SCOPE(oldsave);
5584
5585  return result;
5586 }
5587
5588 /*
5589  - regrepeat - repeatedly match something simple, report how many
5590  */
5591 /*
5592  * [This routine now assumes that it will only match on things of length 1.
5593  * That was true before, but now we assume scan - reginput is the count,
5594  * rather than incrementing count on every character.  [Er, except utf8.]]
5595  */
5596 STATIC I32
5597 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5598 {
5599  dVAR;
5600  register char *scan;
5601  register I32 c;
5602  register char *loceol = PL_regeol;
5603  register I32 hardcount = 0;
5604  register bool do_utf8 = PL_reg_match_utf8;
5605 #ifndef DEBUGGING
5606  PERL_UNUSED_ARG(depth);
5607 #endif
5608
5609  PERL_ARGS_ASSERT_REGREPEAT;
5610
5611  scan = PL_reginput;
5612  if (max == REG_INFTY)
5613   max = I32_MAX;
5614  else if (max < loceol - scan)
5615   loceol = scan + max;
5616  switch (OP(p)) {
5617  case REG_ANY:
5618   if (do_utf8) {
5619    loceol = PL_regeol;
5620    while (scan < loceol && hardcount < max && *scan != '\n') {
5621     scan += UTF8SKIP(scan);
5622     hardcount++;
5623    }
5624   } else {
5625    while (scan < loceol && *scan != '\n')
5626     scan++;
5627   }
5628   break;
5629  case SANY:
5630   if (do_utf8) {
5631    loceol = PL_regeol;
5632    while (scan < loceol && hardcount < max) {
5633     scan += UTF8SKIP(scan);
5634     hardcount++;
5635    }
5636   }
5637   else
5638    scan = loceol;
5639   break;
5640  case CANY:
5641   scan = loceol;
5642   break;
5643  case EXACT:  /* length of string is 1 */
5644   c = (U8)*STRING(p);
5645   while (scan < loceol && UCHARAT(scan) == c)
5646    scan++;
5647   break;
5648  case EXACTF: /* length of string is 1 */
5649   c = (U8)*STRING(p);
5650   while (scan < loceol &&
5651    (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5652    scan++;
5653   break;
5654  case EXACTFL: /* length of string is 1 */
5655   PL_reg_flags |= RF_tainted;
5656   c = (U8)*STRING(p);
5657   while (scan < loceol &&
5658    (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5659    scan++;
5660   break;
5661  case ANYOF:
5662   if (do_utf8) {
5663    loceol = PL_regeol;
5664    while (hardcount < max && scan < loceol &&
5665     reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
5666     scan += UTF8SKIP(scan);
5667     hardcount++;
5668    }
5669   } else {
5670    while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5671     scan++;
5672   }
5673   break;
5674  case ALNUM:
5675   if (do_utf8) {
5676    loceol = PL_regeol;
5677    LOAD_UTF8_CHARCLASS_ALNUM();
5678    while (hardcount < max && scan < loceol &&
5679     swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5680     scan += UTF8SKIP(scan);
5681     hardcount++;
5682    }
5683   } else {
5684    while (scan < loceol && isALNUM(*scan))
5685     scan++;
5686   }
5687   break;
5688  case ALNUML:
5689   PL_reg_flags |= RF_tainted;
5690   if (do_utf8) {
5691    loceol = PL_regeol;
5692    while (hardcount < max && scan < loceol &&
5693     isALNUM_LC_utf8((U8*)scan)) {
5694     scan += UTF8SKIP(scan);
5695     hardcount++;
5696    }
5697   } else {
5698    while (scan < loceol && isALNUM_LC(*scan))
5699     scan++;
5700   }
5701   break;
5702  case NALNUM:
5703   if (do_utf8) {
5704    loceol = PL_regeol;
5705    LOAD_UTF8_CHARCLASS_ALNUM();
5706    while (hardcount < max && scan < loceol &&
5707     !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5708     scan += UTF8SKIP(scan);
5709     hardcount++;
5710    }
5711   } else {
5712    while (scan < loceol && !isALNUM(*scan))
5713     scan++;
5714   }
5715   break;
5716  case NALNUML:
5717   PL_reg_flags |= RF_tainted;
5718   if (do_utf8) {
5719    loceol = PL_regeol;
5720    while (hardcount < max && scan < loceol &&
5721     !isALNUM_LC_utf8((U8*)scan)) {
5722     scan += UTF8SKIP(scan);
5723     hardcount++;
5724    }
5725   } else {
5726    while (scan < loceol && !isALNUM_LC(*scan))
5727     scan++;
5728   }
5729   break;
5730  case SPACE:
5731   if (do_utf8) {
5732    loceol = PL_regeol;
5733    LOAD_UTF8_CHARCLASS_SPACE();
5734    while (hardcount < max && scan < loceol &&
5735     (*scan == ' ' ||
5736      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5737     scan += UTF8SKIP(scan);
5738     hardcount++;
5739    }
5740   } else {
5741    while (scan < loceol && isSPACE(*scan))
5742     scan++;
5743   }
5744   break;
5745  case SPACEL:
5746   PL_reg_flags |= RF_tainted;
5747   if (do_utf8) {
5748    loceol = PL_regeol;
5749    while (hardcount < max && scan < loceol &&
5750     (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5751     scan += UTF8SKIP(scan);
5752     hardcount++;
5753    }
5754   } else {
5755    while (scan < loceol && isSPACE_LC(*scan))
5756     scan++;
5757   }
5758   break;
5759  case NSPACE:
5760   if (do_utf8) {
5761    loceol = PL_regeol;
5762    LOAD_UTF8_CHARCLASS_SPACE();
5763    while (hardcount < max && scan < loceol &&
5764     !(*scan == ' ' ||
5765      swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5766     scan += UTF8SKIP(scan);
5767     hardcount++;
5768    }
5769   } else {
5770    while (scan < loceol && !isSPACE(*scan))
5771     scan++;
5772   }
5773   break;
5774  case NSPACEL:
5775   PL_reg_flags |= RF_tainted;
5776   if (do_utf8) {
5777    loceol = PL_regeol;
5778    while (hardcount < max && scan < loceol &&
5779     !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5780     scan += UTF8SKIP(scan);
5781     hardcount++;
5782    }
5783   } else {
5784    while (scan < loceol && !isSPACE_LC(*scan))
5785     scan++;
5786   }
5787   break;
5788  case DIGIT:
5789   if (do_utf8) {
5790    loceol = PL_regeol;
5791    LOAD_UTF8_CHARCLASS_DIGIT();
5792    while (hardcount < max && scan < loceol &&
5793     swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5794     scan += UTF8SKIP(scan);
5795     hardcount++;
5796    }
5797   } else {
5798    while (scan < loceol && isDIGIT(*scan))
5799     scan++;
5800   }
5801   break;
5802  case NDIGIT:
5803   if (do_utf8) {
5804    loceol = PL_regeol;
5805    LOAD_UTF8_CHARCLASS_DIGIT();
5806    while (hardcount < max && scan < loceol &&
5807     !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5808     scan += UTF8SKIP(scan);
5809     hardcount++;
5810    }
5811   } else {
5812    while (scan < loceol && !isDIGIT(*scan))
5813     scan++;
5814   }
5815  case LNBREAK:
5816   if (do_utf8) {
5817    loceol = PL_regeol;
5818    while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
5819     scan += c;
5820     hardcount++;
5821    }
5822   } else {
5823    /*
5824    LNBREAK can match two latin chars, which is ok,
5825    because we have a null terminated string, but we
5826    have to use hardcount in this situation
5827    */
5828    while (scan < loceol && (c=is_LNBREAK_latin1(scan)))  {
5829     scan+=c;
5830     hardcount++;
5831    }
5832   }
5833   break;
5834  case HORIZWS:
5835   if (do_utf8) {
5836    loceol = PL_regeol;
5837    while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
5838     scan += c;
5839     hardcount++;
5840    }
5841   } else {
5842    while (scan < loceol && is_HORIZWS_latin1(scan))
5843     scan++;
5844   }
5845   break;
5846  case NHORIZWS:
5847   if (do_utf8) {
5848    loceol = PL_regeol;
5849    while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
5850     scan += UTF8SKIP(scan);
5851     hardcount++;
5852    }
5853   } else {
5854    while (scan < loceol && !is_HORIZWS_latin1(scan))
5855     scan++;
5856
5857   }
5858   break;
5859  case VERTWS:
5860   if (do_utf8) {
5861    loceol = PL_regeol;
5862    while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
5863     scan += c;
5864     hardcount++;
5865    }
5866   } else {
5867    while (scan < loceol && is_VERTWS_latin1(scan))
5868     scan++;
5869
5870   }
5871   break;
5872  case NVERTWS:
5873   if (do_utf8) {
5874    loceol = PL_regeol;
5875    while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
5876     scan += UTF8SKIP(scan);
5877     hardcount++;
5878    }
5879   } else {
5880    while (scan < loceol && !is_VERTWS_latin1(scan))
5881     scan++;
5882
5883   }
5884   break;
5885
5886  default:  /* Called on something of 0 width. */
5887   break;  /* So match right here or not at all. */
5888  }
5889
5890  if (hardcount)
5891   c = hardcount;
5892  else
5893   c = scan - PL_reginput;
5894  PL_reginput = scan;
5895
5896  DEBUG_r({
5897   GET_RE_DEBUG_FLAGS_DECL;
5898   DEBUG_EXECUTE_r({
5899    SV * const prop = sv_newmortal();
5900    regprop(prog, prop, p);
5901    PerlIO_printf(Perl_debug_log,
5902       "%*s  %s can match %"IVdf" times out of %"IVdf"...\n",
5903       REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5904   });
5905  });
5906
5907  return(c);
5908 }
5909
5910
5911 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5912 /*
5913 - regclass_swash - prepare the utf8 swash
5914 */
5915
5916 SV *
5917 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5918 {
5919  dVAR;
5920  SV *sw  = NULL;
5921  SV *si  = NULL;
5922  SV *alt = NULL;
5923  RXi_GET_DECL(prog,progi);
5924  const struct reg_data * const data = prog ? progi->data : NULL;
5925
5926  PERL_ARGS_ASSERT_REGCLASS_SWASH;
5927
5928  if (data && data->count) {
5929   const U32 n = ARG(node);
5930
5931   if (data->what[n] == 's') {
5932    SV * const rv = MUTABLE_SV(data->data[n]);
5933    AV * const av = MUTABLE_AV(SvRV(rv));
5934    SV **const ary = AvARRAY(av);
5935    SV **a, **b;
5936
5937    /* See the end of regcomp.c:S_regclass() for
5938    * documentation of these array elements. */
5939
5940    si = *ary;
5941    a  = SvROK(ary[1]) ? &ary[1] : NULL;
5942    b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
5943
5944    if (a)
5945     sw = *a;
5946    else if (si && doinit) {
5947     sw = swash_init("utf8", "", si, 1, 0);
5948     (void)av_store(av, 1, sw);
5949    }
5950    if (b)
5951     alt = *b;
5952   }
5953  }
5954
5955  if (listsvp)
5956   *listsvp = si;
5957  if (altsvp)
5958   *altsvp  = alt;
5959
5960  return sw;
5961 }
5962 #endif
5963
5964 /*
5965  - reginclass - determine if a character falls into a character class
5966
5967   The n is the ANYOF regnode, the p is the target string, lenp
5968   is pointer to the maximum length of how far to go in the p
5969   (if the lenp is zero, UTF8SKIP(p) is used),
5970   do_utf8 tells whether the target string is in UTF-8.
5971
5972  */
5973
5974 STATIC bool
5975 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5976 {
5977  dVAR;
5978  const char flags = ANYOF_FLAGS(n);
5979  bool match = FALSE;
5980  UV c = *p;
5981  STRLEN len = 0;
5982  STRLEN plen;
5983
5984  PERL_ARGS_ASSERT_REGINCLASS;
5985
5986  if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5987   c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5988     (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
5989     | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
5990     /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
5991     * UTF8_ALLOW_FFFF */
5992   if (len == (STRLEN)-1)
5993    Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5994  }
5995
5996  plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5997  if (do_utf8 || (flags & ANYOF_UNICODE)) {
5998   if (lenp)
5999    *lenp = 0;
6000   if (do_utf8 && !ANYOF_RUNTIME(n)) {
6001    if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
6002     match = TRUE;
6003   }
6004   if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
6005    match = TRUE;
6006   if (!match) {
6007    AV *av;
6008    SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
6009
6010    if (sw) {
6011     U8 * utf8_p;
6012     if (do_utf8) {
6013      utf8_p = (U8 *) p;
6014     } else {
6015      STRLEN len = 1;
6016      utf8_p = bytes_to_utf8(p, &len);
6017     }
6018     if (swash_fetch(sw, utf8_p, 1))
6019      match = TRUE;
6020     else if (flags & ANYOF_FOLD) {
6021      if (!match && lenp && av) {
6022       I32 i;
6023       for (i = 0; i <= av_len(av); i++) {
6024        SV* const sv = *av_fetch(av, i, FALSE);
6025        STRLEN len;
6026        const char * const s = SvPV_const(sv, len);
6027        if (len <= plen && memEQ(s, (char*)utf8_p, len)) {
6028         *lenp = len;
6029         match = TRUE;
6030         break;
6031        }
6032       }
6033      }
6034      if (!match) {
6035       U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
6036
6037       STRLEN tmplen;
6038       to_utf8_fold(utf8_p, tmpbuf, &tmplen);
6039       if (swash_fetch(sw, tmpbuf, 1))
6040        match = TRUE;
6041      }
6042     }
6043
6044     /* If we allocated a string above, free it */
6045     if (! do_utf8) Safefree(utf8_p);
6046    }
6047   }
6048   if (match && lenp && *lenp == 0)
6049    *lenp = UNISKIP(NATIVE_TO_UNI(c));
6050  }
6051  if (!match && c < 256) {
6052   if (ANYOF_BITMAP_TEST(n, c))
6053    match = TRUE;
6054   else if (flags & ANYOF_FOLD) {
6055    U8 f;
6056
6057    if (flags & ANYOF_LOCALE) {
6058     PL_reg_flags |= RF_tainted;
6059     f = PL_fold_locale[c];
6060    }
6061    else
6062     f = PL_fold[c];
6063    if (f != c && ANYOF_BITMAP_TEST(n, f))
6064     match = TRUE;
6065   }
6066
6067   if (!match && (flags & ANYOF_CLASS)) {
6068    PL_reg_flags |= RF_tainted;
6069    if (
6070     (ANYOF_CLASS_TEST(n, ANYOF_ALNUM)   &&  isALNUM_LC(c))  ||
6071     (ANYOF_CLASS_TEST(n, ANYOF_NALNUM)  && !isALNUM_LC(c))  ||
6072     (ANYOF_CLASS_TEST(n, ANYOF_SPACE)   &&  isSPACE_LC(c))  ||
6073     (ANYOF_CLASS_TEST(n, ANYOF_NSPACE)  && !isSPACE_LC(c))  ||
6074     (ANYOF_CLASS_TEST(n, ANYOF_DIGIT)   &&  isDIGIT_LC(c))  ||
6075     (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT)  && !isDIGIT_LC(c))  ||
6076     (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC)  &&  isALNUMC_LC(c)) ||
6077     (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
6078     (ANYOF_CLASS_TEST(n, ANYOF_ALPHA)   &&  isALPHA_LC(c))  ||
6079     (ANYOF_CLASS_TEST(n, ANYOF_NALPHA)  && !isALPHA_LC(c))  ||
6080     (ANYOF_CLASS_TEST(n, ANYOF_ASCII)   &&  isASCII(c))     ||
6081     (ANYOF_CLASS_TEST(n, ANYOF_NASCII)  && !isASCII(c))     ||
6082     (ANYOF_CLASS_TEST(n, ANYOF_CNTRL)   &&  isCNTRL_LC(c))  ||
6083     (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL)  && !isCNTRL_LC(c))  ||
6084     (ANYOF_CLASS_TEST(n, ANYOF_GRAPH)   &&  isGRAPH_LC(c))  ||
6085     (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH)  && !isGRAPH_LC(c))  ||
6086     (ANYOF_CLASS_TEST(n, ANYOF_LOWER)   &&  isLOWER_LC(c))  ||
6087     (ANYOF_CLASS_TEST(n, ANYOF_NLOWER)  && !isLOWER_LC(c))  ||
6088     (ANYOF_CLASS_TEST(n, ANYOF_PRINT)   &&  isPRINT_LC(c))  ||
6089     (ANYOF_CLASS_TEST(n, ANYOF_NPRINT)  && !isPRINT_LC(c))  ||
6090     (ANYOF_CLASS_TEST(n, ANYOF_PUNCT)   &&  isPUNCT_LC(c))  ||
6091     (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT)  && !isPUNCT_LC(c))  ||
6092     (ANYOF_CLASS_TEST(n, ANYOF_UPPER)   &&  isUPPER_LC(c))  ||
6093     (ANYOF_CLASS_TEST(n, ANYOF_NUPPER)  && !isUPPER_LC(c))  ||
6094     (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT)  &&  isXDIGIT(c))    ||
6095     (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c))    ||
6096     (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC)  &&  isPSXSPC(c))    ||
6097     (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c))    ||
6098     (ANYOF_CLASS_TEST(n, ANYOF_BLANK)   &&  isBLANK(c))     ||
6099     (ANYOF_CLASS_TEST(n, ANYOF_NBLANK)  && !isBLANK(c))
6100     ) /* How's that for a conditional? */
6101    {
6102     match = TRUE;
6103    }
6104   }
6105  }
6106
6107  return (flags & ANYOF_INVERT) ? !match : match;
6108 }
6109
6110 STATIC U8 *
6111 S_reghop3(U8 *s, I32 off, const U8* lim)
6112 {
6113  dVAR;
6114
6115  PERL_ARGS_ASSERT_REGHOP3;
6116
6117  if (off >= 0) {
6118   while (off-- && s < lim) {
6119    /* XXX could check well-formedness here */
6120    s += UTF8SKIP(s);
6121   }
6122  }
6123  else {
6124   while (off++ && s > lim) {
6125    s--;
6126    if (UTF8_IS_CONTINUED(*s)) {
6127     while (s > lim && UTF8_IS_CONTINUATION(*s))
6128      s--;
6129    }
6130    /* XXX could check well-formedness here */
6131   }
6132  }
6133  return s;
6134 }
6135
6136 #ifdef XXX_dmq
6137 /* there are a bunch of places where we use two reghop3's that should
6138    be replaced with this routine. but since thats not done yet
6139    we ifdef it out - dmq
6140 */
6141 STATIC U8 *
6142 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
6143 {
6144  dVAR;
6145
6146  PERL_ARGS_ASSERT_REGHOP4;
6147
6148  if (off >= 0) {
6149   while (off-- && s < rlim) {
6150    /* XXX could check well-formedness here */
6151    s += UTF8SKIP(s);
6152   }
6153  }
6154  else {
6155   while (off++ && s > llim) {
6156    s--;
6157    if (UTF8_IS_CONTINUED(*s)) {
6158     while (s > llim && UTF8_IS_CONTINUATION(*s))
6159      s--;
6160    }
6161    /* XXX could check well-formedness here */
6162   }
6163  }
6164  return s;
6165 }
6166 #endif
6167
6168 STATIC U8 *
6169 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
6170 {
6171  dVAR;
6172
6173  PERL_ARGS_ASSERT_REGHOPMAYBE3;
6174
6175  if (off >= 0) {
6176   while (off-- && s < lim) {
6177    /* XXX could check well-formedness here */
6178    s += UTF8SKIP(s);
6179   }
6180   if (off >= 0)
6181    return NULL;
6182  }
6183  else {
6184   while (off++ && s > lim) {
6185    s--;
6186    if (UTF8_IS_CONTINUED(*s)) {
6187     while (s > lim && UTF8_IS_CONTINUATION(*s))
6188      s--;
6189    }
6190    /* XXX could check well-formedness here */
6191   }
6192   if (off <= 0)
6193    return NULL;
6194  }
6195  return s;
6196 }
6197
6198 static void
6199 restore_pos(pTHX_ void *arg)
6200 {
6201  dVAR;
6202  regexp * const rex = (regexp *)arg;
6203  if (PL_reg_eval_set) {
6204   if (PL_reg_oldsaved) {
6205    rex->subbeg = PL_reg_oldsaved;
6206    rex->sublen = PL_reg_oldsavedlen;
6207 #ifdef PERL_OLD_COPY_ON_WRITE
6208    rex->saved_copy = PL_nrs;
6209 #endif
6210    RXp_MATCH_COPIED_on(rex);
6211   }
6212   PL_reg_magic->mg_len = PL_reg_oldpos;
6213   PL_reg_eval_set = 0;
6214   PL_curpm = PL_reg_oldcurpm;
6215  }
6216 }
6217
6218 STATIC void
6219 S_to_utf8_substr(pTHX_ register regexp *prog)
6220 {
6221  int i = 1;
6222
6223  PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
6224
6225  do {
6226   if (prog->substrs->data[i].substr
6227    && !prog->substrs->data[i].utf8_substr) {
6228    SV* const sv = newSVsv(prog->substrs->data[i].substr);
6229    prog->substrs->data[i].utf8_substr = sv;
6230    sv_utf8_upgrade(sv);
6231    if (SvVALID(prog->substrs->data[i].substr)) {
6232     const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
6233     if (flags & FBMcf_TAIL) {
6234      /* Trim the trailing \n that fbm_compile added last
6235      time.  */
6236      SvCUR_set(sv, SvCUR(sv) - 1);
6237      /* Whilst this makes the SV technically "invalid" (as its
6238      buffer is no longer followed by "\0") when fbm_compile()
6239      adds the "\n" back, a "\0" is restored.  */
6240     }
6241     fbm_compile(sv, flags);
6242    }
6243    if (prog->substrs->data[i].substr == prog->check_substr)
6244     prog->check_utf8 = sv;
6245   }
6246  } while (i--);
6247 }
6248
6249 STATIC void
6250 S_to_byte_substr(pTHX_ register regexp *prog)
6251 {
6252  dVAR;
6253  int i = 1;
6254
6255  PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
6256
6257  do {
6258   if (prog->substrs->data[i].utf8_substr
6259    && !prog->substrs->data[i].substr) {
6260    SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
6261    if (sv_utf8_downgrade(sv, TRUE)) {
6262     if (SvVALID(prog->substrs->data[i].utf8_substr)) {
6263      const U8 flags
6264       = BmFLAGS(prog->substrs->data[i].utf8_substr);
6265      if (flags & FBMcf_TAIL) {
6266       /* Trim the trailing \n that fbm_compile added last
6267       time.  */
6268       SvCUR_set(sv, SvCUR(sv) - 1);
6269      }
6270      fbm_compile(sv, flags);
6271     }
6272    } else {
6273     SvREFCNT_dec(sv);
6274     sv = &PL_sv_undef;
6275    }
6276    prog->substrs->data[i].substr = sv;
6277    if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
6278     prog->check_substr = sv;
6279   }
6280  } while (i--);
6281 }
6282
6283 /*
6284  * Local variables:
6285  * c-indentation-style: bsd
6286  * c-basic-offset: 4
6287  * indent-tabs-mode: t
6288  * End:
6289  *
6290  * ex: set ts=8 sts=4 sw=4 noet:
6291  */