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