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