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