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