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