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