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