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