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