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