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