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