This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
29058a1e47dbd10ccae98736703a1d2256edee21
[perl5.git] / regexec.c
1 /*    regexec.c
2  */
3
4 /*
5  *      One Ring to rule them all, One Ring to find them
6  &
7  *     [p.v of _The Lord of the Rings_, opening poem]
8  *     [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
9  *     [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
10  */
11
12 /* This file contains functions for executing a regular expression.  See
13  * also regcomp.c which funnily enough, contains functions for compiling
14  * a regular expression.
15  *
16  * This file is also copied at build time to ext/re/re_exec.c, where
17  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
18  * This causes the main functions to be compiled under new names and with
19  * debugging support added, which makes "use re 'debug'" work.
20  */
21
22 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
23  * confused with the original package (see point 3 below).  Thanks, Henry!
24  */
25
26 /* Additional note: this code is very heavily munged from Henry's version
27  * in places.  In some spots I've traded clarity for efficiency, so don't
28  * blame Henry for some of the lack of readability.
29  */
30
31 /* The names of the functions have been changed from regcomp and
32  * regexec to  pregcomp and pregexec in order to avoid conflicts
33  * with the POSIX routines of the same names.
34 */
35
36 #ifdef PERL_EXT_RE_BUILD
37 #include "re_top.h"
38 #endif
39
40 /*
41  * pregcomp and pregexec -- regsub and regerror are not used in perl
42  *
43  *      Copyright (c) 1986 by University of Toronto.
44  *      Written by Henry Spencer.  Not derived from licensed software.
45  *
46  *      Permission is granted to anyone to use this software for any
47  *      purpose on any computer system, and to redistribute it freely,
48  *      subject to the following restrictions:
49  *
50  *      1. The author is not responsible for the consequences of use of
51  *              this software, no matter how awful, even if they arise
52  *              from defects in it.
53  *
54  *      2. The origin of this software must not be misrepresented, either
55  *              by explicit claim or by omission.
56  *
57  *      3. Altered versions must be plainly marked as such, and must not
58  *              be misrepresented as being the original software.
59  *
60  ****    Alterations to Henry's code are...
61  ****
62  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
63  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
64  ****    by Larry Wall and others
65  ****
66  ****    You may distribute under the terms of either the GNU General Public
67  ****    License or the Artistic License, as specified in the README file.
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGEXEC_C
75 #include "perl.h"
76
77 #ifdef PERL_IN_XSUB_RE
78 #  include "re_comp.h"
79 #else
80 #  include "regcomp.h"
81 #endif
82
83 #define RF_tainted      1               /* tainted information used? */
84 #define RF_warned       2               /* warned about big count? */
85
86 #define RF_utf8         8               /* Pattern contains multibyte chars? */
87
88 #define UTF_PATTERN ((PL_reg_flags & RF_utf8) != 0)
89
90 #define RS_init         1               /* eval environment created */
91 #define RS_set          2               /* replsv value is set */
92
93 #ifndef STATIC
94 #define STATIC  static
95 #endif
96
97 /* Valid for non-utf8 strings only: avoids the reginclass call if there are no
98  * complications: i.e., if everything matchable is straight forward in the
99  * bitmap */
100 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0)   \
101                                               : ANYOF_BITMAP_TEST(p,*(c)))
102
103 /*
104  * Forwards.
105  */
106
107 #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv))
108 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
109
110 #define HOPc(pos,off) \
111         (char *)(PL_reg_match_utf8 \
112             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
113             : (U8*)(pos + off))
114 #define HOPBACKc(pos, off) \
115         (char*)(PL_reg_match_utf8\
116             ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
117             : (pos - off >= PL_bostr)           \
118                 ? (U8*)pos - off                \
119                 : NULL)
120
121 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
122 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
123
124 /* these are unrolled below in the CCC_TRY_XXX defined */
125 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
126     if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
127
128 /* Doesn't do an assert to verify that is correct */
129 #define LOAD_UTF8_CHARCLASS_NO_CHECK(class) STMT_START { \
130     if (!CAT2(PL_utf8_,class)) { bool throw_away; ENTER; save_re_context(); throw_away = CAT2(is_utf8_,class)((const U8*)" "); LEAVE; } } STMT_END
131
132 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
133 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
134 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
135
136 #define LOAD_UTF8_CHARCLASS_GCB()  /* Grapheme cluster boundaries */        \
137         LOAD_UTF8_CHARCLASS(X_begin, " ");                                  \
138         LOAD_UTF8_CHARCLASS(X_non_hangul, "A");                             \
139         /* These are utf8 constants, and not utf-ebcdic constants, so the   \
140             * assert should likely and hopefully fail on an EBCDIC machine */ \
141         LOAD_UTF8_CHARCLASS(X_extend, "\xcc\x80"); /* U+0300 */             \
142                                                                             \
143         /* No asserts are done for these, in case called on an early        \
144             * Unicode version in which they map to nothing */               \
145         LOAD_UTF8_CHARCLASS_NO_CHECK(X_prepend);/* U+0E40 "\xe0\xb9\x80" */ \
146         LOAD_UTF8_CHARCLASS_NO_CHECK(X_L);          /* U+1100 "\xe1\x84\x80" */ \
147         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV);     /* U+AC00 "\xea\xb0\x80" */ \
148         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LVT);    /* U+AC01 "\xea\xb0\x81" */ \
149         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV_LVT_V);/* U+AC01 "\xea\xb0\x81" */\
150         LOAD_UTF8_CHARCLASS_NO_CHECK(X_T);      /* U+11A8 "\xe1\x86\xa8" */ \
151         LOAD_UTF8_CHARCLASS_NO_CHECK(X_V)       /* U+1160 "\xe1\x85\xa0" */  
152
153 /* 
154    We dont use PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS as the direct test
155    so that it is possible to override the option here without having to 
156    rebuild the entire core. as we are required to do if we change regcomp.h
157    which is where PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS is defined.
158 */
159 #if PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS
160 #define BROKEN_UNICODE_CHARCLASS_MAPPINGS
161 #endif
162
163 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
164 #define LOAD_UTF8_CHARCLASS_PERL_WORD()   LOAD_UTF8_CHARCLASS_ALNUM()
165 #define LOAD_UTF8_CHARCLASS_PERL_SPACE()  LOAD_UTF8_CHARCLASS_SPACE()
166 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS_DIGIT()
167 #define RE_utf8_perl_word   PL_utf8_alnum
168 #define RE_utf8_perl_space  PL_utf8_space
169 #define RE_utf8_posix_digit PL_utf8_digit
170 #define perl_word  alnum
171 #define perl_space space
172 #define posix_digit digit
173 #else
174 #define LOAD_UTF8_CHARCLASS_PERL_WORD()   LOAD_UTF8_CHARCLASS(perl_word,"a")
175 #define LOAD_UTF8_CHARCLASS_PERL_SPACE()  LOAD_UTF8_CHARCLASS(perl_space," ")
176 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS(posix_digit,"0")
177 #define RE_utf8_perl_word   PL_utf8_perl_word
178 #define RE_utf8_perl_space  PL_utf8_perl_space
179 #define RE_utf8_posix_digit PL_utf8_posix_digit
180 #endif
181
182 #define PLACEHOLDER     /* Something for the preprocessor to grab onto */
183
184 /* The actual code for CCC_TRY, which uses several variables from the routine
185  * it's callable from.  It is designed to be the bulk of a case statement.
186  * FUNC is the macro or function to call on non-utf8 targets that indicate if
187  *      nextchr matches the class.
188  * UTF8_TEST is the whole test string to use for utf8 targets
189  * LOAD is what to use to test, and if not present to load in the swash for the
190  *      class
191  * POS_OR_NEG is either empty or ! to complement the results of FUNC or
192  *      UTF8_TEST test.
193  * The logic is: Fail if we're at the end-of-string; otherwise if the target is
194  * utf8 and a variant, load the swash if necessary and test using the utf8
195  * test.  Advance to the next character if test is ok, otherwise fail; If not
196  * utf8 or an invariant under utf8, use the non-utf8 test, and fail if it
197  * fails, or advance to the next character */
198
199 #define _CCC_TRY_CODE(POS_OR_NEG, FUNC, UTF8_TEST, CLASS, STR)                \
200     if (locinput >= PL_regeol) {                                              \
201         sayNO;                                                                \
202     }                                                                         \
203     if (utf8_target && UTF8_IS_CONTINUED(nextchr)) {                          \
204         LOAD_UTF8_CHARCLASS(CLASS, STR);                                      \
205         if (POS_OR_NEG (UTF8_TEST)) {                                         \
206             sayNO;                                                            \
207         }                                                                     \
208         locinput += PL_utf8skip[nextchr];                                     \
209         nextchr = UCHARAT(locinput);                                          \
210         break;                                                                \
211     }                                                                         \
212     if (POS_OR_NEG (FUNC(nextchr))) {                                         \
213         sayNO;                                                                \
214     }                                                                         \
215     nextchr = UCHARAT(++locinput);                                            \
216     break;
217
218 /* Handle the non-locale cases for a character class and its complement.  It
219  * calls _CCC_TRY_CODE with a ! to complement the test for the character class.
220  * This is because that code fails when the test succeeds, so we want to have
221  * the test fail so that the code succeeds.  The swash is stored in a
222  * predictable PL_ place */
223 #define _CCC_TRY_NONLOCALE(NAME,  NNAME,  FUNC,                               \
224                            CLASS, STR)                                        \
225     case NAME:                                                                \
226         _CCC_TRY_CODE( !, FUNC,                                               \
227                           cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS),             \
228                                             (U8*)locinput, TRUE)),            \
229                           CLASS, STR)                                         \
230     case NNAME:                                                               \
231         _CCC_TRY_CODE(  PLACEHOLDER , FUNC,                                   \
232                           cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS),             \
233                                             (U8*)locinput, TRUE)),            \
234                           CLASS, STR)                                         \
235
236 /* Generate the case statements for both locale and non-locale character
237  * classes in regmatch for classes that don't have special unicode semantics.
238  * Locales don't use an immediate swash, but an intermediary special locale
239  * function that is called on the pointer to the current place in the input
240  * string.  That function will resolve to needing the same swash.  One might
241  * think that because we don't know what the locale will match, we shouldn't
242  * check with the swash loading function that it loaded properly; ie, that we
243  * should use LOAD_UTF8_CHARCLASS_NO_CHECK for those, but what is passed to the
244  * regular LOAD_UTF8_CHARCLASS is in non-locale terms, and so locale is
245  * irrelevant here */
246 #define CCC_TRY(NAME,  NNAME,  FUNC,                                          \
247                 NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8,                           \
248                 NAMEA, NNAMEA, FUNCA,                                         \
249                 CLASS, STR)                                                   \
250     case NAMEL:                                                               \
251         PL_reg_flags |= RF_tainted;                                           \
252         _CCC_TRY_CODE( !, LCFUNC, LCFUNC_utf8((U8*)locinput), CLASS, STR)     \
253     case NNAMEL:                                                              \
254         PL_reg_flags |= RF_tainted;                                           \
255         _CCC_TRY_CODE( PLACEHOLDER, LCFUNC, LCFUNC_utf8((U8*)locinput),       \
256                        CLASS, STR)                                            \
257     case NAMEA:                                                               \
258         if (locinput >= PL_regeol || ! FUNCA(nextchr)) {                      \
259             sayNO;                                                            \
260         }                                                                     \
261         /* Matched a utf8-invariant, so don't have to worry about utf8 */     \
262         nextchr = UCHARAT(++locinput);                                        \
263         break;                                                                \
264     case NNAMEA:                                                              \
265         if (locinput >= PL_regeol || FUNCA(nextchr)) {                        \
266             sayNO;                                                            \
267         }                                                                     \
268         if (utf8_target) {                                                    \
269             locinput += PL_utf8skip[nextchr];                                 \
270             nextchr = UCHARAT(locinput);                                      \
271         }                                                                     \
272         else {                                                                \
273             nextchr = UCHARAT(++locinput);                                    \
274         }                                                                     \
275         break;                                                                \
276     /* Generate the non-locale cases */                                       \
277     _CCC_TRY_NONLOCALE(NAME, NNAME, FUNC, CLASS, STR)
278
279 /* This is like CCC_TRY, but has an extra set of parameters for generating case
280  * statements to handle separate Unicode semantics nodes */
281 #define CCC_TRY_U(NAME,  NNAME,  FUNC,                                         \
282                   NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8,                          \
283                   NAMEU, NNAMEU, FUNCU,                                        \
284                   NAMEA, NNAMEA, FUNCA,                                        \
285                   CLASS, STR)                                                  \
286     CCC_TRY(NAME, NNAME, FUNC,                                                 \
287             NAMEL, NNAMEL, LCFUNC, LCFUNC_utf8,                                \
288             NAMEA, NNAMEA, FUNCA,                                              \
289             CLASS, STR)                                                        \
290     _CCC_TRY_NONLOCALE(NAMEU, NNAMEU, FUNCU, CLASS, STR)
291
292 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
293
294 /* for use after a quantifier and before an EXACT-like node -- japhy */
295 /* it would be nice to rework regcomp.sym to generate this stuff. sigh
296  *
297  * NOTE that *nothing* that affects backtracking should be in here, specifically
298  * VERBS must NOT be included. JUMPABLE is used to determine  if we can ignore a
299  * node that is in between two EXACT like nodes when ascertaining what the required
300  * "follow" character is. This should probably be moved to regex compile time
301  * although it may be done at run time beause of the REF possibility - more
302  * investigation required. -- demerphq
303 */
304 #define JUMPABLE(rn) (      \
305     OP(rn) == OPEN ||       \
306     (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
307     OP(rn) == EVAL ||   \
308     OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
309     OP(rn) == PLUS || OP(rn) == MINMOD || \
310     OP(rn) == KEEPS || \
311     (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
312 )
313 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
314
315 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
316
317 #if 0 
318 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
319    we don't need this definition. */
320 #define IS_TEXT(rn)   ( OP(rn)==EXACT   || OP(rn)==REF   || OP(rn)==NREF   )
321 #define IS_TEXTF(rn)  ( (OP(rn)==EXACTFU ||  OP(rn)==EXACTF)  || OP(rn)==REFF  || OP(rn)==NREFF )
322 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
323
324 #else
325 /* ... so we use this as its faster. */
326 #define IS_TEXT(rn)   ( OP(rn)==EXACT   )
327 #define IS_TEXTFU(rn)  ( OP(rn)==EXACTFU )
328 #define IS_TEXTF(rn)  ( OP(rn)==EXACTF  )
329 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
330
331 #endif
332
333 /*
334   Search for mandatory following text node; for lookahead, the text must
335   follow but for lookbehind (rn->flags != 0) we skip to the next step.
336 */
337 #define FIND_NEXT_IMPT(rn) STMT_START { \
338     while (JUMPABLE(rn)) { \
339         const OPCODE type = OP(rn); \
340         if (type == SUSPEND || PL_regkind[type] == CURLY) \
341             rn = NEXTOPER(NEXTOPER(rn)); \
342         else if (type == PLUS) \
343             rn = NEXTOPER(rn); \
344         else if (type == IFMATCH) \
345             rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
346         else rn += NEXT_OFF(rn); \
347     } \
348 } STMT_END 
349
350
351 static void restore_pos(pTHX_ void *arg);
352
353 #define REGCP_PAREN_ELEMS 4
354 #define REGCP_OTHER_ELEMS 5
355 #define REGCP_FRAME_ELEMS 1
356 /* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
357  * are needed for the regexp context stack bookkeeping. */
358
359 STATIC CHECKPOINT
360 S_regcppush(pTHX_ I32 parenfloor)
361 {
362     dVAR;
363     const int retval = PL_savestack_ix;
364     const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
365     const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
366     const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
367     int p;
368     GET_RE_DEBUG_FLAGS_DECL;
369
370     if (paren_elems_to_push < 0)
371         Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
372
373     if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
374         Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf
375                    " out of range (%lu-%ld)",
376                    total_elems, (unsigned long)PL_regsize, (long)parenfloor);
377
378     SSGROW(total_elems + REGCP_FRAME_ELEMS);
379     
380     for (p = PL_regsize; p > parenfloor; p--) {
381 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
382         SSPUSHINT(PL_regoffs[p].end);
383         SSPUSHINT(PL_regoffs[p].start);
384         SSPUSHPTR(PL_reg_start_tmp[p]);
385         SSPUSHINT(p);
386         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
387           "     saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
388                       (UV)p, (IV)PL_regoffs[p].start,
389                       (IV)(PL_reg_start_tmp[p] - PL_bostr),
390                       (IV)PL_regoffs[p].end
391         ));
392     }
393 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
394     SSPUSHPTR(PL_regoffs);
395     SSPUSHINT(PL_regsize);
396     SSPUSHINT(*PL_reglastparen);
397     SSPUSHINT(*PL_reglastcloseparen);
398     SSPUSHPTR(PL_reginput);
399     SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
400
401     return retval;
402 }
403
404 /* These are needed since we do not localize EVAL nodes: */
405 #define REGCP_SET(cp)                                           \
406     DEBUG_STATE_r(                                              \
407             PerlIO_printf(Perl_debug_log,                       \
408                 "  Setting an EVAL scope, savestack=%"IVdf"\n", \
409                 (IV)PL_savestack_ix));                          \
410     cp = PL_savestack_ix
411
412 #define REGCP_UNWIND(cp)                                        \
413     DEBUG_STATE_r(                                              \
414         if (cp != PL_savestack_ix)                              \
415             PerlIO_printf(Perl_debug_log,                       \
416                 "  Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
417                 (IV)(cp), (IV)PL_savestack_ix));                \
418     regcpblow(cp)
419
420 STATIC char *
421 S_regcppop(pTHX_ const regexp *rex)
422 {
423     dVAR;
424     UV i;
425     char *input;
426     GET_RE_DEBUG_FLAGS_DECL;
427
428     PERL_ARGS_ASSERT_REGCPPOP;
429
430     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
431     i = SSPOPUV;
432     assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
433     i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
434     input = (char *) SSPOPPTR;
435     *PL_reglastcloseparen = SSPOPINT;
436     *PL_reglastparen = SSPOPINT;
437     PL_regsize = SSPOPINT;
438     PL_regoffs=(regexp_paren_pair *) SSPOPPTR;
439
440     i -= REGCP_OTHER_ELEMS;
441     /* Now restore the parentheses context. */
442     for ( ; i > 0; i -= REGCP_PAREN_ELEMS) {
443         I32 tmps;
444         U32 paren = (U32)SSPOPINT;
445         PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
446         PL_regoffs[paren].start = SSPOPINT;
447         tmps = SSPOPINT;
448         if (paren <= *PL_reglastparen)
449             PL_regoffs[paren].end = tmps;
450         DEBUG_BUFFERS_r(
451             PerlIO_printf(Perl_debug_log,
452                           "     restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
453                           (UV)paren, (IV)PL_regoffs[paren].start,
454                           (IV)(PL_reg_start_tmp[paren] - PL_bostr),
455                           (IV)PL_regoffs[paren].end,
456                           (paren > *PL_reglastparen ? "(no)" : ""));
457         );
458     }
459     DEBUG_BUFFERS_r(
460         if (*PL_reglastparen + 1 <= rex->nparens) {
461             PerlIO_printf(Perl_debug_log,
462                           "     restoring \\%"IVdf"..\\%"IVdf" to undef\n",
463                           (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
464         }
465     );
466 #if 1
467     /* It would seem that the similar code in regtry()
468      * already takes care of this, and in fact it is in
469      * a better location to since this code can #if 0-ed out
470      * but the code in regtry() is needed or otherwise tests
471      * requiring null fields (pat.t#187 and split.t#{13,14}
472      * (as of patchlevel 7877)  will fail.  Then again,
473      * this code seems to be necessary or otherwise
474      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
475      * --jhi updated by dapm */
476     for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
477         if (i > PL_regsize)
478             PL_regoffs[i].start = -1;
479         PL_regoffs[i].end = -1;
480     }
481 #endif
482     return input;
483 }
484
485 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
486
487 /*
488  * pregexec and friends
489  */
490
491 #ifndef PERL_IN_XSUB_RE
492 /*
493  - pregexec - match a regexp against a string
494  */
495 I32
496 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
497          char *strbeg, I32 minend, SV *screamer, U32 nosave)
498 /* strend: pointer to null at end of string */
499 /* strbeg: real beginning of string */
500 /* minend: end of match must be >=minend after stringarg. */
501 /* nosave: For optimizations. */
502 {
503     PERL_ARGS_ASSERT_PREGEXEC;
504
505     return
506         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
507                       nosave ? 0 : REXEC_COPY_STR);
508 }
509 #endif
510
511 /*
512  * Need to implement the following flags for reg_anch:
513  *
514  * USE_INTUIT_NOML              - Useful to call re_intuit_start() first
515  * USE_INTUIT_ML
516  * INTUIT_AUTORITATIVE_NOML     - Can trust a positive answer
517  * INTUIT_AUTORITATIVE_ML
518  * INTUIT_ONCE_NOML             - Intuit can match in one location only.
519  * INTUIT_ONCE_ML
520  *
521  * Another flag for this function: SECOND_TIME (so that float substrs
522  * with giant delta may be not rechecked).
523  */
524
525 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
526
527 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
528    Otherwise, only SvCUR(sv) is used to get strbeg. */
529
530 /* XXXX We assume that strpos is strbeg unless sv. */
531
532 /* XXXX Some places assume that there is a fixed substring.
533         An update may be needed if optimizer marks as "INTUITable"
534         RExen without fixed substrings.  Similarly, it is assumed that
535         lengths of all the strings are no more than minlen, thus they
536         cannot come from lookahead.
537         (Or minlen should take into account lookahead.) 
538   NOTE: Some of this comment is not correct. minlen does now take account
539   of lookahead/behind. Further research is required. -- demerphq
540
541 */
542
543 /* A failure to find a constant substring means that there is no need to make
544    an expensive call to REx engine, thus we celebrate a failure.  Similarly,
545    finding a substring too deep into the string means that less calls to
546    regtry() should be needed.
547
548    REx compiler's optimizer found 4 possible hints:
549         a) Anchored substring;
550         b) Fixed substring;
551         c) Whether we are anchored (beginning-of-line or \G);
552         d) First node (of those at offset 0) which may distinguish positions;
553    We use a)b)d) and multiline-part of c), and try to find a position in the
554    string which does not contradict any of them.
555  */
556
557 /* Most of decisions we do here should have been done at compile time.
558    The nodes of the REx which we used for the search should have been
559    deleted from the finite automaton. */
560
561 char *
562 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
563                      char *strend, const U32 flags, re_scream_pos_data *data)
564 {
565     dVAR;
566     struct regexp *const prog = (struct regexp *)SvANY(rx);
567     register I32 start_shift = 0;
568     /* Should be nonnegative! */
569     register I32 end_shift   = 0;
570     register char *s;
571     register SV *check;
572     char *strbeg;
573     char *t;
574     const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
575     I32 ml_anch;
576     register char *other_last = NULL;   /* other substr checked before this */
577     char *check_at = NULL;              /* check substr found at this pos */
578     const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
579     RXi_GET_DECL(prog,progi);
580 #ifdef DEBUGGING
581     const char * const i_strpos = strpos;
582 #endif
583     GET_RE_DEBUG_FLAGS_DECL;
584
585     PERL_ARGS_ASSERT_RE_INTUIT_START;
586
587     RX_MATCH_UTF8_set(rx,utf8_target);
588
589     if (RX_UTF8(rx)) {
590         PL_reg_flags |= RF_utf8;
591     }
592     DEBUG_EXECUTE_r( 
593         debug_start_match(rx, utf8_target, strpos, strend,
594             sv ? "Guessing start of match in sv for"
595                : "Guessing start of match in string for");
596               );
597
598     /* CHR_DIST() would be more correct here but it makes things slow. */
599     if (prog->minlen > strend - strpos) {
600         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
601                               "String too short... [re_intuit_start]\n"));
602         goto fail;
603     }
604                 
605     strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
606     PL_regeol = strend;
607     if (utf8_target) {
608         if (!prog->check_utf8 && prog->check_substr)
609             to_utf8_substr(prog);
610         check = prog->check_utf8;
611     } else {
612         if (!prog->check_substr && prog->check_utf8)
613             to_byte_substr(prog);
614         check = prog->check_substr;
615     }
616     if (check == &PL_sv_undef) {
617         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
618                 "Non-utf8 string cannot match utf8 check string\n"));
619         goto fail;
620     }
621     if (prog->extflags & RXf_ANCH) {    /* Match at beg-of-str or after \n */
622         ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
623                      || ( (prog->extflags & RXf_ANCH_BOL)
624                           && !multiline ) );    /* Check after \n? */
625
626         if (!ml_anch) {
627           if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
628                 && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
629                /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
630                && sv && !SvROK(sv)
631                && (strpos != strbeg)) {
632               DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
633               goto fail;
634           }
635           if (prog->check_offset_min == prog->check_offset_max &&
636               !(prog->extflags & RXf_CANY_SEEN)) {
637             /* Substring at constant offset from beg-of-str... */
638             I32 slen;
639
640             s = HOP3c(strpos, prog->check_offset_min, strend);
641             
642             if (SvTAIL(check)) {
643                 slen = SvCUR(check);    /* >= 1 */
644
645                 if ( strend - s > slen || strend - s < slen - 1
646                      || (strend - s == slen && strend[-1] != '\n')) {
647                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
648                     goto fail_finish;
649                 }
650                 /* Now should match s[0..slen-2] */
651                 slen--;
652                 if (slen && (*SvPVX_const(check) != *s
653                              || (slen > 1
654                                  && memNE(SvPVX_const(check), s, slen)))) {
655                   report_neq:
656                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
657                     goto fail_finish;
658                 }
659             }
660             else if (*SvPVX_const(check) != *s
661                      || ((slen = SvCUR(check)) > 1
662                          && memNE(SvPVX_const(check), s, slen)))
663                 goto report_neq;
664             check_at = s;
665             goto success_at_start;
666           }
667         }
668         /* Match is anchored, but substr is not anchored wrt beg-of-str. */
669         s = strpos;
670         start_shift = prog->check_offset_min; /* okay to underestimate on CC */
671         end_shift = prog->check_end_shift;
672         
673         if (!ml_anch) {
674             const I32 end = prog->check_offset_max + CHR_SVLEN(check)
675                                          - (SvTAIL(check) != 0);
676             const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
677
678             if (end_shift < eshift)
679                 end_shift = eshift;
680         }
681     }
682     else {                              /* Can match at random position */
683         ml_anch = 0;
684         s = strpos;
685         start_shift = prog->check_offset_min;  /* okay to underestimate on CC */
686         end_shift = prog->check_end_shift;
687         
688         /* end shift should be non negative here */
689     }
690
691 #ifdef QDEBUGGING       /* 7/99: reports of failure (with the older version) */
692     if (end_shift < 0)
693         Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
694                    (IV)end_shift, RX_PRECOMP(prog));
695 #endif
696
697   restart:
698     /* Find a possible match in the region s..strend by looking for
699        the "check" substring in the region corrected by start/end_shift. */
700     
701     {
702         I32 srch_start_shift = start_shift;
703         I32 srch_end_shift = end_shift;
704         if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
705             srch_end_shift -= ((strbeg - s) - srch_start_shift); 
706             srch_start_shift = strbeg - s;
707         }
708     DEBUG_OPTIMISE_MORE_r({
709         PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
710             (IV)prog->check_offset_min,
711             (IV)srch_start_shift,
712             (IV)srch_end_shift, 
713             (IV)prog->check_end_shift);
714     });       
715         
716     if (flags & REXEC_SCREAM) {
717         I32 p = -1;                     /* Internal iterator of scream. */
718         I32 * const pp = data ? data->scream_pos : &p;
719
720         if (PL_screamfirst[BmRARE(check)] >= 0
721             || ( BmRARE(check) == '\n'
722                  && (BmPREVIOUS(check) == SvCUR(check) - 1)
723                  && SvTAIL(check) ))
724             s = screaminstr(sv, check,
725                             srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
726         else
727             goto fail_finish;
728         /* we may be pointing at the wrong string */
729         if (s && RXp_MATCH_COPIED(prog))
730             s = strbeg + (s - SvPVX_const(sv));
731         if (data)
732             *data->scream_olds = s;
733     }
734     else {
735         U8* start_point;
736         U8* end_point;
737         if (prog->extflags & RXf_CANY_SEEN) {
738             start_point= (U8*)(s + srch_start_shift);
739             end_point= (U8*)(strend - srch_end_shift);
740         } else {
741             start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
742             end_point= HOP3(strend, -srch_end_shift, strbeg);
743         }
744         DEBUG_OPTIMISE_MORE_r({
745             PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n", 
746                 (int)(end_point - start_point),
747                 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point), 
748                 start_point);
749         });
750
751         s = fbm_instr( start_point, end_point,
752                       check, multiline ? FBMrf_MULTILINE : 0);
753     }
754     }
755     /* Update the count-of-usability, remove useless subpatterns,
756         unshift s.  */
757
758     DEBUG_EXECUTE_r({
759         RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
760             SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
761         PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
762                           (s ? "Found" : "Did not find"),
763             (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr)
764                 ? "anchored" : "floating"),
765             quoted,
766             RE_SV_TAIL(check),
767             (s ? " at offset " : "...\n") ); 
768     });
769
770     if (!s)
771         goto fail_finish;
772     /* Finish the diagnostic message */
773     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
774
775     /* XXX dmq: first branch is for positive lookbehind...
776        Our check string is offset from the beginning of the pattern.
777        So we need to do any stclass tests offset forward from that 
778        point. I think. :-(
779      */
780     
781         
782     
783     check_at=s;
784      
785
786     /* Got a candidate.  Check MBOL anchoring, and the *other* substr.
787        Start with the other substr.
788        XXXX no SCREAM optimization yet - and a very coarse implementation
789        XXXX /ttx+/ results in anchored="ttx", floating="x".  floating will
790                 *always* match.  Probably should be marked during compile...
791        Probably it is right to do no SCREAM here...
792      */
793
794     if (utf8_target ? (prog->float_utf8 && prog->anchored_utf8)
795                 : (prog->float_substr && prog->anchored_substr)) 
796     {
797         /* Take into account the "other" substring. */
798         /* XXXX May be hopelessly wrong for UTF... */
799         if (!other_last)
800             other_last = strpos;
801         if (check == (utf8_target ? prog->float_utf8 : prog->float_substr)) {
802           do_other_anchored:
803             {
804                 char * const last = HOP3c(s, -start_shift, strbeg);
805                 char *last1, *last2;
806                 char * const saved_s = s;
807                 SV* must;
808
809                 t = s - prog->check_offset_max;
810                 if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
811                     && (!utf8_target
812                         || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
813                             && t > strpos)))
814                     NOOP;
815                 else
816                     t = strpos;
817                 t = HOP3c(t, prog->anchored_offset, strend);
818                 if (t < other_last)     /* These positions already checked */
819                     t = other_last;
820                 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
821                 if (last < last1)
822                     last1 = last;
823                 /* XXXX It is not documented what units *_offsets are in.  
824                    We assume bytes, but this is clearly wrong. 
825                    Meaning this code needs to be carefully reviewed for errors.
826                    dmq.
827                   */
828  
829                 /* On end-of-str: see comment below. */
830                 must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
831                 if (must == &PL_sv_undef) {
832                     s = (char*)NULL;
833                     DEBUG_r(must = prog->anchored_utf8);        /* for debug */
834                 }
835                 else
836                     s = fbm_instr(
837                         (unsigned char*)t,
838                         HOP3(HOP3(last1, prog->anchored_offset, strend)
839                                 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
840                         must,
841                         multiline ? FBMrf_MULTILINE : 0
842                     );
843                 DEBUG_EXECUTE_r({
844                     RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
845                         SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
846                     PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
847                         (s ? "Found" : "Contradicts"),
848                         quoted, RE_SV_TAIL(must));
849                 });                 
850                 
851                             
852                 if (!s) {
853                     if (last1 >= last2) {
854                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
855                                                 ", giving up...\n"));
856                         goto fail_finish;
857                     }
858                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
859                         ", trying floating at offset %ld...\n",
860                         (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
861                     other_last = HOP3c(last1, prog->anchored_offset+1, strend);
862                     s = HOP3c(last, 1, strend);
863                     goto restart;
864                 }
865                 else {
866                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
867                           (long)(s - i_strpos)));
868                     t = HOP3c(s, -prog->anchored_offset, strbeg);
869                     other_last = HOP3c(s, 1, strend);
870                     s = saved_s;
871                     if (t == strpos)
872                         goto try_at_start;
873                     goto try_at_offset;
874                 }
875             }
876         }
877         else {          /* Take into account the floating substring. */
878             char *last, *last1;
879             char * const saved_s = s;
880             SV* must;
881
882             t = HOP3c(s, -start_shift, strbeg);
883             last1 = last =
884                 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
885             if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
886                 last = HOP3c(t, prog->float_max_offset, strend);
887             s = HOP3c(t, prog->float_min_offset, strend);
888             if (s < other_last)
889                 s = other_last;
890  /* XXXX It is not documented what units *_offsets are in.  Assume bytes.  */
891             must = utf8_target ? prog->float_utf8 : prog->float_substr;
892             /* fbm_instr() takes into account exact value of end-of-str
893                if the check is SvTAIL(ed).  Since false positives are OK,
894                and end-of-str is not later than strend we are OK. */
895             if (must == &PL_sv_undef) {
896                 s = (char*)NULL;
897                 DEBUG_r(must = prog->float_utf8);       /* for debug message */
898             }
899             else
900                 s = fbm_instr((unsigned char*)s,
901                               (unsigned char*)last + SvCUR(must)
902                                   - (SvTAIL(must)!=0),
903                               must, multiline ? FBMrf_MULTILINE : 0);
904             DEBUG_EXECUTE_r({
905                 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
906                     SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
907                 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
908                     (s ? "Found" : "Contradicts"),
909                     quoted, RE_SV_TAIL(must));
910             });
911             if (!s) {
912                 if (last1 == last) {
913                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
914                                             ", giving up...\n"));
915                     goto fail_finish;
916                 }
917                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
918                     ", trying anchored starting at offset %ld...\n",
919                     (long)(saved_s + 1 - i_strpos)));
920                 other_last = last;
921                 s = HOP3c(t, 1, strend);
922                 goto restart;
923             }
924             else {
925                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
926                       (long)(s - i_strpos)));
927                 other_last = s; /* Fix this later. --Hugo */
928                 s = saved_s;
929                 if (t == strpos)
930                     goto try_at_start;
931                 goto try_at_offset;
932             }
933         }
934     }
935
936     
937     t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
938         
939     DEBUG_OPTIMISE_MORE_r(
940         PerlIO_printf(Perl_debug_log, 
941             "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
942             (IV)prog->check_offset_min,
943             (IV)prog->check_offset_max,
944             (IV)(s-strpos),
945             (IV)(t-strpos),
946             (IV)(t-s),
947             (IV)(strend-strpos)
948         )
949     );
950
951     if (s - strpos > prog->check_offset_max  /* signed-corrected t > strpos */
952         && (!utf8_target
953             || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
954                  && t > strpos))) 
955     {
956         /* Fixed substring is found far enough so that the match
957            cannot start at strpos. */
958       try_at_offset:
959         if (ml_anch && t[-1] != '\n') {
960             /* Eventually fbm_*() should handle this, but often
961                anchored_offset is not 0, so this check will not be wasted. */
962             /* XXXX In the code below we prefer to look for "^" even in
963                presence of anchored substrings.  And we search even
964                beyond the found float position.  These pessimizations
965                are historical artefacts only.  */
966           find_anchor:
967             while (t < strend - prog->minlen) {
968                 if (*t == '\n') {
969                     if (t < check_at - prog->check_offset_min) {
970                         if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
971                             /* Since we moved from the found position,
972                                we definitely contradict the found anchored
973                                substr.  Due to the above check we do not
974                                contradict "check" substr.
975                                Thus we can arrive here only if check substr
976                                is float.  Redo checking for "other"=="fixed".
977                              */
978                             strpos = t + 1;                     
979                             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
980                                 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
981                             goto do_other_anchored;
982                         }
983                         /* We don't contradict the found floating substring. */
984                         /* XXXX Why not check for STCLASS? */
985                         s = t + 1;
986                         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
987                             PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
988                         goto set_useful;
989                     }
990                     /* Position contradicts check-string */
991                     /* XXXX probably better to look for check-string
992                        than for "\n", so one should lower the limit for t? */
993                     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
994                         PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
995                     other_last = strpos = s = t + 1;
996                     goto restart;
997                 }
998                 t++;
999             }
1000             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
1001                         PL_colors[0], PL_colors[1]));
1002             goto fail_finish;
1003         }
1004         else {
1005             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
1006                         PL_colors[0], PL_colors[1]));
1007         }
1008         s = t;
1009       set_useful:
1010         ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr);        /* hooray/5 */
1011     }
1012     else {
1013         /* The found string does not prohibit matching at strpos,
1014            - no optimization of calling REx engine can be performed,
1015            unless it was an MBOL and we are not after MBOL,
1016            or a future STCLASS check will fail this. */
1017       try_at_start:
1018         /* Even in this situation we may use MBOL flag if strpos is offset
1019            wrt the start of the string. */
1020         if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
1021             && (strpos != strbeg) && strpos[-1] != '\n'
1022             /* May be due to an implicit anchor of m{.*foo}  */
1023             && !(prog->intflags & PREGf_IMPLICIT))
1024         {
1025             t = strpos;
1026             goto find_anchor;
1027         }
1028         DEBUG_EXECUTE_r( if (ml_anch)
1029             PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
1030                           (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
1031         );
1032       success_at_start:
1033         if (!(prog->intflags & PREGf_NAUGHTY)   /* XXXX If strpos moved? */
1034             && (utf8_target ? (
1035                 prog->check_utf8                /* Could be deleted already */
1036                 && --BmUSEFUL(prog->check_utf8) < 0
1037                 && (prog->check_utf8 == prog->float_utf8)
1038             ) : (
1039                 prog->check_substr              /* Could be deleted already */
1040                 && --BmUSEFUL(prog->check_substr) < 0
1041                 && (prog->check_substr == prog->float_substr)
1042             )))
1043         {
1044             /* If flags & SOMETHING - do not do it many times on the same match */
1045             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
1046             /* XXX Does the destruction order has to change with utf8_target? */
1047             SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
1048             SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
1049             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
1050             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
1051             check = NULL;                       /* abort */
1052             s = strpos;
1053             /* XXXX If the check string was an implicit check MBOL, then we need to unset the relevant flag
1054                     see http://bugs.activestate.com/show_bug.cgi?id=87173 */
1055             if (prog->intflags & PREGf_IMPLICIT)
1056                 prog->extflags &= ~RXf_ANCH_MBOL;
1057             /* XXXX This is a remnant of the old implementation.  It
1058                     looks wasteful, since now INTUIT can use many
1059                     other heuristics. */
1060             prog->extflags &= ~RXf_USE_INTUIT;
1061             /* XXXX What other flags might need to be cleared in this branch? */
1062         }
1063         else
1064             s = strpos;
1065     }
1066
1067     /* Last resort... */
1068     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
1069     /* trie stclasses are too expensive to use here, we are better off to
1070        leave it to regmatch itself */
1071     if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1072         /* minlen == 0 is possible if regstclass is \b or \B,
1073            and the fixed substr is ''$.
1074            Since minlen is already taken into account, s+1 is before strend;
1075            accidentally, minlen >= 1 guaranties no false positives at s + 1
1076            even for \b or \B.  But (minlen? 1 : 0) below assumes that
1077            regstclass does not come from lookahead...  */
1078         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
1079            This leaves EXACTF, EXACTFU only, which are dealt with in find_byclass().  */
1080         const U8* const str = (U8*)STRING(progi->regstclass);
1081         const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1082                     ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
1083                     : 1);
1084         char * endpos;
1085         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1086             endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
1087         else if (prog->float_substr || prog->float_utf8)
1088             endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
1089         else 
1090             endpos= strend;
1091                     
1092         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
1093                                       (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
1094         
1095         t = s;
1096         s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
1097         if (!s) {
1098 #ifdef DEBUGGING
1099             const char *what = NULL;
1100 #endif
1101             if (endpos == strend) {
1102                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1103                                 "Could not match STCLASS...\n") );
1104                 goto fail;
1105             }
1106             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1107                                    "This position contradicts STCLASS...\n") );
1108             if ((prog->extflags & RXf_ANCH) && !ml_anch)
1109                 goto fail;
1110             /* Contradict one of substrings */
1111             if (prog->anchored_substr || prog->anchored_utf8) {
1112                 if ((utf8_target ? prog->anchored_utf8 : prog->anchored_substr) == check) {
1113                     DEBUG_EXECUTE_r( what = "anchored" );
1114                   hop_and_restart:
1115                     s = HOP3c(t, 1, strend);
1116                     if (s + start_shift + end_shift > strend) {
1117                         /* XXXX Should be taken into account earlier? */
1118                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1119                                                "Could not match STCLASS...\n") );
1120                         goto fail;
1121                     }
1122                     if (!check)
1123                         goto giveup;
1124                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1125                                 "Looking for %s substr starting at offset %ld...\n",
1126                                  what, (long)(s + start_shift - i_strpos)) );
1127                     goto restart;
1128                 }
1129                 /* Have both, check_string is floating */
1130                 if (t + start_shift >= check_at) /* Contradicts floating=check */
1131                     goto retry_floating_check;
1132                 /* Recheck anchored substring, but not floating... */
1133                 s = check_at;
1134                 if (!check)
1135                     goto giveup;
1136                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1137                           "Looking for anchored substr starting at offset %ld...\n",
1138                           (long)(other_last - i_strpos)) );
1139                 goto do_other_anchored;
1140             }
1141             /* Another way we could have checked stclass at the
1142                current position only: */
1143             if (ml_anch) {
1144                 s = t = t + 1;
1145                 if (!check)
1146                     goto giveup;
1147                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1148                           "Looking for /%s^%s/m starting at offset %ld...\n",
1149                           PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
1150                 goto try_at_offset;
1151             }
1152             if (!(utf8_target ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
1153                 goto fail;
1154             /* Check is floating substring. */
1155           retry_floating_check:
1156             t = check_at - start_shift;
1157             DEBUG_EXECUTE_r( what = "floating" );
1158             goto hop_and_restart;
1159         }
1160         if (t != s) {
1161             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1162                         "By STCLASS: moving %ld --> %ld\n",
1163                                   (long)(t - i_strpos), (long)(s - i_strpos))
1164                    );
1165         }
1166         else {
1167             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1168                                   "Does not contradict STCLASS...\n"); 
1169                    );
1170         }
1171     }
1172   giveup:
1173     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
1174                           PL_colors[4], (check ? "Guessed" : "Giving up"),
1175                           PL_colors[5], (long)(s - i_strpos)) );
1176     return s;
1177
1178   fail_finish:                          /* Substring not found */
1179     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
1180         BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1181   fail:
1182     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1183                           PL_colors[4], PL_colors[5]));
1184     return NULL;
1185 }
1186
1187 #define DECL_TRIE_TYPE(scan) \
1188     const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
1189                     trie_type = (scan->flags != EXACT) \
1190                               ? (utf8_target ? trie_utf8_fold : (UTF_PATTERN ? trie_latin_utf8_fold : trie_plain)) \
1191                               : (utf8_target ? trie_utf8 : trie_plain)
1192
1193 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len,  \
1194 uvc, charid, foldlen, foldbuf, uniflags) STMT_START {                       \
1195     switch (trie_type) {                                                    \
1196     case trie_utf8_fold:                                                    \
1197         if ( foldlen>0 ) {                                                  \
1198             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1199             foldlen -= len;                                                 \
1200             uscan += len;                                                   \
1201             len=0;                                                          \
1202         } else {                                                            \
1203             uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1204             uvc = to_uni_fold( uvc, foldbuf, &foldlen );                    \
1205             foldlen -= UNISKIP( uvc );                                      \
1206             uscan = foldbuf + UNISKIP( uvc );                               \
1207         }                                                                   \
1208         break;                                                              \
1209     case trie_latin_utf8_fold:                                              \
1210         if ( foldlen>0 ) {                                                  \
1211             uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );     \
1212             foldlen -= len;                                                 \
1213             uscan += len;                                                   \
1214             len=0;                                                          \
1215         } else {                                                            \
1216             len = 1;                                                        \
1217             uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen );               \
1218             foldlen -= UNISKIP( uvc );                                      \
1219             uscan = foldbuf + UNISKIP( uvc );                               \
1220         }                                                                   \
1221         break;                                                              \
1222     case trie_utf8:                                                         \
1223         uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );       \
1224         break;                                                              \
1225     case trie_plain:                                                        \
1226         uvc = (UV)*uc;                                                      \
1227         len = 1;                                                            \
1228     }                                                                       \
1229     if (uvc < 256) {                                                        \
1230         charid = trie->charmap[ uvc ];                                      \
1231     }                                                                       \
1232     else {                                                                  \
1233         charid = 0;                                                         \
1234         if (widecharmap) {                                                  \
1235             SV** const svpp = hv_fetch(widecharmap,                         \
1236                         (char*)&uvc, sizeof(UV), 0);                        \
1237             if (svpp)                                                       \
1238                 charid = (U16)SvIV(*svpp);                                  \
1239         }                                                                   \
1240     }                                                                       \
1241 } STMT_END
1242
1243 #define REXEC_FBC_EXACTISH_CHECK(CoNd)                 \
1244 {                                                      \
1245     char *my_strend= (char *)strend;                   \
1246     if ( (CoNd)                                        \
1247          && (ln == len ||                              \
1248              foldEQ_utf8(s, &my_strend, 0,  utf8_target,   \
1249                         m, NULL, ln, cBOOL(UTF_PATTERN)))      \
1250          && (!reginfo || regtry(reginfo, &s)) )        \
1251         goto got_it;                                   \
1252     else {                                             \
1253          U8 foldbuf[UTF8_MAXBYTES_CASE+1];             \
1254          uvchr_to_utf8(tmpbuf, c);                     \
1255          f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);  \
1256          if ( f != c                                   \
1257               && (f == c1 || f == c2)                  \
1258               && (ln == len ||                         \
1259                 foldEQ_utf8(s, &my_strend, 0,  utf8_target,\
1260                               m, NULL, ln, cBOOL(UTF_PATTERN)))\
1261               && (!reginfo || regtry(reginfo, &s)) )   \
1262               goto got_it;                             \
1263     }                                                  \
1264 }                                                      \
1265 s += len
1266
1267 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1268 STMT_START {                                              \
1269     re_fold_t folder;                                   \
1270     switch (OP(c)) {                                      \
1271         case EXACTFU: folder = foldEQ_latin1; break;      \
1272         case EXACTFL: folder = foldEQ_locale; break;      \
1273         case EXACTF:  folder = foldEQ; break;             \
1274         default:                                          \
1275             Perl_croak(aTHX_ "panic: Unexpected op %u", OP(c)); \
1276     }                                                     \
1277     while (s <= e) {                                      \
1278         if ( (CoNd)                                       \
1279              && (ln == 1 || folder(s, m, ln))             \
1280              && (!reginfo || regtry(reginfo, &s)) )       \
1281             goto got_it;                                  \
1282         s++;                                              \
1283     }                                                     \
1284 } STMT_END
1285
1286 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1287 STMT_START {                                          \
1288     while (s + (uskip = UTF8SKIP(s)) <= strend) {     \
1289         CoDe                                          \
1290         s += uskip;                                   \
1291     }                                                 \
1292 } STMT_END
1293
1294 #define REXEC_FBC_SCAN(CoDe)                          \
1295 STMT_START {                                          \
1296     while (s < strend) {                              \
1297         CoDe                                          \
1298         s++;                                          \
1299     }                                                 \
1300 } STMT_END
1301
1302 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1303 REXEC_FBC_UTF8_SCAN(                                  \
1304     if (CoNd) {                                       \
1305         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1306             goto got_it;                              \
1307         else                                          \
1308             tmp = doevery;                            \
1309     }                                                 \
1310     else                                              \
1311         tmp = 1;                                      \
1312 )
1313
1314 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1315 REXEC_FBC_SCAN(                                       \
1316     if (CoNd) {                                       \
1317         if (tmp && (!reginfo || regtry(reginfo, &s)))  \
1318             goto got_it;                              \
1319         else                                          \
1320             tmp = doevery;                            \
1321     }                                                 \
1322     else                                              \
1323         tmp = 1;                                      \
1324 )
1325
1326 #define REXEC_FBC_TRYIT               \
1327 if ((!reginfo || regtry(reginfo, &s))) \
1328     goto got_it
1329
1330 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd)                         \
1331     if (utf8_target) {                                             \
1332         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1333     }                                                          \
1334     else {                                                     \
1335         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1336     }                                                          \
1337     break
1338     
1339 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd)      \
1340     if (utf8_target) {                                             \
1341         UtFpReLoAd;                                            \
1342         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1343     }                                                          \
1344     else {                                                     \
1345         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1346     }                                                          \
1347     break
1348
1349 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd)                   \
1350     PL_reg_flags |= RF_tainted;                                \
1351     if (utf8_target) {                                             \
1352         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1353     }                                                          \
1354     else {                                                     \
1355         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1356     }                                                          \
1357     break
1358
1359 #define DUMP_EXEC_POS(li,s,doutf8) \
1360     dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1361
1362
1363 #define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1364         tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';                         \
1365         tmp = TEST_NON_UTF8(tmp);                                              \
1366         REXEC_FBC_UTF8_SCAN(                                                   \
1367             if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1368                 tmp = !tmp;                                                    \
1369                 IF_SUCCESS;                                                    \
1370             }                                                                  \
1371             else {                                                             \
1372                 IF_FAIL;                                                       \
1373             }                                                                  \
1374         );                                                                     \
1375
1376 #define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \
1377         if (s == PL_bostr) {                                                   \
1378             tmp = '\n';                                                        \
1379         }                                                                      \
1380         else {                                                                 \
1381             U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);                 \
1382             tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);       \
1383         }                                                                      \
1384         tmp = TeSt1_UtF8;                                                      \
1385         LOAD_UTF8_CHARCLASS_ALNUM();                                                                \
1386         REXEC_FBC_UTF8_SCAN(                                                   \
1387             if (tmp == ! (TeSt2_UtF8)) { \
1388                 tmp = !tmp;                                                    \
1389                 IF_SUCCESS;                                                    \
1390             }                                                                  \
1391             else {                                                             \
1392                 IF_FAIL;                                                       \
1393             }                                                                  \
1394         );                                                                     \
1395
1396 /* The only difference between the BOUND and NBOUND cases is that
1397  * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
1398  * NBOUND.  This is accomplished by passing it in either the if or else clause,
1399  * with the other one being empty */
1400 #define FBC_BOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1401     FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1402
1403 #define FBC_BOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1404     FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1405
1406 #define FBC_NBOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1407     FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1408
1409 #define FBC_NBOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1410     FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1411
1412
1413 /* Common to the BOUND and NBOUND cases.  Unfortunately the UTF8 tests need to
1414  * be passed in completely with the variable name being tested, which isn't
1415  * such a clean interface, but this is easier to read than it was before.  We
1416  * are looking for the boundary (or non-boundary between a word and non-word
1417  * character.  The utf8 and non-utf8 cases have the same logic, but the details
1418  * must be different.  Find the "wordness" of the character just prior to this
1419  * one, and compare it with the wordness of this one.  If they differ, we have
1420  * a boundary.  At the beginning of the string, pretend that the previous
1421  * character was a new-line */
1422 #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1423     if (utf8_target) {                                                         \
1424                 UTF8_CODE \
1425     }                                                                          \
1426     else {  /* Not utf8 */                                                     \
1427         tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';                         \
1428         tmp = TEST_NON_UTF8(tmp);                                              \
1429         REXEC_FBC_SCAN(                                                        \
1430             if (tmp == ! TEST_NON_UTF8((U8) *s)) {                             \
1431                 tmp = !tmp;                                                    \
1432                 IF_SUCCESS;                                                    \
1433             }                                                                  \
1434             else {                                                             \
1435                 IF_FAIL;                                                       \
1436             }                                                                  \
1437         );                                                                     \
1438     }                                                                          \
1439     if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))           \
1440         goto got_it;
1441
1442 /* We know what class REx starts with.  Try to find this position... */
1443 /* if reginfo is NULL, its a dryrun */
1444 /* annoyingly all the vars in this routine have different names from their counterparts
1445    in regmatch. /grrr */
1446
1447 STATIC char *
1448 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 
1449     const char *strend, regmatch_info *reginfo)
1450 {
1451         dVAR;
1452         const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1453         char *m;
1454         STRLEN ln;
1455         STRLEN lnc;
1456         register STRLEN uskip;
1457         unsigned int c1;
1458         unsigned int c2;
1459         char *e;
1460         register I32 tmp = 1;   /* Scratch variable? */
1461         register const bool utf8_target = PL_reg_match_utf8;
1462         RXi_GET_DECL(prog,progi);
1463
1464         PERL_ARGS_ASSERT_FIND_BYCLASS;
1465         
1466         /* We know what class it must start with. */
1467         switch (OP(c)) {
1468         case ANYOFV:
1469         case ANYOF:
1470             if (utf8_target || OP(c) == ANYOFV) {
1471                  REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_NONBITMAP) ||
1472                           !UTF8_IS_INVARIANT((U8)s[0]) ?
1473                           reginclass(prog, c, (U8*)s, 0, utf8_target) :
1474                           REGINCLASS(prog, c, (U8*)s));
1475             }
1476             else {
1477                  while (s < strend) {
1478                       STRLEN skip = 1;
1479
1480                       if (REGINCLASS(prog, c, (U8*)s) ||
1481                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1482                            /* The assignment of 2 is intentional:
1483                             * for the folded sharp s, the skip is 2. */
1484                            (skip = SHARP_S_SKIP))) {
1485                            if (tmp && (!reginfo || regtry(reginfo, &s)))
1486                                 goto got_it;
1487                            else
1488                                 tmp = doevery;
1489                       }
1490                       else 
1491                            tmp = 1;
1492                       s += skip;
1493                  }
1494             }
1495             break;
1496         case CANY:
1497             REXEC_FBC_SCAN(
1498                 if (tmp && (!reginfo || regtry(reginfo, &s)))
1499                     goto got_it;
1500                 else
1501                     tmp = doevery;
1502             );
1503             break;
1504         case EXACTFU:
1505         case EXACTF:
1506             m   = STRING(c);
1507             ln  = STR_LEN(c);   /* length to match in octets/bytes */
1508             lnc = (I32) ln;     /* length to match in characters */
1509             if (UTF_PATTERN) {
1510                 STRLEN ulen1, ulen2;
1511                 U8 *sm = (U8 *) m;
1512                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1513                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1514                 /* used by commented-out code below */
1515                 /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1516                 
1517                 /* XXX: Since the node will be case folded at compile
1518                    time this logic is a little odd, although im not 
1519                    sure that its actually wrong. --dmq */
1520                    
1521                 c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1522                 c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1523
1524                 /* XXX: This is kinda strange. to_utf8_XYZ returns the 
1525                    codepoint of the first character in the converted
1526                    form, yet originally we did the extra step. 
1527                    No tests fail by commenting this code out however
1528                    so Ive left it out. -- dmq.
1529                    
1530                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE, 
1531                                     0, uniflags);
1532                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1533                                     0, uniflags);
1534                 */
1535                 
1536                 lnc = 0;
1537                 while (sm < ((U8 *) m + ln)) {
1538                     lnc++;
1539                     sm += UTF8SKIP(sm);
1540                 }
1541             }
1542             else {
1543                 c1 = *(U8*)m;
1544                 if (utf8_target || OP(c) == EXACTFU) {
1545
1546                     /* Micro sign folds to GREEK SMALL LETTER MU;
1547                        LATIN_SMALL_LETTER_SHARP_S folds to 'ss', and this sets
1548                        c2 to the first 's' of the pair, and the code below will
1549                        look for others */
1550                     c2 = (c1 == MICRO_SIGN)
1551                         ? GREEK_SMALL_LETTER_MU
1552                         : (c1 == LATIN_SMALL_LETTER_SHARP_S)
1553                            ? 's'
1554                            : PL_fold_latin1[c1];
1555                 } else c2 = PL_fold[c1];
1556             }
1557             goto do_exactf;
1558         case EXACTFL:
1559             m   = STRING(c);
1560             ln  = STR_LEN(c);
1561             lnc = (I32) ln;
1562             c1 = *(U8*)m;
1563             c2 = PL_fold_locale[c1];
1564           do_exactf:
1565             e = HOP3c(strend, -((I32)lnc), s);
1566
1567             if (!reginfo && e < s)
1568                 e = s;                  /* Due to minlen logic of intuit() */
1569
1570             /* The idea in the EXACTF* cases is to first find the
1571              * first character of the EXACTF* node and then, if
1572              * necessary, case-insensitively compare the full
1573              * text of the node.  The c1 and c2 are the first
1574              * characters (though in Unicode it gets a bit
1575              * more complicated because there are more cases
1576              * than just upper and lower: one needs to use
1577              * the so-called folding case for case-insensitive
1578              * matching (called "loose matching" in Unicode).
1579              * foldEQ_utf8() will do just that. */
1580
1581             if (utf8_target || UTF_PATTERN) {
1582                 UV c, f;
1583                 U8 tmpbuf [UTF8_MAXBYTES+1];
1584                 STRLEN len = 1;
1585                 STRLEN foldlen;
1586                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1587                 if (c1 == c2) {
1588                     /* Upper and lower of 1st char are equal -
1589                      * probably not a "letter". */
1590                     while (s <= e) {
1591                         if (utf8_target) {
1592                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1593                                            uniflags);
1594                         } else {
1595                             c = *((U8*)s);
1596                         }                                         
1597                         REXEC_FBC_EXACTISH_CHECK(c == c1);
1598                     }
1599                 }
1600                 else {
1601                     while (s <= e) {
1602                         if (utf8_target) {
1603                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1604                                            uniflags);
1605                         } else {
1606                             c = *((U8*)s);
1607                         }
1608
1609                         /* Handle some of the three Greek sigmas cases.
1610                          * Note that not all the possible combinations
1611                          * are handled here: some of them are handled
1612                          * by the standard folding rules, and some of
1613                          * them (the character class or ANYOF cases)
1614                          * are handled during compiletime in
1615                          * regexec.c:S_regclass(). */
1616                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1617                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1618                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1619
1620                         REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1621                     }
1622                 }
1623             }
1624             else {
1625                 /* Neither pattern nor string are UTF8 */
1626                 if (c1 == c2)
1627                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1628                 else
1629                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1630             }
1631             break;
1632         case BOUNDL:
1633             PL_reg_flags |= RF_tainted;
1634             FBC_BOUND(isALNUM_LC,
1635                       isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
1636                       isALNUM_LC_utf8((U8*)s));
1637             break;
1638         case NBOUNDL:
1639             PL_reg_flags |= RF_tainted;
1640             FBC_NBOUND(isALNUM_LC,
1641                        isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
1642                        isALNUM_LC_utf8((U8*)s));
1643             break;
1644         case BOUND:
1645             FBC_BOUND(isWORDCHAR,
1646                       isALNUM_uni(tmp),
1647                       cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1648             break;
1649         case BOUNDA:
1650             FBC_BOUND_NOLOAD(isWORDCHAR_A,
1651                              isWORDCHAR_A(tmp),
1652                              isWORDCHAR_A((U8*)s));
1653             break;
1654         case NBOUND:
1655             FBC_NBOUND(isWORDCHAR,
1656                        isALNUM_uni(tmp),
1657                        cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1658             break;
1659         case NBOUNDA:
1660             FBC_NBOUND_NOLOAD(isWORDCHAR_A,
1661                               isWORDCHAR_A(tmp),
1662                               isWORDCHAR_A((U8*)s));
1663             break;
1664         case BOUNDU:
1665             FBC_BOUND(isWORDCHAR_L1,
1666                       isALNUM_uni(tmp),
1667                       cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1668             break;
1669         case NBOUNDU:
1670             FBC_NBOUND(isWORDCHAR_L1,
1671                        isALNUM_uni(tmp),
1672                        cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1673             break;
1674         case ALNUML:
1675             REXEC_FBC_CSCAN_TAINT(
1676                 isALNUM_LC_utf8((U8*)s),
1677                 isALNUM_LC(*s)
1678             );
1679             break;
1680         case ALNUMU:
1681             REXEC_FBC_CSCAN_PRELOAD(
1682                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1683                 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1684                 isWORDCHAR_L1((U8) *s)
1685             );
1686             break;
1687         case ALNUM:
1688             REXEC_FBC_CSCAN_PRELOAD(
1689                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1690                 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1691                 isWORDCHAR((U8) *s)
1692             );
1693             break;
1694         case ALNUMA:
1695             /* Don't need to worry about utf8, as it can match only a single
1696              * byte invariant character */
1697             REXEC_FBC_CLASS_SCAN( isWORDCHAR_A(*s));
1698             break;
1699         case NALNUMU:
1700             REXEC_FBC_CSCAN_PRELOAD(
1701                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1702                 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1703                 ! isWORDCHAR_L1((U8) *s)
1704             );
1705             break;
1706         case NALNUM:
1707             REXEC_FBC_CSCAN_PRELOAD(
1708                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1709                 !swash_fetch(RE_utf8_perl_word, (U8*)s, utf8_target),
1710                 ! isALNUM(*s)
1711             );
1712             break;
1713         case NALNUMA:
1714             REXEC_FBC_CSCAN(
1715                 !isWORDCHAR_A(*s),
1716                 !isWORDCHAR_A(*s)
1717             );
1718             break;
1719         case NALNUML:
1720             REXEC_FBC_CSCAN_TAINT(
1721                 !isALNUM_LC_utf8((U8*)s),
1722                 !isALNUM_LC(*s)
1723             );
1724             break;
1725         case SPACEU:
1726             REXEC_FBC_CSCAN_PRELOAD(
1727                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1728                 *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target),
1729                 isSPACE_L1((U8) *s)
1730             );
1731             break;
1732         case SPACE:
1733             REXEC_FBC_CSCAN_PRELOAD(
1734                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1735                 *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target),
1736                 isSPACE((U8) *s)
1737             );
1738             break;
1739         case SPACEA:
1740             /* Don't need to worry about utf8, as it can match only a single
1741              * byte invariant character */
1742             REXEC_FBC_CLASS_SCAN( isSPACE_A(*s));
1743             break;
1744         case SPACEL:
1745             REXEC_FBC_CSCAN_TAINT(
1746                 isSPACE_LC_utf8((U8*)s),
1747                 isSPACE_LC(*s)
1748             );
1749             break;
1750         case NSPACEU:
1751             REXEC_FBC_CSCAN_PRELOAD(
1752                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1753                 !( *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target)),
1754                 ! isSPACE_L1((U8) *s)
1755             );
1756             break;
1757         case NSPACE:
1758             REXEC_FBC_CSCAN_PRELOAD(
1759                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1760                 !(*s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target)),
1761                 ! isSPACE((U8) *s)
1762             );
1763             break;
1764         case NSPACEA:
1765             REXEC_FBC_CSCAN(
1766                 !isSPACE_A(*s),
1767                 !isSPACE_A(*s)
1768             );
1769             break;
1770         case NSPACEL:
1771             REXEC_FBC_CSCAN_TAINT(
1772                 !isSPACE_LC_utf8((U8*)s),
1773                 !isSPACE_LC(*s)
1774             );
1775             break;
1776         case DIGIT:
1777             REXEC_FBC_CSCAN_PRELOAD(
1778                 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1779                 swash_fetch(RE_utf8_posix_digit,(U8*)s, utf8_target),
1780                 isDIGIT(*s)
1781             );
1782             break;
1783         case DIGITA:
1784             /* Don't need to worry about utf8, as it can match only a single
1785              * byte invariant character */
1786             REXEC_FBC_CLASS_SCAN( isDIGIT_A(*s));
1787             break;
1788         case DIGITL:
1789             REXEC_FBC_CSCAN_TAINT(
1790                 isDIGIT_LC_utf8((U8*)s),
1791                 isDIGIT_LC(*s)
1792             );
1793             break;
1794         case NDIGIT:
1795             REXEC_FBC_CSCAN_PRELOAD(
1796                 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1797                 !swash_fetch(RE_utf8_posix_digit,(U8*)s, utf8_target),
1798                 !isDIGIT(*s)
1799             );
1800             break;
1801         case NDIGITA:
1802             REXEC_FBC_CSCAN(
1803                 !isDIGIT_A(*s),
1804                 !isDIGIT_A(*s)
1805             );
1806             break;
1807         case NDIGITL:
1808             REXEC_FBC_CSCAN_TAINT(
1809                 !isDIGIT_LC_utf8((U8*)s),
1810                 !isDIGIT_LC(*s)
1811             );
1812             break;
1813         case LNBREAK:
1814             REXEC_FBC_CSCAN(
1815                 is_LNBREAK_utf8(s),
1816                 is_LNBREAK_latin1(s)
1817             );
1818             break;
1819         case VERTWS:
1820             REXEC_FBC_CSCAN(
1821                 is_VERTWS_utf8(s),
1822                 is_VERTWS_latin1(s)
1823             );
1824             break;
1825         case NVERTWS:
1826             REXEC_FBC_CSCAN(
1827                 !is_VERTWS_utf8(s),
1828                 !is_VERTWS_latin1(s)
1829             );
1830             break;
1831         case HORIZWS:
1832             REXEC_FBC_CSCAN(
1833                 is_HORIZWS_utf8(s),
1834                 is_HORIZWS_latin1(s)
1835             );
1836             break;
1837         case NHORIZWS:
1838             REXEC_FBC_CSCAN(
1839                 !is_HORIZWS_utf8(s),
1840                 !is_HORIZWS_latin1(s)
1841             );      
1842             break;
1843         case AHOCORASICKC:
1844         case AHOCORASICK: 
1845             {
1846                 DECL_TRIE_TYPE(c);
1847                 /* what trie are we using right now */
1848                 reg_ac_data *aho
1849                     = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1850                 reg_trie_data *trie
1851                     = (reg_trie_data*)progi->data->data[ aho->trie ];
1852                 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1853
1854                 const char *last_start = strend - trie->minlen;
1855 #ifdef DEBUGGING
1856                 const char *real_start = s;
1857 #endif
1858                 STRLEN maxlen = trie->maxlen;
1859                 SV *sv_points;
1860                 U8 **points; /* map of where we were in the input string
1861                                 when reading a given char. For ASCII this
1862                                 is unnecessary overhead as the relationship
1863                                 is always 1:1, but for Unicode, especially
1864                                 case folded Unicode this is not true. */
1865                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1866                 U8 *bitmap=NULL;
1867
1868
1869                 GET_RE_DEBUG_FLAGS_DECL;
1870
1871                 /* We can't just allocate points here. We need to wrap it in
1872                  * an SV so it gets freed properly if there is a croak while
1873                  * running the match */
1874                 ENTER;
1875                 SAVETMPS;
1876                 sv_points=newSV(maxlen * sizeof(U8 *));
1877                 SvCUR_set(sv_points,
1878                     maxlen * sizeof(U8 *));
1879                 SvPOK_on(sv_points);
1880                 sv_2mortal(sv_points);
1881                 points=(U8**)SvPV_nolen(sv_points );
1882                 if ( trie_type != trie_utf8_fold 
1883                      && (trie->bitmap || OP(c)==AHOCORASICKC) ) 
1884                 {
1885                     if (trie->bitmap) 
1886                         bitmap=(U8*)trie->bitmap;
1887                     else
1888                         bitmap=(U8*)ANYOF_BITMAP(c);
1889                 }
1890                 /* this is the Aho-Corasick algorithm modified a touch
1891                    to include special handling for long "unknown char" 
1892                    sequences. The basic idea being that we use AC as long
1893                    as we are dealing with a possible matching char, when
1894                    we encounter an unknown char (and we have not encountered
1895                    an accepting state) we scan forward until we find a legal 
1896                    starting char. 
1897                    AC matching is basically that of trie matching, except
1898                    that when we encounter a failing transition, we fall back
1899                    to the current states "fail state", and try the current char 
1900                    again, a process we repeat until we reach the root state, 
1901                    state 1, or a legal transition. If we fail on the root state 
1902                    then we can either terminate if we have reached an accepting 
1903                    state previously, or restart the entire process from the beginning 
1904                    if we have not.
1905
1906                  */
1907                 while (s <= last_start) {
1908                     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1909                     U8 *uc = (U8*)s;
1910                     U16 charid = 0;
1911                     U32 base = 1;
1912                     U32 state = 1;
1913                     UV uvc = 0;
1914                     STRLEN len = 0;
1915                     STRLEN foldlen = 0;
1916                     U8 *uscan = (U8*)NULL;
1917                     U8 *leftmost = NULL;
1918 #ifdef DEBUGGING                    
1919                     U32 accepted_word= 0;
1920 #endif
1921                     U32 pointpos = 0;
1922
1923                     while ( state && uc <= (U8*)strend ) {
1924                         int failed=0;
1925                         U32 word = aho->states[ state ].wordnum;
1926
1927                         if( state==1 ) {
1928                             if ( bitmap ) {
1929                                 DEBUG_TRIE_EXECUTE_r(
1930                                     if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1931                                         dump_exec_pos( (char *)uc, c, strend, real_start, 
1932                                             (char *)uc, utf8_target );
1933                                         PerlIO_printf( Perl_debug_log,
1934                                             " Scanning for legal start char...\n");
1935                                     }
1936                                 );
1937                                 if (utf8_target) {
1938                                     while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1939                                         uc += UTF8SKIP(uc);
1940                                     }
1941                                 } else {
1942                                     while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1943                                         uc++;
1944                                     }
1945                                 }
1946                                 s= (char *)uc;
1947                             }
1948                             if (uc >(U8*)last_start) break;
1949                         }
1950                                             
1951                         if ( word ) {
1952                             U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
1953                             if (!leftmost || lpos < leftmost) {
1954                                 DEBUG_r(accepted_word=word);
1955                                 leftmost= lpos;
1956                             }
1957                             if (base==0) break;
1958                             
1959                         }
1960                         points[pointpos++ % maxlen]= uc;
1961                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1962                                              uscan, len, uvc, charid, foldlen,
1963                                              foldbuf, uniflags);
1964                         DEBUG_TRIE_EXECUTE_r({
1965                             dump_exec_pos( (char *)uc, c, strend, real_start, 
1966                                 s,   utf8_target );
1967                             PerlIO_printf(Perl_debug_log,
1968                                 " Charid:%3u CP:%4"UVxf" ",
1969                                  charid, uvc);
1970                         });
1971
1972                         do {
1973 #ifdef DEBUGGING
1974                             word = aho->states[ state ].wordnum;
1975 #endif
1976                             base = aho->states[ state ].trans.base;
1977
1978                             DEBUG_TRIE_EXECUTE_r({
1979                                 if (failed) 
1980                                     dump_exec_pos( (char *)uc, c, strend, real_start, 
1981                                         s,   utf8_target );
1982                                 PerlIO_printf( Perl_debug_log,
1983                                     "%sState: %4"UVxf", word=%"UVxf,
1984                                     failed ? " Fail transition to " : "",
1985                                     (UV)state, (UV)word);
1986                             });
1987                             if ( base ) {
1988                                 U32 tmp;
1989                                 I32 offset;
1990                                 if (charid &&
1991                                      ( ((offset = base + charid
1992                                         - 1 - trie->uniquecharcount)) >= 0)
1993                                      && ((U32)offset < trie->lasttrans)
1994                                      && trie->trans[offset].check == state
1995                                      && (tmp=trie->trans[offset].next))
1996                                 {
1997                                     DEBUG_TRIE_EXECUTE_r(
1998                                         PerlIO_printf( Perl_debug_log," - legal\n"));
1999                                     state = tmp;
2000                                     break;
2001                                 }
2002                                 else {
2003                                     DEBUG_TRIE_EXECUTE_r(
2004                                         PerlIO_printf( Perl_debug_log," - fail\n"));
2005                                     failed = 1;
2006                                     state = aho->fail[state];
2007                                 }
2008                             }
2009                             else {
2010                                 /* we must be accepting here */
2011                                 DEBUG_TRIE_EXECUTE_r(
2012                                         PerlIO_printf( Perl_debug_log," - accepting\n"));
2013                                 failed = 1;
2014                                 break;
2015                             }
2016                         } while(state);
2017                         uc += len;
2018                         if (failed) {
2019                             if (leftmost)
2020                                 break;
2021                             if (!state) state = 1;
2022                         }
2023                     }
2024                     if ( aho->states[ state ].wordnum ) {
2025                         U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
2026                         if (!leftmost || lpos < leftmost) {
2027                             DEBUG_r(accepted_word=aho->states[ state ].wordnum);
2028                             leftmost = lpos;
2029                         }
2030                     }
2031                     if (leftmost) {
2032                         s = (char*)leftmost;
2033                         DEBUG_TRIE_EXECUTE_r({
2034                             PerlIO_printf( 
2035                                 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
2036                                 (UV)accepted_word, (IV)(s - real_start)
2037                             );
2038                         });
2039                         if (!reginfo || regtry(reginfo, &s)) {
2040                             FREETMPS;
2041                             LEAVE;
2042                             goto got_it;
2043                         }
2044                         s = HOPc(s,1);
2045                         DEBUG_TRIE_EXECUTE_r({
2046                             PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
2047                         });
2048                     } else {
2049                         DEBUG_TRIE_EXECUTE_r(
2050                             PerlIO_printf( Perl_debug_log,"No match.\n"));
2051                         break;
2052                     }
2053                 }
2054                 FREETMPS;
2055                 LEAVE;
2056             }
2057             break;
2058         default:
2059             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
2060             break;
2061         }
2062         return 0;
2063       got_it:
2064         return s;
2065 }
2066
2067
2068 /*
2069  - regexec_flags - match a regexp against a string
2070  */
2071 I32
2072 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
2073               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
2074 /* strend: pointer to null at end of string */
2075 /* strbeg: real beginning of string */
2076 /* minend: end of match must be >=minend after stringarg. */
2077 /* data: May be used for some additional optimizations. 
2078          Currently its only used, with a U32 cast, for transmitting 
2079          the ganch offset when doing a /g match. This will change */
2080 /* nosave: For optimizations. */
2081 {
2082     dVAR;
2083     struct regexp *const prog = (struct regexp *)SvANY(rx);
2084     /*register*/ char *s;
2085     register regnode *c;
2086     /*register*/ char *startpos = stringarg;
2087     I32 minlen;         /* must match at least this many chars */
2088     I32 dontbother = 0; /* how many characters not to try at end */
2089     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
2090     I32 scream_pos = -1;                /* Internal iterator of scream. */
2091     char *scream_olds = NULL;
2092     const bool utf8_target = cBOOL(DO_UTF8(sv));
2093     I32 multiline;
2094     RXi_GET_DECL(prog,progi);
2095     regmatch_info reginfo;  /* create some info to pass to regtry etc */
2096     regexp_paren_pair *swap = NULL;
2097     GET_RE_DEBUG_FLAGS_DECL;
2098
2099     PERL_ARGS_ASSERT_REGEXEC_FLAGS;
2100     PERL_UNUSED_ARG(data);
2101
2102     /* Be paranoid... */
2103     if (prog == NULL || startpos == NULL) {
2104         Perl_croak(aTHX_ "NULL regexp parameter");
2105         return 0;
2106     }
2107
2108     multiline = prog->extflags & RXf_PMf_MULTILINE;
2109     reginfo.prog = rx;   /* Yes, sorry that this is confusing.  */
2110
2111     RX_MATCH_UTF8_set(rx, utf8_target);
2112     DEBUG_EXECUTE_r( 
2113         debug_start_match(rx, utf8_target, startpos, strend,
2114         "Matching");
2115     );
2116
2117     minlen = prog->minlen;
2118     
2119     if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
2120         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2121                               "String too short [regexec_flags]...\n"));
2122         goto phooey;
2123     }
2124
2125     
2126     /* Check validity of program. */
2127     if (UCHARAT(progi->program) != REG_MAGIC) {
2128         Perl_croak(aTHX_ "corrupted regexp program");
2129     }
2130
2131     PL_reg_flags = 0;
2132     PL_reg_eval_set = 0;
2133     PL_reg_maxiter = 0;
2134
2135     if (RX_UTF8(rx))
2136         PL_reg_flags |= RF_utf8;
2137
2138     /* Mark beginning of line for ^ and lookbehind. */
2139     reginfo.bol = startpos; /* XXX not used ??? */
2140     PL_bostr  = strbeg;
2141     reginfo.sv = sv;
2142
2143     /* Mark end of line for $ (and such) */
2144     PL_regeol = strend;
2145
2146     /* see how far we have to get to not match where we matched before */
2147     reginfo.till = startpos+minend;
2148
2149     /* If there is a "must appear" string, look for it. */
2150     s = startpos;
2151
2152     if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
2153         MAGIC *mg;
2154         if (flags & REXEC_IGNOREPOS){   /* Means: check only at start */
2155             reginfo.ganch = startpos + prog->gofs;
2156             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2157               "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
2158         } else if (sv && SvTYPE(sv) >= SVt_PVMG
2159                   && SvMAGIC(sv)
2160                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
2161                   && mg->mg_len >= 0) {
2162             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
2163             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2164                 "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
2165
2166             if (prog->extflags & RXf_ANCH_GPOS) {
2167                 if (s > reginfo.ganch)
2168                     goto phooey;
2169                 s = reginfo.ganch - prog->gofs;
2170                 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2171                      "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
2172                 if (s < strbeg)
2173                     goto phooey;
2174             }
2175         }
2176         else if (data) {
2177             reginfo.ganch = strbeg + PTR2UV(data);
2178             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2179                  "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
2180
2181         } else {                                /* pos() not defined */
2182             reginfo.ganch = strbeg;
2183             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2184                  "GPOS: reginfo.ganch = strbeg\n"));
2185         }
2186     }
2187     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
2188         /* We have to be careful. If the previous successful match
2189            was from this regex we don't want a subsequent partially
2190            successful match to clobber the old results.
2191            So when we detect this possibility we add a swap buffer
2192            to the re, and switch the buffer each match. If we fail
2193            we switch it back, otherwise we leave it swapped.
2194         */
2195         swap = prog->offs;
2196         /* do we need a save destructor here for eval dies? */
2197         Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
2198     }
2199     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
2200         re_scream_pos_data d;
2201
2202         d.scream_olds = &scream_olds;
2203         d.scream_pos = &scream_pos;
2204         s = re_intuit_start(rx, sv, s, strend, flags, &d);
2205         if (!s) {
2206             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
2207             goto phooey;        /* not present */
2208         }
2209     }
2210
2211
2212
2213     /* Simplest case:  anchored match need be tried only once. */
2214     /*  [unless only anchor is BOL and multiline is set] */
2215     if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
2216         if (s == startpos && regtry(&reginfo, &startpos))
2217             goto got_it;
2218         else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2219                  || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
2220         {
2221             char *end;
2222
2223             if (minlen)
2224                 dontbother = minlen - 1;
2225             end = HOP3c(strend, -dontbother, strbeg) - 1;
2226             /* for multiline we only have to try after newlines */
2227             if (prog->check_substr || prog->check_utf8) {
2228                 /* because of the goto we can not easily reuse the macros for bifurcating the
2229                    unicode/non-unicode match modes here like we do elsewhere - demerphq */
2230                 if (utf8_target) {
2231                     if (s == startpos)
2232                         goto after_try_utf8;
2233                     while (1) {
2234                         if (regtry(&reginfo, &s)) {
2235                             goto got_it;
2236                         }
2237                       after_try_utf8:
2238                         if (s > end) {
2239                             goto phooey;
2240                         }
2241                         if (prog->extflags & RXf_USE_INTUIT) {
2242                             s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL);
2243                             if (!s) {
2244                                 goto phooey;
2245                             }
2246                         }
2247                         else {
2248                             s += UTF8SKIP(s);
2249                         }
2250                     }
2251                 } /* end search for check string in unicode */
2252                 else {
2253                     if (s == startpos) {
2254                         goto after_try_latin;
2255                     }
2256                     while (1) {
2257                         if (regtry(&reginfo, &s)) {
2258                             goto got_it;
2259                         }
2260                       after_try_latin:
2261                         if (s > end) {
2262                             goto phooey;
2263                         }
2264                         if (prog->extflags & RXf_USE_INTUIT) {
2265                             s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2266                             if (!s) {
2267                                 goto phooey;
2268                             }
2269                         }
2270                         else {
2271                             s++;
2272                         }
2273                     }
2274                 } /* end search for check string in latin*/
2275             } /* end search for check string */
2276             else { /* search for newline */
2277                 if (s > startpos) {
2278                     /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
2279                     s--;
2280                 }
2281                 /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
2282                 while (s < end) {
2283                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
2284                         if (regtry(&reginfo, &s))
2285                             goto got_it;
2286                     }
2287                 }
2288             } /* end search for newline */
2289         } /* end anchored/multiline check string search */
2290         goto phooey;
2291     } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK)) 
2292     {
2293         /* the warning about reginfo.ganch being used without initialization
2294            is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN 
2295            and we only enter this block when the same bit is set. */
2296         char *tmp_s = reginfo.ganch - prog->gofs;
2297
2298         if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
2299             goto got_it;
2300         goto phooey;
2301     }
2302
2303     /* Messy cases:  unanchored match. */
2304     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2305         /* we have /x+whatever/ */
2306         /* it must be a one character string (XXXX Except UTF_PATTERN?) */
2307         char ch;
2308 #ifdef DEBUGGING
2309         int did_match = 0;
2310 #endif
2311         if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
2312             utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2313         ch = SvPVX_const(utf8_target ? prog->anchored_utf8 : prog->anchored_substr)[0];
2314
2315         if (utf8_target) {
2316             REXEC_FBC_SCAN(
2317                 if (*s == ch) {
2318                     DEBUG_EXECUTE_r( did_match = 1 );
2319                     if (regtry(&reginfo, &s)) goto got_it;
2320                     s += UTF8SKIP(s);
2321                     while (s < strend && *s == ch)
2322                         s += UTF8SKIP(s);
2323                 }
2324             );
2325         }
2326         else {
2327             REXEC_FBC_SCAN(
2328                 if (*s == ch) {
2329                     DEBUG_EXECUTE_r( did_match = 1 );
2330                     if (regtry(&reginfo, &s)) goto got_it;
2331                     s++;
2332                     while (s < strend && *s == ch)
2333                         s++;
2334                 }
2335             );
2336         }
2337         DEBUG_EXECUTE_r(if (!did_match)
2338                 PerlIO_printf(Perl_debug_log,
2339                                   "Did not find anchored character...\n")
2340                );
2341     }
2342     else if (prog->anchored_substr != NULL
2343               || prog->anchored_utf8 != NULL
2344               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2345                   && prog->float_max_offset < strend - s)) {
2346         SV *must;
2347         I32 back_max;
2348         I32 back_min;
2349         char *last;
2350         char *last1;            /* Last position checked before */
2351 #ifdef DEBUGGING
2352         int did_match = 0;
2353 #endif
2354         if (prog->anchored_substr || prog->anchored_utf8) {
2355             if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
2356                 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2357             must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
2358             back_max = back_min = prog->anchored_offset;
2359         } else {
2360             if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
2361                 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2362             must = utf8_target ? prog->float_utf8 : prog->float_substr;
2363             back_max = prog->float_max_offset;
2364             back_min = prog->float_min_offset;
2365         }
2366         
2367             
2368         if (must == &PL_sv_undef)
2369             /* could not downgrade utf8 check substring, so must fail */
2370             goto phooey;
2371
2372         if (back_min<0) {
2373             last = strend;
2374         } else {
2375             last = HOP3c(strend,        /* Cannot start after this */
2376                   -(I32)(CHR_SVLEN(must)
2377                          - (SvTAIL(must) != 0) + back_min), strbeg);
2378         }
2379         if (s > PL_bostr)
2380             last1 = HOPc(s, -1);
2381         else
2382             last1 = s - 1;      /* bogus */
2383
2384         /* XXXX check_substr already used to find "s", can optimize if
2385            check_substr==must. */
2386         scream_pos = -1;
2387         dontbother = end_shift;
2388         strend = HOPc(strend, -dontbother);
2389         while ( (s <= last) &&
2390                 ((flags & REXEC_SCREAM)
2391                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2392                                     end_shift, &scream_pos, 0))
2393                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2394                                   (unsigned char*)strend, must,
2395                                   multiline ? FBMrf_MULTILINE : 0))) ) {
2396             /* we may be pointing at the wrong string */
2397             if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2398                 s = strbeg + (s - SvPVX_const(sv));
2399             DEBUG_EXECUTE_r( did_match = 1 );
2400             if (HOPc(s, -back_max) > last1) {
2401                 last1 = HOPc(s, -back_min);
2402                 s = HOPc(s, -back_max);
2403             }
2404             else {
2405                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2406
2407                 last1 = HOPc(s, -back_min);
2408                 s = t;
2409             }
2410             if (utf8_target) {
2411                 while (s <= last1) {
2412                     if (regtry(&reginfo, &s))
2413                         goto got_it;
2414                     s += UTF8SKIP(s);
2415                 }
2416             }
2417             else {
2418                 while (s <= last1) {
2419                     if (regtry(&reginfo, &s))
2420                         goto got_it;
2421                     s++;
2422                 }
2423             }
2424         }
2425         DEBUG_EXECUTE_r(if (!did_match) {
2426             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
2427                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2428             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2429                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2430                                ? "anchored" : "floating"),
2431                 quoted, RE_SV_TAIL(must));
2432         });                 
2433         goto phooey;
2434     }
2435     else if ( (c = progi->regstclass) ) {
2436         if (minlen) {
2437             const OPCODE op = OP(progi->regstclass);
2438             /* don't bother with what can't match */
2439             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2440                 strend = HOPc(strend, -(minlen - 1));
2441         }
2442         DEBUG_EXECUTE_r({
2443             SV * const prop = sv_newmortal();
2444             regprop(prog, prop, c);
2445             {
2446                 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
2447                     s,strend-s,60);
2448                 PerlIO_printf(Perl_debug_log,
2449                     "Matching stclass %.*s against %s (%d bytes)\n",
2450                     (int)SvCUR(prop), SvPVX_const(prop),
2451                      quoted, (int)(strend - s));
2452             }
2453         });
2454         if (find_byclass(prog, c, s, strend, &reginfo))
2455             goto got_it;
2456         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2457     }
2458     else {
2459         dontbother = 0;
2460         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2461             /* Trim the end. */
2462             char *last;
2463             SV* float_real;
2464
2465             if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
2466                 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2467             float_real = utf8_target ? prog->float_utf8 : prog->float_substr;
2468
2469             if (flags & REXEC_SCREAM) {
2470                 last = screaminstr(sv, float_real, s - strbeg,
2471                                    end_shift, &scream_pos, 1); /* last one */
2472                 if (!last)
2473                     last = scream_olds; /* Only one occurrence. */
2474                 /* we may be pointing at the wrong string */
2475                 else if (RXp_MATCH_COPIED(prog))
2476                     s = strbeg + (s - SvPVX_const(sv));
2477             }
2478             else {
2479                 STRLEN len;
2480                 const char * const little = SvPV_const(float_real, len);
2481
2482                 if (SvTAIL(float_real)) {
2483                     if (memEQ(strend - len + 1, little, len - 1))
2484                         last = strend - len + 1;
2485                     else if (!multiline)
2486                         last = memEQ(strend - len, little, len)
2487                             ? strend - len : NULL;
2488                     else
2489                         goto find_last;
2490                 } else {
2491                   find_last:
2492                     if (len)
2493                         last = rninstr(s, strend, little, little + len);
2494                     else
2495                         last = strend;  /* matching "$" */
2496                 }
2497             }
2498             if (last == NULL) {
2499                 DEBUG_EXECUTE_r(
2500                     PerlIO_printf(Perl_debug_log,
2501                         "%sCan't trim the tail, match fails (should not happen)%s\n",
2502                         PL_colors[4], PL_colors[5]));
2503                 goto phooey; /* Should not happen! */
2504             }
2505             dontbother = strend - last + prog->float_min_offset;
2506         }
2507         if (minlen && (dontbother < minlen))
2508             dontbother = minlen - 1;
2509         strend -= dontbother;              /* this one's always in bytes! */
2510         /* We don't know much -- general case. */
2511         if (utf8_target) {
2512             for (;;) {
2513                 if (regtry(&reginfo, &s))
2514                     goto got_it;
2515                 if (s >= strend)
2516                     break;
2517                 s += UTF8SKIP(s);
2518             };
2519         }
2520         else {
2521             do {
2522                 if (regtry(&reginfo, &s))
2523                     goto got_it;
2524             } while (s++ < strend);
2525         }
2526     }
2527
2528     /* Failure. */
2529     goto phooey;
2530
2531 got_it:
2532     Safefree(swap);
2533     RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2534
2535     if (PL_reg_eval_set)
2536         restore_pos(aTHX_ prog);
2537     if (RXp_PAREN_NAMES(prog)) 
2538         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2539
2540     /* make sure $`, $&, $', and $digit will work later */
2541     if ( !(flags & REXEC_NOT_FIRST) ) {
2542         RX_MATCH_COPY_FREE(rx);
2543         if (flags & REXEC_COPY_STR) {
2544             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2545 #ifdef PERL_OLD_COPY_ON_WRITE
2546             if ((SvIsCOW(sv)
2547                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2548                 if (DEBUG_C_TEST) {
2549                     PerlIO_printf(Perl_debug_log,
2550                                   "Copy on write: regexp capture, type %d\n",
2551                                   (int) SvTYPE(sv));
2552                 }
2553                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2554                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2555                 assert (SvPOKp(prog->saved_copy));
2556             } else
2557 #endif
2558             {
2559                 RX_MATCH_COPIED_on(rx);
2560                 s = savepvn(strbeg, i);
2561                 prog->subbeg = s;
2562             }
2563             prog->sublen = i;
2564         }
2565         else {
2566             prog->subbeg = strbeg;
2567             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2568         }
2569     }
2570
2571     return 1;
2572
2573 phooey:
2574     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2575                           PL_colors[4], PL_colors[5]));
2576     if (PL_reg_eval_set)
2577         restore_pos(aTHX_ prog);
2578     if (swap) {
2579         /* we failed :-( roll it back */
2580         Safefree(prog->offs);
2581         prog->offs = swap;
2582     }
2583
2584     return 0;
2585 }
2586
2587
2588 /*
2589  - regtry - try match at specific point
2590  */
2591 STATIC I32                      /* 0 failure, 1 success */
2592 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2593 {
2594     dVAR;
2595     CHECKPOINT lastcp;
2596     REGEXP *const rx = reginfo->prog;
2597     regexp *const prog = (struct regexp *)SvANY(rx);
2598     RXi_GET_DECL(prog,progi);
2599     GET_RE_DEBUG_FLAGS_DECL;
2600
2601     PERL_ARGS_ASSERT_REGTRY;
2602
2603     reginfo->cutpoint=NULL;
2604
2605     if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2606         MAGIC *mg;
2607
2608         PL_reg_eval_set = RS_init;
2609         DEBUG_EXECUTE_r(DEBUG_s(
2610             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2611                           (IV)(PL_stack_sp - PL_stack_base));
2612             ));
2613         SAVESTACK_CXPOS();
2614         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2615         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2616         SAVETMPS;
2617         /* Apparently this is not needed, judging by wantarray. */
2618         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2619            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2620
2621         if (reginfo->sv) {
2622             /* Make $_ available to executed code. */
2623             if (reginfo->sv != DEFSV) {
2624                 SAVE_DEFSV;
2625                 DEFSV_set(reginfo->sv);
2626             }
2627         
2628             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2629                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2630                 /* prepare for quick setting of pos */
2631 #ifdef PERL_OLD_COPY_ON_WRITE
2632                 if (SvIsCOW(reginfo->sv))
2633                     sv_force_normal_flags(reginfo->sv, 0);
2634 #endif
2635                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2636                                  &PL_vtbl_mglob, NULL, 0);
2637                 mg->mg_len = -1;
2638             }
2639             PL_reg_magic    = mg;
2640             PL_reg_oldpos   = mg->mg_len;
2641             SAVEDESTRUCTOR_X(restore_pos, prog);
2642         }
2643         if (!PL_reg_curpm) {
2644             Newxz(PL_reg_curpm, 1, PMOP);
2645 #ifdef USE_ITHREADS
2646             {
2647                 SV* const repointer = &PL_sv_undef;
2648                 /* this regexp is also owned by the new PL_reg_curpm, which
2649                    will try to free it.  */
2650                 av_push(PL_regex_padav, repointer);
2651                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2652                 PL_regex_pad = AvARRAY(PL_regex_padav);
2653             }
2654 #endif      
2655         }
2656 #ifdef USE_ITHREADS
2657         /* It seems that non-ithreads works both with and without this code.
2658            So for efficiency reasons it seems best not to have the code
2659            compiled when it is not needed.  */
2660         /* This is safe against NULLs: */
2661         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2662         /* PM_reg_curpm owns a reference to this regexp.  */
2663         ReREFCNT_inc(rx);
2664 #endif
2665         PM_SETRE(PL_reg_curpm, rx);
2666         PL_reg_oldcurpm = PL_curpm;
2667         PL_curpm = PL_reg_curpm;
2668         if (RXp_MATCH_COPIED(prog)) {
2669             /*  Here is a serious problem: we cannot rewrite subbeg,
2670                 since it may be needed if this match fails.  Thus
2671                 $` inside (?{}) could fail... */
2672             PL_reg_oldsaved = prog->subbeg;
2673             PL_reg_oldsavedlen = prog->sublen;
2674 #ifdef PERL_OLD_COPY_ON_WRITE
2675             PL_nrs = prog->saved_copy;
2676 #endif
2677             RXp_MATCH_COPIED_off(prog);
2678         }
2679         else
2680             PL_reg_oldsaved = NULL;
2681         prog->subbeg = PL_bostr;
2682         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2683     }
2684     DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2685     prog->offs[0].start = *startpos - PL_bostr;
2686     PL_reginput = *startpos;
2687     PL_reglastparen = &prog->lastparen;
2688     PL_reglastcloseparen = &prog->lastcloseparen;
2689     prog->lastparen = 0;
2690     prog->lastcloseparen = 0;
2691     PL_regsize = 0;
2692     PL_regoffs = prog->offs;
2693     if (PL_reg_start_tmpl <= prog->nparens) {
2694         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2695         if(PL_reg_start_tmp)
2696             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2697         else
2698             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2699     }
2700
2701     /* XXXX What this code is doing here?!!!  There should be no need
2702        to do this again and again, PL_reglastparen should take care of
2703        this!  --ilya*/
2704
2705     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2706      * Actually, the code in regcppop() (which Ilya may be meaning by
2707      * PL_reglastparen), is not needed at all by the test suite
2708      * (op/regexp, op/pat, op/split), but that code is needed otherwise
2709      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2710      * Meanwhile, this code *is* needed for the
2711      * above-mentioned test suite tests to succeed.  The common theme
2712      * on those tests seems to be returning null fields from matches.
2713      * --jhi updated by dapm */
2714 #if 1
2715     if (prog->nparens) {
2716         regexp_paren_pair *pp = PL_regoffs;
2717         register I32 i;
2718         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2719             ++pp;
2720             pp->start = -1;
2721             pp->end = -1;
2722         }
2723     }
2724 #endif
2725     REGCP_SET(lastcp);
2726     if (regmatch(reginfo, progi->program + 1)) {
2727         PL_regoffs[0].end = PL_reginput - PL_bostr;
2728         return 1;
2729     }
2730     if (reginfo->cutpoint)
2731         *startpos= reginfo->cutpoint;
2732     REGCP_UNWIND(lastcp);
2733     return 0;
2734 }
2735
2736
2737 #define sayYES goto yes
2738 #define sayNO goto no
2739 #define sayNO_SILENT goto no_silent
2740
2741 /* we dont use STMT_START/END here because it leads to 
2742    "unreachable code" warnings, which are bogus, but distracting. */
2743 #define CACHEsayNO \
2744     if (ST.cache_mask) \
2745        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2746     sayNO
2747
2748 /* this is used to determine how far from the left messages like
2749    'failed...' are printed. It should be set such that messages 
2750    are inline with the regop output that created them.
2751 */
2752 #define REPORT_CODE_OFF 32
2753
2754
2755 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2756 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2757
2758 #define SLAB_FIRST(s) (&(s)->states[0])
2759 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2760
2761 /* grab a new slab and return the first slot in it */
2762
2763 STATIC regmatch_state *
2764 S_push_slab(pTHX)
2765 {
2766 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2767     dMY_CXT;
2768 #endif
2769     regmatch_slab *s = PL_regmatch_slab->next;
2770     if (!s) {
2771         Newx(s, 1, regmatch_slab);
2772         s->prev = PL_regmatch_slab;
2773         s->next = NULL;
2774         PL_regmatch_slab->next = s;
2775     }
2776     PL_regmatch_slab = s;
2777     return SLAB_FIRST(s);
2778 }
2779
2780
2781 /* push a new state then goto it */
2782
2783 #define PUSH_STATE_GOTO(state, node) \
2784     scan = node; \
2785     st->resume_state = state; \
2786     goto push_state;
2787
2788 /* push a new state with success backtracking, then goto it */
2789
2790 #define PUSH_YES_STATE_GOTO(state, node) \
2791     scan = node; \
2792     st->resume_state = state; \
2793     goto push_yes_state;
2794
2795
2796
2797 /*
2798
2799 regmatch() - main matching routine
2800
2801 This is basically one big switch statement in a loop. We execute an op,
2802 set 'next' to point the next op, and continue. If we come to a point which
2803 we may need to backtrack to on failure such as (A|B|C), we push a
2804 backtrack state onto the backtrack stack. On failure, we pop the top
2805 state, and re-enter the loop at the state indicated. If there are no more
2806 states to pop, we return failure.
2807
2808 Sometimes we also need to backtrack on success; for example /A+/, where
2809 after successfully matching one A, we need to go back and try to
2810 match another one; similarly for lookahead assertions: if the assertion
2811 completes successfully, we backtrack to the state just before the assertion
2812 and then carry on.  In these cases, the pushed state is marked as
2813 'backtrack on success too'. This marking is in fact done by a chain of
2814 pointers, each pointing to the previous 'yes' state. On success, we pop to
2815 the nearest yes state, discarding any intermediate failure-only states.
2816 Sometimes a yes state is pushed just to force some cleanup code to be
2817 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2818 it to free the inner regex.
2819
2820 Note that failure backtracking rewinds the cursor position, while
2821 success backtracking leaves it alone.
2822
2823 A pattern is complete when the END op is executed, while a subpattern
2824 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2825 ops trigger the "pop to last yes state if any, otherwise return true"
2826 behaviour.
2827
2828 A common convention in this function is to use A and B to refer to the two
2829 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2830 the subpattern to be matched possibly multiple times, while B is the entire
2831 rest of the pattern. Variable and state names reflect this convention.
2832
2833 The states in the main switch are the union of ops and failure/success of
2834 substates associated with with that op.  For example, IFMATCH is the op
2835 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2836 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2837 successfully matched A and IFMATCH_A_fail is a state saying that we have
2838 just failed to match A. Resume states always come in pairs. The backtrack
2839 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2840 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2841 on success or failure.
2842
2843 The struct that holds a backtracking state is actually a big union, with
2844 one variant for each major type of op. The variable st points to the
2845 top-most backtrack struct. To make the code clearer, within each
2846 block of code we #define ST to alias the relevant union.
2847
2848 Here's a concrete example of a (vastly oversimplified) IFMATCH
2849 implementation:
2850
2851     switch (state) {
2852     ....
2853
2854 #define ST st->u.ifmatch
2855
2856     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2857         ST.foo = ...; // some state we wish to save
2858         ...
2859         // push a yes backtrack state with a resume value of
2860         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2861         // first node of A:
2862         PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2863         // NOTREACHED
2864
2865     case IFMATCH_A: // we have successfully executed A; now continue with B
2866         next = B;
2867         bar = ST.foo; // do something with the preserved value
2868         break;
2869
2870     case IFMATCH_A_fail: // A failed, so the assertion failed
2871         ...;   // do some housekeeping, then ...
2872         sayNO; // propagate the failure
2873
2874 #undef ST
2875
2876     ...
2877     }
2878
2879 For any old-timers reading this who are familiar with the old recursive
2880 approach, the code above is equivalent to:
2881
2882     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2883     {
2884         int foo = ...
2885         ...
2886         if (regmatch(A)) {
2887             next = B;
2888             bar = foo;
2889             break;
2890         }
2891         ...;   // do some housekeeping, then ...
2892         sayNO; // propagate the failure
2893     }
2894
2895 The topmost backtrack state, pointed to by st, is usually free. If you
2896 want to claim it, populate any ST.foo fields in it with values you wish to
2897 save, then do one of
2898
2899         PUSH_STATE_GOTO(resume_state, node);
2900         PUSH_YES_STATE_GOTO(resume_state, node);
2901
2902 which sets that backtrack state's resume value to 'resume_state', pushes a
2903 new free entry to the top of the backtrack stack, then goes to 'node'.
2904 On backtracking, the free slot is popped, and the saved state becomes the
2905 new free state. An ST.foo field in this new top state can be temporarily
2906 accessed to retrieve values, but once the main loop is re-entered, it
2907 becomes available for reuse.
2908
2909 Note that the depth of the backtrack stack constantly increases during the
2910 left-to-right execution of the pattern, rather than going up and down with
2911 the pattern nesting. For example the stack is at its maximum at Z at the
2912 end of the pattern, rather than at X in the following:
2913
2914     /(((X)+)+)+....(Y)+....Z/
2915
2916 The only exceptions to this are lookahead/behind assertions and the cut,
2917 (?>A), which pop all the backtrack states associated with A before
2918 continuing.
2919  
2920 Backtrack state structs are allocated in slabs of about 4K in size.
2921 PL_regmatch_state and st always point to the currently active state,
2922 and PL_regmatch_slab points to the slab currently containing
2923 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2924 allocated, and is never freed until interpreter destruction. When the slab
2925 is full, a new one is allocated and chained to the end. At exit from
2926 regmatch(), slabs allocated since entry are freed.
2927
2928 */
2929  
2930
2931 #define DEBUG_STATE_pp(pp)                                  \
2932     DEBUG_STATE_r({                                         \
2933         DUMP_EXEC_POS(locinput, scan, utf8_target);                 \
2934         PerlIO_printf(Perl_debug_log,                       \
2935             "    %*s"pp" %s%s%s%s%s\n",                     \
2936             depth*2, "",                                    \
2937             PL_reg_name[st->resume_state],                     \
2938             ((st==yes_state||st==mark_state) ? "[" : ""),   \
2939             ((st==yes_state) ? "Y" : ""),                   \
2940             ((st==mark_state) ? "M" : ""),                  \
2941             ((st==yes_state||st==mark_state) ? "]" : "")    \
2942         );                                                  \
2943     });
2944
2945
2946 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2947
2948 #ifdef DEBUGGING
2949
2950 STATIC void
2951 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
2952     const char *start, const char *end, const char *blurb)
2953 {
2954     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2955
2956     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2957
2958     if (!PL_colorset)   
2959             reginitcolors();    
2960     {
2961         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), 
2962             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);   
2963         
2964         RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
2965             start, end - start, 60); 
2966         
2967         PerlIO_printf(Perl_debug_log, 
2968             "%s%s REx%s %s against %s\n", 
2969                        PL_colors[4], blurb, PL_colors[5], s0, s1); 
2970         
2971         if (utf8_target||utf8_pat)
2972             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2973                 utf8_pat ? "pattern" : "",
2974                 utf8_pat && utf8_target ? " and " : "",
2975                 utf8_target ? "string" : ""
2976             ); 
2977     }
2978 }
2979
2980 STATIC void
2981 S_dump_exec_pos(pTHX_ const char *locinput, 
2982                       const regnode *scan, 
2983                       const char *loc_regeol, 
2984                       const char *loc_bostr, 
2985                       const char *loc_reg_starttry,
2986                       const bool utf8_target)
2987 {
2988     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2989     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2990     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2991     /* The part of the string before starttry has one color
2992        (pref0_len chars), between starttry and current
2993        position another one (pref_len - pref0_len chars),
2994        after the current position the third one.
2995        We assume that pref0_len <= pref_len, otherwise we
2996        decrease pref0_len.  */
2997     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2998         ? (5 + taill) - l : locinput - loc_bostr;
2999     int pref0_len;
3000
3001     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
3002
3003     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
3004         pref_len++;
3005     pref0_len = pref_len  - (locinput - loc_reg_starttry);
3006     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
3007         l = ( loc_regeol - locinput > (5 + taill) - pref_len
3008               ? (5 + taill) - pref_len : loc_regeol - locinput);
3009     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
3010         l--;
3011     if (pref0_len < 0)
3012         pref0_len = 0;
3013     if (pref0_len > pref_len)
3014         pref0_len = pref_len;
3015     {
3016         const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
3017
3018         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
3019             (locinput - pref_len),pref0_len, 60, 4, 5);
3020         
3021         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3022                     (locinput - pref_len + pref0_len),
3023                     pref_len - pref0_len, 60, 2, 3);
3024         
3025         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
3026                     locinput, loc_regeol - locinput, 10, 0, 1);
3027
3028         const STRLEN tlen=len0+len1+len2;
3029         PerlIO_printf(Perl_debug_log,
3030                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
3031                     (IV)(locinput - loc_bostr),
3032                     len0, s0,
3033                     len1, s1,
3034                     (docolor ? "" : "> <"),
3035                     len2, s2,
3036                     (int)(tlen > 19 ? 0 :  19 - tlen),
3037                     "");
3038     }
3039 }
3040
3041 #endif
3042
3043 /* reg_check_named_buff_matched()
3044  * Checks to see if a named buffer has matched. The data array of 
3045  * buffer numbers corresponding to the buffer is expected to reside
3046  * in the regexp->data->data array in the slot stored in the ARG() of
3047  * node involved. Note that this routine doesn't actually care about the
3048  * name, that information is not preserved from compilation to execution.
3049  * Returns the index of the leftmost defined buffer with the given name
3050  * or 0 if non of the buffers matched.
3051  */
3052 STATIC I32
3053 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
3054 {
3055     I32 n;
3056     RXi_GET_DECL(rex,rexi);
3057     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
3058     I32 *nums=(I32*)SvPVX(sv_dat);
3059
3060     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3061
3062     for ( n=0; n<SvIVX(sv_dat); n++ ) {
3063         if ((I32)*PL_reglastparen >= nums[n] &&
3064             PL_regoffs[nums[n]].end != -1)
3065         {
3066             return nums[n];
3067         }
3068     }
3069     return 0;
3070 }
3071
3072
3073 /* free all slabs above current one  - called during LEAVE_SCOPE */
3074
3075 STATIC void
3076 S_clear_backtrack_stack(pTHX_ void *p)
3077 {
3078     regmatch_slab *s = PL_regmatch_slab->next;
3079     PERL_UNUSED_ARG(p);
3080
3081     if (!s)
3082         return;
3083     PL_regmatch_slab->next = NULL;
3084     while (s) {
3085         regmatch_slab * const osl = s;
3086         s = s->next;
3087         Safefree(osl);
3088     }
3089 }
3090
3091
3092 #define SETREX(Re1,Re2) \
3093     if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
3094     Re1 = (Re2)
3095
3096 STATIC I32                      /* 0 failure, 1 success */
3097 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
3098 {
3099 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3100     dMY_CXT;
3101 #endif
3102     dVAR;
3103     register const bool utf8_target = PL_reg_match_utf8;
3104     const U32 uniflags = UTF8_ALLOW_DEFAULT;
3105     REGEXP *rex_sv = reginfo->prog;
3106     regexp *rex = (struct regexp *)SvANY(rex_sv);
3107     RXi_GET_DECL(rex,rexi);
3108     I32 oldsave;
3109     /* the current state. This is a cached copy of PL_regmatch_state */
3110     register regmatch_state *st;
3111     /* cache heavy used fields of st in registers */
3112     register regnode *scan;
3113     register regnode *next;
3114     register U32 n = 0; /* general value; init to avoid compiler warning */
3115     register I32 ln = 0; /* len or last;  init to avoid compiler warning */
3116     register char *locinput = PL_reginput;
3117     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
3118
3119     bool result = 0;        /* return value of S_regmatch */
3120     int depth = 0;          /* depth of backtrack stack */
3121     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
3122     const U32 max_nochange_depth =
3123         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
3124         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
3125     regmatch_state *yes_state = NULL; /* state to pop to on success of
3126                                                             subpattern */
3127     /* mark_state piggy backs on the yes_state logic so that when we unwind 
3128        the stack on success we can update the mark_state as we go */
3129     regmatch_state *mark_state = NULL; /* last mark state we have seen */
3130     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
3131     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
3132     U32 state_num;
3133     bool no_final = 0;      /* prevent failure from backtracking? */
3134     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
3135     char *startpoint = PL_reginput;
3136     SV *popmark = NULL;     /* are we looking for a mark? */
3137     SV *sv_commit = NULL;   /* last mark name seen in failure */
3138     SV *sv_yes_mark = NULL; /* last mark name we have seen 
3139                                during a successful match */
3140     U32 lastopen = 0;       /* last open we saw */
3141     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;   
3142     SV* const oreplsv = GvSV(PL_replgv);
3143     /* these three flags are set by various ops to signal information to
3144      * the very next op. They have a useful lifetime of exactly one loop
3145      * iteration, and are not preserved or restored by state pushes/pops
3146      */
3147     bool sw = 0;            /* the condition value in (?(cond)a|b) */
3148     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
3149     int logical = 0;        /* the following EVAL is:
3150                                 0: (?{...})
3151                                 1: (?(?{...})X|Y)
3152                                 2: (??{...})
3153                                or the following IFMATCH/UNLESSM is:
3154                                 false: plain (?=foo)
3155                                 true:  used as a condition: (?(?=foo))
3156                             */
3157 #ifdef DEBUGGING
3158     GET_RE_DEBUG_FLAGS_DECL;
3159 #endif
3160
3161     PERL_ARGS_ASSERT_REGMATCH;
3162
3163     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
3164             PerlIO_printf(Perl_debug_log,"regmatch start\n");
3165     }));
3166     /* on first ever call to regmatch, allocate first slab */
3167     if (!PL_regmatch_slab) {
3168         Newx(PL_regmatch_slab, 1, regmatch_slab);
3169         PL_regmatch_slab->prev = NULL;
3170         PL_regmatch_slab->next = NULL;
3171         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
3172     }
3173
3174     oldsave = PL_savestack_ix;
3175     SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
3176     SAVEVPTR(PL_regmatch_slab);
3177     SAVEVPTR(PL_regmatch_state);
3178
3179     /* grab next free state slot */
3180     st = ++PL_regmatch_state;
3181     if (st >  SLAB_LAST(PL_regmatch_slab))
3182         st = PL_regmatch_state = S_push_slab(aTHX);
3183
3184     /* Note that nextchr is a byte even in UTF */
3185     nextchr = UCHARAT(locinput);
3186     scan = prog;
3187     while (scan != NULL) {
3188
3189         DEBUG_EXECUTE_r( {
3190             SV * const prop = sv_newmortal();
3191             regnode *rnext=regnext(scan);
3192             DUMP_EXEC_POS( locinput, scan, utf8_target );
3193             regprop(rex, prop, scan);
3194             
3195             PerlIO_printf(Perl_debug_log,
3196                     "%3"IVdf":%*s%s(%"IVdf")\n",
3197                     (IV)(scan - rexi->program), depth*2, "",
3198                     SvPVX_const(prop),
3199                     (PL_regkind[OP(scan)] == END || !rnext) ? 
3200                         0 : (IV)(rnext - rexi->program));
3201         });
3202
3203         next = scan + NEXT_OFF(scan);
3204         if (next == scan)
3205             next = NULL;
3206         state_num = OP(scan);
3207
3208       reenter_switch:
3209
3210         assert(PL_reglastparen == &rex->lastparen);
3211         assert(PL_reglastcloseparen == &rex->lastcloseparen);
3212         assert(PL_regoffs == rex->offs);
3213
3214         switch (state_num) {
3215         case BOL:
3216             if (locinput == PL_bostr)
3217             {
3218                 /* reginfo->till = reginfo->bol; */
3219                 break;
3220             }
3221             sayNO;
3222         case MBOL:
3223             if (locinput == PL_bostr ||
3224                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
3225             {
3226                 break;
3227             }
3228             sayNO;
3229         case SBOL:
3230             if (locinput == PL_bostr)
3231                 break;
3232             sayNO;
3233         case GPOS:
3234             if (locinput == reginfo->ganch)
3235                 break;
3236             sayNO;
3237
3238         case KEEPS:
3239             /* update the startpoint */
3240             st->u.keeper.val = PL_regoffs[0].start;
3241             PL_reginput = locinput;
3242             PL_regoffs[0].start = locinput - PL_bostr;
3243             PUSH_STATE_GOTO(KEEPS_next, next);
3244             /*NOT-REACHED*/
3245         case KEEPS_next_fail:
3246             /* rollback the start point change */
3247             PL_regoffs[0].start = st->u.keeper.val;
3248             sayNO_SILENT;
3249             /*NOT-REACHED*/
3250         case EOL:
3251                 goto seol;
3252         case MEOL:
3253             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3254                 sayNO;
3255             break;
3256         case SEOL:
3257           seol:
3258             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3259                 sayNO;
3260             if (PL_regeol - locinput > 1)
3261                 sayNO;
3262             break;
3263         case EOS:
3264             if (PL_regeol != locinput)
3265                 sayNO;
3266             break;
3267         case SANY:
3268             if (!nextchr && locinput >= PL_regeol)
3269                 sayNO;
3270             if (utf8_target) {
3271                 locinput += PL_utf8skip[nextchr];
3272                 if (locinput > PL_regeol)
3273                     sayNO;
3274                 nextchr = UCHARAT(locinput);
3275             }
3276             else
3277                 nextchr = UCHARAT(++locinput);
3278             break;
3279         case CANY:
3280             if (!nextchr && locinput >= PL_regeol)
3281                 sayNO;
3282             nextchr = UCHARAT(++locinput);
3283             break;
3284         case REG_ANY:
3285             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
3286                 sayNO;
3287             if (utf8_target) {
3288                 locinput += PL_utf8skip[nextchr];
3289                 if (locinput > PL_regeol)
3290                     sayNO;
3291                 nextchr = UCHARAT(locinput);
3292             }
3293             else
3294                 nextchr = UCHARAT(++locinput);
3295             break;
3296
3297 #undef  ST
3298 #define ST st->u.trie
3299         case TRIEC:
3300             /* In this case the charclass data is available inline so
3301                we can fail fast without a lot of extra overhead. 
3302              */
3303             if (scan->flags == EXACT || !utf8_target) {
3304                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3305                     DEBUG_EXECUTE_r(
3306                         PerlIO_printf(Perl_debug_log,
3307                                   "%*s  %sfailed to match trie start class...%s\n",
3308                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3309                     );
3310                     sayNO_SILENT;
3311                     /* NOTREACHED */
3312                 }                       
3313             }
3314             /* FALL THROUGH */
3315         case TRIE:
3316             /* the basic plan of execution of the trie is:
3317              * At the beginning, run though all the states, and
3318              * find the longest-matching word. Also remember the position
3319              * of the shortest matching word. For example, this pattern:
3320              *    1  2 3 4    5
3321              *    ab|a|x|abcd|abc
3322              * when matched against the string "abcde", will generate
3323              * accept states for all words except 3, with the longest
3324              * matching word being 4, and the shortest being 1 (with
3325              * the position being after char 1 of the string).
3326              *
3327              * Then for each matching word, in word order (i.e. 1,2,4,5),
3328              * we run the remainder of the pattern; on each try setting
3329              * the current position to the character following the word,
3330              * returning to try the next word on failure.
3331              *
3332              * We avoid having to build a list of words at runtime by
3333              * using a compile-time structure, wordinfo[].prev, which
3334              * gives, for each word, the previous accepting word (if any).
3335              * In the case above it would contain the mappings 1->2, 2->0,
3336              * 3->0, 4->5, 5->1.  We can use this table to generate, from
3337              * the longest word (4 above), a list of all words, by
3338              * following the list of prev pointers; this gives us the
3339              * unordered list 4,5,1,2. Then given the current word we have
3340              * just tried, we can go through the list and find the
3341              * next-biggest word to try (so if we just failed on word 2,
3342              * the next in the list is 4).
3343              *
3344              * Since at runtime we don't record the matching position in
3345              * the string for each word, we have to work that out for
3346              * each word we're about to process. The wordinfo table holds
3347              * the character length of each word; given that we recorded
3348              * at the start: the position of the shortest word and its
3349              * length in chars, we just need to move the pointer the
3350              * difference between the two char lengths. Depending on
3351              * Unicode status and folding, that's cheap or expensive.
3352              *
3353              * This algorithm is optimised for the case where are only a
3354              * small number of accept states, i.e. 0,1, or maybe 2.
3355              * With lots of accepts states, and having to try all of them,
3356              * it becomes quadratic on number of accept states to find all
3357              * the next words.
3358              */
3359
3360             {
3361                 /* what type of TRIE am I? (utf8 makes this contextual) */
3362                 DECL_TRIE_TYPE(scan);
3363
3364                 /* what trie are we using right now */
3365                 reg_trie_data * const trie
3366                     = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3367                 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3368                 U32 state = trie->startstate;
3369
3370                 if (trie->bitmap && trie_type != trie_utf8_fold &&
3371                     !TRIE_BITMAP_TEST(trie,*locinput)
3372                 ) {
3373                     if (trie->states[ state ].wordnum) {
3374                          DEBUG_EXECUTE_r(
3375                             PerlIO_printf(Perl_debug_log,
3376                                           "%*s  %smatched empty string...%s\n",
3377                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3378                         );
3379                         if (!trie->jump)
3380                             break;
3381                     } else {
3382                         DEBUG_EXECUTE_r(
3383                             PerlIO_printf(Perl_debug_log,
3384                                           "%*s  %sfailed to match trie start class...%s\n",
3385                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3386                         );
3387                         sayNO_SILENT;
3388                    }
3389                 }
3390
3391             { 
3392                 U8 *uc = ( U8* )locinput;
3393
3394                 STRLEN len = 0;
3395                 STRLEN foldlen = 0;
3396                 U8 *uscan = (U8*)NULL;
3397                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3398                 U32 charcount = 0; /* how many input chars we have matched */
3399                 U32 accepted = 0; /* have we seen any accepting states? */
3400
3401                 ST.B = next;
3402                 ST.jump = trie->jump;
3403                 ST.me = scan;
3404                 ST.firstpos = NULL;
3405                 ST.longfold = FALSE; /* char longer if folded => it's harder */
3406                 ST.nextword = 0;
3407
3408                 /* fully traverse the TRIE; note the position of the
3409                    shortest accept state and the wordnum of the longest
3410                    accept state */
3411
3412                 while ( state && uc <= (U8*)PL_regeol ) {
3413                     U32 base = trie->states[ state ].trans.base;
3414                     UV uvc = 0;
3415                     U16 charid = 0;
3416                     U16 wordnum;
3417                     wordnum = trie->states[ state ].wordnum;
3418
3419                     if (wordnum) { /* it's an accept state */
3420                         if (!accepted) {
3421                             accepted = 1;
3422                             /* record first match position */
3423                             if (ST.longfold) {
3424                                 ST.firstpos = (U8*)locinput;
3425                                 ST.firstchars = 0;
3426                             }
3427                             else {
3428                                 ST.firstpos = uc;
3429                                 ST.firstchars = charcount;
3430                             }
3431                         }
3432                         if (!ST.nextword || wordnum < ST.nextword)
3433                             ST.nextword = wordnum;
3434                         ST.topword = wordnum;
3435                     }
3436
3437                     DEBUG_TRIE_EXECUTE_r({
3438                                 DUMP_EXEC_POS( (char *)uc, scan, utf8_target );
3439                                 PerlIO_printf( Perl_debug_log,
3440                                     "%*s  %sState: %4"UVxf" Accepted: %c ",
3441                                     2+depth * 2, "", PL_colors[4],
3442                                     (UV)state, (accepted ? 'Y' : 'N'));
3443                     });
3444
3445                     /* read a char and goto next state */
3446                     if ( base ) {
3447                         I32 offset;
3448                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3449                                              uscan, len, uvc, charid, foldlen,
3450                                              foldbuf, uniflags);
3451                         charcount++;
3452                         if (foldlen>0)
3453                             ST.longfold = TRUE;
3454                         if (charid &&
3455                              ( ((offset =
3456                               base + charid - 1 - trie->uniquecharcount)) >= 0)
3457
3458                              && ((U32)offset < trie->lasttrans)
3459                              && trie->trans[offset].check == state)
3460                         {
3461                             state = trie->trans[offset].next;
3462                         }
3463                         else {
3464                             state = 0;
3465                         }
3466                         uc += len;
3467
3468                     }
3469                     else {
3470                         state = 0;
3471                     }
3472                     DEBUG_TRIE_EXECUTE_r(
3473                         PerlIO_printf( Perl_debug_log,
3474                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3475                             charid, uvc, (UV)state, PL_colors[5] );
3476                     );
3477                 }
3478                 if (!accepted)
3479                    sayNO;
3480
3481                 /* calculate total number of accept states */
3482                 {
3483                     U16 w = ST.topword;
3484                     accepted = 0;
3485                     while (w) {
3486                         w = trie->wordinfo[w].prev;
3487                         accepted++;
3488                     }
3489                     ST.accepted = accepted;
3490                 }
3491
3492                 DEBUG_EXECUTE_r(
3493                     PerlIO_printf( Perl_debug_log,
3494                         "%*s  %sgot %"IVdf" possible matches%s\n",
3495                         REPORT_CODE_OFF + depth * 2, "",
3496                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3497                 );
3498                 goto trie_first_try; /* jump into the fail handler */
3499             }}
3500             /* NOTREACHED */
3501
3502         case TRIE_next_fail: /* we failed - try next alternative */
3503             if ( ST.jump) {
3504                 REGCP_UNWIND(ST.cp);
3505                 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3506                     PL_regoffs[n].end = -1;
3507                 *PL_reglastparen = n;
3508             }
3509             if (!--ST.accepted) {
3510                 DEBUG_EXECUTE_r({
3511                     PerlIO_printf( Perl_debug_log,
3512                         "%*s  %sTRIE failed...%s\n",
3513                         REPORT_CODE_OFF+depth*2, "", 
3514                         PL_colors[4],
3515                         PL_colors[5] );
3516                 });
3517                 sayNO_SILENT;
3518             }
3519             {
3520                 /* Find next-highest word to process.  Note that this code
3521                  * is O(N^2) per trie run (O(N) per branch), so keep tight */
3522                 register U16 min = 0;
3523                 register U16 word;
3524                 register U16 const nextword = ST.nextword;
3525                 register reg_trie_wordinfo * const wordinfo
3526                     = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo;
3527                 for (word=ST.topword; word; word=wordinfo[word].prev) {
3528                     if (word > nextword && (!min || word < min))
3529                         min = word;
3530                 }
3531                 ST.nextword = min;
3532             }
3533
3534           trie_first_try:
3535             if (do_cutgroup) {
3536                 do_cutgroup = 0;
3537                 no_final = 0;
3538             }
3539
3540             if ( ST.jump) {
3541                 ST.lastparen = *PL_reglastparen;
3542                 REGCP_SET(ST.cp);
3543             }
3544
3545             /* find start char of end of current word */
3546             {
3547                 U32 chars; /* how many chars to skip */
3548                 U8 *uc = ST.firstpos;
3549                 reg_trie_data * const trie
3550                     = (reg_trie_data*)rexi->data->data[ARG(ST.me)];
3551
3552                 assert((trie->wordinfo[ST.nextword].len - trie->prefixlen)
3553                             >=  ST.firstchars);
3554                 chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen)
3555                             - ST.firstchars;
3556
3557                 if (ST.longfold) {
3558                     /* the hard option - fold each char in turn and find
3559                      * its folded length (which may be different */
3560                     U8 foldbuf[UTF8_MAXBYTES_CASE + 1];
3561                     STRLEN foldlen;
3562                     STRLEN len;
3563                     UV uvc;
3564                     U8 *uscan;
3565
3566                     while (chars) {
3567                         if (utf8_target) {
3568                             uvc = utf8n_to_uvuni((U8*)uc, UTF8_MAXLEN, &len,
3569                                                     uniflags);
3570                             uc += len;
3571                         }
3572                         else {
3573                             uvc = *uc;
3574                             uc++;
3575                         }
3576                         uvc = to_uni_fold(uvc, foldbuf, &foldlen);
3577                         uscan = foldbuf;
3578                         while (foldlen) {
3579                             if (!--chars)
3580                                 break;
3581                             uvc = utf8n_to_uvuni(uscan, UTF8_MAXLEN, &len,
3582                                             uniflags);
3583                             uscan += len;
3584                             foldlen -= len;
3585                         }
3586                     }
3587                 }
3588                 else {
3589                     if (utf8_target)
3590                         while (chars--)
3591                             uc += UTF8SKIP(uc);
3592                     else
3593                         uc += chars;
3594                 }
3595                 PL_reginput = (char *)uc;
3596             }
3597
3598             scan = (ST.jump && ST.jump[ST.nextword]) 
3599                         ? ST.me + ST.jump[ST.nextword]
3600                         : ST.B;
3601
3602             DEBUG_EXECUTE_r({
3603                 PerlIO_printf( Perl_debug_log,
3604                     "%*s  %sTRIE matched word #%d, continuing%s\n",
3605                     REPORT_CODE_OFF+depth*2, "", 
3606                     PL_colors[4],
3607                     ST.nextword,
3608                     PL_colors[5]
3609                     );
3610             });
3611
3612             if (ST.accepted > 1 || has_cutgroup) {
3613                 PUSH_STATE_GOTO(TRIE_next, scan);
3614                 /* NOTREACHED */
3615             }
3616             /* only one choice left - just continue */
3617             DEBUG_EXECUTE_r({
3618                 AV *const trie_words
3619                     = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3620                 SV ** const tmp = av_fetch( trie_words,
3621                     ST.nextword-1, 0 );
3622                 SV *sv= tmp ? sv_newmortal() : NULL;
3623
3624                 PerlIO_printf( Perl_debug_log,
3625                     "%*s  %sonly one match left, short-circuiting: #%d <%s>%s\n",
3626                     REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3627                     ST.nextword,
3628                     tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3629                             PL_colors[0], PL_colors[1],
3630                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII
3631                         ) 
3632                     : "not compiled under -Dr",
3633                     PL_colors[5] );
3634             });
3635
3636             locinput = PL_reginput;
3637             nextchr = UCHARAT(locinput);
3638             continue; /* execute rest of RE */
3639             /* NOTREACHED */
3640 #undef  ST
3641
3642         case EXACT: {
3643             char *s = STRING(scan);
3644             ln = STR_LEN(scan);
3645             if (utf8_target != UTF_PATTERN) {
3646                 /* The target and the pattern have differing utf8ness. */
3647                 char *l = locinput;
3648                 const char * const e = s + ln;
3649
3650                 if (utf8_target) {
3651                     /* The target is utf8, the pattern is not utf8. */
3652                     while (s < e) {
3653                         STRLEN ulen;
3654                         if (l >= PL_regeol)
3655                              sayNO;
3656                         if (NATIVE_TO_UNI(*(U8*)s) !=
3657                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3658                                             uniflags))
3659                              sayNO;
3660                         l += ulen;
3661                         s ++;
3662                     }
3663                 }
3664                 else {
3665                     /* The target is not utf8, the pattern is utf8. */
3666                     while (s < e) {
3667                         STRLEN ulen;
3668                         if (l >= PL_regeol)
3669                             sayNO;
3670                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3671                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3672                                            uniflags))
3673                             sayNO;
3674                         s += ulen;
3675                         l ++;
3676                     }
3677                 }
3678                 locinput = l;
3679                 nextchr = UCHARAT(locinput);
3680                 break;
3681             }
3682             /* The target and the pattern have the same utf8ness. */
3683             /* Inline the first character, for speed. */
3684             if (UCHARAT(s) != nextchr)
3685                 sayNO;
3686             if (PL_regeol - locinput < ln)
3687                 sayNO;
3688             if (ln > 1 && memNE(s, locinput, ln))
3689                 sayNO;
3690             locinput += ln;
3691             nextchr = UCHARAT(locinput);
3692             break;
3693             }
3694         case EXACTFL: {
3695             re_fold_t folder;
3696             const U8 * fold_array;
3697             const char * s;
3698
3699             PL_reg_flags |= RF_tainted;
3700             folder = foldEQ_locale;
3701             fold_array = PL_fold_locale;
3702             goto do_exactf;
3703
3704         case EXACTFU:
3705             folder = foldEQ_latin1;
3706             fold_array = PL_fold_latin1;
3707             goto do_exactf;
3708
3709         case EXACTF:
3710             folder = foldEQ;
3711             fold_array = PL_fold;
3712
3713           do_exactf:
3714             s = STRING(scan);
3715             ln = STR_LEN(scan);
3716
3717             if (utf8_target || UTF_PATTERN) {
3718               /* Either target or the pattern are utf8. */
3719                 const char * const l = locinput;
3720                 char *e = PL_regeol;
3721
3722                 if (! foldEQ_utf8(s, 0,  ln, cBOOL(UTF_PATTERN),
3723                                l, &e, 0,  utf8_target)) {
3724                      /* One more case for the sharp s:
3725                       * pack("U0U*", 0xDF) =~ /ss/i,
3726                       * the 0xC3 0x9F are the UTF-8
3727                       * byte sequence for the U+00DF. */
3728
3729                      if (!(utf8_target &&
3730                            toLOWER(s[0]) == 's' &&
3731                            ln >= 2 &&
3732                            toLOWER(s[1]) == 's' &&
3733                            (U8)l[0] == 0xC3 &&
3734                            e - l >= 2 &&
3735                            (U8)l[1] == 0x9F))
3736                           sayNO;
3737                 }
3738                 locinput = e;
3739                 nextchr = UCHARAT(locinput);
3740                 break;
3741             }
3742
3743             /* Neither the target and the pattern are utf8. */
3744
3745             /* Inline the first character, for speed. */
3746             if (UCHARAT(s) != nextchr &&
3747                 UCHARAT(s) != fold_array[nextchr])
3748             {
3749                 sayNO;
3750             }
3751             if (PL_regeol - locinput < ln)
3752                 sayNO;
3753             if (ln > 1 && ! folder(s, locinput, ln))
3754                 sayNO;
3755             locinput += ln;
3756             nextchr = UCHARAT(locinput);
3757             break;
3758         }
3759
3760         /* XXX Could improve efficiency by separating these all out using a
3761          * macro or in-line function.  At that point regcomp.c would no longer
3762          * have to set the FLAGS fields of these */
3763         case BOUNDL:
3764         case NBOUNDL:
3765             PL_reg_flags |= RF_tainted;
3766             /* FALL THROUGH */
3767         case BOUND:
3768         case BOUNDU:
3769         case BOUNDA:
3770         case NBOUND:
3771         case NBOUNDU:
3772         case NBOUNDA:
3773             /* was last char in word? */
3774             if (utf8_target && FLAGS(scan) != REGEX_ASCII_RESTRICTED_CHARSET) {
3775                 if (locinput == PL_bostr)
3776                     ln = '\n';
3777                 else {
3778                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3779
3780                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3781                 }
3782                 if (FLAGS(scan) != REGEX_LOCALE_CHARSET) {
3783                     ln = isALNUM_uni(ln);
3784                     LOAD_UTF8_CHARCLASS_ALNUM();
3785                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, utf8_target);
3786                 }
3787                 else {
3788                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3789                     n = isALNUM_LC_utf8((U8*)locinput);
3790                 }
3791             }
3792             else {
3793
3794                 /* Here the string isn't utf8, or is utf8 and only ascii
3795                  * characters are to match \w.  In the latter case looking at
3796                  * the byte just prior to the current one may be just the final
3797                  * byte of a multi-byte character.  This is ok.  There are two
3798                  * cases:
3799                  * 1) it is a single byte character, and then the test is doing
3800                  *      just what it's supposed to.
3801                  * 2) it is a multi-byte character, in which case the final
3802                  *      byte is never mistakable for ASCII, and so the test
3803                  *      will say it is not a word character, which is the
3804                  *      correct answer. */
3805                 ln = (locinput != PL_bostr) ?
3806                     UCHARAT(locinput - 1) : '\n';
3807                 switch (FLAGS(scan)) {
3808                     case REGEX_UNICODE_CHARSET:
3809                         ln = isWORDCHAR_L1(ln);
3810                         n = isWORDCHAR_L1(nextchr);
3811                         break;
3812                     case REGEX_LOCALE_CHARSET:
3813                         ln = isALNUM_LC(ln);
3814                         n = isALNUM_LC(nextchr);
3815                         break;
3816                     case REGEX_DEPENDS_CHARSET:
3817                         ln = isALNUM(ln);
3818                         n = isALNUM(nextchr);
3819                         break;
3820              &nbs