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