This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
a584addd6f65d78e532f26a7efe822961d1314cd
[perl5.git] / regexec.c
1 /*    regexec.c
2  */
3
4 /*
5  *      One Ring to rule them all, One Ring to find them
6  &
7  *     [p.v of _The Lord of the Rings_, opening poem]
8  *     [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
9  *     [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
10  */
11
12 /* This file contains functions for executing a regular expression.  See
13  * also regcomp.c which funnily enough, contains functions for compiling
14  * a regular expression.
15  *
16  * This file is also copied at build time to ext/re/re_exec.c, where
17  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
18  * This causes the main functions to be compiled under new names and with
19  * debugging support added, which makes "use re 'debug'" work.
20  */
21
22 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
23  * confused with the original package (see point 3 below).  Thanks, Henry!
24  */
25
26 /* Additional note: this code is very heavily munged from Henry's version
27  * in places.  In some spots I've traded clarity for efficiency, so don't
28  * blame Henry for some of the lack of readability.
29  */
30
31 /* The names of the functions have been changed from regcomp and
32  * regexec to  pregcomp and pregexec in order to avoid conflicts
33  * with the POSIX routines of the same names.
34 */
35
36 #ifdef PERL_EXT_RE_BUILD
37 #include "re_top.h"
38 #endif
39
40 /*
41  * pregcomp and pregexec -- regsub and regerror are not used in perl
42  *
43  *      Copyright (c) 1986 by University of Toronto.
44  *      Written by Henry Spencer.  Not derived from licensed software.
45  *
46  *      Permission is granted to anyone to use this software for any
47  *      purpose on any computer system, and to redistribute it freely,
48  *      subject to the following restrictions:
49  *
50  *      1. The author is not responsible for the consequences of use of
51  *              this software, no matter how awful, even if they arise
52  *              from defects in it.
53  *
54  *      2. The origin of this software must not be misrepresented, either
55  *              by explicit claim or by omission.
56  *
57  *      3. Altered versions must be plainly marked as such, and must not
58  *              be misrepresented as being the original software.
59  *
60  ****    Alterations to Henry's code are...
61  ****
62  ****    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
63  ****    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
64  ****    by Larry Wall and others
65  ****
66  ****    You may distribute under the terms of either the GNU General Public
67  ****    License or the Artistic License, as specified in the README file.
68  *
69  * Beware that some of this code is subtly aware of the way operator
70  * precedence is structured in regular expressions.  Serious changes in
71  * regular-expression syntax might require a total rethink.
72  */
73 #include "EXTERN.h"
74 #define PERL_IN_REGEXEC_C
75 #include "perl.h"
76
77 #ifdef PERL_IN_XSUB_RE
78 #  include "re_comp.h"
79 #else
80 #  include "regcomp.h"
81 #endif
82
83 #define RF_tainted      1               /* tainted information used? */
84 #define RF_warned       2               /* warned about big count? */
85
86 #define RF_utf8         8               /* Pattern contains multibyte chars? */
87
88 #define UTF_PATTERN ((PL_reg_flags & RF_utf8) != 0)
89
90 #define RS_init         1               /* eval environment created */
91 #define RS_set          2               /* replsv value is set */
92
93 #ifndef STATIC
94 #define STATIC  static
95 #endif
96
97 /* Valid for non-utf8 strings only: avoids the reginclass call if there are no
98  * complications: i.e., if everything matchable is straight forward in the
99  * bitmap */
100 #define REGINCLASS(prog,p,c)  (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0)   \
101                                               : ANYOF_BITMAP_TEST(p,*(c)))
102
103 /*
104  * Forwards.
105  */
106
107 #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv))
108 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
109
110 #define HOPc(pos,off) \
111         (char *)(PL_reg_match_utf8 \
112             ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
113             : (U8*)(pos + off))
114 #define HOPBACKc(pos, off) \
115         (char*)(PL_reg_match_utf8\
116             ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
117             : (pos - off >= PL_bostr)           \
118                 ? (U8*)pos - off                \
119                 : NULL)
120
121 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
122 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
123
124 /* these are unrolled below in the CCC_TRY_XXX defined */
125 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
126     if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
127
128 /* Doesn't do an assert to verify that is correct */
129 #define LOAD_UTF8_CHARCLASS_NO_CHECK(class) STMT_START { \
130     if (!CAT2(PL_utf8_,class)) { bool throw_away; ENTER; save_re_context(); throw_away = CAT2(is_utf8_,class)((const U8*)" "); LEAVE; } } STMT_END
131
132 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
133 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
134 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
135
136 #define LOAD_UTF8_CHARCLASS_GCB()  /* Grapheme cluster boundaries */        \
137         LOAD_UTF8_CHARCLASS(X_begin, " ");                                  \
138         LOAD_UTF8_CHARCLASS(X_non_hangul, "A");                             \
139         /* These are utf8 constants, and not utf-ebcdic constants, so the   \
140             * assert should likely and hopefully fail on an EBCDIC machine */ \
141         LOAD_UTF8_CHARCLASS(X_extend, "\xcc\x80"); /* U+0300 */             \
142                                                                             \
143         /* No asserts are done for these, in case called on an early        \
144             * Unicode version in which they map to nothing */               \
145         LOAD_UTF8_CHARCLASS_NO_CHECK(X_prepend);/* U+0E40 "\xe0\xb9\x80" */ \
146         LOAD_UTF8_CHARCLASS_NO_CHECK(X_L);          /* U+1100 "\xe1\x84\x80" */ \
147         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV);     /* U+AC00 "\xea\xb0\x80" */ \
148         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LVT);    /* U+AC01 "\xea\xb0\x81" */ \
149         LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV_LVT_V);/* U+AC01 "\xea\xb0\x81" */\
150         LOAD_UTF8_CHARCLASS_NO_CHECK(X_T);      /* U+11A8 "\xe1\x86\xa8" */ \
151         LOAD_UTF8_CHARCLASS_NO_CHECK(X_V)       /* U+1160 "\xe1\x85\xa0" */  
152
153 /* 
154    We dont use PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS as the direct test
155    so that it is possible to override the option here without having to 
156    rebuild the entire core. as we are required to do if we change regcomp.h
157    which is where PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS is defined.
158 */
159 #if PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS
160 #define BROKEN_UNICODE_CHARCLASS_MAPPINGS
161 #endif
162
163 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
164 #define LOAD_UTF8_CHARCLASS_PERL_WORD()   LOAD_UTF8_CHARCLASS_ALNUM()
165 #define LOAD_UTF8_CHARCLASS_PERL_SPACE()  LOAD_UTF8_CHARCLASS_SPACE()
166 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS_DIGIT()
167 #define RE_utf8_perl_word   PL_utf8_alnum
168 #define RE_utf8_perl_space  PL_utf8_space
169 #define RE_utf8_posix_digit PL_utf8_digit
170 #define perl_word  alnum
171 #define perl_space space
172 #define posix_digit digit
173 #else
174 #define LOAD_UTF8_CHARCLASS_PERL_WORD()   LOAD_UTF8_CHARCLASS(perl_word,"a")
175 #define LOAD_UTF8_CHARCLASS_PERL_SPACE()  LOAD_UTF8_CHARCLASS(perl_space," ")
176 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS(posix_digit,"0")
177 #define RE_utf8_perl_word   PL_utf8_perl_word
178 #define RE_utf8_perl_space  PL_utf8_perl_space
179 #define RE_utf8_posix_digit PL_utf8_posix_digit
180 #endif
181
182
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 /* We know what class REx starts with.  Try to find this position... */
1336 /* if reginfo is NULL, its a dryrun */
1337 /* annoyingly all the vars in this routine have different names from their counterparts
1338    in regmatch. /grrr */
1339
1340 STATIC char *
1341 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 
1342     const char *strend, regmatch_info *reginfo)
1343 {
1344         dVAR;
1345         const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1346         char *m;
1347         STRLEN ln;
1348         STRLEN lnc;
1349         register STRLEN uskip;
1350         unsigned int c1;
1351         unsigned int c2;
1352         char *e;
1353         register I32 tmp = 1;   /* Scratch variable? */
1354         register const bool utf8_target = PL_reg_match_utf8;
1355         RXi_GET_DECL(prog,progi);
1356
1357         PERL_ARGS_ASSERT_FIND_BYCLASS;
1358         
1359         /* We know what class it must start with. */
1360         switch (OP(c)) {
1361         case ANYOFV:
1362         case ANYOF:
1363             if (utf8_target || OP(c) == ANYOFV) {
1364                  REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_NONBITMAP) ||
1365                           !UTF8_IS_INVARIANT((U8)s[0]) ?
1366                           reginclass(prog, c, (U8*)s, 0, utf8_target) :
1367                           REGINCLASS(prog, c, (U8*)s));
1368             }
1369             else {
1370                  while (s < strend) {
1371                       STRLEN skip = 1;
1372
1373                       if (REGINCLASS(prog, c, (U8*)s) ||
1374                           (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1375                            /* The assignment of 2 is intentional:
1376                             * for the folded sharp s, the skip is 2. */
1377                            (skip = SHARP_S_SKIP))) {
1378                            if (tmp && (!reginfo || regtry(reginfo, &s)))
1379                                 goto got_it;
1380                            else
1381                                 tmp = doevery;
1382                       }
1383                       else 
1384                            tmp = 1;
1385                       s += skip;
1386                  }
1387             }
1388             break;
1389         case CANY:
1390             REXEC_FBC_SCAN(
1391                 if (tmp && (!reginfo || regtry(reginfo, &s)))
1392                     goto got_it;
1393                 else
1394                     tmp = doevery;
1395             );
1396             break;
1397         case EXACTFU:
1398         case EXACTF:
1399             m   = STRING(c);
1400             ln  = STR_LEN(c);   /* length to match in octets/bytes */
1401             lnc = (I32) ln;     /* length to match in characters */
1402             if (UTF_PATTERN) {
1403                 STRLEN ulen1, ulen2;
1404                 U8 *sm = (U8 *) m;
1405                 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1406                 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1407                 /* used by commented-out code below */
1408                 /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1409                 
1410                 /* XXX: Since the node will be case folded at compile
1411                    time this logic is a little odd, although im not 
1412                    sure that its actually wrong. --dmq */
1413                    
1414                 c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1415                 c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1416
1417                 /* XXX: This is kinda strange. to_utf8_XYZ returns the 
1418                    codepoint of the first character in the converted
1419                    form, yet originally we did the extra step. 
1420                    No tests fail by commenting this code out however
1421                    so Ive left it out. -- dmq.
1422                    
1423                 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE, 
1424                                     0, uniflags);
1425                 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1426                                     0, uniflags);
1427                 */
1428                 
1429                 lnc = 0;
1430                 while (sm < ((U8 *) m + ln)) {
1431                     lnc++;
1432                     sm += UTF8SKIP(sm);
1433                 }
1434             }
1435             else {
1436                 c1 = *(U8*)m;
1437                 if (utf8_target || OP(c) == EXACTFU) {
1438
1439                     /* Micro sign folds to GREEK SMALL LETTER MU;
1440                        LATIN_SMALL_LETTER_SHARP_S folds to 'ss', and this sets
1441                        c2 to the first 's' of the pair, and the code below will
1442                        look for others */
1443                     c2 = (c1 == MICRO_SIGN)
1444                         ? GREEK_SMALL_LETTER_MU
1445                         : (c1 == LATIN_SMALL_LETTER_SHARP_S)
1446                            ? 's'
1447                            : PL_fold_latin1[c1];
1448                 } else c2 = PL_fold[c1];
1449             }
1450             goto do_exactf;
1451         case EXACTFL:
1452             m   = STRING(c);
1453             ln  = STR_LEN(c);
1454             lnc = (I32) ln;
1455             c1 = *(U8*)m;
1456             c2 = PL_fold_locale[c1];
1457           do_exactf:
1458             e = HOP3c(strend, -((I32)lnc), s);
1459
1460             if (!reginfo && e < s)
1461                 e = s;                  /* Due to minlen logic of intuit() */
1462
1463             /* The idea in the EXACTF* cases is to first find the
1464              * first character of the EXACTF* node and then, if
1465              * necessary, case-insensitively compare the full
1466              * text of the node.  The c1 and c2 are the first
1467              * characters (though in Unicode it gets a bit
1468              * more complicated because there are more cases
1469              * than just upper and lower: one needs to use
1470              * the so-called folding case for case-insensitive
1471              * matching (called "loose matching" in Unicode).
1472              * foldEQ_utf8() will do just that. */
1473
1474             if (utf8_target || UTF_PATTERN) {
1475                 UV c, f;
1476                 U8 tmpbuf [UTF8_MAXBYTES+1];
1477                 STRLEN len = 1;
1478                 STRLEN foldlen;
1479                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1480                 if (c1 == c2) {
1481                     /* Upper and lower of 1st char are equal -
1482                      * probably not a "letter". */
1483                     while (s <= e) {
1484                         if (utf8_target) {
1485                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1486                                            uniflags);
1487                         } else {
1488                             c = *((U8*)s);
1489                         }                                         
1490                         REXEC_FBC_EXACTISH_CHECK(c == c1);
1491                     }
1492                 }
1493                 else {
1494                     while (s <= e) {
1495                         if (utf8_target) {
1496                             c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1497                                            uniflags);
1498                         } else {
1499                             c = *((U8*)s);
1500                         }
1501
1502                         /* Handle some of the three Greek sigmas cases.
1503                          * Note that not all the possible combinations
1504                          * are handled here: some of them are handled
1505                          * by the standard folding rules, and some of
1506                          * them (the character class or ANYOF cases)
1507                          * are handled during compiletime in
1508                          * regexec.c:S_regclass(). */
1509                         if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1510                             c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1511                             c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1512
1513                         REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1514                     }
1515                 }
1516             }
1517             else {
1518                 /* Neither pattern nor string are UTF8 */
1519                 if (c1 == c2)
1520                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1521                 else
1522                     REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1523             }
1524             break;
1525         case BOUNDL:
1526             PL_reg_flags |= RF_tainted;
1527             /* FALL THROUGH */
1528         case BOUND:
1529             if (utf8_target) {
1530                 if (s == PL_bostr)
1531                     tmp = '\n';
1532                 else {
1533                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1534                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1535                 }
1536                 tmp = cBOOL(FLAGS(c) != REGEX_LOCALE_CHARSET ?
1537                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)));
1538                 LOAD_UTF8_CHARCLASS_ALNUM();
1539                 REXEC_FBC_UTF8_SCAN(
1540                     if (tmp == !(FLAGS(c) != REGEX_LOCALE_CHARSET ?
1541                                  cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)) :
1542                                  isALNUM_LC_utf8((U8*)s)))
1543                     {
1544                         tmp = !tmp;
1545                         REXEC_FBC_TRYIT;
1546                 }
1547                 );
1548             }
1549             else {  /* Not utf8 */
1550                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1551                 tmp = cBOOL((FLAGS(c) == REGEX_LOCALE_CHARSET)
1552                             ? isALNUM_LC(tmp)
1553                             : (isWORDCHAR_L1(tmp)
1554                                && (isASCII(tmp) || (FLAGS(c) == REGEX_UNICODE_CHARSET))));
1555                 REXEC_FBC_SCAN(
1556                     if (tmp ==
1557                         !((FLAGS(c) == REGEX_LOCALE_CHARSET)
1558                           ? isALNUM_LC(*s)
1559                           : (isWORDCHAR_L1((U8) *s)
1560                              && (isASCII((U8) *s) || (FLAGS(c) == REGEX_UNICODE_CHARSET)))))
1561                     {
1562                         tmp = !tmp;
1563                         REXEC_FBC_TRYIT;
1564                 }
1565                 );
1566             }
1567             if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1568                 goto got_it;
1569             break;
1570         case NBOUNDL:
1571             PL_reg_flags |= RF_tainted;
1572             /* FALL THROUGH */
1573         case NBOUND:
1574             if (utf8_target) {
1575                 if (s == PL_bostr)
1576                     tmp = '\n';
1577                 else {
1578                     U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1579                     tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1580                 }
1581                 tmp = cBOOL(FLAGS(c) != REGEX_LOCALE_CHARSET ?
1582                         isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)));
1583                 LOAD_UTF8_CHARCLASS_ALNUM();
1584                 REXEC_FBC_UTF8_SCAN(
1585                     if (tmp == !(FLAGS(c) != REGEX_LOCALE_CHARSET ?
1586                                  cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)) :
1587                                  isALNUM_LC_utf8((U8*)s)))
1588                         tmp = !tmp;
1589                     else REXEC_FBC_TRYIT;
1590                 );
1591             }
1592             else {
1593                 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1594                 tmp = cBOOL((FLAGS(c) == REGEX_LOCALE_CHARSET)
1595                             ? isALNUM_LC(tmp)
1596                             : (isWORDCHAR_L1(tmp)
1597                                && (isASCII(tmp) || (FLAGS(c) == REGEX_UNICODE_CHARSET))));
1598                 REXEC_FBC_SCAN(
1599                     if (tmp == ! cBOOL(
1600                             (FLAGS(c) == REGEX_LOCALE_CHARSET)
1601                             ? isALNUM_LC(*s)
1602                             : (isWORDCHAR_L1((U8) *s)
1603                                && (isASCII((U8) *s) || (FLAGS(c) == REGEX_UNICODE_CHARSET)))))
1604                     {
1605                         tmp = !tmp;
1606                     }
1607                     else REXEC_FBC_TRYIT;
1608                 );
1609             }
1610             if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1611                 goto got_it;
1612             break;
1613         case ALNUML:
1614             REXEC_FBC_CSCAN_TAINT(
1615                 isALNUM_LC_utf8((U8*)s),
1616                 isALNUM_LC(*s)
1617             );
1618         case ALNUMU:
1619             REXEC_FBC_CSCAN_PRELOAD(
1620                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1621                 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1622                 isWORDCHAR_L1((U8) *s)
1623             );
1624         case ALNUM:
1625             REXEC_FBC_CSCAN_PRELOAD(
1626                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1627                 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1628                 isWORDCHAR((U8) *s)
1629             );
1630         case NALNUMU:
1631             REXEC_FBC_CSCAN_PRELOAD(
1632                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1633                 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1634                 ! isWORDCHAR_L1((U8) *s)
1635             );
1636         case NALNUM:
1637             REXEC_FBC_CSCAN_PRELOAD(
1638                 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1639                 !swash_fetch(RE_utf8_perl_word, (U8*)s, utf8_target),
1640                 ! isALNUM(*s)
1641             );
1642         case NALNUML:
1643             REXEC_FBC_CSCAN_TAINT(
1644                 !isALNUM_LC_utf8((U8*)s),
1645                 !isALNUM_LC(*s)
1646             );
1647         case SPACEU:
1648             REXEC_FBC_CSCAN_PRELOAD(
1649                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1650                 *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target),
1651                 isSPACE_L1((U8) *s)
1652             );
1653         case SPACE:
1654             REXEC_FBC_CSCAN_PRELOAD(
1655                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1656                 *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target),
1657                 isSPACE((U8) *s)
1658             );
1659         case SPACEL:
1660             REXEC_FBC_CSCAN_TAINT(
1661                 isSPACE_LC_utf8((U8*)s),
1662                 isSPACE_LC(*s)
1663             );
1664         case NSPACEU:
1665             REXEC_FBC_CSCAN_PRELOAD(
1666                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1667                 !( *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target)),
1668                 ! isSPACE_L1((U8) *s)
1669             );
1670         case NSPACE:
1671             REXEC_FBC_CSCAN_PRELOAD(
1672                 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1673                 !(*s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target)),
1674                 ! isSPACE((U8) *s)
1675             );
1676         case NSPACEL:
1677             REXEC_FBC_CSCAN_TAINT(
1678                 !isSPACE_LC_utf8((U8*)s),
1679                 !isSPACE_LC(*s)
1680             );
1681         case DIGIT:
1682             REXEC_FBC_CSCAN_PRELOAD(
1683                 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1684                 swash_fetch(RE_utf8_posix_digit,(U8*)s, utf8_target),
1685                 isDIGIT(*s)
1686             );
1687         case DIGITL:
1688             REXEC_FBC_CSCAN_TAINT(
1689                 isDIGIT_LC_utf8((U8*)s),
1690                 isDIGIT_LC(*s)
1691             );
1692         case NDIGIT:
1693             REXEC_FBC_CSCAN_PRELOAD(
1694                 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1695                 !swash_fetch(RE_utf8_posix_digit,(U8*)s, utf8_target),
1696                 !isDIGIT(*s)
1697             );
1698         case NDIGITL:
1699             REXEC_FBC_CSCAN_TAINT(
1700                 !isDIGIT_LC_utf8((U8*)s),
1701                 !isDIGIT_LC(*s)
1702             );
1703         case LNBREAK:
1704             REXEC_FBC_CSCAN(
1705                 is_LNBREAK_utf8(s),
1706                 is_LNBREAK_latin1(s)
1707             );
1708         case VERTWS:
1709             REXEC_FBC_CSCAN(
1710                 is_VERTWS_utf8(s),
1711                 is_VERTWS_latin1(s)
1712             );
1713         case NVERTWS:
1714             REXEC_FBC_CSCAN(
1715                 !is_VERTWS_utf8(s),
1716                 !is_VERTWS_latin1(s)
1717             );
1718         case HORIZWS:
1719             REXEC_FBC_CSCAN(
1720                 is_HORIZWS_utf8(s),
1721                 is_HORIZWS_latin1(s)
1722             );
1723         case NHORIZWS:
1724             REXEC_FBC_CSCAN(
1725                 !is_HORIZWS_utf8(s),
1726                 !is_HORIZWS_latin1(s)
1727             );      
1728         case AHOCORASICKC:
1729         case AHOCORASICK: 
1730             {
1731                 DECL_TRIE_TYPE(c);
1732                 /* what trie are we using right now */
1733                 reg_ac_data *aho
1734                     = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1735                 reg_trie_data *trie
1736                     = (reg_trie_data*)progi->data->data[ aho->trie ];
1737                 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1738
1739                 const char *last_start = strend - trie->minlen;
1740 #ifdef DEBUGGING
1741                 const char *real_start = s;
1742 #endif
1743                 STRLEN maxlen = trie->maxlen;
1744                 SV *sv_points;
1745                 U8 **points; /* map of where we were in the input string
1746                                 when reading a given char. For ASCII this
1747                                 is unnecessary overhead as the relationship
1748                                 is always 1:1, but for Unicode, especially
1749                                 case folded Unicode this is not true. */
1750                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1751                 U8 *bitmap=NULL;
1752
1753
1754                 GET_RE_DEBUG_FLAGS_DECL;
1755
1756                 /* We can't just allocate points here. We need to wrap it in
1757                  * an SV so it gets freed properly if there is a croak while
1758                  * running the match */
1759                 ENTER;
1760                 SAVETMPS;
1761                 sv_points=newSV(maxlen * sizeof(U8 *));
1762                 SvCUR_set(sv_points,
1763                     maxlen * sizeof(U8 *));
1764                 SvPOK_on(sv_points);
1765                 sv_2mortal(sv_points);
1766                 points=(U8**)SvPV_nolen(sv_points );
1767                 if ( trie_type != trie_utf8_fold 
1768                      && (trie->bitmap || OP(c)==AHOCORASICKC) ) 
1769                 {
1770                     if (trie->bitmap) 
1771                         bitmap=(U8*)trie->bitmap;
1772                     else
1773                         bitmap=(U8*)ANYOF_BITMAP(c);
1774                 }
1775                 /* this is the Aho-Corasick algorithm modified a touch
1776                    to include special handling for long "unknown char" 
1777                    sequences. The basic idea being that we use AC as long
1778                    as we are dealing with a possible matching char, when
1779                    we encounter an unknown char (and we have not encountered
1780                    an accepting state) we scan forward until we find a legal 
1781                    starting char. 
1782                    AC matching is basically that of trie matching, except
1783                    that when we encounter a failing transition, we fall back
1784                    to the current states "fail state", and try the current char 
1785                    again, a process we repeat until we reach the root state, 
1786                    state 1, or a legal transition. If we fail on the root state 
1787                    then we can either terminate if we have reached an accepting 
1788                    state previously, or restart the entire process from the beginning 
1789                    if we have not.
1790
1791                  */
1792                 while (s <= last_start) {
1793                     const U32 uniflags = UTF8_ALLOW_DEFAULT;
1794                     U8 *uc = (U8*)s;
1795                     U16 charid = 0;
1796                     U32 base = 1;
1797                     U32 state = 1;
1798                     UV uvc = 0;
1799                     STRLEN len = 0;
1800                     STRLEN foldlen = 0;
1801                     U8 *uscan = (U8*)NULL;
1802                     U8 *leftmost = NULL;
1803 #ifdef DEBUGGING                    
1804                     U32 accepted_word= 0;
1805 #endif
1806                     U32 pointpos = 0;
1807
1808                     while ( state && uc <= (U8*)strend ) {
1809                         int failed=0;
1810                         U32 word = aho->states[ state ].wordnum;
1811
1812                         if( state==1 ) {
1813                             if ( bitmap ) {
1814                                 DEBUG_TRIE_EXECUTE_r(
1815                                     if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1816                                         dump_exec_pos( (char *)uc, c, strend, real_start, 
1817                                             (char *)uc, utf8_target );
1818                                         PerlIO_printf( Perl_debug_log,
1819                                             " Scanning for legal start char...\n");
1820                                     }
1821                                 );
1822                                 if (utf8_target) {
1823                                     while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1824                                         uc += UTF8SKIP(uc);
1825                                     }
1826                                 } else {
1827                                     while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
1828                                         uc++;
1829                                     }
1830                                 }
1831                                 s= (char *)uc;
1832                             }
1833                             if (uc >(U8*)last_start) break;
1834                         }
1835                                             
1836                         if ( word ) {
1837                             U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
1838                             if (!leftmost || lpos < leftmost) {
1839                                 DEBUG_r(accepted_word=word);
1840                                 leftmost= lpos;
1841                             }
1842                             if (base==0) break;
1843                             
1844                         }
1845                         points[pointpos++ % maxlen]= uc;
1846                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1847                                              uscan, len, uvc, charid, foldlen,
1848                                              foldbuf, uniflags);
1849                         DEBUG_TRIE_EXECUTE_r({
1850                             dump_exec_pos( (char *)uc, c, strend, real_start, 
1851                                 s,   utf8_target );
1852                             PerlIO_printf(Perl_debug_log,
1853                                 " Charid:%3u CP:%4"UVxf" ",
1854                                  charid, uvc);
1855                         });
1856
1857                         do {
1858 #ifdef DEBUGGING
1859                             word = aho->states[ state ].wordnum;
1860 #endif
1861                             base = aho->states[ state ].trans.base;
1862
1863                             DEBUG_TRIE_EXECUTE_r({
1864                                 if (failed) 
1865                                     dump_exec_pos( (char *)uc, c, strend, real_start, 
1866                                         s,   utf8_target );
1867                                 PerlIO_printf( Perl_debug_log,
1868                                     "%sState: %4"UVxf", word=%"UVxf,
1869                                     failed ? " Fail transition to " : "",
1870                                     (UV)state, (UV)word);
1871                             });
1872                             if ( base ) {
1873                                 U32 tmp;
1874                                 I32 offset;
1875                                 if (charid &&
1876                                      ( ((offset = base + charid
1877                                         - 1 - trie->uniquecharcount)) >= 0)
1878                                      && ((U32)offset < trie->lasttrans)
1879                                      && trie->trans[offset].check == state
1880                                      && (tmp=trie->trans[offset].next))
1881                                 {
1882                                     DEBUG_TRIE_EXECUTE_r(
1883                                         PerlIO_printf( Perl_debug_log," - legal\n"));
1884                                     state = tmp;
1885                                     break;
1886                                 }
1887                                 else {
1888                                     DEBUG_TRIE_EXECUTE_r(
1889                                         PerlIO_printf( Perl_debug_log," - fail\n"));
1890                                     failed = 1;
1891                                     state = aho->fail[state];
1892                                 }
1893                             }
1894                             else {
1895                                 /* we must be accepting here */
1896                                 DEBUG_TRIE_EXECUTE_r(
1897                                         PerlIO_printf( Perl_debug_log," - accepting\n"));
1898                                 failed = 1;
1899                                 break;
1900                             }
1901                         } while(state);
1902                         uc += len;
1903                         if (failed) {
1904                             if (leftmost)
1905                                 break;
1906                             if (!state) state = 1;
1907                         }
1908                     }
1909                     if ( aho->states[ state ].wordnum ) {
1910                         U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
1911                         if (!leftmost || lpos < leftmost) {
1912                             DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1913                             leftmost = lpos;
1914                         }
1915                     }
1916                     if (leftmost) {
1917                         s = (char*)leftmost;
1918                         DEBUG_TRIE_EXECUTE_r({
1919                             PerlIO_printf( 
1920                                 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1921                                 (UV)accepted_word, (IV)(s - real_start)
1922                             );
1923                         });
1924                         if (!reginfo || regtry(reginfo, &s)) {
1925                             FREETMPS;
1926                             LEAVE;
1927                             goto got_it;
1928                         }
1929                         s = HOPc(s,1);
1930                         DEBUG_TRIE_EXECUTE_r({
1931                             PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1932                         });
1933                     } else {
1934                         DEBUG_TRIE_EXECUTE_r(
1935                             PerlIO_printf( Perl_debug_log,"No match.\n"));
1936                         break;
1937                     }
1938                 }
1939                 FREETMPS;
1940                 LEAVE;
1941             }
1942             break;
1943         default:
1944             Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1945             break;
1946         }
1947         return 0;
1948       got_it:
1949         return s;
1950 }
1951
1952
1953 /*
1954  - regexec_flags - match a regexp against a string
1955  */
1956 I32
1957 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
1958               char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1959 /* strend: pointer to null at end of string */
1960 /* strbeg: real beginning of string */
1961 /* minend: end of match must be >=minend after stringarg. */
1962 /* data: May be used for some additional optimizations. 
1963          Currently its only used, with a U32 cast, for transmitting 
1964          the ganch offset when doing a /g match. This will change */
1965 /* nosave: For optimizations. */
1966 {
1967     dVAR;
1968     struct regexp *const prog = (struct regexp *)SvANY(rx);
1969     /*register*/ char *s;
1970     register regnode *c;
1971     /*register*/ char *startpos = stringarg;
1972     I32 minlen;         /* must match at least this many chars */
1973     I32 dontbother = 0; /* how many characters not to try at end */
1974     I32 end_shift = 0;                  /* Same for the end. */         /* CC */
1975     I32 scream_pos = -1;                /* Internal iterator of scream. */
1976     char *scream_olds = NULL;
1977     const bool utf8_target = cBOOL(DO_UTF8(sv));
1978     I32 multiline;
1979     RXi_GET_DECL(prog,progi);
1980     regmatch_info reginfo;  /* create some info to pass to regtry etc */
1981     regexp_paren_pair *swap = NULL;
1982     GET_RE_DEBUG_FLAGS_DECL;
1983
1984     PERL_ARGS_ASSERT_REGEXEC_FLAGS;
1985     PERL_UNUSED_ARG(data);
1986
1987     /* Be paranoid... */
1988     if (prog == NULL || startpos == NULL) {
1989         Perl_croak(aTHX_ "NULL regexp parameter");
1990         return 0;
1991     }
1992
1993     multiline = prog->extflags & RXf_PMf_MULTILINE;
1994     reginfo.prog = rx;   /* Yes, sorry that this is confusing.  */
1995
1996     RX_MATCH_UTF8_set(rx, utf8_target);
1997     DEBUG_EXECUTE_r( 
1998         debug_start_match(rx, utf8_target, startpos, strend,
1999         "Matching");
2000     );
2001
2002     minlen = prog->minlen;
2003     
2004     if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
2005         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2006                               "String too short [regexec_flags]...\n"));
2007         goto phooey;
2008     }
2009
2010     
2011     /* Check validity of program. */
2012     if (UCHARAT(progi->program) != REG_MAGIC) {
2013         Perl_croak(aTHX_ "corrupted regexp program");
2014     }
2015
2016     PL_reg_flags = 0;
2017     PL_reg_eval_set = 0;
2018     PL_reg_maxiter = 0;
2019
2020     if (RX_UTF8(rx))
2021         PL_reg_flags |= RF_utf8;
2022
2023     /* Mark beginning of line for ^ and lookbehind. */
2024     reginfo.bol = startpos; /* XXX not used ??? */
2025     PL_bostr  = strbeg;
2026     reginfo.sv = sv;
2027
2028     /* Mark end of line for $ (and such) */
2029     PL_regeol = strend;
2030
2031     /* see how far we have to get to not match where we matched before */
2032     reginfo.till = startpos+minend;
2033
2034     /* If there is a "must appear" string, look for it. */
2035     s = startpos;
2036
2037     if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
2038         MAGIC *mg;
2039         if (flags & REXEC_IGNOREPOS){   /* Means: check only at start */
2040             reginfo.ganch = startpos + prog->gofs;
2041             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2042               "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
2043         } else if (sv && SvTYPE(sv) >= SVt_PVMG
2044                   && SvMAGIC(sv)
2045                   && (mg = mg_find(sv, PERL_MAGIC_regex_global))
2046                   && mg->mg_len >= 0) {
2047             reginfo.ganch = strbeg + mg->mg_len;        /* Defined pos() */
2048             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2049                 "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
2050
2051             if (prog->extflags & RXf_ANCH_GPOS) {
2052                 if (s > reginfo.ganch)
2053                     goto phooey;
2054                 s = reginfo.ganch - prog->gofs;
2055                 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2056                      "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
2057                 if (s < strbeg)
2058                     goto phooey;
2059             }
2060         }
2061         else if (data) {
2062             reginfo.ganch = strbeg + PTR2UV(data);
2063             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2064                  "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
2065
2066         } else {                                /* pos() not defined */
2067             reginfo.ganch = strbeg;
2068             DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2069                  "GPOS: reginfo.ganch = strbeg\n"));
2070         }
2071     }
2072     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
2073         /* We have to be careful. If the previous successful match
2074            was from this regex we don't want a subsequent partially
2075            successful match to clobber the old results.
2076            So when we detect this possibility we add a swap buffer
2077            to the re, and switch the buffer each match. If we fail
2078            we switch it back, otherwise we leave it swapped.
2079         */
2080         swap = prog->offs;
2081         /* do we need a save destructor here for eval dies? */
2082         Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
2083     }
2084     if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
2085         re_scream_pos_data d;
2086
2087         d.scream_olds = &scream_olds;
2088         d.scream_pos = &scream_pos;
2089         s = re_intuit_start(rx, sv, s, strend, flags, &d);
2090         if (!s) {
2091             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
2092             goto phooey;        /* not present */
2093         }
2094     }
2095
2096
2097
2098     /* Simplest case:  anchored match need be tried only once. */
2099     /*  [unless only anchor is BOL and multiline is set] */
2100     if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
2101         if (s == startpos && regtry(&reginfo, &startpos))
2102             goto got_it;
2103         else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2104                  || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
2105         {
2106             char *end;
2107
2108             if (minlen)
2109                 dontbother = minlen - 1;
2110             end = HOP3c(strend, -dontbother, strbeg) - 1;
2111             /* for multiline we only have to try after newlines */
2112             if (prog->check_substr || prog->check_utf8) {
2113                 /* because of the goto we can not easily reuse the macros for bifurcating the
2114                    unicode/non-unicode match modes here like we do elsewhere - demerphq */
2115                 if (utf8_target) {
2116                     if (s == startpos)
2117                         goto after_try_utf8;
2118                     while (1) {
2119                         if (regtry(&reginfo, &s)) {
2120                             goto got_it;
2121                         }
2122                       after_try_utf8:
2123                         if (s > end) {
2124                             goto phooey;
2125                         }
2126                         if (prog->extflags & RXf_USE_INTUIT) {
2127                             s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL);
2128                             if (!s) {
2129                                 goto phooey;
2130                             }
2131                         }
2132                         else {
2133                             s += UTF8SKIP(s);
2134                         }
2135                     }
2136                 } /* end search for check string in unicode */
2137                 else {
2138                     if (s == startpos) {
2139                         goto after_try_latin;
2140                     }
2141                     while (1) {
2142                         if (regtry(&reginfo, &s)) {
2143                             goto got_it;
2144                         }
2145                       after_try_latin:
2146                         if (s > end) {
2147                             goto phooey;
2148                         }
2149                         if (prog->extflags & RXf_USE_INTUIT) {
2150                             s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2151                             if (!s) {
2152                                 goto phooey;
2153                             }
2154                         }
2155                         else {
2156                             s++;
2157                         }
2158                     }
2159                 } /* end search for check string in latin*/
2160             } /* end search for check string */
2161             else { /* search for newline */
2162                 if (s > startpos) {
2163                     /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
2164                     s--;
2165                 }
2166                 /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
2167                 while (s < end) {
2168                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
2169                         if (regtry(&reginfo, &s))
2170                             goto got_it;
2171                     }
2172                 }
2173             } /* end search for newline */
2174         } /* end anchored/multiline check string search */
2175         goto phooey;
2176     } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK)) 
2177     {
2178         /* the warning about reginfo.ganch being used without initialization
2179            is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN 
2180            and we only enter this block when the same bit is set. */
2181         char *tmp_s = reginfo.ganch - prog->gofs;
2182
2183         if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
2184             goto got_it;
2185         goto phooey;
2186     }
2187
2188     /* Messy cases:  unanchored match. */
2189     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2190         /* we have /x+whatever/ */
2191         /* it must be a one character string (XXXX Except UTF_PATTERN?) */
2192         char ch;
2193 #ifdef DEBUGGING
2194         int did_match = 0;
2195 #endif
2196         if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
2197             utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2198         ch = SvPVX_const(utf8_target ? prog->anchored_utf8 : prog->anchored_substr)[0];
2199
2200         if (utf8_target) {
2201             REXEC_FBC_SCAN(
2202                 if (*s == ch) {
2203                     DEBUG_EXECUTE_r( did_match = 1 );
2204                     if (regtry(&reginfo, &s)) goto got_it;
2205                     s += UTF8SKIP(s);
2206                     while (s < strend && *s == ch)
2207                         s += UTF8SKIP(s);
2208                 }
2209             );
2210         }
2211         else {
2212             REXEC_FBC_SCAN(
2213                 if (*s == ch) {
2214                     DEBUG_EXECUTE_r( did_match = 1 );
2215                     if (regtry(&reginfo, &s)) goto got_it;
2216                     s++;
2217                     while (s < strend && *s == ch)
2218                         s++;
2219                 }
2220             );
2221         }
2222         DEBUG_EXECUTE_r(if (!did_match)
2223                 PerlIO_printf(Perl_debug_log,
2224                                   "Did not find anchored character...\n")
2225                );
2226     }
2227     else if (prog->anchored_substr != NULL
2228               || prog->anchored_utf8 != NULL
2229               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2230                   && prog->float_max_offset < strend - s)) {
2231         SV *must;
2232         I32 back_max;
2233         I32 back_min;
2234         char *last;
2235         char *last1;            /* Last position checked before */
2236 #ifdef DEBUGGING
2237         int did_match = 0;
2238 #endif
2239         if (prog->anchored_substr || prog->anchored_utf8) {
2240             if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
2241                 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2242             must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
2243             back_max = back_min = prog->anchored_offset;
2244         } else {
2245             if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
2246                 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2247             must = utf8_target ? prog->float_utf8 : prog->float_substr;
2248             back_max = prog->float_max_offset;
2249             back_min = prog->float_min_offset;
2250         }
2251         
2252             
2253         if (must == &PL_sv_undef)
2254             /* could not downgrade utf8 check substring, so must fail */
2255             goto phooey;
2256
2257         if (back_min<0) {
2258             last = strend;
2259         } else {
2260             last = HOP3c(strend,        /* Cannot start after this */
2261                   -(I32)(CHR_SVLEN(must)
2262                          - (SvTAIL(must) != 0) + back_min), strbeg);
2263         }
2264         if (s > PL_bostr)
2265             last1 = HOPc(s, -1);
2266         else
2267             last1 = s - 1;      /* bogus */
2268
2269         /* XXXX check_substr already used to find "s", can optimize if
2270            check_substr==must. */
2271         scream_pos = -1;
2272         dontbother = end_shift;
2273         strend = HOPc(strend, -dontbother);
2274         while ( (s <= last) &&
2275                 ((flags & REXEC_SCREAM)
2276                  ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2277                                     end_shift, &scream_pos, 0))
2278                  : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2279                                   (unsigned char*)strend, must,
2280                                   multiline ? FBMrf_MULTILINE : 0))) ) {
2281             /* we may be pointing at the wrong string */
2282             if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2283                 s = strbeg + (s - SvPVX_const(sv));
2284             DEBUG_EXECUTE_r( did_match = 1 );
2285             if (HOPc(s, -back_max) > last1) {
2286                 last1 = HOPc(s, -back_min);
2287                 s = HOPc(s, -back_max);
2288             }
2289             else {
2290                 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2291
2292                 last1 = HOPc(s, -back_min);
2293                 s = t;
2294             }
2295             if (utf8_target) {
2296                 while (s <= last1) {
2297                     if (regtry(&reginfo, &s))
2298                         goto got_it;
2299                     s += UTF8SKIP(s);
2300                 }
2301             }
2302             else {
2303                 while (s <= last1) {
2304                     if (regtry(&reginfo, &s))
2305                         goto got_it;
2306                     s++;
2307                 }
2308             }
2309         }
2310         DEBUG_EXECUTE_r(if (!did_match) {
2311             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
2312                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2313             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2314                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2315                                ? "anchored" : "floating"),
2316                 quoted, RE_SV_TAIL(must));
2317         });                 
2318         goto phooey;
2319     }
2320     else if ( (c = progi->regstclass) ) {
2321         if (minlen) {
2322             const OPCODE op = OP(progi->regstclass);
2323             /* don't bother with what can't match */
2324             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2325                 strend = HOPc(strend, -(minlen - 1));
2326         }
2327         DEBUG_EXECUTE_r({
2328             SV * const prop = sv_newmortal();
2329             regprop(prog, prop, c);
2330             {
2331                 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
2332                     s,strend-s,60);
2333                 PerlIO_printf(Perl_debug_log,
2334                     "Matching stclass %.*s against %s (%d bytes)\n",
2335                     (int)SvCUR(prop), SvPVX_const(prop),
2336                      quoted, (int)(strend - s));
2337             }
2338         });
2339         if (find_byclass(prog, c, s, strend, &reginfo))
2340             goto got_it;
2341         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2342     }
2343     else {
2344         dontbother = 0;
2345         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2346             /* Trim the end. */
2347             char *last;
2348             SV* float_real;
2349
2350             if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
2351                 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2352             float_real = utf8_target ? prog->float_utf8 : prog->float_substr;
2353
2354             if (flags & REXEC_SCREAM) {
2355                 last = screaminstr(sv, float_real, s - strbeg,
2356                                    end_shift, &scream_pos, 1); /* last one */
2357                 if (!last)
2358                     last = scream_olds; /* Only one occurrence. */
2359                 /* we may be pointing at the wrong string */
2360                 else if (RXp_MATCH_COPIED(prog))
2361                     s = strbeg + (s - SvPVX_const(sv));
2362             }
2363             else {
2364                 STRLEN len;
2365                 const char * const little = SvPV_const(float_real, len);
2366
2367                 if (SvTAIL(float_real)) {
2368                     if (memEQ(strend - len + 1, little, len - 1))
2369                         last = strend - len + 1;
2370                     else if (!multiline)
2371                         last = memEQ(strend - len, little, len)
2372                             ? strend - len : NULL;
2373                     else
2374                         goto find_last;
2375                 } else {
2376                   find_last:
2377                     if (len)
2378                         last = rninstr(s, strend, little, little + len);
2379                     else
2380                         last = strend;  /* matching "$" */
2381                 }
2382             }
2383             if (last == NULL) {
2384                 DEBUG_EXECUTE_r(
2385                     PerlIO_printf(Perl_debug_log,
2386                         "%sCan't trim the tail, match fails (should not happen)%s\n",
2387                         PL_colors[4], PL_colors[5]));
2388                 goto phooey; /* Should not happen! */
2389             }
2390             dontbother = strend - last + prog->float_min_offset;
2391         }
2392         if (minlen && (dontbother < minlen))
2393             dontbother = minlen - 1;
2394         strend -= dontbother;              /* this one's always in bytes! */
2395         /* We don't know much -- general case. */
2396         if (utf8_target) {
2397             for (;;) {
2398                 if (regtry(&reginfo, &s))
2399                     goto got_it;
2400                 if (s >= strend)
2401                     break;
2402                 s += UTF8SKIP(s);
2403             };
2404         }
2405         else {
2406             do {
2407                 if (regtry(&reginfo, &s))
2408                     goto got_it;
2409             } while (s++ < strend);
2410         }
2411     }
2412
2413     /* Failure. */
2414     goto phooey;
2415
2416 got_it:
2417     Safefree(swap);
2418     RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2419
2420     if (PL_reg_eval_set)
2421         restore_pos(aTHX_ prog);
2422     if (RXp_PAREN_NAMES(prog)) 
2423         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2424
2425     /* make sure $`, $&, $', and $digit will work later */
2426     if ( !(flags & REXEC_NOT_FIRST) ) {
2427         RX_MATCH_COPY_FREE(rx);
2428         if (flags & REXEC_COPY_STR) {
2429             const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2430 #ifdef PERL_OLD_COPY_ON_WRITE
2431             if ((SvIsCOW(sv)
2432                  || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2433                 if (DEBUG_C_TEST) {
2434                     PerlIO_printf(Perl_debug_log,
2435                                   "Copy on write: regexp capture, type %d\n",
2436                                   (int) SvTYPE(sv));
2437                 }
2438                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2439                 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2440                 assert (SvPOKp(prog->saved_copy));
2441             } else
2442 #endif
2443             {
2444                 RX_MATCH_COPIED_on(rx);
2445                 s = savepvn(strbeg, i);
2446                 prog->subbeg = s;
2447             }
2448             prog->sublen = i;
2449         }
2450         else {
2451             prog->subbeg = strbeg;
2452             prog->sublen = PL_regeol - strbeg;  /* strend may have been modified */
2453         }
2454     }
2455
2456     return 1;
2457
2458 phooey:
2459     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2460                           PL_colors[4], PL_colors[5]));
2461     if (PL_reg_eval_set)
2462         restore_pos(aTHX_ prog);
2463     if (swap) {
2464         /* we failed :-( roll it back */
2465         Safefree(prog->offs);
2466         prog->offs = swap;
2467     }
2468
2469     return 0;
2470 }
2471
2472
2473 /*
2474  - regtry - try match at specific point
2475  */
2476 STATIC I32                      /* 0 failure, 1 success */
2477 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2478 {
2479     dVAR;
2480     CHECKPOINT lastcp;
2481     REGEXP *const rx = reginfo->prog;
2482     regexp *const prog = (struct regexp *)SvANY(rx);
2483     RXi_GET_DECL(prog,progi);
2484     GET_RE_DEBUG_FLAGS_DECL;
2485
2486     PERL_ARGS_ASSERT_REGTRY;
2487
2488     reginfo->cutpoint=NULL;
2489
2490     if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2491         MAGIC *mg;
2492
2493         PL_reg_eval_set = RS_init;
2494         DEBUG_EXECUTE_r(DEBUG_s(
2495             PerlIO_printf(Perl_debug_log, "  setting stack tmpbase at %"IVdf"\n",
2496                           (IV)(PL_stack_sp - PL_stack_base));
2497             ));
2498         SAVESTACK_CXPOS();
2499         cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2500         /* Otherwise OP_NEXTSTATE will free whatever on stack now.  */
2501         SAVETMPS;
2502         /* Apparently this is not needed, judging by wantarray. */
2503         /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2504            cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2505
2506         if (reginfo->sv) {
2507             /* Make $_ available to executed code. */
2508             if (reginfo->sv != DEFSV) {
2509                 SAVE_DEFSV;
2510                 DEFSV_set(reginfo->sv);
2511             }
2512         
2513             if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2514                   && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2515                 /* prepare for quick setting of pos */
2516 #ifdef PERL_OLD_COPY_ON_WRITE
2517                 if (SvIsCOW(reginfo->sv))
2518                     sv_force_normal_flags(reginfo->sv, 0);
2519 #endif
2520                 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2521                                  &PL_vtbl_mglob, NULL, 0);
2522                 mg->mg_len = -1;
2523             }
2524             PL_reg_magic    = mg;
2525             PL_reg_oldpos   = mg->mg_len;
2526             SAVEDESTRUCTOR_X(restore_pos, prog);
2527         }
2528         if (!PL_reg_curpm) {
2529             Newxz(PL_reg_curpm, 1, PMOP);
2530 #ifdef USE_ITHREADS
2531             {
2532                 SV* const repointer = &PL_sv_undef;
2533                 /* this regexp is also owned by the new PL_reg_curpm, which
2534                    will try to free it.  */
2535                 av_push(PL_regex_padav, repointer);
2536                 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2537                 PL_regex_pad = AvARRAY(PL_regex_padav);
2538             }
2539 #endif      
2540         }
2541 #ifdef USE_ITHREADS
2542         /* It seems that non-ithreads works both with and without this code.
2543            So for efficiency reasons it seems best not to have the code
2544            compiled when it is not needed.  */
2545         /* This is safe against NULLs: */
2546         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2547         /* PM_reg_curpm owns a reference to this regexp.  */
2548         ReREFCNT_inc(rx);
2549 #endif
2550         PM_SETRE(PL_reg_curpm, rx);
2551         PL_reg_oldcurpm = PL_curpm;
2552         PL_curpm = PL_reg_curpm;
2553         if (RXp_MATCH_COPIED(prog)) {
2554             /*  Here is a serious problem: we cannot rewrite subbeg,
2555                 since it may be needed if this match fails.  Thus
2556                 $` inside (?{}) could fail... */
2557             PL_reg_oldsaved = prog->subbeg;
2558             PL_reg_oldsavedlen = prog->sublen;
2559 #ifdef PERL_OLD_COPY_ON_WRITE
2560             PL_nrs = prog->saved_copy;
2561 #endif
2562             RXp_MATCH_COPIED_off(prog);
2563         }
2564         else
2565             PL_reg_oldsaved = NULL;
2566         prog->subbeg = PL_bostr;
2567         prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2568     }
2569     DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2570     prog->offs[0].start = *startpos - PL_bostr;
2571     PL_reginput = *startpos;
2572     PL_reglastparen = &prog->lastparen;
2573     PL_reglastcloseparen = &prog->lastcloseparen;
2574     prog->lastparen = 0;
2575     prog->lastcloseparen = 0;
2576     PL_regsize = 0;
2577     PL_regoffs = prog->offs;
2578     if (PL_reg_start_tmpl <= prog->nparens) {
2579         PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2580         if(PL_reg_start_tmp)
2581             Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2582         else
2583             Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2584     }
2585
2586     /* XXXX What this code is doing here?!!!  There should be no need
2587        to do this again and again, PL_reglastparen should take care of
2588        this!  --ilya*/
2589
2590     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2591      * Actually, the code in regcppop() (which Ilya may be meaning by
2592      * PL_reglastparen), is not needed at all by the test suite
2593      * (op/regexp, op/pat, op/split), but that code is needed otherwise
2594      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2595      * Meanwhile, this code *is* needed for the
2596      * above-mentioned test suite tests to succeed.  The common theme
2597      * on those tests seems to be returning null fields from matches.
2598      * --jhi updated by dapm */
2599 #if 1
2600     if (prog->nparens) {
2601         regexp_paren_pair *pp = PL_regoffs;
2602         register I32 i;
2603         for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2604             ++pp;
2605             pp->start = -1;
2606             pp->end = -1;
2607         }
2608     }
2609 #endif
2610     REGCP_SET(lastcp);
2611     if (regmatch(reginfo, progi->program + 1)) {
2612         PL_regoffs[0].end = PL_reginput - PL_bostr;
2613         return 1;
2614     }
2615     if (reginfo->cutpoint)
2616         *startpos= reginfo->cutpoint;
2617     REGCP_UNWIND(lastcp);
2618     return 0;
2619 }
2620
2621
2622 #define sayYES goto yes
2623 #define sayNO goto no
2624 #define sayNO_SILENT goto no_silent
2625
2626 /* we dont use STMT_START/END here because it leads to 
2627    "unreachable code" warnings, which are bogus, but distracting. */
2628 #define CACHEsayNO \
2629     if (ST.cache_mask) \
2630        PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2631     sayNO
2632
2633 /* this is used to determine how far from the left messages like
2634    'failed...' are printed. It should be set such that messages 
2635    are inline with the regop output that created them.
2636 */
2637 #define REPORT_CODE_OFF 32
2638
2639
2640 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2641 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
2642
2643 #define SLAB_FIRST(s) (&(s)->states[0])
2644 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2645
2646 /* grab a new slab and return the first slot in it */
2647
2648 STATIC regmatch_state *
2649 S_push_slab(pTHX)
2650 {
2651 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2652     dMY_CXT;
2653 #endif
2654     regmatch_slab *s = PL_regmatch_slab->next;
2655     if (!s) {
2656         Newx(s, 1, regmatch_slab);
2657         s->prev = PL_regmatch_slab;
2658         s->next = NULL;
2659         PL_regmatch_slab->next = s;
2660     }
2661     PL_regmatch_slab = s;
2662     return SLAB_FIRST(s);
2663 }
2664
2665
2666 /* push a new state then goto it */
2667
2668 #define PUSH_STATE_GOTO(state, node) \
2669     scan = node; \
2670     st->resume_state = state; \
2671     goto push_state;
2672
2673 /* push a new state with success backtracking, then goto it */
2674
2675 #define PUSH_YES_STATE_GOTO(state, node) \
2676     scan = node; \
2677     st->resume_state = state; \
2678     goto push_yes_state;
2679
2680
2681
2682 /*
2683
2684 regmatch() - main matching routine
2685
2686 This is basically one big switch statement in a loop. We execute an op,
2687 set 'next' to point the next op, and continue. If we come to a point which
2688 we may need to backtrack to on failure such as (A|B|C), we push a
2689 backtrack state onto the backtrack stack. On failure, we pop the top
2690 state, and re-enter the loop at the state indicated. If there are no more
2691 states to pop, we return failure.
2692
2693 Sometimes we also need to backtrack on success; for example /A+/, where
2694 after successfully matching one A, we need to go back and try to
2695 match another one; similarly for lookahead assertions: if the assertion
2696 completes successfully, we backtrack to the state just before the assertion
2697 and then carry on.  In these cases, the pushed state is marked as
2698 'backtrack on success too'. This marking is in fact done by a chain of
2699 pointers, each pointing to the previous 'yes' state. On success, we pop to
2700 the nearest yes state, discarding any intermediate failure-only states.
2701 Sometimes a yes state is pushed just to force some cleanup code to be
2702 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2703 it to free the inner regex.
2704
2705 Note that failure backtracking rewinds the cursor position, while
2706 success backtracking leaves it alone.
2707
2708 A pattern is complete when the END op is executed, while a subpattern
2709 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2710 ops trigger the "pop to last yes state if any, otherwise return true"
2711 behaviour.
2712
2713 A common convention in this function is to use A and B to refer to the two
2714 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2715 the subpattern to be matched possibly multiple times, while B is the entire
2716 rest of the pattern. Variable and state names reflect this convention.
2717
2718 The states in the main switch are the union of ops and failure/success of
2719 substates associated with with that op.  For example, IFMATCH is the op
2720 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2721 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2722 successfully matched A and IFMATCH_A_fail is a state saying that we have
2723 just failed to match A. Resume states always come in pairs. The backtrack
2724 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2725 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2726 on success or failure.
2727
2728 The struct that holds a backtracking state is actually a big union, with
2729 one variant for each major type of op. The variable st points to the
2730 top-most backtrack struct. To make the code clearer, within each
2731 block of code we #define ST to alias the relevant union.
2732
2733 Here's a concrete example of a (vastly oversimplified) IFMATCH
2734 implementation:
2735
2736     switch (state) {
2737     ....
2738
2739 #define ST st->u.ifmatch
2740
2741     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2742         ST.foo = ...; // some state we wish to save
2743         ...
2744         // push a yes backtrack state with a resume value of
2745         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2746         // first node of A:
2747         PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2748         // NOTREACHED
2749
2750     case IFMATCH_A: // we have successfully executed A; now continue with B
2751         next = B;
2752         bar = ST.foo; // do something with the preserved value
2753         break;
2754
2755     case IFMATCH_A_fail: // A failed, so the assertion failed
2756         ...;   // do some housekeeping, then ...
2757         sayNO; // propagate the failure
2758
2759 #undef ST
2760
2761     ...
2762     }
2763
2764 For any old-timers reading this who are familiar with the old recursive
2765 approach, the code above is equivalent to:
2766
2767     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2768     {
2769         int foo = ...
2770         ...
2771         if (regmatch(A)) {
2772             next = B;
2773             bar = foo;
2774             break;
2775         }
2776         ...;   // do some housekeeping, then ...
2777         sayNO; // propagate the failure
2778     }
2779
2780 The topmost backtrack state, pointed to by st, is usually free. If you
2781 want to claim it, populate any ST.foo fields in it with values you wish to
2782 save, then do one of
2783
2784         PUSH_STATE_GOTO(resume_state, node);
2785         PUSH_YES_STATE_GOTO(resume_state, node);
2786
2787 which sets that backtrack state's resume value to 'resume_state', pushes a
2788 new free entry to the top of the backtrack stack, then goes to 'node'.
2789 On backtracking, the free slot is popped, and the saved state becomes the
2790 new free state. An ST.foo field in this new top state can be temporarily
2791 accessed to retrieve values, but once the main loop is re-entered, it
2792 becomes available for reuse.
2793
2794 Note that the depth of the backtrack stack constantly increases during the
2795 left-to-right execution of the pattern, rather than going up and down with
2796 the pattern nesting. For example the stack is at its maximum at Z at the
2797 end of the pattern, rather than at X in the following:
2798
2799     /(((X)+)+)+....(Y)+....Z/
2800
2801 The only exceptions to this are lookahead/behind assertions and the cut,
2802 (?>A), which pop all the backtrack states associated with A before
2803 continuing.
2804  
2805 Backtrack state structs are allocated in slabs of about 4K in size.
2806 PL_regmatch_state and st always point to the currently active state,
2807 and PL_regmatch_slab points to the slab currently containing
2808 PL_regmatch_state.  The first time regmatch() is called, the first slab is
2809 allocated, and is never freed until interpreter destruction. When the slab
2810 is full, a new one is allocated and chained to the end. At exit from
2811 regmatch(), slabs allocated since entry are freed.
2812
2813 */
2814  
2815
2816 #define DEBUG_STATE_pp(pp)                                  \
2817     DEBUG_STATE_r({                                         \
2818         DUMP_EXEC_POS(locinput, scan, utf8_target);                 \
2819         PerlIO_printf(Perl_debug_log,                       \
2820             "    %*s"pp" %s%s%s%s%s\n",                     \
2821             depth*2, "",                                    \
2822             PL_reg_name[st->resume_state],                     \
2823             ((st==yes_state||st==mark_state) ? "[" : ""),   \
2824             ((st==yes_state) ? "Y" : ""),                   \
2825             ((st==mark_state) ? "M" : ""),                  \
2826             ((st==yes_state||st==mark_state) ? "]" : "")    \
2827         );                                                  \
2828     });
2829
2830
2831 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2832
2833 #ifdef DEBUGGING
2834
2835 STATIC void
2836 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
2837     const char *start, const char *end, const char *blurb)
2838 {
2839     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2840
2841     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2842
2843     if (!PL_colorset)   
2844             reginitcolors();    
2845     {
2846         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), 
2847             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);   
2848         
2849         RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
2850             start, end - start, 60); 
2851         
2852         PerlIO_printf(Perl_debug_log, 
2853             "%s%s REx%s %s against %s\n", 
2854                        PL_colors[4], blurb, PL_colors[5], s0, s1); 
2855         
2856         if (utf8_target||utf8_pat)
2857             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2858                 utf8_pat ? "pattern" : "",
2859                 utf8_pat && utf8_target ? " and " : "",
2860                 utf8_target ? "string" : ""
2861             ); 
2862     }
2863 }
2864
2865 STATIC void
2866 S_dump_exec_pos(pTHX_ const char *locinput, 
2867                       const regnode *scan, 
2868                       const char *loc_regeol, 
2869                       const char *loc_bostr, 
2870                       const char *loc_reg_starttry,
2871                       const bool utf8_target)
2872 {
2873     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2874     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2875     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2876     /* The part of the string before starttry has one color
2877        (pref0_len chars), between starttry and current
2878        position another one (pref_len - pref0_len chars),
2879        after the current position the third one.
2880        We assume that pref0_len <= pref_len, otherwise we
2881        decrease pref0_len.  */
2882     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2883         ? (5 + taill) - l : locinput - loc_bostr;
2884     int pref0_len;
2885
2886     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2887
2888     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2889         pref_len++;
2890     pref0_len = pref_len  - (locinput - loc_reg_starttry);
2891     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2892         l = ( loc_regeol - locinput > (5 + taill) - pref_len
2893               ? (5 + taill) - pref_len : loc_regeol - locinput);
2894     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2895         l--;
2896     if (pref0_len < 0)
2897         pref0_len = 0;
2898     if (pref0_len > pref_len)
2899         pref0_len = pref_len;
2900     {
2901         const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
2902
2903         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2904             (locinput - pref_len),pref0_len, 60, 4, 5);
2905         
2906         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2907                     (locinput - pref_len + pref0_len),
2908                     pref_len - pref0_len, 60, 2, 3);
2909         
2910         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2911                     locinput, loc_regeol - locinput, 10, 0, 1);
2912
2913         const STRLEN tlen=len0+len1+len2;
2914         PerlIO_printf(Perl_debug_log,
2915                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2916                     (IV)(locinput - loc_bostr),
2917                     len0, s0,
2918                     len1, s1,
2919                     (docolor ? "" : "> <"),
2920                     len2, s2,
2921                     (int)(tlen > 19 ? 0 :  19 - tlen),
2922                     "");
2923     }
2924 }
2925
2926 #endif
2927
2928 /* reg_check_named_buff_matched()
2929  * Checks to see if a named buffer has matched. The data array of 
2930  * buffer numbers corresponding to the buffer is expected to reside
2931  * in the regexp->data->data array in the slot stored in the ARG() of
2932  * node involved. Note that this routine doesn't actually care about the
2933  * name, that information is not preserved from compilation to execution.
2934  * Returns the index of the leftmost defined buffer with the given name
2935  * or 0 if non of the buffers matched.
2936  */
2937 STATIC I32
2938 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2939 {
2940     I32 n;
2941     RXi_GET_DECL(rex,rexi);
2942     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
2943     I32 *nums=(I32*)SvPVX(sv_dat);
2944
2945     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
2946
2947     for ( n=0; n<SvIVX(sv_dat); n++ ) {
2948         if ((I32)*PL_reglastparen >= nums[n] &&
2949             PL_regoffs[nums[n]].end != -1)
2950         {
2951             return nums[n];
2952         }
2953     }
2954     return 0;
2955 }
2956
2957
2958 /* free all slabs above current one  - called during LEAVE_SCOPE */
2959
2960 STATIC void
2961 S_clear_backtrack_stack(pTHX_ void *p)
2962 {
2963     regmatch_slab *s = PL_regmatch_slab->next;
2964     PERL_UNUSED_ARG(p);
2965
2966     if (!s)
2967         return;
2968     PL_regmatch_slab->next = NULL;
2969     while (s) {
2970         regmatch_slab * const osl = s;
2971         s = s->next;
2972         Safefree(osl);
2973     }
2974 }
2975
2976
2977 #define SETREX(Re1,Re2) \
2978     if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2979     Re1 = (Re2)
2980
2981 STATIC I32                      /* 0 failure, 1 success */
2982 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2983 {
2984 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2985     dMY_CXT;
2986 #endif
2987     dVAR;
2988     register const bool utf8_target = PL_reg_match_utf8;
2989     const U32 uniflags = UTF8_ALLOW_DEFAULT;
2990     REGEXP *rex_sv = reginfo->prog;
2991     regexp *rex = (struct regexp *)SvANY(rex_sv);
2992     RXi_GET_DECL(rex,rexi);
2993     I32 oldsave;
2994     /* the current state. This is a cached copy of PL_regmatch_state */
2995     register regmatch_state *st;
2996     /* cache heavy used fields of st in registers */
2997     register regnode *scan;
2998     register regnode *next;
2999     register U32 n = 0; /* general value; init to avoid compiler warning */
3000     register I32 ln = 0; /* len or last;  init to avoid compiler warning */
3001     register char *locinput = PL_reginput;
3002     register I32 nextchr;   /* is always set to UCHARAT(locinput) */
3003
3004     bool result = 0;        /* return value of S_regmatch */
3005     int depth = 0;          /* depth of backtrack stack */
3006     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
3007     const U32 max_nochange_depth =
3008         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
3009         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
3010     regmatch_state *yes_state = NULL; /* state to pop to on success of
3011                                                             subpattern */
3012     /* mark_state piggy backs on the yes_state logic so that when we unwind 
3013        the stack on success we can update the mark_state as we go */
3014     regmatch_state *mark_state = NULL; /* last mark state we have seen */
3015     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
3016     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
3017     U32 state_num;
3018     bool no_final = 0;      /* prevent failure from backtracking? */
3019     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
3020     char *startpoint = PL_reginput;
3021     SV *popmark = NULL;     /* are we looking for a mark? */
3022     SV *sv_commit = NULL;   /* last mark name seen in failure */
3023     SV *sv_yes_mark = NULL; /* last mark name we have seen 
3024                                during a successful match */
3025     U32 lastopen = 0;       /* last open we saw */
3026     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;   
3027     SV* const oreplsv = GvSV(PL_replgv);
3028     /* these three flags are set by various ops to signal information to
3029      * the very next op. They have a useful lifetime of exactly one loop
3030      * iteration, and are not preserved or restored by state pushes/pops
3031      */
3032     bool sw = 0;            /* the condition value in (?(cond)a|b) */
3033     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
3034     int logical = 0;        /* the following EVAL is:
3035                                 0: (?{...})
3036                                 1: (?(?{...})X|Y)
3037                                 2: (??{...})
3038                                or the following IFMATCH/UNLESSM is:
3039                                 false: plain (?=foo)
3040                                 true:  used as a condition: (?(?=foo))
3041                             */
3042 #ifdef DEBUGGING
3043     GET_RE_DEBUG_FLAGS_DECL;
3044 #endif
3045
3046     PERL_ARGS_ASSERT_REGMATCH;
3047
3048     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
3049             PerlIO_printf(Perl_debug_log,"regmatch start\n");
3050     }));
3051     /* on first ever call to regmatch, allocate first slab */
3052     if (!PL_regmatch_slab) {
3053         Newx(PL_regmatch_slab, 1, regmatch_slab);
3054         PL_regmatch_slab->prev = NULL;
3055         PL_regmatch_slab->next = NULL;
3056         PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
3057     }
3058
3059     oldsave = PL_savestack_ix;
3060     SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
3061     SAVEVPTR(PL_regmatch_slab);
3062     SAVEVPTR(PL_regmatch_state);
3063
3064     /* grab next free state slot */
3065     st = ++PL_regmatch_state;
3066     if (st >  SLAB_LAST(PL_regmatch_slab))
3067         st = PL_regmatch_state = S_push_slab(aTHX);
3068
3069     /* Note that nextchr is a byte even in UTF */
3070     nextchr = UCHARAT(locinput);
3071     scan = prog;
3072     while (scan != NULL) {
3073
3074         DEBUG_EXECUTE_r( {
3075             SV * const prop = sv_newmortal();
3076             regnode *rnext=regnext(scan);
3077             DUMP_EXEC_POS( locinput, scan, utf8_target );
3078             regprop(rex, prop, scan);
3079             
3080             PerlIO_printf(Perl_debug_log,
3081                     "%3"IVdf":%*s%s(%"IVdf")\n",
3082                     (IV)(scan - rexi->program), depth*2, "",
3083                     SvPVX_const(prop),
3084                     (PL_regkind[OP(scan)] == END || !rnext) ? 
3085                         0 : (IV)(rnext - rexi->program));
3086         });
3087
3088         next = scan + NEXT_OFF(scan);
3089         if (next == scan)
3090             next = NULL;
3091         state_num = OP(scan);
3092
3093       reenter_switch:
3094
3095         assert(PL_reglastparen == &rex->lastparen);
3096         assert(PL_reglastcloseparen == &rex->lastcloseparen);
3097         assert(PL_regoffs == rex->offs);
3098
3099         switch (state_num) {
3100         case BOL:
3101             if (locinput == PL_bostr)
3102             {
3103                 /* reginfo->till = reginfo->bol; */
3104                 break;
3105             }
3106             sayNO;
3107         case MBOL:
3108             if (locinput == PL_bostr ||
3109                 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
3110             {
3111                 break;
3112             }
3113             sayNO;
3114         case SBOL:
3115             if (locinput == PL_bostr)
3116                 break;
3117             sayNO;
3118         case GPOS:
3119             if (locinput == reginfo->ganch)
3120                 break;
3121             sayNO;
3122
3123         case KEEPS:
3124             /* update the startpoint */
3125             st->u.keeper.val = PL_regoffs[0].start;
3126             PL_reginput = locinput;
3127             PL_regoffs[0].start = locinput - PL_bostr;
3128             PUSH_STATE_GOTO(KEEPS_next, next);
3129             /*NOT-REACHED*/
3130         case KEEPS_next_fail:
3131             /* rollback the start point change */
3132             PL_regoffs[0].start = st->u.keeper.val;
3133             sayNO_SILENT;
3134             /*NOT-REACHED*/
3135         case EOL:
3136                 goto seol;
3137         case MEOL:
3138             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3139                 sayNO;
3140             break;
3141         case SEOL:
3142           seol:
3143             if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3144                 sayNO;
3145             if (PL_regeol - locinput > 1)
3146                 sayNO;
3147             break;
3148         case EOS:
3149             if (PL_regeol != locinput)
3150                 sayNO;
3151             break;
3152         case SANY:
3153             if (!nextchr && locinput >= PL_regeol)
3154                 sayNO;
3155             if (utf8_target) {
3156                 locinput += PL_utf8skip[nextchr];
3157                 if (locinput > PL_regeol)
3158                     sayNO;
3159                 nextchr = UCHARAT(locinput);
3160             }
3161             else
3162                 nextchr = UCHARAT(++locinput);
3163             break;
3164         case CANY:
3165             if (!nextchr && locinput >= PL_regeol)
3166                 sayNO;
3167             nextchr = UCHARAT(++locinput);
3168             break;
3169         case REG_ANY:
3170             if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
3171                 sayNO;
3172             if (utf8_target) {
3173                 locinput += PL_utf8skip[nextchr];
3174                 if (locinput > PL_regeol)
3175                     sayNO;
3176                 nextchr = UCHARAT(locinput);
3177             }
3178             else
3179                 nextchr = UCHARAT(++locinput);
3180             break;
3181
3182 #undef  ST
3183 #define ST st->u.trie
3184         case TRIEC:
3185             /* In this case the charclass data is available inline so
3186                we can fail fast without a lot of extra overhead. 
3187              */
3188             if (scan->flags == EXACT || !utf8_target) {
3189                 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3190                     DEBUG_EXECUTE_r(
3191                         PerlIO_printf(Perl_debug_log,
3192                                   "%*s  %sfailed to match trie start class...%s\n",
3193                                   REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3194                     );
3195                     sayNO_SILENT;
3196                     /* NOTREACHED */
3197                 }                       
3198             }
3199             /* FALL THROUGH */
3200         case TRIE:
3201             /* the basic plan of execution of the trie is:
3202              * At the beginning, run though all the states, and
3203              * find the longest-matching word. Also remember the position
3204              * of the shortest matching word. For example, this pattern:
3205              *    1  2 3 4    5
3206              *    ab|a|x|abcd|abc
3207              * when matched against the string "abcde", will generate
3208              * accept states for all words except 3, with the longest
3209              * matching word being 4, and the shortest being 1 (with
3210              * the position being after char 1 of the string).
3211              *
3212              * Then for each matching word, in word order (i.e. 1,2,4,5),
3213              * we run the remainder of the pattern; on each try setting
3214              * the current position to the character following the word,
3215              * returning to try the next word on failure.
3216              *
3217              * We avoid having to build a list of words at runtime by
3218              * using a compile-time structure, wordinfo[].prev, which
3219              * gives, for each word, the previous accepting word (if any).
3220              * In the case above it would contain the mappings 1->2, 2->0,
3221              * 3->0, 4->5, 5->1.  We can use this table to generate, from
3222              * the longest word (4 above), a list of all words, by
3223              * following the list of prev pointers; this gives us the
3224              * unordered list 4,5,1,2. Then given the current word we have
3225              * just tried, we can go through the list and find the
3226              * next-biggest word to try (so if we just failed on word 2,
3227              * the next in the list is 4).
3228              *
3229              * Since at runtime we don't record the matching position in
3230              * the string for each word, we have to work that out for
3231              * each word we're about to process. The wordinfo table holds
3232              * the character length of each word; given that we recorded
3233              * at the start: the position of the shortest word and its
3234              * length in chars, we just need to move the pointer the
3235              * difference between the two char lengths. Depending on
3236              * Unicode status and folding, that's cheap or expensive.
3237              *
3238              * This algorithm is optimised for the case where are only a
3239              * small number of accept states, i.e. 0,1, or maybe 2.
3240              * With lots of accepts states, and having to try all of them,
3241              * it becomes quadratic on number of accept states to find all
3242              * the next words.
3243              */
3244
3245             {
3246                 /* what type of TRIE am I? (utf8 makes this contextual) */
3247                 DECL_TRIE_TYPE(scan);
3248
3249                 /* what trie are we using right now */
3250                 reg_trie_data * const trie
3251                     = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3252                 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3253                 U32 state = trie->startstate;
3254
3255                 if (trie->bitmap && trie_type != trie_utf8_fold &&
3256                     !TRIE_BITMAP_TEST(trie,*locinput)
3257                 ) {
3258                     if (trie->states[ state ].wordnum) {
3259                          DEBUG_EXECUTE_r(
3260                             PerlIO_printf(Perl_debug_log,
3261                                           "%*s  %smatched empty string...%s\n",
3262                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3263                         );
3264                         if (!trie->jump)
3265                             break;
3266                     } else {
3267                         DEBUG_EXECUTE_r(
3268                             PerlIO_printf(Perl_debug_log,
3269                                           "%*s  %sfailed to match trie start class...%s\n",
3270                                           REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3271                         );
3272                         sayNO_SILENT;
3273                    }
3274                 }
3275
3276             { 
3277                 U8 *uc = ( U8* )locinput;
3278
3279                 STRLEN len = 0;
3280                 STRLEN foldlen = 0;
3281                 U8 *uscan = (U8*)NULL;
3282                 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3283                 U32 charcount = 0; /* how many input chars we have matched */
3284                 U32 accepted = 0; /* have we seen any accepting states? */
3285
3286                 ST.B = next;
3287                 ST.jump = trie->jump;
3288                 ST.me = scan;
3289                 ST.firstpos = NULL;
3290                 ST.longfold = FALSE; /* char longer if folded => it's harder */
3291                 ST.nextword = 0;
3292
3293                 /* fully traverse the TRIE; note the position of the
3294                    shortest accept state and the wordnum of the longest
3295                    accept state */
3296
3297                 while ( state && uc <= (U8*)PL_regeol ) {
3298                     U32 base = trie->states[ state ].trans.base;
3299                     UV uvc = 0;
3300                     U16 charid = 0;
3301                     U16 wordnum;
3302                     wordnum = trie->states[ state ].wordnum;
3303
3304                     if (wordnum) { /* it's an accept state */
3305                         if (!accepted) {
3306                             accepted = 1;
3307                             /* record first match position */
3308                             if (ST.longfold) {
3309                                 ST.firstpos = (U8*)locinput;
3310                                 ST.firstchars = 0;
3311                             }
3312                             else {
3313                                 ST.firstpos = uc;
3314                                 ST.firstchars = charcount;
3315                             }
3316                         }
3317                         if (!ST.nextword || wordnum < ST.nextword)
3318                             ST.nextword = wordnum;
3319                         ST.topword = wordnum;
3320                     }
3321
3322                     DEBUG_TRIE_EXECUTE_r({
3323                                 DUMP_EXEC_POS( (char *)uc, scan, utf8_target );
3324                                 PerlIO_printf( Perl_debug_log,
3325                                     "%*s  %sState: %4"UVxf" Accepted: %c ",
3326                                     2+depth * 2, "", PL_colors[4],
3327                                     (UV)state, (accepted ? 'Y' : 'N'));
3328                     });
3329
3330                     /* read a char and goto next state */
3331                     if ( base ) {
3332                         I32 offset;
3333                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3334                                              uscan, len, uvc, charid, foldlen,
3335                                              foldbuf, uniflags);
3336                         charcount++;
3337                         if (foldlen>0)
3338                             ST.longfold = TRUE;
3339                         if (charid &&
3340                              ( ((offset =
3341                               base + charid - 1 - trie->uniquecharcount)) >= 0)
3342
3343                              && ((U32)offset < trie->lasttrans)
3344                              && trie->trans[offset].check == state)
3345                         {
3346                             state = trie->trans[offset].next;
3347                         }
3348                         else {
3349                             state = 0;
3350                         }
3351                         uc += len;
3352
3353                     }
3354                     else {
3355                         state = 0;
3356                     }
3357                     DEBUG_TRIE_EXECUTE_r(
3358                         PerlIO_printf( Perl_debug_log,
3359                             "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3360                             charid, uvc, (UV)state, PL_colors[5] );
3361                     );
3362                 }
3363                 if (!accepted)
3364                    sayNO;
3365
3366                 /* calculate total number of accept states */
3367                 {
3368                     U16 w = ST.topword;
3369                     accepted = 0;
3370                     while (w) {
3371                         w = trie->wordinfo[w].prev;
3372                         accepted++;
3373                     }
3374                     ST.accepted = accepted;
3375                 }
3376
3377                 DEBUG_EXECUTE_r(
3378                     PerlIO_printf( Perl_debug_log,
3379                         "%*s  %sgot %"IVdf" possible matches%s\n",
3380                         REPORT_CODE_OFF + depth * 2, "",
3381                         PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3382                 );
3383                 goto trie_first_try; /* jump into the fail handler */
3384             }}
3385             /* NOTREACHED */
3386
3387         case TRIE_next_fail: /* we failed - try next alternative */
3388             if ( ST.jump) {
3389                 REGCP_UNWIND(ST.cp);
3390                 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3391                     PL_regoffs[n].end = -1;
3392                 *PL_reglastparen = n;
3393             }
3394             if (!--ST.accepted) {
3395                 DEBUG_EXECUTE_r({
3396                     PerlIO_printf( Perl_debug_log,
3397                         "%*s  %sTRIE failed...%s\n",
3398                         REPORT_CODE_OFF+depth*2, "", 
3399                         PL_colors[4],
3400                         PL_colors[5] );
3401                 });
3402                 sayNO_SILENT;
3403             }
3404             {
3405                 /* Find next-highest word to process.  Note that this code
3406                  * is O(N^2) per trie run (O(N) per branch), so keep tight */
3407                 register U16 min = 0;
3408                 register U16 word;
3409                 register U16 const nextword = ST.nextword;
3410                 register reg_trie_wordinfo * const wordinfo
3411                     = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo;
3412                 for (word=ST.topword; word; word=wordinfo[word].prev) {
3413                     if (word > nextword && (!min || word < min))
3414                         min = word;
3415                 }
3416                 ST.nextword = min;
3417             }
3418
3419           trie_first_try:
3420             if (do_cutgroup) {
3421                 do_cutgroup = 0;
3422                 no_final = 0;
3423             }
3424
3425             if ( ST.jump) {
3426                 ST.lastparen = *PL_reglastparen;
3427                 REGCP_SET(ST.cp);
3428             }
3429
3430             /* find start char of end of current word */
3431             {
3432                 U32 chars; /* how many chars to skip */
3433                 U8 *uc = ST.firstpos;
3434                 reg_trie_data * const trie
3435                     = (reg_trie_data*)rexi->data->data[ARG(ST.me)];
3436
3437                 assert((trie->wordinfo[ST.nextword].len - trie->prefixlen)
3438                             >=  ST.firstchars);
3439                 chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen)
3440                             - ST.firstchars;
3441
3442                 if (ST.longfold) {
3443                     /* the hard option - fold each char in turn and find
3444                      * its folded length (which may be different */
3445                     U8 foldbuf[UTF8_MAXBYTES_CASE + 1];
3446                     STRLEN foldlen;
3447                     STRLEN len;
3448                     UV uvc;
3449                     U8 *uscan;
3450
3451                     while (chars) {
3452                         if (utf8_target) {
3453                             uvc = utf8n_to_uvuni((U8*)uc, UTF8_MAXLEN, &len,
3454                                                     uniflags);
3455                             uc += len;
3456                         }
3457                         else {
3458                             uvc = *uc;
3459                             uc++;
3460                         }
3461                         uvc = to_uni_fold(uvc, foldbuf, &foldlen);
3462                         uscan = foldbuf;
3463                         while (foldlen) {
3464                             if (!--chars)
3465                                 break;
3466                             uvc = utf8n_to_uvuni(uscan, UTF8_MAXLEN, &len,
3467                                             uniflags);
3468                             uscan += len;
3469                             foldlen -= len;
3470                         }
3471                     }
3472                 }
3473                 else {
3474                     if (utf8_target)
3475                         while (chars--)
3476                             uc += UTF8SKIP(uc);
3477                     else
3478                         uc += chars;
3479                 }
3480                 PL_reginput = (char *)uc;
3481             }
3482
3483             scan = (ST.jump && ST.jump[ST.nextword]) 
3484                         ? ST.me + ST.jump[ST.nextword]
3485                         : ST.B;
3486
3487             DEBUG_EXECUTE_r({
3488                 PerlIO_printf( Perl_debug_log,
3489                     "%*s  %sTRIE matched word #%d, continuing%s\n",
3490                     REPORT_CODE_OFF+depth*2, "", 
3491                     PL_colors[4],
3492                     ST.nextword,
3493                     PL_colors[5]
3494                     );
3495             });
3496
3497             if (ST.accepted > 1 || has_cutgroup) {
3498                 PUSH_STATE_GOTO(TRIE_next, scan);
3499                 /* NOTREACHED */
3500             }
3501             /* only one choice left - just continue */
3502             DEBUG_EXECUTE_r({
3503                 AV *const trie_words
3504                     = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3505                 SV ** const tmp = av_fetch( trie_words,
3506                     ST.nextword-1, 0 );
3507                 SV *sv= tmp ? sv_newmortal() : NULL;
3508
3509                 PerlIO_printf( Perl_debug_log,
3510                     "%*s  %sonly one match left, short-circuiting: #%d <%s>%s\n",
3511                     REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3512                     ST.nextword,
3513                     tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3514                             PL_colors[0], PL_colors[1],
3515                             (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII
3516                         ) 
3517                     : "not compiled under -Dr",
3518                     PL_colors[5] );
3519             });
3520
3521             locinput = PL_reginput;
3522             nextchr = UCHARAT(locinput);
3523             continue; /* execute rest of RE */
3524             /* NOTREACHED */
3525 #undef  ST
3526
3527         case EXACT: {
3528             char *s = STRING(scan);
3529             ln = STR_LEN(scan);
3530             if (utf8_target != UTF_PATTERN) {
3531                 /* The target and the pattern have differing utf8ness. */
3532                 char *l = locinput;
3533                 const char * const e = s + ln;
3534
3535                 if (utf8_target) {
3536                     /* The target is utf8, the pattern is not utf8. */
3537                     while (s < e) {
3538                         STRLEN ulen;
3539                         if (l >= PL_regeol)
3540                              sayNO;
3541                         if (NATIVE_TO_UNI(*(U8*)s) !=
3542                             utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3543                                             uniflags))
3544                              sayNO;
3545                         l += ulen;
3546                         s ++;
3547                     }
3548                 }
3549                 else {
3550                     /* The target is not utf8, the pattern is utf8. */
3551                     while (s < e) {
3552                         STRLEN ulen;
3553                         if (l >= PL_regeol)
3554                             sayNO;
3555                         if (NATIVE_TO_UNI(*((U8*)l)) !=
3556                             utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3557                                            uniflags))
3558                             sayNO;
3559                         s += ulen;
3560                         l ++;
3561                     }
3562                 }
3563                 locinput = l;
3564                 nextchr = UCHARAT(locinput);
3565                 break;
3566             }
3567             /* The target and the pattern have the same utf8ness. */
3568             /* Inline the first character, for speed. */
3569             if (UCHARAT(s) != nextchr)
3570                 sayNO;
3571             if (PL_regeol - locinput < ln)
3572                 sayNO;
3573             if (ln > 1 && memNE(s, locinput, ln))
3574                 sayNO;
3575             locinput += ln;
3576             nextchr = UCHARAT(locinput);
3577             break;
3578             }
3579         case EXACTFL: {
3580             re_fold_t folder;
3581             const U8 * fold_array;
3582             const char * s;
3583
3584             PL_reg_flags |= RF_tainted;
3585             folder = foldEQ_locale;
3586             fold_array = PL_fold_locale;
3587             goto do_exactf;
3588
3589         case EXACTFU:
3590             folder = foldEQ_latin1;
3591             fold_array = PL_fold_latin1;
3592             goto do_exactf;
3593
3594         case EXACTF:
3595             folder = foldEQ;
3596             fold_array = PL_fold;
3597
3598           do_exactf:
3599             s = STRING(scan);
3600             ln = STR_LEN(scan);
3601
3602             if (utf8_target || UTF_PATTERN) {
3603               /* Either target or the pattern are utf8. */
3604                 const char * const l = locinput;
3605                 char *e = PL_regeol;
3606
3607                 if (! foldEQ_utf8(s, 0,  ln, cBOOL(UTF_PATTERN),
3608                                l, &e, 0,  utf8_target)) {
3609                      /* One more case for the sharp s:
3610                       * pack("U0U*", 0xDF) =~ /ss/i,
3611                       * the 0xC3 0x9F are the UTF-8
3612                       * byte sequence for the U+00DF. */
3613
3614                      if (!(utf8_target &&
3615                            toLOWER(s[0]) == 's' &&
3616                            ln >= 2 &&
3617                            toLOWER(s[1]) == 's' &&
3618                            (U8)l[0] == 0xC3 &&
3619                            e - l >= 2 &&
3620                            (U8)l[1] == 0x9F))
3621                           sayNO;
3622                 }
3623                 locinput = e;
3624                 nextchr = UCHARAT(locinput);
3625                 break;
3626             }
3627
3628             /* Neither the target and the pattern are utf8. */
3629
3630             /* Inline the first character, for speed. */
3631             if (UCHARAT(s) != nextchr &&
3632                 UCHARAT(s) != fold_array[nextchr])
3633             {
3634                 sayNO;
3635             }
3636             if (PL_regeol - locinput < ln)
3637                 sayNO;
3638             if (ln > 1 && ! folder(s, locinput, ln))
3639                 sayNO;
3640             locinput += ln;
3641             nextchr = UCHARAT(locinput);
3642             break;
3643         }
3644         case BOUNDL:
3645         case NBOUNDL:
3646             PL_reg_flags |= RF_tainted;
3647             /* FALL THROUGH */
3648         case BOUND:
3649         case NBOUND:
3650             /* was last char in word? */
3651             if (utf8_target) {
3652                 if (locinput == PL_bostr)
3653                     ln = '\n';
3654                 else {
3655                     const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3656
3657                     ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3658                 }
3659                 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3660                     ln = isALNUM_uni(ln);
3661                     LOAD_UTF8_CHARCLASS_ALNUM();
3662                     n = swash_fetch(PL_utf8_alnum, (U8*)locinput, utf8_target);
3663                 }
3664                 else {
3665                     ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3666                     n = isALNUM_LC_utf8((U8*)locinput);
3667                 }
3668             }
3669             else {
3670                 ln = (locinput != PL_bostr) ?
3671                     UCHARAT(locinput - 1) : '\n';
3672                 if (FLAGS(scan) == REGEX_UNICODE_CHARSET) {
3673
3674                     /* Here, can't be BOUNDL or NBOUNDL because they never set
3675                      * the flags to REGEX_UNICODE_CHARSET */
3676                     ln = isWORDCHAR_L1(ln);
3677                     n = isWORDCHAR_L1(nextchr);
3678                 }
3679                 else if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3680                     ln = isALNUM(ln);
3681                     n = isALNUM(nextchr);
3682                 }
3683                 else {
3684                     ln = isALNUM_LC(ln);
3685                     n = isALNUM_LC(nextchr);
3686                 }
3687             }
3688             if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3689                                     OP(scan) == BOUNDL))
3690                     sayNO;
3691             break;
3692         case ANYOFV:
3693         case ANYOF:
3694             if (utf8_target || state_num == ANYOFV) {
3695                 STRLEN inclasslen = PL_regeol - locinput;
3696                 if (locinput >= PL_regeol)
3697                     sayNO;
3698
3699                 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, utf8_target))
3700                     sayNO;
3701                 locinput += inclasslen;
3702                 nextchr = UCHARAT(locinput);
3703                 break;
3704             }
3705             else {
3706                 if (nextchr < 0)
3707                     nextchr = UCHARAT(locinput);
3708                 if (!nextchr && locinput >= PL_regeol)
3709                     sayNO;
3710                 if (!REGINCLASS(rex, scan, (U8*)locinput))
3711                     sayNO;
3712                 nextchr = UCHARAT(++locinput);
3713                 break;
3714             }
3715             break;
3716         /* Special char classes - The defines start on line 129 or so */
3717         CCC_TRY_U(ALNUM,  NALNUM,  isWORDCHAR,
3718                   ALNUML, NALNUML, isALNUM_LC, isALNUM_LC_utf8,
3719                   ALNUMU, NALNUMU, isWORDCHAR_L1,
3720                   perl_word, "a");
3721
3722         CCC_TRY_U(SPACE,  NSPACE,  isSPACE,
3723                   SPACEL, NSPACEL, isSPACE_LC, isSPACE_LC_utf8,
3724                   SPACEU, NSPACEU, isSPACE_L1,
3725                   perl_space, " ");
3726
3727         CCC_TRY(DIGIT,  NDIGIT,  isDIGIT,
3728                 DIGITL, NDIGITL, isDIGIT_LC, isDIGIT_LC_utf8,
3729                 posix_digit, "0");
3730
3731         case CLUMP: /* Match \X: logical Unicode character.  This is defined as
3732                        a Unicode extended Grapheme Cluster */
3733             /* From http://www.unicode.org/reports/tr29 (5.2 version).  An
3734               extended Grapheme Cluster is:
3735
3736                CR LF
3737                | Prepend* Begin Extend*
3738                | .
3739
3740                Begin is (Hangul-syllable | ! Control)
3741                Extend is (Grapheme_Extend | Spacing_Mark)
3742                Control is [ GCB_Control CR LF ]
3743
3744                The discussion below shows how the code for CLUMP is derived
3745                from this regex.  Note that most of these concepts are from
3746                property values of the Grapheme Cluster Boundary (GCB) property.
3747                No code point can have multiple property values for a given
3748                property.  Thus a code point in Prepend can't be in Control, but
3749                it must be in !Control.  This is why Control above includes
3750                GCB_Control plus CR plus LF.  The latter two are used in the GCB
3751                property separately, and so can't be in GCB_Control, even though
3752                they logically are controls.  Control is not the same as gc=cc,
3753                but includes format and other characters as well.
3754
3755                The Unicode definition of Hangul-syllable is:
3756                    L+
3757                    | (L* ( ( V | LV ) V* | LVT ) T*)
3758                    | T+ 
3759                   )
3760                Each of these is a value for the GCB property, and hence must be
3761                disjoint, so the order they are tested is immaterial, so the
3762                above can safely be changed to
3763                    T+
3764                    | L+
3765                    | (L* ( LVT | ( V | LV ) V*) T*)
3766
3767                The last two terms can be combined like this:
3768                    L* ( L
3769                         | (( LVT | ( V | LV ) V*) T*))
3770
3771                And refactored into this:
3772                    L* (L | LVT T* | V  V* T* | LV  V* T*)
3773
3774                That means that if we have seen any L's at all we can quit
3775                there, but if the next character is a LVT, a V or and LV we
3776                should keep going.
3777
3778                There is a subtlety with Prepend* which showed up in testing.
3779                Note that the Begin, and only the Begin is required in:
3780                 | Prepend* Begin Extend*
3781                Also, Begin contains '! Control'.  A Prepend must be a '!
3782                Control', which means it must be a Begin.  What it comes down to
3783                is that if we match Prepend* and then find no suitable Begin
3784                afterwards, that if we backtrack the last Prepend, that one will
3785                be a suitable Begin.
3786             */
3787
3788             if (locinput >= PL_regeol)
3789                 sayNO;
3790             if  (! utf8_target) {
3791
3792                 /* Match either CR LF  or '.', as all the other possibilities
3793                  * require utf8 */
3794                 locinput++;         /* Match the . or CR */
3795                 if (nextchr == '\r'
3796                     && locinput < PL_regeol
3797                     && UCHARAT(locinput) == '\n') locinput++;
3798             }
3799             else {
3800
3801                 /* Utf8: See if is ( CR LF ); already know that locinput <
3802                  * PL_regeol, so locinput+1 is in bounds */
3803                 if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
3804                     locinput += 2;
3805                 }
3806                 else {
3807                     /* In case have to backtrack to beginning, then match '.' */
3808                     char *starting = locinput;
3809
3810                     /* In case have to backtrack the last prepend */
3811                     char *previous_prepend = 0;
3812
3813                     LOAD_UTF8_CHARCLASS_GCB();
3814
3815                     /* Match (prepend)* */
3816                     while (locinput < PL_regeol
3817                            && swash_fetch(PL_utf8_X_prepend,
3818                                           (U8*)locinput, utf8_target))
3819                     {
3820                         previous_prepend = locinput;
3821                         locinput += UTF8SKIP(locinput);
3822                     }
3823
3824                     /* As noted above, if we matched a prepend character, but
3825                      * the next thing won't match, back off the last prepend we
3826                      * matched, as it is guaranteed to match the begin */
3827                     if (previous_prepend
3828                         && (locinput >=  PL_regeol
3829                             || ! swash_fetch(PL_utf8_X_begin,
3830                                              (U8*)locinput, utf8_target)))
3831                     {
3832                         locinput = previous_prepend;
3833                     }
3834
3835                     /* Note that here we know PL_regeol > locinput, as we
3836                      * tested that upon input to this switch case, and if we
3837                      * moved locinput forward, we tested the result just above
3838                      * and it either passed, or we backed off so that it will
3839                      * now pass */
3840                     if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, utf8_target)) {
3841
3842                         /* Here did not match the required 'Begin' in the
3843                          * second term.  So just match the very first
3844                          * character, the '.' of the final term of the regex */
3845                         locinput = starting + UTF8SKIP(starting);
3846                     } else {
3847
3848                         /* Here is the beginning of a character that can have
3849                          * an extender.  It is either a hangul syllable, or a
3850                          * non-control */
3851                         if (swash_fetch(PL_utf8_X_non_hangul,
3852                                         (U8*)locinput, utf8_target))
3853                         {
3854
3855                             /* Here not a Hangul syllable, must be a
3856                              * ('!  * Control') */
3857                             locinput += UTF8SKIP(locinput);
3858                         } else {
3859
3860                             /* Here is a Hangul syllable.  It can be composed
3861                              * of several individual characters.  One
3862                              * possibility is T+ */