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