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