This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
cc09994d119e36fcab906af3e8b9655ee5a81b50
[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->extflags & RXf_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->extflags & RXf_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->extflags & RXf_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 (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK)) 
2577     {
2578         /* For anchored \G, the only position it can match from is
2579          * (ganch-gofs); we already set startpos to this above; if intuit
2580          * moved us on from there, we can't possibly succeed */
2581         assert(startpos == reginfo->ganch - prog->gofs);
2582         if (s == startpos && regtry(reginfo, &s))
2583             goto got_it;
2584         goto phooey;
2585     }
2586
2587     /* Messy cases:  unanchored match. */
2588     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2589         /* we have /x+whatever/ */
2590         /* it must be a one character string (XXXX Except is_utf8_pat?) */
2591         char ch;
2592 #ifdef DEBUGGING
2593         int did_match = 0;
2594 #endif
2595         if (utf8_target) {
2596             if (! prog->anchored_utf8) {
2597                 to_utf8_substr(prog);
2598             }
2599             ch = SvPVX_const(prog->anchored_utf8)[0];
2600             REXEC_FBC_SCAN(
2601                 if (*s == ch) {
2602                     DEBUG_EXECUTE_r( did_match = 1 );
2603                     if (regtry(reginfo, &s)) goto got_it;
2604                     s += UTF8SKIP(s);
2605                     while (s < strend && *s == ch)
2606                         s += UTF8SKIP(s);
2607                 }
2608             );
2609
2610         }
2611         else {
2612             if (! prog->anchored_substr) {
2613                 if (! to_byte_substr(prog)) {
2614                     NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2615                 }
2616             }
2617             ch = SvPVX_const(prog->anchored_substr)[0];
2618             REXEC_FBC_SCAN(
2619                 if (*s == ch) {
2620                     DEBUG_EXECUTE_r( did_match = 1 );
2621                     if (regtry(reginfo, &s)) goto got_it;
2622                     s++;
2623                     while (s < strend && *s == ch)
2624                         s++;
2625                 }
2626             );
2627         }
2628         DEBUG_EXECUTE_r(if (!did_match)
2629                 PerlIO_printf(Perl_debug_log,
2630                                   "Did not find anchored character...\n")
2631                );
2632     }
2633     else if (prog->anchored_substr != NULL
2634               || prog->anchored_utf8 != NULL
2635               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2636                   && prog->float_max_offset < strend - s)) {
2637         SV *must;
2638         SSize_t back_max;
2639         SSize_t back_min;
2640         char *last;
2641         char *last1;            /* Last position checked before */
2642 #ifdef DEBUGGING
2643         int did_match = 0;
2644 #endif
2645         if (prog->anchored_substr || prog->anchored_utf8) {
2646             if (utf8_target) {
2647                 if (! prog->anchored_utf8) {
2648                     to_utf8_substr(prog);
2649                 }
2650                 must = prog->anchored_utf8;
2651             }
2652             else {
2653                 if (! prog->anchored_substr) {
2654                     if (! to_byte_substr(prog)) {
2655                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2656                     }
2657                 }
2658                 must = prog->anchored_substr;
2659             }
2660             back_max = back_min = prog->anchored_offset;
2661         } else {
2662             if (utf8_target) {
2663                 if (! prog->float_utf8) {
2664                     to_utf8_substr(prog);
2665                 }
2666                 must = prog->float_utf8;
2667             }
2668             else {
2669                 if (! prog->float_substr) {
2670                     if (! to_byte_substr(prog)) {
2671                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2672                     }
2673                 }
2674                 must = prog->float_substr;
2675             }
2676             back_max = prog->float_max_offset;
2677             back_min = prog->float_min_offset;
2678         }
2679             
2680         if (back_min<0) {
2681             last = strend;
2682         } else {
2683             last = HOP3c(strend,        /* Cannot start after this */
2684                   -(SSize_t)(CHR_SVLEN(must)
2685                          - (SvTAIL(must) != 0) + back_min), strbeg);
2686         }
2687         if (s > reginfo->strbeg)
2688             last1 = HOPc(s, -1);
2689         else
2690             last1 = s - 1;      /* bogus */
2691
2692         /* XXXX check_substr already used to find "s", can optimize if
2693            check_substr==must. */
2694         dontbother = 0;
2695         strend = HOPc(strend, -dontbother);
2696         while ( (s <= last) &&
2697                 (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2698                                   (unsigned char*)strend, must,
2699                                   multiline ? FBMrf_MULTILINE : 0)) ) {
2700             DEBUG_EXECUTE_r( did_match = 1 );
2701             if (HOPc(s, -back_max) > last1) {
2702                 last1 = HOPc(s, -back_min);
2703                 s = HOPc(s, -back_max);
2704             }
2705             else {
2706                 char * const t = (last1 >= reginfo->strbeg)
2707                                     ? HOPc(last1, 1) : last1 + 1;
2708
2709                 last1 = HOPc(s, -back_min);
2710                 s = t;
2711             }
2712             if (utf8_target) {
2713                 while (s <= last1) {
2714                     if (regtry(reginfo, &s))
2715                         goto got_it;
2716                     if (s >= last1) {
2717                         s++; /* to break out of outer loop */
2718                         break;
2719                     }
2720                     s += UTF8SKIP(s);
2721                 }
2722             }
2723             else {
2724                 while (s <= last1) {
2725                     if (regtry(reginfo, &s))
2726                         goto got_it;
2727                     s++;
2728                 }
2729             }
2730         }
2731         DEBUG_EXECUTE_r(if (!did_match) {
2732             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
2733                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2734             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2735                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2736                                ? "anchored" : "floating"),
2737                 quoted, RE_SV_TAIL(must));
2738         });                 
2739         goto phooey;
2740     }
2741     else if ( (c = progi->regstclass) ) {
2742         if (minlen) {
2743             const OPCODE op = OP(progi->regstclass);
2744             /* don't bother with what can't match */
2745             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2746                 strend = HOPc(strend, -(minlen - 1));
2747         }
2748         DEBUG_EXECUTE_r({
2749             SV * const prop = sv_newmortal();
2750             regprop(prog, prop, c);
2751             {
2752                 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
2753                     s,strend-s,60);
2754                 PerlIO_printf(Perl_debug_log,
2755                     "Matching stclass %.*s against %s (%d bytes)\n",
2756                     (int)SvCUR(prop), SvPVX_const(prop),
2757                      quoted, (int)(strend - s));
2758             }
2759         });
2760         if (find_byclass(prog, c, s, strend, reginfo))
2761             goto got_it;
2762         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2763     }
2764     else {
2765         dontbother = 0;
2766         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2767             /* Trim the end. */
2768             char *last= NULL;
2769             SV* float_real;
2770             STRLEN len;
2771             const char *little;
2772
2773             if (utf8_target) {
2774                 if (! prog->float_utf8) {
2775                     to_utf8_substr(prog);
2776                 }
2777                 float_real = prog->float_utf8;
2778             }
2779             else {
2780                 if (! prog->float_substr) {
2781                     if (! to_byte_substr(prog)) {
2782                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2783                     }
2784                 }
2785                 float_real = prog->float_substr;
2786             }
2787
2788             little = SvPV_const(float_real, len);
2789             if (SvTAIL(float_real)) {
2790                     /* This means that float_real contains an artificial \n on
2791                      * the end due to the presence of something like this:
2792                      * /foo$/ where we can match both "foo" and "foo\n" at the
2793                      * end of the string.  So we have to compare the end of the
2794                      * string first against the float_real without the \n and
2795                      * then against the full float_real with the string.  We
2796                      * have to watch out for cases where the string might be
2797                      * smaller than the float_real or the float_real without
2798                      * the \n. */
2799                     char *checkpos= strend - len;
2800                     DEBUG_OPTIMISE_r(
2801                         PerlIO_printf(Perl_debug_log,
2802                             "%sChecking for float_real.%s\n",
2803                             PL_colors[4], PL_colors[5]));
2804                     if (checkpos + 1 < strbeg) {
2805                         /* can't match, even if we remove the trailing \n
2806                          * string is too short to match */
2807                         DEBUG_EXECUTE_r(
2808                             PerlIO_printf(Perl_debug_log,
2809                                 "%sString shorter than required trailing substring, cannot match.%s\n",
2810                                 PL_colors[4], PL_colors[5]));
2811                         goto phooey;
2812                     } else if (memEQ(checkpos + 1, little, len - 1)) {
2813                         /* can match, the end of the string matches without the
2814                          * "\n" */
2815                         last = checkpos + 1;
2816                     } else if (checkpos < strbeg) {
2817                         /* cant match, string is too short when the "\n" is
2818                          * included */
2819                         DEBUG_EXECUTE_r(
2820                             PerlIO_printf(Perl_debug_log,
2821                                 "%sString does not contain required trailing substring, cannot match.%s\n",
2822                                 PL_colors[4], PL_colors[5]));
2823                         goto phooey;
2824                     } else if (!multiline) {
2825                         /* non multiline match, so compare with the "\n" at the
2826                          * end of the string */
2827                         if (memEQ(checkpos, little, len)) {
2828                             last= checkpos;
2829                         } else {
2830                             DEBUG_EXECUTE_r(
2831                                 PerlIO_printf(Perl_debug_log,
2832                                     "%sString does not contain required trailing substring, cannot match.%s\n",
2833                                     PL_colors[4], PL_colors[5]));
2834                             goto phooey;
2835                         }
2836                     } else {
2837                         /* multiline match, so we have to search for a place
2838                          * where the full string is located */
2839                         goto find_last;
2840                     }
2841             } else {
2842                   find_last:
2843                     if (len)
2844                         last = rninstr(s, strend, little, little + len);
2845                     else
2846                         last = strend;  /* matching "$" */
2847             }
2848             if (!last) {
2849                 /* at one point this block contained a comment which was
2850                  * probably incorrect, which said that this was a "should not
2851                  * happen" case.  Even if it was true when it was written I am
2852                  * pretty sure it is not anymore, so I have removed the comment
2853                  * and replaced it with this one. Yves */
2854                 DEBUG_EXECUTE_r(
2855                     PerlIO_printf(Perl_debug_log,
2856                         "String does not contain required substring, cannot match.\n"
2857                     ));
2858                 goto phooey;
2859             }
2860             dontbother = strend - last + prog->float_min_offset;
2861         }
2862         if (minlen && (dontbother < minlen))
2863             dontbother = minlen - 1;
2864         strend -= dontbother;              /* this one's always in bytes! */
2865         /* We don't know much -- general case. */
2866         if (utf8_target) {
2867             for (;;) {
2868                 if (regtry(reginfo, &s))
2869                     goto got_it;
2870                 if (s >= strend)
2871                     break;
2872                 s += UTF8SKIP(s);
2873             };
2874         }
2875         else {
2876             do {
2877                 if (regtry(reginfo, &s))
2878                     goto got_it;
2879             } while (s++ < strend);
2880         }
2881     }
2882
2883     /* Failure. */
2884     goto phooey;
2885
2886 got_it:
2887     /* s/// doesn't like it if $& is earlier than where we asked it to
2888      * start searching (which can happen on something like /.\G/) */
2889     if (       (flags & REXEC_FAIL_ON_UNDERFLOW)
2890             && (prog->offs[0].start < stringarg - strbeg))
2891     {
2892         /* this should only be possible under \G */
2893         assert(prog->extflags & RXf_GPOS_SEEN);
2894         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2895             "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
2896         goto phooey;
2897     }
2898
2899     DEBUG_BUFFERS_r(
2900         if (swap)
2901             PerlIO_printf(Perl_debug_log,
2902                 "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
2903                 PTR2UV(prog),
2904                 PTR2UV(swap)
2905             );
2906     );
2907     Safefree(swap);
2908
2909     /* clean up; this will trigger destructors that will free all slabs
2910      * above the current one, and cleanup the regmatch_info_aux
2911      * and regmatch_info_aux_eval sructs */
2912
2913     LEAVE_SCOPE(oldsave);
2914
2915     if (RXp_PAREN_NAMES(prog)) 
2916         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2917
2918     RX_MATCH_UTF8_set(rx, utf8_target);
2919
2920     /* make sure $`, $&, $', and $digit will work later */
2921     if ( !(flags & REXEC_NOT_FIRST) )
2922         S_reg_set_capture_string(aTHX_ rx,
2923                                     strbeg, reginfo->strend,
2924                                     sv, flags, utf8_target);
2925
2926     return 1;
2927
2928 phooey:
2929     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2930                           PL_colors[4], PL_colors[5]));
2931
2932     /* clean up; this will trigger destructors that will free all slabs
2933      * above the current one, and cleanup the regmatch_info_aux
2934      * and regmatch_info_aux_eval sructs */
2935
2936     LEAVE_SCOPE(oldsave);
2937
2938     if (swap) {
2939         /* we failed :-( roll it back */
2940         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
2941             "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
2942             PTR2UV(prog),
2943             PTR2UV(prog->offs),
2944             PTR2UV(swap)
2945         ));
2946         Safefree(prog->offs);
2947         prog->offs = swap;
2948     }
2949     return 0;
2950 }
2951
2952
2953 /* Set which rex is pointed to by PL_reg_curpm, handling ref counting.
2954  * Do inc before dec, in case old and new rex are the same */
2955 #define SET_reg_curpm(Re2)                          \
2956     if (reginfo->info_aux_eval) {                   \
2957         (void)ReREFCNT_inc(Re2);                    \
2958         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));       \
2959         PM_SETRE((PL_reg_curpm), (Re2));            \
2960     }
2961
2962
2963 /*
2964  - regtry - try match at specific point
2965  */
2966 STATIC I32                      /* 0 failure, 1 success */
2967 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
2968 {
2969     dVAR;
2970     CHECKPOINT lastcp;
2971     REGEXP *const rx = reginfo->prog;
2972     regexp *const prog = ReANY(rx);
2973     SSize_t result;
2974     RXi_GET_DECL(prog,progi);
2975     GET_RE_DEBUG_FLAGS_DECL;
2976
2977     PERL_ARGS_ASSERT_REGTRY;
2978
2979     reginfo->cutpoint=NULL;
2980
2981     prog->offs[0].start = *startposp - reginfo->strbeg;
2982     prog->lastparen = 0;
2983     prog->lastcloseparen = 0;
2984
2985     /* XXXX What this code is doing here?!!!  There should be no need
2986        to do this again and again, prog->lastparen should take care of
2987        this!  --ilya*/
2988
2989     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2990      * Actually, the code in regcppop() (which Ilya may be meaning by
2991      * prog->lastparen), is not needed at all by the test suite
2992      * (op/regexp, op/pat, op/split), but that code is needed otherwise
2993      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2994      * Meanwhile, this code *is* needed for the
2995      * above-mentioned test suite tests to succeed.  The common theme
2996      * on those tests seems to be returning null fields from matches.
2997      * --jhi updated by dapm */
2998 #if 1
2999     if (prog->nparens) {
3000         regexp_paren_pair *pp = prog->offs;
3001         I32 i;
3002         for (i = prog->nparens; i > (I32)prog->lastparen; i--) {
3003             ++pp;
3004             pp->start = -1;
3005             pp->end = -1;
3006         }
3007     }
3008 #endif
3009     REGCP_SET(lastcp);
3010     result = regmatch(reginfo, *startposp, progi->program + 1);
3011     if (result != -1) {
3012         prog->offs[0].end = result;
3013         return 1;
3014     }
3015     if (reginfo->cutpoint)
3016         *startposp= reginfo->cutpoint;
3017     REGCP_UNWIND(lastcp);
3018     return 0;
3019 }
3020
3021
3022 #define sayYES goto yes
3023 #define sayNO goto no
3024 #define sayNO_SILENT goto no_silent
3025
3026 /* we dont use STMT_START/END here because it leads to 
3027    "unreachable code" warnings, which are bogus, but distracting. */
3028 #define CACHEsayNO \
3029     if (ST.cache_mask) \
3030        reginfo->info_aux->poscache[ST.cache_offset] |= ST.cache_mask; \
3031     sayNO
3032
3033 /* this is used to determine how far from the left messages like
3034    'failed...' are printed. It should be set such that messages 
3035    are inline with the regop output that created them.
3036 */
3037 #define REPORT_CODE_OFF 32
3038
3039
3040 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
3041 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
3042 #define CHRTEST_NOT_A_CP_1 -999
3043 #define CHRTEST_NOT_A_CP_2 -998
3044
3045 /* grab a new slab and return the first slot in it */
3046
3047 STATIC regmatch_state *
3048 S_push_slab(pTHX)
3049 {
3050 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3051     dMY_CXT;
3052 #endif
3053     regmatch_slab *s = PL_regmatch_slab->next;
3054     if (!s) {
3055         Newx(s, 1, regmatch_slab);
3056         s->prev = PL_regmatch_slab;
3057         s->next = NULL;
3058         PL_regmatch_slab->next = s;
3059     }
3060     PL_regmatch_slab = s;
3061     return SLAB_FIRST(s);
3062 }
3063
3064
3065 /* push a new state then goto it */
3066
3067 #define PUSH_STATE_GOTO(state, node, input) \
3068     pushinput = input; \
3069     scan = node; \
3070     st->resume_state = state; \
3071     goto push_state;
3072
3073 /* push a new state with success backtracking, then goto it */
3074
3075 #define PUSH_YES_STATE_GOTO(state, node, input) \
3076     pushinput = input; \
3077     scan = node; \
3078     st->resume_state = state; \
3079     goto push_yes_state;
3080
3081
3082
3083
3084 /*
3085
3086 regmatch() - main matching routine
3087
3088 This is basically one big switch statement in a loop. We execute an op,
3089 set 'next' to point the next op, and continue. If we come to a point which
3090 we may need to backtrack to on failure such as (A|B|C), we push a
3091 backtrack state onto the backtrack stack. On failure, we pop the top
3092 state, and re-enter the loop at the state indicated. If there are no more
3093 states to pop, we return failure.
3094
3095 Sometimes we also need to backtrack on success; for example /A+/, where
3096 after successfully matching one A, we need to go back and try to
3097 match another one; similarly for lookahead assertions: if the assertion
3098 completes successfully, we backtrack to the state just before the assertion
3099 and then carry on.  In these cases, the pushed state is marked as
3100 'backtrack on success too'. This marking is in fact done by a chain of
3101 pointers, each pointing to the previous 'yes' state. On success, we pop to
3102 the nearest yes state, discarding any intermediate failure-only states.
3103 Sometimes a yes state is pushed just to force some cleanup code to be
3104 called at the end of a successful match or submatch; e.g. (??{$re}) uses
3105 it to free the inner regex.
3106
3107 Note that failure backtracking rewinds the cursor position, while
3108 success backtracking leaves it alone.
3109
3110 A pattern is complete when the END op is executed, while a subpattern
3111 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
3112 ops trigger the "pop to last yes state if any, otherwise return true"
3113 behaviour.
3114
3115 A common convention in this function is to use A and B to refer to the two
3116 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
3117 the subpattern to be matched possibly multiple times, while B is the entire
3118 rest of the pattern. Variable and state names reflect this convention.
3119
3120 The states in the main switch are the union of ops and failure/success of
3121 substates associated with with that op.  For example, IFMATCH is the op
3122 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
3123 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
3124 successfully matched A and IFMATCH_A_fail is a state saying that we have
3125 just failed to match A. Resume states always come in pairs. The backtrack
3126 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
3127 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
3128 on success or failure.
3129
3130 The struct that holds a backtracking state is actually a big union, with
3131 one variant for each major type of op. The variable st points to the
3132 top-most backtrack struct. To make the code clearer, within each
3133 block of code we #define ST to alias the relevant union.
3134
3135 Here's a concrete example of a (vastly oversimplified) IFMATCH
3136 implementation:
3137
3138     switch (state) {
3139     ....
3140
3141 #define ST st->u.ifmatch
3142
3143     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3144         ST.foo = ...; // some state we wish to save
3145         ...
3146         // push a yes backtrack state with a resume value of
3147         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
3148         // first node of A:
3149         PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput);
3150         // NOTREACHED
3151
3152     case IFMATCH_A: // we have successfully executed A; now continue with B
3153         next = B;
3154         bar = ST.foo; // do something with the preserved value
3155         break;
3156
3157     case IFMATCH_A_fail: // A failed, so the assertion failed
3158         ...;   // do some housekeeping, then ...
3159         sayNO; // propagate the failure
3160
3161 #undef ST
3162
3163     ...
3164     }
3165
3166 For any old-timers reading this who are familiar with the old recursive
3167 approach, the code above is equivalent to:
3168
3169     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3170     {
3171         int foo = ...
3172         ...
3173         if (regmatch(A)) {
3174             next = B;
3175             bar = foo;
3176             break;
3177         }
3178         ...;   // do some housekeeping, then ...
3179         sayNO; // propagate the failure
3180     }
3181
3182 The topmost backtrack state, pointed to by st, is usually free. If you
3183 want to claim it, populate any ST.foo fields in it with values you wish to
3184 save, then do one of
3185
3186         PUSH_STATE_GOTO(resume_state, node, newinput);
3187         PUSH_YES_STATE_GOTO(resume_state, node, newinput);
3188
3189 which sets that backtrack state's resume value to 'resume_state', pushes a
3190 new free entry to the top of the backtrack stack, then goes to 'node'.
3191 On backtracking, the free slot is popped, and the saved state becomes the
3192 new free state. An ST.foo field in this new top state can be temporarily
3193 accessed to retrieve values, but once the main loop is re-entered, it
3194 becomes available for reuse.
3195
3196 Note that the depth of the backtrack stack constantly increases during the
3197 left-to-right execution of the pattern, rather than going up and down with
3198 the pattern nesting. For example the stack is at its maximum at Z at the
3199 end of the pattern, rather than at X in the following:
3200
3201     /(((X)+)+)+....(Y)+....Z/
3202
3203 The only exceptions to this are lookahead/behind assertions and the cut,
3204 (?>A), which pop all the backtrack states associated with A before
3205 continuing.
3206  
3207 Backtrack state structs are allocated in slabs of about 4K in size.
3208 PL_regmatch_state and st always point to the currently active state,
3209 and PL_regmatch_slab points to the slab currently containing
3210 PL_regmatch_state.  The first time regmatch() is called, the first slab is
3211 allocated, and is never freed until interpreter destruction. When the slab
3212 is full, a new one is allocated and chained to the end. At exit from
3213 regmatch(), slabs allocated since entry are freed.
3214
3215 */
3216  
3217
3218 #define DEBUG_STATE_pp(pp)                                  \
3219     DEBUG_STATE_r({                                         \
3220         DUMP_EXEC_POS(locinput, scan, utf8_target);         \
3221         PerlIO_printf(Perl_debug_log,                       \
3222             "    %*s"pp" %s%s%s%s%s\n",                     \
3223             depth*2, "",                                    \
3224             PL_reg_name[st->resume_state],                  \
3225             ((st==yes_state||st==mark_state) ? "[" : ""),   \
3226             ((st==yes_state) ? "Y" : ""),                   \
3227             ((st==mark_state) ? "M" : ""),                  \
3228             ((st==yes_state||st==mark_state) ? "]" : "")    \
3229         );                                                  \
3230     });
3231
3232
3233 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
3234
3235 #ifdef DEBUGGING
3236
3237 STATIC void
3238 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
3239     const char *start, const char *end, const char *blurb)
3240 {
3241     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
3242
3243     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
3244
3245     if (!PL_colorset)   
3246             reginitcolors();    
3247     {
3248         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), 
3249             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);   
3250         
3251         RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
3252             start, end - start, 60); 
3253         
3254         PerlIO_printf(Perl_debug_log, 
3255             "%s%s REx%s %s against %s\n", 
3256                        PL_colors[4], blurb, PL_colors[5], s0, s1); 
3257         
3258         if (utf8_target||utf8_pat)
3259             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
3260                 utf8_pat ? "pattern" : "",
3261                 utf8_pat && utf8_target ? " and " : "",
3262                 utf8_target ? "string" : ""
3263             ); 
3264     }
3265 }
3266
3267 STATIC void
3268 S_dump_exec_pos(pTHX_ const char *locinput, 
3269                       const regnode *scan, 
3270                       const char *loc_regeol, 
3271                       const char *loc_bostr, 
3272                       const char *loc_reg_starttry,
3273                       const bool utf8_target)
3274 {
3275     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
3276     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
3277     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
3278     /* The part of the string before starttry has one color
3279        (pref0_len chars), between starttry and current
3280        position another one (pref_len - pref0_len chars),
3281        after the current position the third one.
3282        We assume that pref0_len <= pref_len, otherwise we
3283        decrease pref0_len.  */
3284     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
3285         ? (5 + taill) - l : locinput - loc_bostr;
3286     int pref0_len;
3287
3288     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
3289
3290     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
3291         pref_len++;
3292     pref0_len = pref_len  - (locinput - loc_reg_starttry);
3293     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
3294         l = ( loc_regeol - locinput > (5 + taill) - pref_len
3295               ? (5 + taill) - pref_len : loc_regeol - locinput);
3296     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
3297         l--;
3298     if (pref0_len < 0)
3299         pref0_len = 0;
3300     if (pref0_len > pref_len)
3301         pref0_len = pref_len;
3302     {
3303         const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
3304
3305         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
3306             (locinput - pref_len),pref0_len, 60, 4, 5);
3307         
3308         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3309                     (locinput - pref_len + pref0_len),
3310                     pref_len - pref0_len, 60, 2, 3);
3311         
3312         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
3313                     locinput, loc_regeol - locinput, 10, 0, 1);
3314
3315         const STRLEN tlen=len0+len1+len2;
3316         PerlIO_printf(Perl_debug_log,
3317                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
3318                     (IV)(locinput - loc_bostr),
3319                     len0, s0,
3320                     len1, s1,
3321                     (docolor ? "" : "> <"),
3322                     len2, s2,
3323                     (int)(tlen > 19 ? 0 :  19 - tlen),
3324                     "");
3325     }
3326 }
3327
3328 #endif
3329
3330 /* reg_check_named_buff_matched()
3331  * Checks to see if a named buffer has matched. The data array of 
3332  * buffer numbers corresponding to the buffer is expected to reside
3333  * in the regexp->data->data array in the slot stored in the ARG() of
3334  * node involved. Note that this routine doesn't actually care about the
3335  * name, that information is not preserved from compilation to execution.
3336  * Returns the index of the leftmost defined buffer with the given name
3337  * or 0 if non of the buffers matched.
3338  */
3339 STATIC I32
3340 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
3341 {
3342     I32 n;
3343     RXi_GET_DECL(rex,rexi);
3344     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
3345     I32 *nums=(I32*)SvPVX(sv_dat);
3346
3347     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3348
3349     for ( n=0; n<SvIVX(sv_dat); n++ ) {
3350         if ((I32)rex->lastparen >= nums[n] &&
3351             rex->offs[nums[n]].end != -1)
3352         {
3353             return nums[n];
3354         }
3355     }
3356     return 0;
3357 }
3358
3359
3360 static bool
3361 S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p,
3362         U8* c1_utf8, int *c2p, U8* c2_utf8, regmatch_info *reginfo)
3363 {
3364     /* This function determines if there are one or two characters that match
3365      * the first character of the passed-in EXACTish node <text_node>, and if
3366      * so, returns them in the passed-in pointers.
3367      *
3368      * If it determines that no possible character in the target string can
3369      * match, it returns FALSE; otherwise TRUE.  (The FALSE situation occurs if
3370      * the first character in <text_node> requires UTF-8 to represent, and the
3371      * target string isn't in UTF-8.)
3372      *
3373      * If there are more than two characters that could match the beginning of
3374      * <text_node>, or if more context is required to determine a match or not,
3375      * it sets both *<c1p> and *<c2p> to CHRTEST_VOID.
3376      *
3377      * The motiviation behind this function is to allow the caller to set up
3378      * tight loops for matching.  If <text_node> is of type EXACT, there is
3379      * only one possible character that can match its first character, and so
3380      * the situation is quite simple.  But things get much more complicated if
3381      * folding is involved.  It may be that the first character of an EXACTFish
3382      * node doesn't participate in any possible fold, e.g., punctuation, so it
3383      * can be matched only by itself.  The vast majority of characters that are
3384      * in folds match just two things, their lower and upper-case equivalents.
3385      * But not all are like that; some have multiple possible matches, or match
3386      * sequences of more than one character.  This function sorts all that out.
3387      *
3388      * Consider the patterns A*B or A*?B where A and B are arbitrary.  In a
3389      * loop of trying to match A*, we know we can't exit where the thing
3390      * following it isn't a B.  And something can't be a B unless it is the
3391      * beginning of B.  By putting a quick test for that beginning in a tight
3392      * loop, we can rule out things that can't possibly be B without having to
3393      * break out of the loop, thus avoiding work.  Similarly, if A is a single
3394      * character, we can make a tight loop matching A*, using the outputs of
3395      * this function.
3396      *
3397      * If the target string to match isn't in UTF-8, and there aren't
3398      * complications which require CHRTEST_VOID, *<c1p> and *<c2p> are set to
3399      * the one or two possible octets (which are characters in this situation)
3400      * that can match.  In all cases, if there is only one character that can
3401      * match, *<c1p> and *<c2p> will be identical.
3402      *
3403      * If the target string is in UTF-8, the buffers pointed to by <c1_utf8>
3404      * and <c2_utf8> will contain the one or two UTF-8 sequences of bytes that
3405      * can match the beginning of <text_node>.  They should be declared with at
3406      * least length UTF8_MAXBYTES+1.  (If the target string isn't in UTF-8, it is
3407      * undefined what these contain.)  If one or both of the buffers are
3408      * invariant under UTF-8, *<c1p>, and *<c2p> will also be set to the
3409      * corresponding invariant.  If variant, the corresponding *<c1p> and/or
3410      * *<c2p> will be set to a negative number(s) that shouldn't match any code
3411      * point (unless inappropriately coerced to unsigned).   *<c1p> will equal
3412      * *<c2p> if and only if <c1_utf8> and <c2_utf8> are the same. */
3413
3414     const bool utf8_target = reginfo->is_utf8_target;
3415
3416     UV c1 = CHRTEST_NOT_A_CP_1;
3417     UV c2 = CHRTEST_NOT_A_CP_2;
3418     bool use_chrtest_void = FALSE;
3419     const bool is_utf8_pat = reginfo->is_utf8_pat;
3420
3421     /* Used when we have both utf8 input and utf8 output, to avoid converting
3422      * to/from code points */
3423     bool utf8_has_been_setup = FALSE;
3424
3425     dVAR;
3426
3427     U8 *pat = (U8*)STRING(text_node);
3428     U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1];
3429
3430     if (OP(text_node) == EXACT) {
3431
3432         /* In an exact node, only one thing can be matched, that first
3433          * character.  If both the pat and the target are UTF-8, we can just
3434          * copy the input to the output, avoiding finding the code point of
3435          * that character */
3436         if (!is_utf8_pat) {
3437             c2 = c1 = *pat;
3438         }
3439         else if (utf8_target) {
3440             Copy(pat, c1_utf8, UTF8SKIP(pat), U8);
3441             Copy(pat, c2_utf8, UTF8SKIP(pat), U8);
3442             utf8_has_been_setup = TRUE;
3443         }
3444         else {
3445             c2 = c1 = valid_utf8_to_uvchr(pat, NULL);
3446         }
3447     }
3448     else { /* an EXACTFish node */
3449         U8 *pat_end = pat + STR_LEN(text_node);
3450
3451         /* An EXACTFL node has at least some characters unfolded, because what
3452          * they match is not known until now.  So, now is the time to fold
3453          * the first few of them, as many as are needed to determine 'c1' and
3454          * 'c2' later in the routine.  If the pattern isn't UTF-8, we only need
3455          * to fold if in a UTF-8 locale, and then only the Sharp S; everything
3456          * else is 1-1 and isn't assumed to be folded.  In a UTF-8 pattern, we
3457          * need to fold as many characters as a single character can fold to,
3458          * so that later we can check if the first ones are such a multi-char
3459          * fold.  But, in such a pattern only locale-problematic characters
3460          * aren't folded, so we can skip this completely if the first character
3461          * in the node isn't one of the tricky ones */
3462         if (OP(text_node) == EXACTFL) {
3463
3464             if (! is_utf8_pat) {
3465                 if (IN_UTF8_CTYPE_LOCALE && *pat == LATIN_SMALL_LETTER_SHARP_S)
3466                 {
3467                     folded[0] = folded[1] = 's';
3468                     pat = folded;
3469                     pat_end = folded + 2;
3470                 }
3471             }
3472             else if (is_PROBLEMATIC_LOCALE_FOLDEDS_START_utf8(pat)) {
3473                 U8 *s = pat;
3474                 U8 *d = folded;
3475                 int i;
3476
3477                 for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < pat_end; i++) {
3478                     if (isASCII(*s)) {
3479                         *(d++) = (U8) toFOLD_LC(*s);
3480                         s++;
3481                     }
3482                     else {
3483                         STRLEN len;
3484                         _to_utf8_fold_flags(s,
3485                                             d,
3486                                             &len,
3487                                             FOLD_FLAGS_FULL | FOLD_FLAGS_LOCALE);
3488                         d += len;
3489                         s += UTF8SKIP(s);
3490                     }
3491                 }
3492
3493                 pat = folded;
3494                 pat_end = d;
3495             }
3496         }
3497
3498         if ((is_utf8_pat && is_MULTI_CHAR_FOLD_utf8(pat))
3499              || (!is_utf8_pat && is_MULTI_CHAR_FOLD_latin1(pat)))
3500         {
3501             /* Multi-character folds require more context to sort out.  Also
3502              * PL_utf8_foldclosures used below doesn't handle them, so have to
3503              * be handled outside this routine */
3504             use_chrtest_void = TRUE;
3505         }
3506         else { /* an EXACTFish node which doesn't begin with a multi-char fold */
3507             c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
3508             if (c1 > 256) {
3509                 /* Load the folds hash, if not already done */
3510                 SV** listp;
3511                 if (! PL_utf8_foldclosures) {
3512                     if (! PL_utf8_tofold) {
3513                         U8 dummy[UTF8_MAXBYTES_CASE+1];
3514
3515                         /* Force loading this by folding an above-Latin1 char */
3516                         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
3517                         assert(PL_utf8_tofold); /* Verify that worked */
3518                     }
3519                     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
3520                 }
3521
3522                 /* The fold closures data structure is a hash with the keys
3523                  * being the UTF-8 of every character that is folded to, like
3524                  * 'k', and the values each an array of all code points that
3525                  * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
3526                  * Multi-character folds are not included */
3527                 if ((! (listp = hv_fetch(PL_utf8_foldclosures,
3528                                         (char *) pat,
3529                                         UTF8SKIP(pat),
3530                                         FALSE))))
3531                 {
3532                     /* Not found in the hash, therefore there are no folds
3533                     * containing it, so there is only a single character that
3534                     * could match */
3535                     c2 = c1;
3536                 }
3537                 else {  /* Does participate in folds */
3538                     AV* list = (AV*) *listp;
3539                     if (av_len(list) != 1) {
3540
3541                         /* If there aren't exactly two folds to this, it is
3542                          * outside the scope of this function */
3543                         use_chrtest_void = TRUE;
3544                     }
3545                     else {  /* There are two.  Get them */
3546                         SV** c_p = av_fetch(list, 0, FALSE);
3547                         if (c_p == NULL) {
3548                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
3549                         }
3550                         c1 = SvUV(*c_p);
3551
3552                         c_p = av_fetch(list, 1, FALSE);
3553                         if (c_p == NULL) {
3554                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
3555                         }
3556                         c2 = SvUV(*c_p);
3557
3558                         /* Folds that cross the 255/256 boundary are forbidden
3559                          * if EXACTFL (and isnt a UTF8 locale), or EXACTFA and
3560                          * one is ASCIII.  Since the pattern character is above
3561                          * 256, and its only other match is below 256, the only
3562                          * legal match will be to itself.  We have thrown away
3563                          * the original, so have to compute which is the one
3564                          * above 255 */
3565                         if ((c1 < 256) != (c2 < 256)) {
3566                             if ((OP(text_node) == EXACTFL
3567                                  && ! IN_UTF8_CTYPE_LOCALE)
3568                                 || ((OP(text_node) == EXACTFA
3569                                     || OP(text_node) == EXACTFA_NO_TRIE)
3570                                     && (isASCII(c1) || isASCII(c2))))
3571                             {
3572                                 if (c1 < 256) {
3573                                     c1 = c2;
3574                                 }
3575                                 else {
3576                                     c2 = c1;
3577                                 }
3578                             }
3579                         }
3580                     }
3581                 }
3582             }
3583             else /* Here, c1 is < 255 */
3584                 if (utf8_target
3585                     && HAS_NONLATIN1_FOLD_CLOSURE(c1)
3586                     && ( ! (OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE))
3587                     && ((OP(text_node) != EXACTFA
3588                         && OP(text_node) != EXACTFA_NO_TRIE)
3589                         || ! isASCII(c1)))
3590             {
3591                 /* Here, there could be something above Latin1 in the target
3592                  * which folds to this character in the pattern.  All such
3593                  * cases except LATIN SMALL LETTER Y WITH DIAERESIS have more
3594                  * than two characters involved in their folds, so are outside
3595                  * the scope of this function */
3596                 if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3597                     c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
3598                 }
3599                 else {
3600                     use_chrtest_void = TRUE;
3601                 }
3602             }
3603             else { /* Here nothing above Latin1 can fold to the pattern
3604                       character */
3605                 switch (OP(text_node)) {
3606
3607                     case EXACTFL:   /* /l rules */
3608                         c2 = PL_fold_locale[c1];
3609                         break;
3610
3611                     case EXACTF:   /* This node only generated for non-utf8
3612                                     patterns */
3613                         assert(! is_utf8_pat);
3614                         if (! utf8_target) {    /* /d rules */
3615                             c2 = PL_fold[c1];
3616                             break;
3617                         }
3618                         /* FALLTHROUGH */
3619                         /* /u rules for all these.  This happens to work for
3620                         * EXACTFA as nothing in Latin1 folds to ASCII */
3621                     case EXACTFA_NO_TRIE:   /* This node only generated for
3622                                             non-utf8 patterns */
3623                         assert(! is_utf8_pat);
3624                         /* FALL THROUGH */
3625                     case EXACTFA:
3626                     case EXACTFU_SS:
3627                     case EXACTFU:
3628                         c2 = PL_fold_latin1[c1];
3629                         break;
3630
3631                     default:
3632                         Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
3633                         assert(0); /* NOTREACHED */
3634                 }
3635             }
3636         }
3637     }
3638
3639     /* Here have figured things out.  Set up the returns */
3640     if (use_chrtest_void) {
3641         *c2p = *c1p = CHRTEST_VOID;
3642     }
3643     else if (utf8_target) {
3644         if (! utf8_has_been_setup) {    /* Don't have the utf8; must get it */
3645             uvchr_to_utf8(c1_utf8, c1);
3646             uvchr_to_utf8(c2_utf8, c2);
3647         }
3648
3649         /* Invariants are stored in both the utf8 and byte outputs; Use
3650          * negative numbers otherwise for the byte ones.  Make sure that the
3651          * byte ones are the same iff the utf8 ones are the same */
3652         *c1p = (UTF8_IS_INVARIANT(*c1_utf8)) ? *c1_utf8 : CHRTEST_NOT_A_CP_1;
3653         *c2p = (UTF8_IS_INVARIANT(*c2_utf8))
3654                 ? *c2_utf8
3655                 : (c1 == c2)
3656                   ? CHRTEST_NOT_A_CP_1
3657                   : CHRTEST_NOT_A_CP_2;
3658     }
3659     else if (c1 > 255) {
3660        if (c2 > 255) {  /* both possibilities are above what a non-utf8 string
3661                            can represent */
3662            return FALSE;
3663        }
3664
3665        *c1p = *c2p = c2;    /* c2 is the only representable value */
3666     }
3667     else {  /* c1 is representable; see about c2 */
3668        *c1p = c1;
3669        *c2p = (c2 < 256) ? c2 : c1;
3670     }
3671
3672     return TRUE;
3673 }
3674
3675 /* returns -1 on failure, $+[0] on success */
3676 STATIC SSize_t
3677 S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
3678 {
3679 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3680     dMY_CXT;
3681 #endif
3682     dVAR;
3683     const bool utf8_target = reginfo->is_utf8_target;
3684     const U32 uniflags = UTF8_ALLOW_DEFAULT;
3685     REGEXP *rex_sv = reginfo->prog;
3686     regexp *rex = ReANY(rex_sv);
3687     RXi_GET_DECL(rex,rexi);
3688     /* the current state. This is a cached copy of PL_regmatch_state */
3689     regmatch_state *st;
3690     /* cache heavy used fields of st in registers */
3691     regnode *scan;
3692     regnode *next;
3693     U32 n = 0;  /* general value; init to avoid compiler warning */
3694     SSize_t ln = 0; /* len or last;  init to avoid compiler warning */
3695     char *locinput = startpos;
3696     char *pushinput; /* where to continue after a PUSH */
3697     I32 nextchr;   /* is always set to UCHARAT(locinput) */
3698
3699     bool result = 0;        /* return value of S_regmatch */
3700     int depth = 0;          /* depth of backtrack stack */
3701     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
3702     const U32 max_nochange_depth =
3703         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
3704         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
3705     regmatch_state *yes_state = NULL; /* state to pop to on success of
3706                                                             subpattern */
3707     /* mark_state piggy backs on the yes_state logic so that when we unwind 
3708        the stack on success we can update the mark_state as we go */
3709     regmatch_state *mark_state = NULL; /* last mark state we have seen */
3710     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
3711     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
3712     U32 state_num;
3713     bool no_final = 0;      /* prevent failure from backtracking? */
3714     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
3715     char *startpoint = locinput;
3716     SV *popmark = NULL;     /* are we looking for a mark? */
3717     SV *sv_commit = NULL;   /* last mark name seen in failure */
3718     SV *sv_yes_mark = NULL; /* last mark name we have seen 
3719                                during a successful match */
3720     U32 lastopen = 0;       /* last open we saw */
3721     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;   
3722     SV* const oreplsv = GvSVn(PL_replgv);
3723     /* these three flags are set by various ops to signal information to
3724      * the very next op. They have a useful lifetime of exactly one loop
3725      * iteration, and are not preserved or restored by state pushes/pops
3726      */
3727     bool sw = 0;            /* the condition value in (?(cond)a|b) */
3728     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
3729     int logical = 0;        /* the following EVAL is:
3730                                 0: (?{...})
3731                                 1: (?(?{...})X|Y)
3732                                 2: (??{...})
3733                                or the following IFMATCH/UNLESSM is:
3734                                 false: plain (?=foo)
3735                                 true:  used as a condition: (?(?=foo))
3736                             */
3737     PAD* last_pad = NULL;
3738     dMULTICALL;
3739     I32 gimme = G_SCALAR;
3740     CV *caller_cv = NULL;       /* who called us */
3741     CV *last_pushed_cv = NULL;  /* most recently called (?{}) CV */
3742     CHECKPOINT runops_cp;       /* savestack position before executing EVAL */
3743     U32 maxopenparen = 0;       /* max '(' index seen so far */
3744     int to_complement;  /* Invert the result? */
3745     _char_class_number classnum;
3746     bool is_utf8_pat = reginfo->is_utf8_pat;
3747
3748 #ifdef DEBUGGING
3749     GET_RE_DEBUG_FLAGS_DECL;
3750 #endif
3751
3752     /* protect against undef(*^R) */
3753     SAVEFREESV(SvREFCNT_inc_simple_NN(oreplsv));
3754
3755     /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
3756     multicall_oldcatch = 0;
3757     multicall_cv = NULL;
3758     cx = NULL;
3759     PERL_UNUSED_VAR(multicall_cop);
3760     PERL_UNUSED_VAR(newsp);
3761
3762
3763     PERL_ARGS_ASSERT_REGMATCH;
3764
3765     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
3766             PerlIO_printf(Perl_debug_log,"regmatch start\n");
3767     }));
3768
3769     st = PL_regmatch_state;
3770
3771     /* Note that nextchr is a byte even in UTF */
3772     SET_nextchr;
3773     scan = prog;
3774     while (scan != NULL) {
3775
3776         DEBUG_EXECUTE_r( {
3777             SV * const prop = sv_newmortal();
3778             regnode *rnext=regnext(scan);
3779             DUMP_EXEC_POS( locinput, scan, utf8_target );
3780             regprop(rex, prop, scan);
3781             
3782             PerlIO_printf(Perl_debug_log,
3783                     "%3"IVdf":%*s%s(%"IVdf")\n",
3784                     (IV)(scan - rexi->program), depth*2, "",
3785                     SvPVX_const(prop),
3786                     (PL_regkind[OP(scan)] == END || !rnext) ? 
3787                         0 : (IV)(rnext - rexi->program));
3788         });
3789
3790         next = scan + NEXT_OFF(scan);
3791         if (next == scan)
3792             next = NULL;
3793         state_num = OP(scan);
3794
3795       reenter_switch:
3796         to_complement = 0;
3797
3798         SET_nextchr;
3799         assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS));
3800
3801         switch (state_num) {
3802         case BOL: /*  /^../  */
3803             if (locinput == reginfo->strbeg)
3804                 break;
3805             sayNO;
3806
3807         case MBOL: /*  /^../m  */
3808             if (locinput == reginfo->strbeg ||
3809                 (!NEXTCHR_IS_EOS && locinput[-1] == '\n'))
3810             {
3811                 break;
3812             }
3813             sayNO;
3814
3815         case SBOL: /*  /^../s  */
3816             if (locinput == reginfo->strbeg)
3817                 break;
3818             sayNO;
3819
3820         case GPOS: /*  \G  */
3821             if (locinput == reginfo->ganch)
3822                 break;
3823             sayNO;
3824
3825         case KEEPS: /*   \K  */
3826             /* update the startpoint */
3827             st->u.keeper.val = rex->offs[0].start;
3828             rex->offs[0].start = locinput - reginfo->strbeg;
3829             PUSH_STATE_GOTO(KEEPS_next, next, locinput);
3830             assert(0); /*NOTREACHED*/
3831         case KEEPS_next_fail:
3832             /* rollback the start point change */
3833             rex->offs[0].start = st->u.keeper.val;
3834             sayNO_SILENT;
3835             assert(0); /*NOTREACHED*/
3836
3837         case MEOL: /* /..$/m  */
3838             if (!NEXTCHR_IS_EOS && nextchr != '\n')
3839                 sayNO;
3840             break;
3841
3842         case EOL: /* /..$/  */
3843             /* FALL THROUGH */
3844         case SEOL: /* /..$/s  */
3845             if (!NEXTCHR_IS_EOS && nextchr != '\n')
3846                 sayNO;
3847             if (reginfo->strend - locinput > 1)
3848                 sayNO;
3849             break;
3850
3851         case EOS: /*  \z  */
3852             if (!NEXTCHR_IS_EOS)
3853                 sayNO;
3854             break;
3855
3856         case SANY: /*  /./s  */
3857             if (NEXTCHR_IS_EOS)
3858                 sayNO;
3859             goto increment_locinput;
3860
3861         case CANY: /*  \C  */
3862             if (NEXTCHR_IS_EOS)
3863                 sayNO;
3864             locinput++;
3865             break;
3866
3867         case REG_ANY: /*  /./  */
3868             if ((NEXTCHR_IS_EOS) || nextchr == '\n')
3869                 sayNO;
3870             goto increment_locinput;
3871
3872
3873 #undef  ST
3874 #define ST st->u.trie
3875         case TRIEC: /* (ab|cd) with known charclass */
3876             /* In this case the charclass data is available inline so
3877                we can fail fast without a lot of extra overhead. 
3878              */
3879             if(!NEXTCHR_IS_EOS && !ANYOF_BITMAP_TEST(scan, nextchr)) {
3880                 DEBUG_EXECUTE_r(
3881                     PerlIO_printf(Perl_debug_log,
3882                               "%*s  %sfailed to match trie start class...%s\n",
3883                               REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3884                 );
3885                 sayNO_SILENT;
3886                 assert(0); /* NOTREACHED */
3887             }
3888             /* FALL THROUGH */
3889         case TRIE:  /* (ab|cd)  */
3890             /* the basic plan of execution of the trie is:
3891              * At the beginning, run though all the states, and
3892              * find the longest-matching word. Also remember the position
3893              * of the shortest matching word. For example, this pattern:
3894              *    1  2 3 4    5
3895              *    ab|a|x|abcd|abc
3896              * when matched against the string "abcde", will generate
3897              * accept states for all words except 3, with the longest
3898              * matching word being 4, and the shortest being 2 (with
3899              * the position being after char 1 of the string).
3900              *
3901              * Then for each matching word, in word order (i.e. 1,2,4,5),
3902              * we run the remainder of the pattern; on each try setting
3903              * the current position to the character following the word,
3904              * returning to try the next word on failure.
3905              *
3906              * We avoid having to build a list of words at runtime by
3907          &nbs