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