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