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