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