This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
perlretut: use a numbered list to format a numbered list
[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_REGEX_ENGINE
75 #define PERL_IN_REGEXEC_C
76 #include "perl.h"
77
78 #ifdef PERL_IN_XSUB_RE
79 #  include "re_comp.h"
80 #else
81 #  include "regcomp.h"
82 #endif
83
84 #include "invlist_inline.h"
85 #include "unicode_constants.h"
86
87 static const char b_utf8_locale_required[] =
88  "Use of \\b{} or \\B{} for non-UTF-8 locale is wrong."
89                                                 "  Assuming a UTF-8 locale";
90
91 #define CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_BOUND                       \
92     STMT_START {                                                            \
93         if (! IN_UTF8_CTYPE_LOCALE) {                                       \
94           Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),                       \
95                                                 b_utf8_locale_required);    \
96         }                                                                   \
97     } STMT_END
98
99 static const char sets_utf8_locale_required[] =
100       "Use of (?[ ]) for non-UTF-8 locale is wrong.  Assuming a UTF-8 locale";
101
102 #define CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_SETS(n)                     \
103     STMT_START {                                                            \
104         if (! IN_UTF8_CTYPE_LOCALE && (FLAGS(n) & ANYOFL_UTF8_LOCALE_REQD)){\
105           Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),                       \
106                                              sets_utf8_locale_required);    \
107         }                                                                   \
108     } STMT_END
109
110 #ifdef DEBUGGING
111 /* At least one required character in the target string is expressible only in
112  * UTF-8. */
113 static const char non_utf8_target_but_utf8_required[]
114                 = "Can't match, because target string needs to be in UTF-8\n";
115 #endif
116
117 #define NON_UTF8_TARGET_BUT_UTF8_REQUIRED(target) STMT_START {           \
118     DEBUG_EXECUTE_r(Perl_re_printf( aTHX_  "%s", non_utf8_target_but_utf8_required));\
119     goto target;                                                         \
120 } STMT_END
121
122 #ifndef STATIC
123 #define STATIC  static
124 #endif
125
126 /*
127  * Forwards.
128  */
129
130 #define CHR_SVLEN(sv) (utf8_target ? sv_len_utf8(sv) : SvCUR(sv))
131
132 #define HOPc(pos,off) \
133         (char *)(reginfo->is_utf8_target \
134             ? reghop3((U8*)pos, off, \
135                     (U8*)(off >= 0 ? reginfo->strend : reginfo->strbeg)) \
136             : (U8*)(pos + off))
137
138 /* like HOPMAYBE3 but backwards. lim must be +ve. Returns NULL on overshoot */
139 #define HOPBACK3(pos, off, lim) \
140         (reginfo->is_utf8_target                          \
141             ? reghopmaybe3((U8*)pos, (SSize_t)0-off, (U8*)(lim)) \
142             : (pos - off >= lim)                                 \
143                 ? (U8*)pos - off                                 \
144                 : NULL)
145
146 #define HOPBACKc(pos, off) ((char*)HOPBACK3(pos, off, reginfo->strbeg))
147
148 #define HOP3(pos,off,lim) (reginfo->is_utf8_target  ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
149 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
150
151 /* lim must be +ve. Returns NULL on overshoot */
152 #define HOPMAYBE3(pos,off,lim) \
153         (reginfo->is_utf8_target                        \
154             ? reghopmaybe3((U8*)pos, off, (U8*)(lim))   \
155             : ((U8*)pos + off <= lim)                   \
156                 ? (U8*)pos + off                        \
157                 : NULL)
158
159 /* like HOP3, but limits the result to <= lim even for the non-utf8 case.
160  * off must be >=0; args should be vars rather than expressions */
161 #define HOP3lim(pos,off,lim) (reginfo->is_utf8_target \
162     ? reghop3((U8*)(pos), off, (U8*)(lim)) \
163     : (U8*)((pos + off) > lim ? lim : (pos + off)))
164 #define HOP3clim(pos,off,lim) ((char*)HOP3lim(pos,off,lim))
165
166 #define HOP4(pos,off,llim, rlim) (reginfo->is_utf8_target \
167     ? reghop4((U8*)(pos), off, (U8*)(llim), (U8*)(rlim)) \
168     : (U8*)(pos + off))
169 #define HOP4c(pos,off,llim, rlim) ((char*)HOP4(pos,off,llim, rlim))
170
171 #define PLACEHOLDER     /* Something for the preprocessor to grab onto */
172 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
173
174 /* for use after a quantifier and before an EXACT-like node -- japhy */
175 /* it would be nice to rework regcomp.sym to generate this stuff. sigh
176  *
177  * NOTE that *nothing* that affects backtracking should be in here, specifically
178  * VERBS must NOT be included. JUMPABLE is used to determine  if we can ignore a
179  * node that is in between two EXACT like nodes when ascertaining what the required
180  * "follow" character is. This should probably be moved to regex compile time
181  * although it may be done at run time because of the REF possibility - more
182  * investigation required. -- demerphq
183 */
184 #define JUMPABLE(rn) (                                                             \
185     OP(rn) == OPEN ||                                                              \
186     (OP(rn) == CLOSE &&                                                            \
187      !EVAL_CLOSE_PAREN_IS(cur_eval,PARNO(rn)) ) ||                                 \
188     OP(rn) == EVAL ||                                                              \
189     OP(rn) == SUSPEND || OP(rn) == IFMATCH ||                                      \
190     OP(rn) == PLUS || OP(rn) == MINMOD ||                                          \
191     OP(rn) == KEEPS ||                                                             \
192     (REGNODE_TYPE(OP(rn)) == CURLY && ARG1i(rn) > 0)                                  \
193 )
194 #define IS_EXACT(rn) (REGNODE_TYPE(OP(rn)) == EXACT)
195
196 #define HAS_TEXT(rn) ( IS_EXACT(rn) || REGNODE_TYPE(OP(rn)) == REF )
197
198 /*
199   Search for mandatory following text node; for lookahead, the text must
200   follow but for lookbehind (FLAGS(rn) != 0) we skip to the next step.
201 */
202 #define FIND_NEXT_IMPT(rn) STMT_START {                                   \
203     while (JUMPABLE(rn)) { \
204         const OPCODE type = OP(rn); \
205         if (type == SUSPEND || REGNODE_TYPE(type) == CURLY) \
206             rn = REGNODE_AFTER_opcode(rn,type); \
207         else if (type == PLUS) \
208             rn = REGNODE_AFTER_type(rn,tregnode_PLUS); \
209         else if (type == IFMATCH) \
210             rn = (FLAGS(rn) == 0) ? REGNODE_AFTER_type(rn,tregnode_IFMATCH) : rn + ARG1u(rn); \
211         else rn += NEXT_OFF(rn); \
212     } \
213 } STMT_END
214
215 #define SLAB_FIRST(s) (&(s)->states[0])
216 #define SLAB_LAST(s)  (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
217
218 static void S_setup_eval_state(pTHX_ regmatch_info *const reginfo);
219 static void S_cleanup_regmatch_info_aux(pTHX_ void *arg);
220 static regmatch_state * S_push_slab(pTHX);
221
222 #define REGCP_OTHER_ELEMS 3
223 #define REGCP_FRAME_ELEMS 1
224 /* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
225  * are needed for the regexp context stack bookkeeping. */
226
227 STATIC CHECKPOINT
228 S_regcppush(pTHX_ const regexp *rex, I32 parenfloor, U32 maxopenparen comma_pDEPTH)
229 {
230     const int retval = PL_savestack_ix;
231     /* Number of bytes about to be stored in the stack */
232     const SSize_t paren_bytes_to_push = sizeof(*RXp_OFFSp(rex)) * (maxopenparen - parenfloor);
233     /* Number of savestack[] entries to be filled by the paren data */
234     /* Rounding is performed in case we are few elements short */
235     const int paren_elems_to_push = (paren_bytes_to_push + sizeof(*PL_savestack) - 1) / sizeof(*PL_savestack);
236     const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
237     const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
238
239     DECLARE_AND_GET_RE_DEBUG_FLAGS;
240
241     PERL_ARGS_ASSERT_REGCPPUSH;
242
243     if (paren_elems_to_push < 0)
244         Perl_croak(aTHX_ "panic: paren_elems_to_push, %i < 0, maxopenparen: %i parenfloor: %i",
245                    (int)paren_elems_to_push, (int)maxopenparen,
246                    (int)parenfloor);
247
248     if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
249         Perl_croak(aTHX_ "panic: paren_elems_to_push offset %" UVuf
250                    " out of range (%lu-%ld)",
251                    total_elems,
252                    (unsigned long)maxopenparen,
253                    (long)parenfloor);
254
255     DEBUG_BUFFERS_r(
256         if ((int)maxopenparen > (int)parenfloor)
257             Perl_re_exec_indentf( aTHX_
258                 "rex=0x%" UVxf " offs=0x%" UVxf ": saving capture indices:\n",
259                 depth,
260                 PTR2UV(rex),
261                 PTR2UV(RXp_OFFSp(rex))
262             );
263     );
264
265     SSGROW(total_elems + REGCP_FRAME_ELEMS);
266     assert((IV)PL_savestack_max > (IV)(total_elems + REGCP_FRAME_ELEMS));
267
268     /* memcpy the offs inside the stack - it's faster than for loop */
269     memcpy(&PL_savestack[PL_savestack_ix], RXp_OFFSp(rex) + parenfloor + 1, paren_bytes_to_push);
270     PL_savestack_ix += paren_elems_to_push;
271
272     DEBUG_BUFFERS_r({
273         I32 p;
274         for (p = parenfloor + 1; p <= (I32)maxopenparen; p++) {
275             Perl_re_exec_indentf(aTHX_
276                 "    \\%" UVuf " %" IVdf " (%" IVdf ") .. %" IVdf " (regcppush)\n",
277                 depth,
278                 (UV)p,
279                 (IV)RXp_OFFSp(rex)[p].start,
280                 (IV)RXp_OFFSp(rex)[p].start_tmp,
281                 (IV)RXp_OFFSp(rex)[p].end
282             );
283         }
284     });
285
286 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
287     SSPUSHINT(maxopenparen);
288     SSPUSHINT(RXp_LASTPAREN(rex));
289     SSPUSHINT(RXp_LASTCLOSEPAREN(rex));
290     SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
291
292
293     DEBUG_BUFFERS_r({
294         Perl_re_exec_indentf(aTHX_
295                 "finished regcppush returning %" IVdf " cur: %" IVdf "\n",
296                 depth, retval, PL_savestack_ix);
297     });
298
299     return retval;
300 }
301
302 /* These are needed since we do not localize EVAL nodes: */
303 #define REGCP_SET(cp)                                           \
304     DEBUG_STATE_r(                                              \
305         Perl_re_exec_indentf( aTHX_                             \
306             "Setting an EVAL scope, savestack=%" IVdf ",\n",    \
307             depth, (IV)PL_savestack_ix                          \
308         )                                                       \
309     );                                                          \
310     cp = PL_savestack_ix
311
312 #define REGCP_UNWIND(cp)                                        \
313     DEBUG_STATE_r(                                              \
314         if (cp != PL_savestack_ix)                              \
315             Perl_re_exec_indentf( aTHX_                         \
316                 "Clearing an EVAL scope, savestack=%"           \
317                 IVdf "..%" IVdf "\n",                           \
318                 depth, (IV)(cp), (IV)PL_savestack_ix            \
319             )                                                   \
320     );                                                          \
321     regcpblow(cp)
322
323 /* set the start and end positions of capture ix */
324 #define CLOSE_ANY_CAPTURE(rex, ix, s, e)                                    \
325     RXp_OFFSp(rex)[(ix)].start = (s);                                       \
326     RXp_OFFSp(rex)[(ix)].end = (e)
327
328 #define CLOSE_CAPTURE(rex, ix, s, e)                                        \
329     CLOSE_ANY_CAPTURE(rex, ix, s, e);                                       \
330     if (ix > RXp_LASTPAREN(rex))                                            \
331         RXp_LASTPAREN(rex) = (ix);                                          \
332     RXp_LASTCLOSEPAREN(rex) = (ix);                                         \
333     DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_                             \
334         "CLOSE: rex=0x%" UVxf " offs=0x%" UVxf ": \\%" UVuf ": set %" IVdf " .. %" IVdf " max: %" UVuf "\n", \
335         depth,                                                              \
336         PTR2UV(rex),                                                        \
337         PTR2UV(RXp_OFFSp(rex)),                                             \
338         (UV)(ix),                                                           \
339         (IV)RXp_OFFSp(rex)[ix].start,                                       \
340         (IV)RXp_OFFSp(rex)[ix].end,                                         \
341         (UV)RXp_LASTPAREN(rex)                                              \
342     ))
343
344 /* the lp and lcp args match the relevant members of the
345  * regexp structure, but in practice they should all be U16
346  * instead as we have a hard limit of U16_MAX parens. See
347  * line 4003 or so of regcomp.c where we parse OPEN parens
348  * of various types. */
349 PERL_STATIC_INLINE void
350 S_unwind_paren(pTHX_ regexp *rex, U32 lp, U32 lcp comma_pDEPTH) {
351     PERL_ARGS_ASSERT_UNWIND_PAREN;
352     U32 n;
353     DECLARE_AND_GET_RE_DEBUG_FLAGS;
354     DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
355         "UNWIND_PAREN: rex=0x%" UVxf " offs=0x%" UVxf
356         ": invalidate (%" UVuf " .. %" UVuf ") set lcp: %" UVuf "\n",
357         depth,
358         PTR2UV(rex),
359         PTR2UV(RXp_OFFSp(rex)),
360         (UV)(lp),
361         (UV)(RXp_LASTPAREN(rex)),
362         (UV)(lcp)
363     ));
364     for (n = RXp_LASTPAREN(rex); n > lp; n--) {
365         RXp_OFFSp(rex)[n].end = -1;
366     }
367     RXp_LASTPAREN(rex) = n;
368     RXp_LASTCLOSEPAREN(rex) = lcp;
369 }
370 #define UNWIND_PAREN(lp,lcp) unwind_paren(rex,lp,lcp)
371
372 PERL_STATIC_INLINE void
373 S_capture_clear(pTHX_ regexp *rex, U16 from_ix, U16 to_ix, const char *str comma_pDEPTH) {
374     PERL_ARGS_ASSERT_CAPTURE_CLEAR;
375     PERL_UNUSED_ARG(str); /* only used for debugging */
376     U16 my_ix;
377     DECLARE_AND_GET_RE_DEBUG_FLAGS;
378     for ( my_ix = from_ix; my_ix <= to_ix; my_ix++ ) {
379         DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
380                 "CAPTURE_CLEAR %s \\%" IVdf ": "
381                 "%" IVdf "(%" IVdf ") .. %" IVdf
382                 " => "
383                 "%" IVdf "(%" IVdf ") .. %" IVdf
384                 "\n",
385             depth, str, (IV)my_ix,
386             (IV)RXp_OFFSp(rex)[my_ix].start,
387             (IV)RXp_OFFSp(rex)[my_ix].start_tmp,
388             (IV)RXp_OFFSp(rex)[my_ix].end,
389             (IV)-1, (IV)-1, (IV)-1));
390         RXp_OFFSp(rex)[my_ix].start = -1;
391         RXp_OFFSp(rex)[my_ix].start_tmp = -1;
392         RXp_OFFSp(rex)[my_ix].end = -1;
393     }
394 }
395
396 #define CAPTURE_CLEAR(from_ix, to_ix, str) \
397     if (from_ix) capture_clear(rex,from_ix, to_ix, str)
398
399 STATIC void
400 S_regcppop(pTHX_ regexp *rex, U32 *maxopenparen_p comma_pDEPTH)
401 {
402     UV i;
403     U32 paren;
404     DECLARE_AND_GET_RE_DEBUG_FLAGS;
405
406     PERL_ARGS_ASSERT_REGCPPOP;
407
408
409     DEBUG_BUFFERS_r({
410         Perl_re_exec_indentf(aTHX_
411                 "starting regcppop at %" IVdf "\n",
412                 depth, PL_savestack_ix);
413     });
414
415     /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
416     i = SSPOPUV;
417     assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
418     i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
419     RXp_LASTCLOSEPAREN(rex) = SSPOPINT;
420     RXp_LASTPAREN(rex) = SSPOPINT;
421     *maxopenparen_p = SSPOPINT;
422
423     i -= REGCP_OTHER_ELEMS;
424     /* Now restore the parentheses context. */
425     DEBUG_BUFFERS_r(
426         if (i || RXp_LASTPAREN(rex) + 1 <= rex->nparens)
427             Perl_re_exec_indentf( aTHX_
428                 "rex=0x%" UVxf " offs=0x%" UVxf ": restoring capture indices to:\n",
429                 depth,
430                 PTR2UV(rex),
431                 PTR2UV(RXp_OFFSp(rex))
432             );
433     );
434     /* substract remaining elements from the stack */
435     PL_savestack_ix -= i;
436
437     /* static assert that offs struc size is not less than stack elem size */
438     STATIC_ASSERT_STMT(sizeof(*RXp_OFFSp(rex)) >= sizeof(*PL_savestack));
439
440     /* calculate actual number of offs/capture groups stored */
441     /* by doing integer division (leaving potential alignment aside) */
442     i = (i * sizeof(*PL_savestack)) / sizeof(*RXp_OFFSp(rex));
443
444     /* calculate paren starting point */
445     /* i is our number of entries which we are subtracting from *maxopenparen_p */
446     /* and we are storing + 1 this to get the beginning */
447     paren = *maxopenparen_p - i + 1;
448
449     /* restore them */
450     memcpy(RXp_OFFSp(rex) + paren, &PL_savestack[PL_savestack_ix], i * sizeof(*RXp_OFFSp(rex)));
451
452     DEBUG_BUFFERS_r(
453         for (; paren <= *maxopenparen_p; ++paren) {
454             Perl_re_exec_indentf(aTHX_
455                 "    \\%" UVuf " %" IVdf "(%" IVdf ") .. %" IVdf " %s (regcppop)\n",
456                 depth,
457                 (UV)paren,
458                 (IV)RXp_OFFSp(rex)[paren].start,
459                 (IV)RXp_OFFSp(rex)[paren].start_tmp,
460                 (IV)RXp_OFFSp(rex)[paren].end,
461                 (paren > RXp_LASTPAREN(rex) ? "(skipped)" : ""));
462         }
463     );
464 #if 1
465     /* It would seem that the similar code in regtry()
466      * already takes care of this, and in fact it is in
467      * a better location to since this code can #if 0-ed out
468      * but the code in regtry() is needed or otherwise tests
469      * requiring null fields (pat.t#187 and split.t#{13,14}
470      * (as of patchlevel 7877)  will fail.  Then again,
471      * this code seems to be necessary or otherwise
472      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
473      * --jhi updated by dapm */
474     for (i = RXp_LASTPAREN(rex) + 1; i <= rex->nparens; i++) {
475         if (i > *maxopenparen_p) {
476             RXp_OFFSp(rex)[i].start = -1;
477         }
478         RXp_OFFSp(rex)[i].end = -1;
479         DEBUG_BUFFERS_r( Perl_re_exec_indentf( aTHX_
480             "    \\%" UVuf ": %s   ..-1 undeffing (regcppop)\n",
481             depth,
482             (UV)i,
483             (i > *maxopenparen_p) ? "-1" : "  "
484         ));
485     }
486 #endif
487     DEBUG_BUFFERS_r({
488         Perl_re_exec_indentf(aTHX_
489                 "finished regcppop at %" IVdf "\n",
490                 depth, PL_savestack_ix);
491     });
492 }
493
494 /* restore the parens and associated vars at savestack position ix,
495  * but without popping the stack */
496
497 STATIC void
498 S_regcp_restore(pTHX_ regexp *rex, I32 ix, U32 *maxopenparen_p comma_pDEPTH)
499 {
500     I32 tmpix = PL_savestack_ix;
501     PERL_ARGS_ASSERT_REGCP_RESTORE;
502
503     PL_savestack_ix = ix;
504     regcppop(rex, maxopenparen_p);
505     PL_savestack_ix = tmpix;
506 }
507
508 #define regcpblow(cp) LEAVE_SCOPE(cp)   /* Ignores regcppush()ed data. */
509
510 STATIC bool
511 S_isFOO_lc(pTHX_ const U8 classnum, const U8 character)
512 {
513     /* Returns a boolean as to whether or not 'character' is a member of the
514      * Posix character class given by 'classnum' that should be equivalent to a
515      * value in the typedef 'char_class_number_'.
516      *
517      * Ideally this could be replaced by a just an array of function pointers
518      * to the C library functions that implement the macros this calls.
519      * However, to compile, the precise function signatures are required, and
520      * these may vary from platform to platform.  To avoid having to figure
521      * out what those all are on each platform, I (khw) am using this method,
522      * which adds an extra layer of function call overhead (unless the C
523      * optimizer strips it away).  But we don't particularly care about
524      * performance with locales anyway. */
525
526     if (IN_UTF8_CTYPE_LOCALE) {
527         return cBOOL(generic_isCC_(character, classnum));
528     }
529
530     switch ((char_class_number_) classnum) {
531         case CC_ENUM_ALPHANUMERIC_: return isU8_ALPHANUMERIC_LC(character);
532         case CC_ENUM_ALPHA_:        return    isU8_ALPHA_LC(character);
533         case CC_ENUM_ASCII_:        return    isU8_ASCII_LC(character);
534         case CC_ENUM_BLANK_:        return    isU8_BLANK_LC(character);
535         case CC_ENUM_CASED_:        return    isU8_CASED_LC(character);
536         case CC_ENUM_CNTRL_:        return    isU8_CNTRL_LC(character);
537         case CC_ENUM_DIGIT_:        return    isU8_DIGIT_LC(character);
538         case CC_ENUM_GRAPH_:        return    isU8_GRAPH_LC(character);
539         case CC_ENUM_LOWER_:        return    isU8_LOWER_LC(character);
540         case CC_ENUM_PRINT_:        return    isU8_PRINT_LC(character);
541         case CC_ENUM_PUNCT_:        return    isU8_PUNCT_LC(character);
542         case CC_ENUM_SPACE_:        return    isU8_SPACE_LC(character);
543         case CC_ENUM_UPPER_:        return    isU8_UPPER_LC(character);
544         case CC_ENUM_WORDCHAR_:     return isU8_WORDCHAR_LC(character);
545         case CC_ENUM_XDIGIT_:       return   isU8_XDIGIT_LC(character);
546         default:    /* VERTSPACE should never occur in locales */
547             break;
548     }
549
550     Perl_croak(aTHX_
551                "panic: isFOO_lc() has an unexpected character class '%d'",
552                classnum);
553
554     NOT_REACHED; /* NOTREACHED */
555     return FALSE;
556 }
557
558 PERL_STATIC_INLINE I32
559 S_foldEQ_latin1_s2_folded(pTHX_ const char *s1, const char *s2, I32 len)
560 {
561     /* Compare non-UTF-8 using Unicode (Latin1) semantics.  s2 must already be
562      * folded.  Works on all folds representable without UTF-8, except for
563      * LATIN_SMALL_LETTER_SHARP_S, and does not check for this.  Nor does it
564      * check that the strings each have at least 'len' characters.
565      *
566      * There is almost an identical API function where s2 need not be folded:
567      * Perl_foldEQ_latin1() */
568
569     const U8 *a = (const U8 *)s1;
570     const U8 *b = (const U8 *)s2;
571
572     PERL_ARGS_ASSERT_FOLDEQ_LATIN1_S2_FOLDED;
573
574     assert(len >= 0);
575
576     while (len--) {
577         assert(! isUPPER_L1(*b));
578         if (toLOWER_L1(*a) != *b) {
579             return 0;
580         }
581         a++, b++;
582     }
583     return 1;
584 }
585
586 STATIC bool
587 S_isFOO_utf8_lc(pTHX_ const U8 classnum, const U8* character, const U8* e)
588 {
589     /* Returns a boolean as to whether or not the (well-formed) UTF-8-encoded
590      * 'character' is a member of the Posix character class given by 'classnum'
591      * that should be equivalent to a value in the typedef
592      * 'char_class_number_'.
593      *
594      * This just calls isFOO_lc on the code point for the character if it is in
595      * the range 0-255.  Outside that range, all characters use Unicode
596      * rules, ignoring any locale.  So use the Unicode function if this class
597      * requires an inversion list, and use the Unicode macro otherwise. */
598
599
600     PERL_ARGS_ASSERT_ISFOO_UTF8_LC;
601
602     if (UTF8_IS_INVARIANT(*character)) {
603         return isFOO_lc(classnum, *character);
604     }
605     else if (UTF8_IS_DOWNGRADEABLE_START(*character)) {
606         return isFOO_lc(classnum,
607                         EIGHT_BIT_UTF8_TO_NATIVE(*character, *(character + 1)));
608     }
609
610     _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(character, e);
611
612     switch ((char_class_number_) classnum) {
613         case CC_ENUM_SPACE_:     return is_XPERLSPACE_high(character);
614         case CC_ENUM_BLANK_:     return is_HORIZWS_high(character);
615         case CC_ENUM_XDIGIT_:    return is_XDIGIT_high(character);
616         case CC_ENUM_VERTSPACE_: return is_VERTWS_high(character);
617         default:
618             return _invlist_contains_cp(PL_XPosix_ptrs[classnum],
619                                         utf8_to_uvchr_buf(character, e, NULL));
620     }
621     NOT_REACHED; /* NOTREACHED */
622 }
623
624 STATIC U8 *
625 S_find_span_end(U8 * s, const U8 * send, const U8 span_byte)
626 {
627     /* Returns the position of the first byte in the sequence between 's' and
628      * 'send-1' inclusive that isn't 'span_byte'; returns 'send' if none found.
629      * */
630
631     PERL_ARGS_ASSERT_FIND_SPAN_END;
632
633     assert(send >= s);
634
635     if ((STRLEN) (send - s) >= PERL_WORDSIZE
636                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(s)
637                           - (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK))
638     {
639         PERL_UINTMAX_T span_word;
640
641         /* Process per-byte until reach word boundary.  XXX This loop could be
642          * eliminated if we knew that this platform had fast unaligned reads */
643         while (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK) {
644             if (*s != span_byte) {
645                 return s;
646             }
647             s++;
648         }
649
650         /* Create a word filled with the bytes we are spanning */
651         span_word = PERL_COUNT_MULTIPLIER * span_byte;
652
653         /* Process per-word as long as we have at least a full word left */
654         do {
655
656             /* Keep going if the whole word is composed of 'span_byte's */
657             if ((* (PERL_UINTMAX_T *) s) == span_word)  {
658                 s += PERL_WORDSIZE;
659                 continue;
660             }
661
662             /* Here, at least one byte in the word isn't 'span_byte'. */
663
664 #ifdef EBCDIC
665
666             break;
667
668 #else
669
670             /* This xor leaves 1 bits only in those non-matching bytes */
671             span_word ^= * (PERL_UINTMAX_T *) s;
672
673             /* Make sure the upper bit of each non-matching byte is set.  This
674              * makes each such byte look like an ASCII platform variant byte */
675             span_word |= span_word << 1;
676             span_word |= span_word << 2;
677             span_word |= span_word << 4;
678
679             /* That reduces the problem to what this function solves */
680             return s + variant_byte_number(span_word);
681
682 #endif
683
684         } while (s + PERL_WORDSIZE <= send);
685     }
686
687     /* Process the straggler bytes beyond the final word boundary */
688     while (s < send) {
689         if (*s != span_byte) {
690             return s;
691         }
692         s++;
693     }
694
695     return s;
696 }
697
698 STATIC U8 *
699 S_find_next_masked(U8 * s, const U8 * send, const U8 byte, const U8 mask)
700 {
701     /* Returns the position of the first byte in the sequence between 's'
702      * and 'send-1' inclusive that when ANDed with 'mask' yields 'byte';
703      * returns 'send' if none found.  It uses word-level operations instead of
704      * byte to speed up the process */
705
706     PERL_ARGS_ASSERT_FIND_NEXT_MASKED;
707
708     assert(send >= s);
709     assert((byte & mask) == byte);
710
711 #ifndef EBCDIC
712
713     if ((STRLEN) (send - s) >= PERL_WORDSIZE
714                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(s)
715                           - (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK))
716     {
717         PERL_UINTMAX_T word, mask_word;
718
719         while (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK) {
720             if (((*s) & mask) == byte) {
721                 return s;
722             }
723             s++;
724         }
725
726         word      = PERL_COUNT_MULTIPLIER * byte;
727         mask_word = PERL_COUNT_MULTIPLIER * mask;
728
729         do {
730             PERL_UINTMAX_T masked = (* (PERL_UINTMAX_T *) s) & mask_word;
731
732             /* If 'masked' contains bytes with the bit pattern of 'byte' within
733              * it, xoring with 'word' will leave each of the 8 bits in such
734              * bytes be 0, and no byte containing any other bit pattern will be
735              * 0. */
736             masked ^= word;
737
738             /* This causes the most significant bit to be set to 1 for any
739              * bytes in the word that aren't completely 0 */
740             masked |= masked << 1;
741             masked |= masked << 2;
742             masked |= masked << 4;
743
744             /* The msbits are the same as what marks a byte as variant, so we
745              * can use this mask.  If all msbits are 1, the word doesn't
746              * contain 'byte' */
747             if ((masked & PERL_VARIANTS_WORD_MASK) == PERL_VARIANTS_WORD_MASK) {
748                 s += PERL_WORDSIZE;
749                 continue;
750             }
751
752             /* Here, the msbit of bytes in the word that aren't 'byte' are 1,
753              * and any that are, are 0.  Complement and re-AND to swap that */
754             masked = ~ masked;
755             masked &= PERL_VARIANTS_WORD_MASK;
756
757             /* This reduces the problem to that solved by this function */
758             s += variant_byte_number(masked);
759             return s;
760
761         } while (s + PERL_WORDSIZE <= send);
762     }
763
764 #endif
765
766     while (s < send) {
767         if (((*s) & mask) == byte) {
768             return s;
769         }
770         s++;
771     }
772
773     return s;
774 }
775
776 STATIC U8 *
777 S_find_span_end_mask(U8 * s, const U8 * send, const U8 span_byte, const U8 mask)
778 {
779     /* Returns the position of the first byte in the sequence between 's' and
780      * 'send-1' inclusive that when ANDed with 'mask' isn't 'span_byte'.
781      * 'span_byte' should have been ANDed with 'mask' in the call of this
782      * function.  Returns 'send' if none found.  Works like find_span_end(),
783      * except for the AND */
784
785     PERL_ARGS_ASSERT_FIND_SPAN_END_MASK;
786
787     assert(send >= s);
788     assert((span_byte & mask) == span_byte);
789
790     if ((STRLEN) (send - s) >= PERL_WORDSIZE
791                           + PERL_WORDSIZE * PERL_IS_SUBWORD_ADDR(s)
792                           - (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK))
793     {
794         PERL_UINTMAX_T span_word, mask_word;
795
796         while (PTR2nat(s) & PERL_WORD_BOUNDARY_MASK) {
797             if (((*s) & mask) != span_byte) {
798                 return s;
799             }
800             s++;
801         }
802
803         span_word = PERL_COUNT_MULTIPLIER * span_byte;
804         mask_word = PERL_COUNT_MULTIPLIER * mask;
805
806         do {
807             PERL_UINTMAX_T masked = (* (PERL_UINTMAX_T *) s) & mask_word;
808
809             if (masked == span_word) {
810                 s += PERL_WORDSIZE;
811                 continue;
812             }
813
814 #ifdef EBCDIC
815
816             break;
817
818 #else
819
820             masked ^= span_word;
821             masked |= masked << 1;
822             masked |= masked << 2;
823             masked |= masked << 4;
824             return s + variant_byte_number(masked);
825
826 #endif
827
828         } while (s + PERL_WORDSIZE <= send);
829     }
830
831     while (s < send) {
832         if (((*s) & mask) != span_byte) {
833             return s;
834         }
835         s++;
836     }
837
838     return s;
839 }
840
841 /*
842  * pregexec and friends
843  */
844
845 #ifndef PERL_IN_XSUB_RE
846 /*
847  - pregexec - match a regexp against a string
848  */
849 I32
850 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, char *strend,
851          char *strbeg, SSize_t minend, SV *screamer, U32 nosave)
852 /* stringarg: the point in the string at which to begin matching */
853 /* strend:    pointer to null at end of string */
854 /* strbeg:    real beginning of string */
855 /* minend:    end of match must be >= minend bytes after stringarg. */
856 /* screamer:  SV being matched: only used for utf8 flag, pos() etc; string
857  *            itself is accessed via the pointers above */
858 /* nosave:    For optimizations. */
859 {
860     PERL_ARGS_ASSERT_PREGEXEC;
861
862     return
863         regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
864                       nosave ? 0 : REXEC_COPY_STR);
865 }
866 #endif
867
868
869
870 /* re_intuit_start():
871  *
872  * Based on some optimiser hints, try to find the earliest position in the
873  * string where the regex could match.
874  *
875  *   rx:     the regex to match against
876  *   sv:     the SV being matched: only used for utf8 flag; the string
877  *           itself is accessed via the pointers below. Note that on
878  *           something like an overloaded SV, SvPOK(sv) may be false
879  *           and the string pointers may point to something unrelated to
880  *           the SV itself.
881  *   strbeg: real beginning of string
882  *   strpos: the point in the string at which to begin matching
883  *   strend: pointer to the byte following the last char of the string
884  *   flags   currently unused; set to 0
885  *   data:   currently unused; set to NULL
886  *
887  * The basic idea of re_intuit_start() is to use some known information
888  * about the pattern, namely:
889  *
890  *   a) the longest known anchored substring (i.e. one that's at a
891  *      constant offset from the beginning of the pattern; but not
892  *      necessarily at a fixed offset from the beginning of the
893  *      string);
894  *   b) the longest floating substring (i.e. one that's not at a constant
895  *      offset from the beginning of the pattern);
896  *   c) Whether the pattern is anchored to the string; either
897  *      an absolute anchor: /^../, or anchored to \n: /^.../m,
898  *      or anchored to pos(): /\G/;
899  *   d) A start class: a real or synthetic character class which
900  *      represents which characters are legal at the start of the pattern;
901  *
902  * to either quickly reject the match, or to find the earliest position
903  * within the string at which the pattern might match, thus avoiding
904  * running the full NFA engine at those earlier locations, only to
905  * eventually fail and retry further along.
906  *
907  * Returns NULL if the pattern can't match, or returns the address within
908  * the string which is the earliest place the match could occur.
909  *
910  * The longest of the anchored and floating substrings is called 'check'
911  * and is checked first. The other is called 'other' and is checked
912  * second. The 'other' substring may not be present.  For example,
913  *
914  *    /(abc|xyz)ABC\d{0,3}DEFG/
915  *
916  * will have
917  *
918  *   check substr (float)    = "DEFG", offset 6..9 chars
919  *   other substr (anchored) = "ABC",  offset 3..3 chars
920  *   stclass = [ax]
921  *
922  * Be aware that during the course of this function, sometimes 'anchored'
923  * refers to a substring being anchored relative to the start of the
924  * pattern, and sometimes to the pattern itself being anchored relative to
925  * the string. For example:
926  *
927  *   /\dabc/:   "abc" is anchored to the pattern;
928  *   /^\dabc/:  "abc" is anchored to the pattern and the string;
929  *   /\d+abc/:  "abc" is anchored to neither the pattern nor the string;
930  *   /^\d+abc/: "abc" is anchored to neither the pattern nor the string,
931  *                    but the pattern is anchored to the string.
932  */
933
934 char *
935 Perl_re_intuit_start(pTHX_
936                     REGEXP * const rx,
937                     SV *sv,
938                     const char * const strbeg,
939                     char *strpos,
940                     char *strend,
941                     const U32 flags,
942                     re_scream_pos_data *data)
943 {
944     struct regexp *const prog = ReANY(rx);
945     SSize_t start_shift = prog->check_offset_min;
946     /* Should be nonnegative! */
947     SSize_t end_shift   = 0;
948     /* current lowest pos in string where the regex can start matching */
949     char *rx_origin = strpos;
950     SV *check;
951     const bool utf8_target = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
952     U8   other_ix = 1 - prog->substrs->check_ix;
953     bool ml_anch = 0;
954     char *other_last = strpos;/* latest pos 'other' substr already checked to */
955     char *check_at = NULL;              /* check substr found at this pos */
956     const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
957     RXi_GET_DECL(prog,progi);
958     regmatch_info reginfo_buf;  /* create some info to pass to find_byclass */
959     regmatch_info *const reginfo = &reginfo_buf;
960     DECLARE_AND_GET_RE_DEBUG_FLAGS;
961
962     PERL_ARGS_ASSERT_RE_INTUIT_START;
963     PERL_UNUSED_ARG(flags);
964     PERL_UNUSED_ARG(data);
965
966     DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
967                 "Intuit: trying to determine minimum start position...\n"));
968
969     /* for now, assume that all substr offsets are positive. If at some point
970      * in the future someone wants to do clever things with lookbehind and
971      * -ve offsets, they'll need to fix up any code in this function
972      * which uses these offsets. See the thread beginning
973      * <20140113145929.GF27210@iabyn.com>
974      */
975     assert(prog->substrs->data[0].min_offset >= 0);
976     assert(prog->substrs->data[0].max_offset >= 0);
977     assert(prog->substrs->data[1].min_offset >= 0);
978     assert(prog->substrs->data[1].max_offset >= 0);
979     assert(prog->substrs->data[2].min_offset >= 0);
980     assert(prog->substrs->data[2].max_offset >= 0);
981
982     /* for now, assume that if both present, that the floating substring
983      * doesn't start before the anchored substring.
984      * If you break this assumption (e.g. doing better optimisations
985      * with lookahead/behind), then you'll need to audit the code in this
986      * function carefully first
987      */
988     assert(
989             ! (  (prog->anchored_utf8 || prog->anchored_substr)
990               && (prog->float_utf8    || prog->float_substr))
991            || (prog->float_min_offset >= prog->anchored_offset));
992
993     /* byte rather than char calculation for efficiency. It fails
994      * to quickly reject some cases that can't match, but will reject
995      * them later after doing full char arithmetic */
996     if (prog->minlen > strend - strpos) {
997         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
998                               "  String too short...\n"));
999         goto fail;
1000     }
1001
1002     RXp_MATCH_UTF8_set(prog, utf8_target);
1003     reginfo->is_utf8_target = cBOOL(utf8_target);
1004     reginfo->info_aux = NULL;
1005     reginfo->strbeg = strbeg;
1006     reginfo->strend = strend;
1007     reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx));
1008     reginfo->intuit = 1;
1009     /* not actually used within intuit, but zero for safety anyway */
1010     reginfo->poscache_maxiter = 0;
1011
1012     if (utf8_target) {
1013         if ((!prog->anchored_utf8 && prog->anchored_substr)
1014                 || (!prog->float_utf8 && prog->float_substr))
1015             to_utf8_substr(prog);
1016         check = prog->check_utf8;
1017     } else {
1018         if (!prog->check_substr && prog->check_utf8) {
1019             if (! to_byte_substr(prog)) {
1020                 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(fail);
1021             }
1022         }
1023         check = prog->check_substr;
1024     }
1025
1026     /* dump the various substring data */
1027     DEBUG_OPTIMISE_MORE_r({
1028         int i;
1029         for (i=0; i<=2; i++) {
1030             SV *sv = (utf8_target ? prog->substrs->data[i].utf8_substr
1031                                   : prog->substrs->data[i].substr);
1032             if (!sv)
1033                 continue;
1034
1035             Perl_re_printf( aTHX_
1036                 "  substrs[%d]: min=%" IVdf " max=%" IVdf " end shift=%" IVdf
1037                 " useful=%" IVdf " utf8=%d [%s]\n",
1038                 i,
1039                 (IV)prog->substrs->data[i].min_offset,
1040                 (IV)prog->substrs->data[i].max_offset,
1041                 (IV)prog->substrs->data[i].end_shift,
1042                 BmUSEFUL(sv),
1043                 utf8_target ? 1 : 0,
1044                 SvPEEK(sv));
1045         }
1046     });
1047
1048     if (prog->intflags & PREGf_ANCH) { /* Match at \G, beg-of-str or after \n */
1049
1050         /* ml_anch: check after \n?
1051          *
1052          * A note about PREGf_IMPLICIT: on an un-anchored pattern beginning
1053          * with /.*.../, these flags will have been added by the
1054          * compiler:
1055          *   /.*abc/, /.*abc/m:  PREGf_IMPLICIT | PREGf_ANCH_MBOL
1056          *   /.*abc/s:           PREGf_IMPLICIT | PREGf_ANCH_SBOL
1057          */
1058         ml_anch =      (prog->intflags & PREGf_ANCH_MBOL)
1059                    && !(prog->intflags & PREGf_IMPLICIT);
1060
1061         if (!ml_anch && !(prog->intflags & PREGf_IMPLICIT)) {
1062             /* we are only allowed to match at BOS or \G */
1063
1064             /* trivially reject if there's a BOS anchor and we're not at BOS.
1065              *
1066              * Note that we don't try to do a similar quick reject for
1067              * \G, since generally the caller will have calculated strpos
1068              * based on pos() and gofs, so the string is already correctly
1069              * anchored by definition; and handling the exceptions would
1070              * be too fiddly (e.g. REXEC_IGNOREPOS).
1071              */
1072             if (   strpos != strbeg
1073                 && (prog->intflags & PREGf_ANCH_SBOL))
1074             {
1075                 DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1076                                 "  Not at start...\n"));
1077                 goto fail;
1078             }
1079
1080             /* in the presence of an anchor, the anchored (relative to the
1081              * start of the regex) substr must also be anchored relative
1082              * to strpos. So quickly reject if substr isn't found there.
1083              * This works for \G too, because the caller will already have
1084              * subtracted gofs from pos, and gofs is the offset from the
1085              * \G to the start of the regex. For example, in /.abc\Gdef/,
1086              * where substr="abcdef", pos()=3, gofs=4, offset_min=1:
1087              * caller will have set strpos=pos()-4; we look for the substr
1088              * at position pos()-4+1, which lines up with the "a" */
1089
1090             if (prog->check_offset_min == prog->check_offset_max) {
1091                 /* Substring at constant offset from beg-of-str... */
1092                 SSize_t slen = SvCUR(check);
1093                 char *s = HOP3c(strpos, prog->check_offset_min, strend);
1094
1095                 DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1096                     "  Looking for check substr at fixed offset %" IVdf "...\n",
1097                     (IV)prog->check_offset_min));
1098
1099                 if (SvTAIL(check)) {
1100                     /* In this case, the regex is anchored at the end too.
1101                      * Unless it's a multiline match, the lengths must match
1102                      * exactly, give or take a \n.  NB: slen >= 1 since
1103                      * the last char of check is \n */
1104                     if (!multiline
1105                         && (   strend - s > slen
1106                             || strend - s < slen - 1
1107                             || (strend - s == slen && strend[-1] != '\n')))
1108                     {
1109                         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1110                                             "  String too long...\n"));
1111                         goto fail_finish;
1112                     }
1113                     /* Now should match s[0..slen-2] */
1114                     slen--;
1115                 }
1116                 if (slen && (strend - s < slen
1117                     || *SvPVX_const(check) != *s
1118                     || (slen > 1 && (memNE(SvPVX_const(check), s, slen)))))
1119                 {
1120                     DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1121                                     "  String not equal...\n"));
1122                     goto fail_finish;
1123                 }
1124
1125                 check_at = s;
1126                 goto success_at_start;
1127             }
1128         }
1129     }
1130
1131     end_shift = prog->check_end_shift;
1132
1133 #ifdef DEBUGGING        /* 7/99: reports of failure (with the older version) */
1134     if (end_shift < 0)
1135         Perl_croak(aTHX_ "panic: end_shift: %" IVdf " pattern:\n%s\n ",
1136                    (IV)end_shift, RX_PRECOMP(rx));
1137 #endif
1138
1139   restart:
1140
1141     /* This is the (re)entry point of the main loop in this function.
1142      * The goal of this loop is to:
1143      * 1) find the "check" substring in the region rx_origin..strend
1144      *    (adjusted by start_shift / end_shift). If not found, reject
1145      *    immediately.
1146      * 2) If it exists, look for the "other" substr too if defined; for
1147      *    example, if the check substr maps to the anchored substr, then
1148      *    check the floating substr, and vice-versa. If not found, go
1149      *    back to (1) with rx_origin suitably incremented.
1150      * 3) If we find an rx_origin position that doesn't contradict
1151      *    either of the substrings, then check the possible additional
1152      *    constraints on rx_origin of /^.../m or a known start class.
1153      *    If these fail, then depending on which constraints fail, jump
1154      *    back to here, or to various other re-entry points further along
1155      *    that skip some of the first steps.
1156      * 4) If we pass all those tests, update the BmUSEFUL() count on the
1157      *    substring. If the start position was determined to be at the
1158      *    beginning of the string  - so, not rejected, but not optimised,
1159      *    since we have to run regmatch from position 0 - decrement the
1160      *    BmUSEFUL() count. Otherwise increment it.
1161      */
1162
1163
1164     /* first, look for the 'check' substring */
1165
1166     {
1167         U8* start_point;
1168         U8* end_point;
1169
1170         DEBUG_OPTIMISE_MORE_r({
1171             Perl_re_printf( aTHX_
1172                 "  At restart: rx_origin=%" IVdf " Check offset min: %" IVdf
1173                 " Start shift: %" IVdf " End shift %" IVdf
1174                 " Real end Shift: %" IVdf "\n",
1175                 (IV)(rx_origin - strbeg),
1176                 (IV)prog->check_offset_min,
1177                 (IV)start_shift,
1178                 (IV)end_shift,
1179                 (IV)prog->check_end_shift);
1180         });
1181
1182         end_point = HOPBACK3(strend, end_shift, rx_origin);
1183         if (!end_point)
1184             goto fail_finish;
1185         start_point = HOPMAYBE3(rx_origin, start_shift, end_point);
1186         if (!start_point)
1187             goto fail_finish;
1188
1189
1190         /* If the regex is absolutely anchored to either the start of the
1191          * string (SBOL) or to pos() (ANCH_GPOS), then
1192          * check_offset_max represents an upper bound on the string where
1193          * the substr could start. For the ANCH_GPOS case, we assume that
1194          * the caller of intuit will have already set strpos to
1195          * pos()-gofs, so in this case strpos + offset_max will still be
1196          * an upper bound on the substr.
1197          */
1198         if (!ml_anch
1199             && prog->intflags & PREGf_ANCH
1200             && prog->check_offset_max != SSize_t_MAX)
1201         {
1202             SSize_t check_len = SvCUR(check) - cBOOL(SvTAIL(check));
1203             const char * const anchor =
1204                         (prog->intflags & PREGf_ANCH_GPOS ? strpos : strbeg);
1205             SSize_t targ_len = (char*)end_point - anchor;
1206
1207             if (check_len > targ_len) {
1208                 DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1209                               "Target string too short to match required substring...\n"));
1210                 goto fail_finish;
1211             }
1212
1213             /* do a bytes rather than chars comparison. It's conservative;
1214              * so it skips doing the HOP if the result can't possibly end
1215              * up earlier than the old value of end_point.
1216              */
1217             assert(anchor + check_len <= (char *)end_point);
1218             if (prog->check_offset_max + check_len < targ_len) {
1219                 end_point = HOP3lim((U8*)anchor,
1220                                 prog->check_offset_max,
1221                                 end_point - check_len
1222                             )
1223                             + check_len;
1224                 if (end_point < start_point)
1225                     goto fail_finish;
1226             }
1227         }
1228
1229         check_at = fbm_instr( start_point, end_point,
1230                       check, multiline ? FBMrf_MULTILINE : 0);
1231
1232         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1233             "  doing 'check' fbm scan, [%" IVdf "..%" IVdf "] gave %" IVdf "\n",
1234             (IV)((char*)start_point - strbeg),
1235             (IV)((char*)end_point   - strbeg),
1236             (IV)(check_at ? check_at - strbeg : -1)
1237         ));
1238
1239         /* Update the count-of-usability, remove useless subpatterns,
1240             unshift s.  */
1241
1242         DEBUG_EXECUTE_r({
1243             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
1244                 SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
1245             Perl_re_printf( aTHX_  "  %s %s substr %s%s%s",
1246                               (check_at ? "Found" : "Did not find"),
1247                 (check == (utf8_target ? prog->anchored_utf8 : prog->anchored_substr)
1248                     ? "anchored" : "floating"),
1249                 quoted,
1250                 RE_SV_TAIL(check),
1251                 (check_at ? " at offset " : "...\n") );
1252         });
1253
1254         if (!check_at)
1255             goto fail_finish;
1256         /* set rx_origin to the minimum position where the regex could start
1257          * matching, given the constraint of the just-matched check substring.
1258          * But don't set it lower than previously.
1259          */
1260
1261         if (check_at - rx_origin > prog->check_offset_max)
1262             rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin);
1263         /* Finish the diagnostic message */
1264         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1265             "%ld (rx_origin now %" IVdf ")...\n",
1266             (long)(check_at - strbeg),
1267             (IV)(rx_origin - strbeg)
1268         ));
1269     }
1270
1271
1272     /* now look for the 'other' substring if defined */
1273
1274     if (prog->substrs->data[other_ix].utf8_substr
1275         || prog->substrs->data[other_ix].substr)
1276     {
1277         /* Take into account the "other" substring. */
1278         char *last, *last1;
1279         char *s;
1280         SV* must;
1281         struct reg_substr_datum *other;
1282
1283       do_other_substr:
1284         other = &prog->substrs->data[other_ix];
1285         if (!utf8_target && !other->substr) {
1286             if (!to_byte_substr(prog)) {
1287                 NON_UTF8_TARGET_BUT_UTF8_REQUIRED(fail);
1288             }
1289         }
1290
1291         /* if "other" is anchored:
1292          * we've previously found a floating substr starting at check_at.
1293          * This means that the regex origin must lie somewhere
1294          * between min (rx_origin): HOP3(check_at, -check_offset_max)
1295          * and max:                 HOP3(check_at, -check_offset_min)
1296          * (except that min will be >= strpos)
1297          * So the fixed  substr must lie somewhere between
1298          *  HOP3(min, anchored_offset)
1299          *  HOP3(max, anchored_offset) + SvCUR(substr)
1300          */
1301
1302         /* if "other" is floating
1303          * Calculate last1, the absolute latest point where the
1304          * floating substr could start in the string, ignoring any
1305          * constraints from the earlier fixed match. It is calculated
1306          * as follows:
1307          *
1308          * strend - prog->minlen (in chars) is the absolute latest
1309          * position within the string where the origin of the regex
1310          * could appear. The latest start point for the floating
1311          * substr is float_min_offset(*) on from the start of the
1312          * regex.  last1 simply combines thee two offsets.
1313          *
1314          * (*) You might think the latest start point should be
1315          * float_max_offset from the regex origin, and technically
1316          * you'd be correct. However, consider
1317          *    /a\d{2,4}bcd\w/
1318          * Here, float min, max are 3,5 and minlen is 7.
1319          * This can match either
1320          *    /a\d\dbcd\w/
1321          *    /a\d\d\dbcd\w/
1322          *    /a\d\d\d\dbcd\w/
1323          * In the first case, the regex matches minlen chars; in the
1324          * second, minlen+1, in the third, minlen+2.
1325          * In the first case, the floating offset is 3 (which equals
1326          * float_min), in the second, 4, and in the third, 5 (which
1327          * equals float_max). In all cases, the floating string bcd
1328          * can never start more than 4 chars from the end of the
1329          * string, which equals minlen - float_min. As the substring
1330          * starts to match more than float_min from the start of the
1331          * regex, it makes the regex match more than minlen chars,
1332          * and the two cancel each other out. So we can always use
1333          * float_min - minlen, rather than float_max - minlen for the
1334          * latest position in the string.
1335          *
1336          * Note that -minlen + float_min_offset is equivalent (AFAIKT)
1337          * to CHR_SVLEN(must) - !!SvTAIL(must) + prog->float_end_shift
1338          */
1339
1340         assert(prog->minlen >= other->min_offset);
1341         last1 = HOP3c(strend,
1342                         other->min_offset - prog->minlen, strbeg);
1343
1344         if (other_ix) {/* i.e. if (other-is-float) */
1345             /* last is the latest point where the floating substr could
1346              * start, *given* any constraints from the earlier fixed
1347              * match. This constraint is that the floating string starts
1348              * <= float_max_offset chars from the regex origin (rx_origin).
1349              * If this value is less than last1, use it instead.
1350              */
1351             assert(rx_origin <= last1);
1352             last =
1353                 /* this condition handles the offset==infinity case, and
1354                  * is a short-cut otherwise. Although it's comparing a
1355                  * byte offset to a char length, it does so in a safe way,
1356                  * since 1 char always occupies 1 or more bytes,
1357                  * so if a string range is  (last1 - rx_origin) bytes,
1358                  * it will be less than or equal to  (last1 - rx_origin)
1359                  * chars; meaning it errs towards doing the accurate HOP3
1360                  * rather than just using last1 as a short-cut */
1361                 (last1 - rx_origin) < other->max_offset
1362                     ? last1
1363                     : (char*)HOP3lim(rx_origin, other->max_offset, last1);
1364         }
1365         else {
1366             assert(strpos + start_shift <= check_at);
1367             last = HOP4c(check_at, other->min_offset - start_shift,
1368                         strbeg, strend);
1369         }
1370
1371         s = HOP3c(rx_origin, other->min_offset, strend);
1372         if (s < other_last)     /* These positions already checked */
1373             s = other_last;
1374
1375         must = utf8_target ? other->utf8_substr : other->substr;
1376         assert(SvPOK(must));
1377         {
1378             char *from = s;
1379             char *to   = last + SvCUR(must) - (SvTAIL(must)!=0);
1380
1381             if (to > strend)
1382                 to = strend;
1383             if (from > to) {
1384                 s = NULL;
1385                 DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1386                     "  skipping 'other' fbm scan: %" IVdf " > %" IVdf "\n",
1387                     (IV)(from - strbeg),
1388                     (IV)(to   - strbeg)
1389                 ));
1390             }
1391             else {
1392                 s = fbm_instr(
1393                     (unsigned char*)from,
1394                     (unsigned char*)to,
1395                     must,
1396                     multiline ? FBMrf_MULTILINE : 0
1397                 );
1398                 DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1399                     "  doing 'other' fbm scan, [%" IVdf "..%" IVdf "] gave %" IVdf "\n",
1400                     (IV)(from - strbeg),
1401                     (IV)(to   - strbeg),
1402                     (IV)(s ? s - strbeg : -1)
1403                 ));
1404             }
1405         }
1406
1407         DEBUG_EXECUTE_r({
1408             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
1409                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1410             Perl_re_printf( aTHX_  "  %s %s substr %s%s",
1411                 s ? "Found" : "Contradicts",
1412                 other_ix ? "floating" : "anchored",
1413                 quoted, RE_SV_TAIL(must));
1414         });
1415
1416
1417         if (!s) {
1418             /* last1 is latest possible substr location. If we didn't
1419              * find it before there, we never will */
1420             if (last >= last1) {
1421                 DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1422                                         "; giving up...\n"));
1423                 goto fail_finish;
1424             }
1425
1426             /* try to find the check substr again at a later
1427              * position. Maybe next time we'll find the "other" substr
1428              * in range too */
1429             other_last = HOP3c(last, 1, strend) /* highest failure */;
1430             rx_origin =
1431                 other_ix /* i.e. if other-is-float */
1432                     ? HOP3c(rx_origin, 1, strend)
1433                     : HOP4c(last, 1 - other->min_offset, strbeg, strend);
1434             DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1435                 "; about to retry %s at offset %ld (rx_origin now %" IVdf ")...\n",
1436                 (other_ix ? "floating" : "anchored"),
1437                 (long)(HOP3c(check_at, 1, strend) - strbeg),
1438                 (IV)(rx_origin - strbeg)
1439             ));
1440             goto restart;
1441         }
1442         else {
1443             if (other_ix) { /* if (other-is-float) */
1444                 /* other_last is set to s, not s+1, since its possible for
1445                  * a floating substr to fail first time, then succeed
1446                  * second time at the same floating position; e.g.:
1447                  *     "-AB--AABZ" =~ /\wAB\d*Z/
1448                  * The first time round, anchored and float match at
1449                  * "-(AB)--AAB(Z)" then fail on the initial \w character
1450                  * class. Second time round, they match at "-AB--A(AB)(Z)".
1451                  */
1452                 other_last = s;
1453             }
1454             else {
1455                 rx_origin = HOP3c(s, -other->min_offset, strbeg);
1456                 other_last = HOP3c(s, 1, strend);
1457             }
1458             DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1459                 " at offset %ld (rx_origin now %" IVdf ")...\n",
1460                   (long)(s - strbeg),
1461                 (IV)(rx_origin - strbeg)
1462               ));
1463
1464         }
1465     }
1466     else {
1467         DEBUG_OPTIMISE_MORE_r(
1468             Perl_re_printf( aTHX_
1469                 "  Check-only match: offset min:%" IVdf " max:%" IVdf
1470                 " check_at:%" IVdf " rx_origin:%" IVdf " rx_origin-check_at:%" IVdf
1471                 " strend:%" IVdf "\n",
1472                 (IV)prog->check_offset_min,
1473                 (IV)prog->check_offset_max,
1474                 (IV)(check_at-strbeg),
1475                 (IV)(rx_origin-strbeg),
1476                 (IV)(rx_origin-check_at),
1477                 (IV)(strend-strbeg)
1478             )
1479         );
1480     }
1481
1482   postprocess_substr_matches:
1483
1484     /* handle the extra constraint of /^.../m if present */
1485
1486     if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') {
1487         char *s;
1488
1489         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1490                         "  looking for /^/m anchor"));
1491
1492         /* we have failed the constraint of a \n before rx_origin.
1493          * Find the next \n, if any, even if it's beyond the current
1494          * anchored and/or floating substrings. Whether we should be
1495          * scanning ahead for the next \n or the next substr is debatable.
1496          * On the one hand you'd expect rare substrings to appear less
1497          * often than \n's. On the other hand, searching for \n means
1498          * we're effectively flipping between check_substr and "\n" on each
1499          * iteration as the current "rarest" candidate string, which
1500          * means for example that we'll quickly reject the whole string if
1501          * hasn't got a \n, rather than trying every substr position
1502          * first
1503          */
1504
1505         s = HOP3c(strend, - prog->minlen, strpos);
1506         if (s <= rx_origin ||
1507             ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin)))
1508         {
1509             DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1510                             "  Did not find /%s^%s/m...\n",
1511                             PL_colors[0], PL_colors[1]));
1512             goto fail_finish;
1513         }
1514
1515         /* earliest possible origin is 1 char after the \n.
1516          * (since *rx_origin == '\n', it's safe to ++ here rather than
1517          * HOP(rx_origin, 1)) */
1518         rx_origin++;
1519
1520         if (prog->substrs->check_ix == 0  /* check is anchored */
1521             || rx_origin >= HOP3c(check_at,  - prog->check_offset_min, strpos))
1522         {
1523             /* Position contradicts check-string; either because
1524              * check was anchored (and thus has no wiggle room),
1525              * or check was float and rx_origin is above the float range */
1526             DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1527                 "  Found /%s^%s/m, about to restart lookup for check-string with rx_origin %ld...\n",
1528                 PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)));
1529             goto restart;
1530         }
1531
1532         /* if we get here, the check substr must have been float,
1533          * is in range, and we may or may not have had an anchored
1534          * "other" substr which still contradicts */
1535         assert(prog->substrs->check_ix); /* check is float */
1536
1537         if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
1538             /* whoops, the anchored "other" substr exists, so we still
1539              * contradict. On the other hand, the float "check" substr
1540              * didn't contradict, so just retry the anchored "other"
1541              * substr */
1542             DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1543                 "  Found /%s^%s/m, rescanning for anchored from offset %" IVdf " (rx_origin now %" IVdf ")...\n",
1544                 PL_colors[0], PL_colors[1],
1545                 (IV)(rx_origin - strbeg + prog->anchored_offset),
1546                 (IV)(rx_origin - strbeg)
1547             ));
1548             goto do_other_substr;
1549         }
1550
1551         /* success: we don't contradict the found floating substring
1552          * (and there's no anchored substr). */
1553         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1554             "  Found /%s^%s/m with rx_origin %ld...\n",
1555             PL_colors[0], PL_colors[1], (long)(rx_origin - strbeg)));
1556     }
1557     else {
1558         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1559             "  (multiline anchor test skipped)\n"));
1560     }
1561
1562   success_at_start:
1563
1564
1565     /* if we have a starting character class, then test that extra constraint.
1566      * (trie stclasses are too expensive to use here, we are better off to
1567      * leave it to regmatch itself) */
1568
1569     if (progi->regstclass && REGNODE_TYPE(OP(progi->regstclass))!=TRIE) {
1570         const U8* const str = (U8*)STRING(progi->regstclass);
1571
1572         /* XXX this value could be pre-computed */
1573         const SSize_t cl_l = (REGNODE_TYPE(OP(progi->regstclass)) == EXACT
1574                     ?  (reginfo->is_utf8_pat
1575                         ? (SSize_t)utf8_distance(str + STR_LEN(progi->regstclass), str)
1576                         : (SSize_t)STR_LEN(progi->regstclass))
1577                     : 1);
1578         char * endpos;
1579         char *s;
1580         /* latest pos that a matching float substr constrains rx start to */
1581         char *rx_max_float = NULL;
1582
1583         /* if the current rx_origin is anchored, either by satisfying an
1584          * anchored substring constraint, or a /^.../m constraint, then we
1585          * can reject the current origin if the start class isn't found
1586          * at the current position. If we have a float-only match, then
1587          * rx_origin is constrained to a range; so look for the start class
1588          * in that range. if neither, then look for the start class in the
1589          * whole rest of the string */
1590
1591         /* XXX DAPM it's not clear what the minlen test is for, and why
1592          * it's not used in the floating case. Nothing in the test suite
1593          * causes minlen == 0 here. See <20140313134639.GS12844@iabyn.com>.
1594          * Here are some old comments, which may or may not be correct:
1595          *
1596          *   minlen == 0 is possible if regstclass is \b or \B,
1597          *   and the fixed substr is ''$.
1598          *   Since minlen is already taken into account, rx_origin+1 is
1599          *   before strend; accidentally, minlen >= 1 guaranties no false
1600          *   positives at rx_origin + 1 even for \b or \B.  But (minlen? 1 :
1601          *   0) below assumes that regstclass does not come from lookahead...
1602          *   If regstclass takes bytelength more than 1: If charlength==1, OK.
1603          *   This leaves EXACTF-ish only, which are dealt with in
1604          *   find_byclass().
1605          */
1606
1607         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1608             endpos = HOP3clim(rx_origin, (prog->minlen ? cl_l : 0), strend);
1609         else if (prog->float_substr || prog->float_utf8) {
1610             rx_max_float = HOP3c(check_at, -start_shift, strbeg);
1611             endpos = HOP3clim(rx_max_float, cl_l, strend);
1612         }
1613         else
1614             endpos= strend;
1615
1616         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1617             "  looking for class: start_shift: %" IVdf " check_at: %" IVdf
1618             " rx_origin: %" IVdf " endpos: %" IVdf "\n",
1619               (IV)start_shift, (IV)(check_at - strbeg),
1620               (IV)(rx_origin - strbeg), (IV)(endpos - strbeg)));
1621
1622         s = find_byclass(prog, progi->regstclass, rx_origin, endpos,
1623                             reginfo);
1624         if (!s) {
1625             if (endpos == strend) {
1626                 DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
1627                                 "  Could not match STCLASS...\n") );
1628                 goto fail;
1629             }
1630             DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
1631                                "  This position contradicts STCLASS...\n") );
1632             if ((prog->intflags & PREGf_ANCH) && !ml_anch
1633                         && !(prog->intflags & PREGf_IMPLICIT))
1634                 goto fail;
1635
1636             /* Contradict one of substrings */
1637             if (prog->anchored_substr || prog->anchored_utf8) {
1638                 if (prog->substrs->check_ix == 1) { /* check is float */
1639                     /* Have both, check_string is floating */
1640                     assert(rx_origin + start_shift <= check_at);
1641                     if (rx_origin + start_shift != check_at) {
1642                         /* not at latest position float substr could match:
1643                          * Recheck anchored substring, but not floating.
1644                          * The condition above is in bytes rather than
1645                          * chars for efficiency. It's conservative, in
1646                          * that it errs on the side of doing 'goto
1647                          * do_other_substr'. In this case, at worst,
1648                          * an extra anchored search may get done, but in
1649                          * practice the extra fbm_instr() is likely to
1650                          * get skipped anyway. */
1651                         DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
1652                             "  about to retry anchored at offset %ld (rx_origin now %" IVdf ")...\n",
1653                             (long)(other_last - strbeg),
1654                             (IV)(rx_origin - strbeg)
1655                         ));
1656                         goto do_other_substr;
1657                     }
1658                 }
1659             }
1660             else {
1661                 /* float-only */
1662
1663                 if (ml_anch) {
1664                     /* In the presence of ml_anch, we might be able to
1665                      * find another \n without breaking the current float
1666                      * constraint. */
1667
1668                     /* strictly speaking this should be HOP3c(..., 1, ...),
1669                      * but since we goto a block of code that's going to
1670                      * search for the next \n if any, its safe here */
1671                     rx_origin++;
1672                     DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
1673                               "  about to look for /%s^%s/m starting at rx_origin %ld...\n",
1674                               PL_colors[0], PL_colors[1],
1675                               (long)(rx_origin - strbeg)) );
1676                     goto postprocess_substr_matches;
1677                 }
1678
1679                 /* strictly speaking this can never be true; but might
1680                  * be if we ever allow intuit without substrings */
1681                 if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
1682                     goto fail;
1683
1684                 rx_origin = rx_max_float;
1685             }
1686
1687             /* at this point, any matching substrings have been
1688              * contradicted. Start again... */
1689
1690             rx_origin = HOP3c(rx_origin, 1, strend);
1691
1692             /* uses bytes rather than char calculations for efficiency.
1693              * It's conservative: it errs on the side of doing 'goto restart',
1694              * where there is code that does a proper char-based test */
1695             if (rx_origin + start_shift + end_shift > strend) {
1696                 DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
1697                                        "  Could not match STCLASS...\n") );
1698                 goto fail;
1699             }
1700             DEBUG_EXECUTE_r( Perl_re_printf( aTHX_
1701                 "  about to look for %s substr starting at offset %ld (rx_origin now %" IVdf ")...\n",
1702                 (prog->substrs->check_ix ? "floating" : "anchored"),
1703                 (long)(rx_origin + start_shift - strbeg),
1704                 (IV)(rx_origin - strbeg)
1705             ));
1706             goto restart;
1707         }
1708
1709         /* Success !!! */
1710
1711         if (rx_origin != s) {
1712             DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1713                         "  By STCLASS: moving %ld --> %ld\n",
1714                                   (long)(rx_origin - strbeg), (long)(s - strbeg))
1715                    );
1716         }
1717         else {
1718             DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1719                                   "  Does not contradict STCLASS...\n");
1720                    );
1721         }
1722     }
1723
1724     /* Decide whether using the substrings helped */
1725
1726     if (rx_origin != strpos) {
1727         /* Fixed substring is found far enough so that the match
1728            cannot start at strpos. */
1729
1730         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_  "  try at offset...\n"));
1731         ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr);        /* hooray/5 */
1732     }
1733     else {
1734         /* The found rx_origin position does not prohibit matching at
1735          * strpos, so calling intuit didn't gain us anything. Decrement
1736          * the BmUSEFUL() count on the check substring, and if we reach
1737          * zero, free it.  */
1738         if (!(prog->intflags & PREGf_NAUGHTY)
1739             && (utf8_target ? (
1740                 prog->check_utf8                /* Could be deleted already */
1741                 && --BmUSEFUL(prog->check_utf8) < 0
1742                 && (prog->check_utf8 == prog->float_utf8)
1743             ) : (
1744                 prog->check_substr              /* Could be deleted already */
1745                 && --BmUSEFUL(prog->check_substr) < 0
1746                 && (prog->check_substr == prog->float_substr)
1747             )))
1748         {
1749             /* If flags & SOMETHING - do not do it many times on the same match */
1750             DEBUG_EXECUTE_r(Perl_re_printf( aTHX_  "  ... Disabling check substring...\n"));
1751             /* XXX Does the destruction order has to change with utf8_target? */
1752             SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
1753             SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
1754             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
1755             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
1756             check = NULL;                       /* abort */
1757             /* XXXX This is a remnant of the old implementation.  It
1758                     looks wasteful, since now INTUIT can use many
1759                     other heuristics. */
1760             prog->extflags &= ~RXf_USE_INTUIT;
1761         }
1762     }
1763
1764     DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
1765             "Intuit: %sSuccessfully guessed:%s match at offset %ld\n",
1766              PL_colors[4], PL_colors[5], (long)(rx_origin - strbeg)) );
1767
1768     return rx_origin;
1769
1770   fail_finish:                          /* Substring not found */
1771     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
1772         BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1773   fail:
1774     DEBUG_EXECUTE_r(Perl_re_printf( aTHX_  "%sMatch rejected by optimizer%s\n",
1775                           PL_colors[4], PL_colors[5]));
1776     return NULL;
1777 }
1778
1779
1780 #define DECL_TRIE_TYPE(scan) \
1781     const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold,       \
1782                  trie_utf8_exactfa_fold, trie_latin_utf8_exactfa_fold,              \
1783                  trie_utf8l, trie_flu8, trie_flu8_latin }                           \
1784                     trie_type = ((FLAGS(scan) == EXACT)                             \
1785                                  ? (utf8_target ? trie_utf8 : trie_plain)           \
1786                                  : (FLAGS(scan) == EXACTL)                          \
1787                                     ? (utf8_target ? trie_utf8l : trie_plain)       \
1788                                     : (FLAGS(scan) == EXACTFAA)                     \
1789                                       ? (utf8_target                                \
1790                                          ? trie_utf8_exactfa_fold                   \
1791                                          : trie_latin_utf8_exactfa_fold)            \
1792                                       : (FLAGS(scan) == EXACTFLU8                   \
1793                                          ? (utf8_target                             \
1794                                            ? trie_flu8                              \
1795                                            : trie_flu8_latin)                       \
1796                                          : (utf8_target                             \
1797                                            ? trie_utf8_fold                         \
1798                                            : trie_latin_utf8_fold)))
1799
1800 /* 'uscan' is set to foldbuf, and incremented, so below the end of uscan is
1801  * 'foldbuf+sizeof(foldbuf)' */
1802 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uc_end, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \
1803 STMT_START {                                                                        \
1804     STRLEN skiplen;                                                                 \
1805     U8 flags = FOLD_FLAGS_FULL;                                                     \
1806     switch (trie_type) {                                                            \
1807     case trie_flu8:                                                                 \
1808         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;                                         \
1809         if (UTF8_IS_ABOVE_LATIN1(*uc)) {                                            \
1810             _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end);                     \
1811         }                                                                           \
1812         goto do_trie_utf8_fold;                                                     \
1813     case trie_utf8_exactfa_fold:                                                    \
1814         flags |= FOLD_FLAGS_NOMIX_ASCII;                                            \
1815         /* FALLTHROUGH */                                                           \
1816     case trie_utf8_fold:                                                            \
1817       do_trie_utf8_fold:                                                            \
1818         if ( foldlen>0 ) {                                                          \
1819             uvc = utf8n_to_uvchr( (const U8*) uscan, foldlen, &len, uniflags );     \
1820             foldlen -= len;                                                         \
1821             uscan += len;                                                           \
1822             len=0;                                                                  \
1823         } else {                                                                    \
1824             uvc = _toFOLD_utf8_flags( (const U8*) uc, uc_end, foldbuf, &foldlen,    \
1825                                                                             flags); \
1826             len = UTF8_SAFE_SKIP(uc, uc_end);                                       \
1827             skiplen = UVCHR_SKIP( uvc );                                            \
1828             foldlen -= skiplen;                                                     \
1829             uscan = foldbuf + skiplen;                                              \
1830         }                                                                           \
1831         break;                                                                      \
1832     case trie_flu8_latin:                                                           \
1833         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;                                         \
1834         goto do_trie_latin_utf8_fold;                                               \
1835     case trie_latin_utf8_exactfa_fold:                                              \
1836         flags |= FOLD_FLAGS_NOMIX_ASCII;                                            \
1837         /* FALLTHROUGH */                                                           \
1838     case trie_latin_utf8_fold:                                                      \
1839       do_trie_latin_utf8_fold:                                                      \
1840         if ( foldlen>0 ) {                                                          \
1841             uvc = utf8n_to_uvchr( (const U8*) uscan, foldlen, &len, uniflags );     \
1842             foldlen -= len;                                                         \
1843             uscan += len;                                                           \
1844             len=0;                                                                  \
1845         } else {                                                                    \
1846             len = 1;                                                                \
1847             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, flags);             \
1848             skiplen = UVCHR_SKIP( uvc );                                            \
1849             foldlen -= skiplen;                                                     \
1850             uscan = foldbuf + skiplen;                                              \
1851         }                                                                           \
1852         break;                                                                      \
1853     case trie_utf8l:                                                                \
1854         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;                                         \
1855         if (utf8_target && UTF8_IS_ABOVE_LATIN1(*uc)) {                             \
1856             _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc_end);                     \
1857         }                                                                           \
1858         /* FALLTHROUGH */                                                           \
1859     case trie_utf8:                                                                 \
1860         uvc = utf8n_to_uvchr( (const U8*) uc, uc_end - uc, &len, uniflags );        \
1861         break;                                                                      \
1862     case trie_plain:                                                                \
1863         uvc = (UV)*uc;                                                              \
1864         len = 1;                                                                    \
1865     }                                                                               \
1866     if (uvc < 256) {                                                                \
1867         charid = trie->charmap[ uvc ];                                              \
1868     }                                                                               \
1869     else {                                                                          \
1870         charid = 0;                                                                 \
1871         if (widecharmap) {                                                          \
1872             SV** const svpp = hv_fetch(widecharmap,                                 \
1873                         (char*)&uvc, sizeof(UV), 0);                                \
1874             if (svpp)                                                               \
1875                 charid = (U16)SvIV(*svpp);                                          \
1876         }                                                                           \
1877     }                                                                               \
1878 } STMT_END
1879
1880 #define DUMP_EXEC_POS(li,s,doutf8,depth)                    \
1881     dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \
1882                 startpos, doutf8, depth)
1883
1884 #define GET_ANYOFH_INVLIST(prog, n)                                         \
1885                         GET_REGCLASS_AUX_DATA(prog, n, TRUE, 0, NULL, NULL)
1886
1887 #define REXEC_FBC_UTF8_SCAN(CODE)                           \
1888     STMT_START {                                            \
1889         while (s < strend) {                                \
1890             CODE                                            \
1891             s += UTF8_SAFE_SKIP(s, reginfo->strend);        \
1892         }                                                   \
1893     } STMT_END
1894
1895 #define REXEC_FBC_NON_UTF8_SCAN(CODE)                       \
1896     STMT_START {                                            \
1897         while (s < strend) {                                \
1898             CODE                                            \
1899             s++;                                            \
1900         }                                                   \
1901     } STMT_END
1902
1903 #define REXEC_FBC_UTF8_CLASS_SCAN(COND)                     \
1904     STMT_START {                                            \
1905         while (s < strend) {                                \
1906             REXEC_FBC_UTF8_CLASS_SCAN_GUTS(COND)            \
1907         }                                                   \
1908     } STMT_END
1909
1910 #define REXEC_FBC_NON_UTF8_CLASS_SCAN(COND)                 \
1911     STMT_START {                                            \
1912         while (s < strend) {                                \
1913             REXEC_FBC_NON_UTF8_CLASS_SCAN_GUTS(COND)        \
1914         }                                                   \
1915     } STMT_END
1916
1917 #define REXEC_FBC_UTF8_CLASS_SCAN_GUTS(COND)                   \
1918     if (COND) {                                                \
1919         FBC_CHECK_AND_TRY                                      \
1920         s += UTF8_SAFE_SKIP(s, reginfo->strend);               \
1921         previous_occurrence_end = s;                           \
1922     }                                                          \
1923     else {                                                     \
1924         s += UTF8SKIP(s);                                      \
1925     }
1926
1927 #define REXEC_FBC_NON_UTF8_CLASS_SCAN_GUTS(COND)               \
1928     if (COND) {                                                \
1929         FBC_CHECK_AND_TRY                                      \
1930         s++;                                                   \
1931         previous_occurrence_end = s;                           \
1932     }                                                          \
1933     else {                                                     \
1934         s++;                                                   \
1935     }
1936
1937 /* We keep track of where the next character should start after an occurrence
1938  * of the one we're looking for.  Knowing that, we can see right away if the
1939  * next occurrence is adjacent to the previous.  When 'doevery' is FALSE, we
1940  * don't accept the 2nd and succeeding adjacent occurrences */
1941 #define FBC_CHECK_AND_TRY                                           \
1942         if (   (   doevery                                          \
1943                 || s != previous_occurrence_end)                    \
1944             && (   reginfo->intuit                                  \
1945                 || (s <= reginfo->strend && regtry(reginfo, &s))))  \
1946         {                                                           \
1947             goto got_it;                                            \
1948         }
1949
1950
1951 /* These differ from the above macros in that they call a function which
1952  * returns the next occurrence of the thing being looked for in 's'; and
1953  * 'strend' if there is no such occurrence.  'f' is something like fcn(a,b,c)
1954  * */
1955 #define REXEC_FBC_UTF8_FIND_NEXT_SCAN(f)                    \
1956     while (s < strend) {                                    \
1957         s = (char *) (f);                                   \
1958         if (s >= strend) {                                  \
1959             break;                                          \
1960         }                                                   \
1961                                                             \
1962         FBC_CHECK_AND_TRY                                   \
1963         s += UTF8SKIP(s);                                   \
1964         previous_occurrence_end = s;                        \
1965     }
1966
1967 #define REXEC_FBC_NON_UTF8_FIND_NEXT_SCAN(f)                \
1968     while (s < strend) {                                    \
1969         s = (char *) (f);                                   \
1970         if (s >= strend) {                                  \
1971             break;                                          \
1972         }                                                   \
1973                                                             \
1974         FBC_CHECK_AND_TRY                                   \
1975         s++;                                                \
1976         previous_occurrence_end = s;                        \
1977     }
1978
1979 /* This is like the above macro except the function returns NULL if there is no
1980  * occurrence, and there is a further condition that must be matched besides
1981  * the function */
1982 #define REXEC_FBC_FIND_NEXT_UTF8_SCAN_COND(f, COND)         \
1983     while (s < strend) {                                    \
1984         s = (char *) (f);                                     \
1985         if (s == NULL) {                                    \
1986             s = (char *) strend;                            \
1987             break;                                          \
1988         }                                                   \
1989                                                             \
1990         if (COND) {                                         \
1991             FBC_CHECK_AND_TRY                               \
1992             s += UTF8_SAFE_SKIP(s, reginfo->strend);        \
1993             previous_occurrence_end = s;                    \
1994         }                                                   \
1995         else {                                              \
1996             s += UTF8SKIP(s);                               \
1997         }                                                   \
1998     }
1999
2000 /* This differs from the above macros in that it is passed a single byte that
2001  * is known to begin the next occurrence of the thing being looked for in 's'.
2002  * It does a memchr to find the next occurrence of 'byte', before trying 'COND'
2003  * at that position. */
2004 #define REXEC_FBC_FIND_NEXT_UTF8_BYTE_SCAN(byte, COND)                  \
2005     REXEC_FBC_FIND_NEXT_UTF8_SCAN_COND(memchr(s, byte, strend - s),     \
2006                                               COND)
2007
2008 /* This is like the function above, but takes an entire string to look for
2009  * instead of a single byte */
2010 #define REXEC_FBC_FIND_NEXT_UTF8_STRING_SCAN(substr, substr_end, COND)      \
2011     REXEC_FBC_FIND_NEXT_UTF8_SCAN_COND(                                     \
2012                                      ninstr(s, strend, substr, substr_end), \
2013                                      COND)
2014
2015 /* The four macros below are slightly different versions of the same logic.
2016  *
2017  * The first is for /a and /aa when the target string is UTF-8.  This can only
2018  * match ascii, but it must advance based on UTF-8.   The other three handle
2019  * the non-UTF-8 and the more generic UTF-8 cases.   In all four, we are
2020  * looking for the boundary (or non-boundary) between a word and non-word
2021  * character.  The utf8 and non-utf8 cases have the same logic, but the details
2022  * must be different.  Find the "wordness" of the character just prior to this
2023  * one, and compare it with the wordness of this one.  If they differ, we have
2024  * a boundary.  At the beginning of the string, pretend that the previous
2025  * character was a new-line.
2026  *
2027  * All these macros uncleanly have side-effects with each other and outside
2028  * variables.  So far it's been too much trouble to clean-up
2029  *
2030  * TEST_NON_UTF8 is the macro or function to call to test if its byte input is
2031  *               a word character or not.
2032  * IF_SUCCESS    is code to do if it finds that we are at a boundary between
2033  *               word/non-word
2034  * IF_FAIL       is code to do if we aren't at a boundary between word/non-word
2035  *
2036  * Exactly one of the two IF_FOO parameters is a no-op, depending on whether we
2037  * are looking for a boundary or for a non-boundary.  If we are looking for a
2038  * boundary, we want IF_FAIL to be the no-op, and for IF_SUCCESS to go out and
2039  * see if this tentative match actually works, and if so, to quit the loop
2040  * here.  And vice-versa if we are looking for a non-boundary.
2041  *
2042  * 'tmp' below in the next four macros in the REXEC_FBC_UTF8_SCAN and
2043  * REXEC_FBC_UTF8_SCAN loops is a loop invariant, a bool giving the return of
2044  * TEST_NON_UTF8(s-1).  To see this, note that that's what it is defined to be
2045  * at entry to the loop, and to get to the IF_FAIL branch, tmp must equal
2046  * TEST_NON_UTF8(s), and in the opposite branch, IF_SUCCESS, tmp is that
2047  * complement.  But in that branch we complement tmp, meaning that at the
2048  * bottom of the loop tmp is always going to be equal to TEST_NON_UTF8(s),
2049  * which means at the top of the loop in the next iteration, it is
2050  * TEST_NON_UTF8(s-1) */
2051 #define FBC_UTF8_A(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL)                         \
2052     tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n';                      \
2053     tmp = TEST_NON_UTF8(tmp);                                                  \
2054     REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */                     \
2055         if (tmp == ! TEST_NON_UTF8((U8) *s)) {                                 \
2056             tmp = !tmp;                                                        \
2057             IF_SUCCESS; /* Is a boundary if values for s-1 and s differ */     \
2058         }                                                                      \
2059         else {                                                                 \
2060             IF_FAIL;                                                           \
2061         }                                                                      \
2062     );                                                                         \
2063
2064 /* Like FBC_UTF8_A, but TEST_UV is a macro which takes a UV as its input, and
2065  * TEST_UTF8 is a macro that for the same input code points returns identically
2066  * to TEST_UV, but takes a pointer to a UTF-8 encoded string instead (and an
2067  * end pointer as well) */
2068 #define FBC_UTF8(TEST_UV, TEST_UTF8, IF_SUCCESS, IF_FAIL)                      \
2069     if (s == reginfo->strbeg) {                                                \
2070         tmp = '\n';                                                            \
2071     }                                                                          \
2072     else { /* Back-up to the start of the previous character */                \
2073         U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg);              \
2074         tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r,                     \
2075                                                        0, UTF8_ALLOW_DEFAULT); \
2076     }                                                                          \
2077     tmp = TEST_UV(tmp);                                                        \
2078     REXEC_FBC_UTF8_SCAN(/* advances s while s < strend */                      \
2079         if (tmp == ! (TEST_UTF8((U8 *) s, (U8 *) reginfo->strend))) {          \
2080             tmp = !tmp;                                                        \
2081             IF_SUCCESS;                                                        \
2082         }                                                                      \
2083         else {                                                                 \
2084             IF_FAIL;                                                           \
2085         }                                                                      \
2086     );
2087
2088 /* Like the above two macros, for a UTF-8 target string.  UTF8_CODE is the
2089  * complete code for handling UTF-8.  Common to the BOUND and NBOUND cases,
2090  * set-up by the FBC_BOUND, etc macros below */
2091 #define FBC_BOUND_COMMON_UTF8(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL)   \
2092     UTF8_CODE;                                                                 \
2093     /* Here, things have been set up by the previous code so that tmp is the   \
2094      * return of TEST_NON_UTF8(s-1).  We also have to check if this matches    \
2095      * against the EOS, which we treat as a \n */                              \
2096     if (tmp == ! TEST_NON_UTF8('\n')) {                                        \
2097         IF_SUCCESS;                                                            \
2098     }                                                                          \
2099     else {                                                                     \
2100         IF_FAIL;                                                               \
2101     }
2102
2103 /* Same as the macro above, but the target isn't UTF-8 */
2104 #define FBC_BOUND_COMMON_NON_UTF8(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL)       \
2105     tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n';                   \
2106     tmp = TEST_NON_UTF8(tmp);                                               \
2107     REXEC_FBC_NON_UTF8_SCAN(/* advances s while s < strend */               \
2108         if (tmp == ! TEST_NON_UTF8(UCHARAT(s))) {                           \
2109             IF_SUCCESS;                                                     \
2110             tmp = !tmp;                                                     \
2111         }                                                                   \
2112         else {                                                              \
2113             IF_FAIL;                                                        \
2114         }                                                                   \
2115     );                                                                      \
2116     /* Here, things have been set up by the previous code so that tmp is    \
2117      * the return of TEST_NON_UTF8(s-1).   We also have to check if this    \
2118      * matches against the EOS, which we treat as a \n */                   \
2119     if (tmp == ! TEST_NON_UTF8('\n')) {                                     \
2120         IF_SUCCESS;                                                         \
2121     }                                                                       \
2122     else {                                                                  \
2123         IF_FAIL;                                                            \
2124     }
2125
2126 /* This is the macro to use when we want to see if something that looks like it
2127  * could match, actually does, and if so exits the loop.  It needs to be used
2128  * only for bounds checking macros, as it allows for matching beyond the end of
2129  * string (which should be zero length without having to look at the string
2130  * contents) */
2131 #define REXEC_FBC_TRYIT                                                     \
2132     if (reginfo->intuit || (s <= reginfo->strend && regtry(reginfo, &s)))   \
2133         goto got_it
2134
2135 /* The only difference between the BOUND and NBOUND cases is that
2136  * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
2137  * NBOUND.  This is accomplished by passing it as either the if or else clause,
2138  * with the other one being empty (PLACEHOLDER is defined as empty).
2139  *
2140  * The TEST_FOO parameters are for operating on different forms of input, but
2141  * all should be ones that return identically for the same underlying code
2142  * points */
2143
2144 #define FBC_BOUND_UTF8(TEST_NON_UTF8, TEST_UV, TEST_UTF8)                   \
2145     FBC_BOUND_COMMON_UTF8(                                                  \
2146           FBC_UTF8(TEST_UV, TEST_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER),       \
2147           TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
2148
2149 #define FBC_BOUND_NON_UTF8(TEST_NON_UTF8)                                   \
2150     FBC_BOUND_COMMON_NON_UTF8(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
2151
2152 #define FBC_BOUND_A_UTF8(TEST_NON_UTF8)                                     \
2153     FBC_BOUND_COMMON_UTF8(                                                  \
2154                     FBC_UTF8_A(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER),\
2155                     TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
2156
2157 #define FBC_BOUND_A_NON_UTF8(TEST_NON_UTF8)                                 \
2158     FBC_BOUND_COMMON_NON_UTF8(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
2159
2160 #define FBC_NBOUND_UTF8(TEST_NON_UTF8, TEST_UV, TEST_UTF8)                  \
2161     FBC_BOUND_COMMON_UTF8(                                                  \
2162               FBC_UTF8(TEST_UV, TEST_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT),   \
2163               TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
2164
2165 #define FBC_NBOUND_NON_UTF8(TEST_NON_UTF8)                                  \
2166     FBC_BOUND_COMMON_NON_UTF8(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
2167
2168 #define FBC_NBOUND_A_UTF8(TEST_NON_UTF8)                                    \
2169     FBC_BOUND_COMMON_UTF8(                                                  \
2170             FBC_UTF8_A(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT),        \
2171             TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
2172
2173 #define FBC_NBOUND_A_NON_UTF8(TEST_NON_UTF8)                                \
2174     FBC_BOUND_COMMON_NON_UTF8(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
2175
2176 #ifdef DEBUGGING
2177 static IV
2178 S_get_break_val_cp_checked(SV* const invlist, const UV cp_in) {
2179   IV cp_out = _invlist_search(invlist, cp_in);
2180   assert(cp_out >= 0);
2181   return cp_out;
2182 }
2183 #  define _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) \
2184         invmap[S_get_break_val_cp_checked(invlist, cp)]
2185 #else
2186 #  define _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp) \
2187         invmap[_invlist_search(invlist, cp)]
2188 #endif
2189
2190 /* Takes a pointer to an inversion list, a pointer to its corresponding
2191  * inversion map, and a code point, and returns the code point's value
2192  * according to the two arrays.  It assumes that all code points have a value.
2193  * This is used as the base macro for macros for particular properties */
2194 #define _generic_GET_BREAK_VAL_CP(invlist, invmap, cp)              \
2195         _generic_GET_BREAK_VAL_CP_CHECKED(invlist, invmap, cp)
2196
2197 /* Same as above, but takes begin, end ptrs to a UTF-8 encoded string instead
2198  * of a code point, returning the value for the first code point in the string.
2199  * And it takes the particular macro name that finds the desired value given a
2200  * code point.  Merely convert the UTF-8 to code point and call the cp macro */
2201 #define _generic_GET_BREAK_VAL_UTF8(cp_macro, pos, strend)                     \
2202              (__ASSERT_(pos < strend)                                          \
2203                  /* Note assumes is valid UTF-8 */                             \
2204              (cp_macro(utf8_to_uvchr_buf((pos), (strend), NULL))))
2205
2206 /* Returns the GCB value for the input code point */
2207 #define getGCB_VAL_CP(cp)                                                      \
2208           _generic_GET_BREAK_VAL_CP(                                           \
2209                                     PL_GCB_invlist,                            \
2210                                     _Perl_GCB_invmap,                          \
2211                                     (cp))
2212
2213 /* Returns the GCB value for the first code point in the UTF-8 encoded string
2214  * bounded by pos and strend */
2215 #define getGCB_VAL_UTF8(pos, strend)                                           \
2216     _generic_GET_BREAK_VAL_UTF8(getGCB_VAL_CP, pos, strend)
2217
2218 /* Returns the LB value for the input code point */
2219 #define getLB_VAL_CP(cp)                                                       \
2220           _generic_GET_BREAK_VAL_CP(                                           \
2221                                     PL_LB_invlist,                             \
2222                                     _Perl_LB_invmap,                           \
2223                                     (cp))
2224
2225 /* Returns the LB value for the first code point in the UTF-8 encoded string
2226  * bounded by pos and strend */
2227 #define getLB_VAL_UTF8(pos, strend)                                            \
2228     _generic_GET_BREAK_VAL_UTF8(getLB_VAL_CP, pos, strend)
2229
2230
2231 /* Returns the SB value for the input code point */
2232 #define getSB_VAL_CP(cp)                                                       \
2233           _generic_GET_BREAK_VAL_CP(                                           \
2234                                     PL_SB_invlist,                             \
2235                                     _Perl_SB_invmap,                     \
2236                                     (cp))
2237
2238 /* Returns the SB value for the first code point in the UTF-8 encoded string
2239  * bounded by pos and strend */
2240 #define getSB_VAL_UTF8(pos, strend)                                            \
2241     _generic_GET_BREAK_VAL_UTF8(getSB_VAL_CP, pos, strend)
2242
2243 /* Returns the WB value for the input code point */
2244 #define getWB_VAL_CP(cp)                                                       \
2245           _generic_GET_BREAK_VAL_CP(                                           \
2246                                     PL_WB_invlist,                             \
2247                                     _Perl_WB_invmap,                         \
2248                                     (cp))
2249
2250 /* Returns the WB value for the first code point in the UTF-8 encoded string
2251  * bounded by pos and strend */
2252 #define getWB_VAL_UTF8(pos, strend)                                            \
2253     _generic_GET_BREAK_VAL_UTF8(getWB_VAL_CP, pos, strend)
2254
2255 /* We know what class REx starts with.  Try to find this position... */
2256 /* if reginfo->intuit, its a dryrun */
2257 /* annoyingly all the vars in this routine have different names from their counterparts
2258    in regmatch. /grrr */
2259 STATIC char *
2260 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
2261     const char *strend, regmatch_info *reginfo)
2262 {
2263
2264     /* TRUE if x+ need not match at just the 1st pos of run of x's */
2265     const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
2266
2267     char *pat_string;   /* The pattern's exactish string */
2268     char *pat_end;          /* ptr to end char of pat_string */
2269     re_fold_t folder;   /* Function for computing non-utf8 folds */
2270     const U8 *fold_array;   /* array for folding ords < 256 */
2271     STRLEN ln;
2272     STRLEN lnc;
2273     U8 c1;
2274     U8 c2;
2275     char *e = NULL;
2276
2277     /* In some cases we accept only the first occurrence of 'x' in a sequence of
2278      * them.  This variable points to just beyond the end of the previous
2279      * occurrence of 'x', hence we can tell if we are in a sequence.  (Having
2280      * it point to beyond the 'x' allows us to work for UTF-8 without having to
2281      * hop back.) */
2282     char * previous_occurrence_end = 0;
2283
2284     I32 tmp;            /* Scratch variable */
2285     const bool utf8_target = reginfo->is_utf8_target;
2286     UV utf8_fold_flags = 0;
2287     const bool is_utf8_pat = reginfo->is_utf8_pat;
2288     bool to_complement = FALSE; /* Invert the result?  Taking the xor of this
2289                                    with a result inverts that result, as 0^1 =
2290                                    1 and 1^1 = 0 */
2291     char_class_number_ classnum;
2292
2293     RXi_GET_DECL(prog,progi);
2294
2295     PERL_ARGS_ASSERT_FIND_BYCLASS;
2296
2297     /* We know what class it must start with. The case statements below have
2298      * encoded the OP, and the UTF8ness of the target ('t8' for is UTF-8; 'tb'
2299      * for it isn't; 'b' stands for byte), and the UTF8ness of the pattern
2300      * ('p8' and 'pb'. */
2301     switch (with_tp_UTF8ness(OP(c), utf8_target, is_utf8_pat)) {
2302         SV * anyofh_list;
2303
2304       case ANYOFPOSIXL_t8_pb:
2305       case ANYOFPOSIXL_t8_p8:
2306       case ANYOFL_t8_pb:
2307       case ANYOFL_t8_p8:
2308         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
2309         CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_SETS(c);
2310
2311         /* FALLTHROUGH */
2312
2313       case ANYOFD_t8_pb:
2314       case ANYOFD_t8_p8:
2315       case ANYOF_t8_pb:
2316       case ANYOF_t8_p8:
2317         REXEC_FBC_UTF8_CLASS_SCAN(
2318                 reginclass(prog, c, (U8*)s, (U8*) strend, 1 /* is utf8 */));
2319         break;
2320
2321       case ANYOFPOSIXL_tb_pb:
2322       case ANYOFPOSIXL_tb_p8:
2323       case ANYOFL_tb_pb:
2324       case ANYOFL_tb_p8:
2325         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
2326         CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_SETS(c);
2327
2328         /* FALLTHROUGH */
2329
2330       case ANYOFD_tb_pb:
2331       case ANYOFD_tb_p8:
2332       case ANYOF_tb_pb:
2333       case ANYOF_tb_p8:
2334         if (! ANYOF_FLAGS(c) && ANYOF_MATCHES_NONE_OUTSIDE_BITMAP(c)) {
2335             /* We know that s is in the bitmap range since the target isn't
2336              * UTF-8, so what happens for out-of-range values is not relevant,
2337              * so exclude that from the flags */
2338             REXEC_FBC_NON_UTF8_CLASS_SCAN(ANYOF_BITMAP_TEST(c, *((U8*)s)));
2339         }
2340         else {
2341             REXEC_FBC_NON_UTF8_CLASS_SCAN(reginclass(prog,c, (U8*)s, (U8*)s+1,
2342                                                      0));
2343         }
2344         break;
2345
2346       case ANYOFM_tb_pb: /* ARG1u() is the base byte; FLAGS() the mask byte */
2347       case ANYOFM_tb_p8:
2348         REXEC_FBC_NON_UTF8_FIND_NEXT_SCAN(
2349              find_next_masked((U8 *) s, (U8 *) strend, (U8) ARG1u(c), FLAGS(c)));
2350         break;
2351
2352       case ANYOFM_t8_pb:
2353       case ANYOFM_t8_p8:
2354         /* UTF-8ness doesn't matter because only matches UTF-8 invariants.  But
2355          * we do anyway for performance reasons, as otherwise we would have to
2356          * examine all the continuation characters */
2357         REXEC_FBC_UTF8_FIND_NEXT_SCAN(
2358              find_next_masked((U8 *) s, (U8 *) strend, (U8) ARG1u(c), FLAGS(c)));
2359         break;
2360
2361       case NANYOFM_tb_pb:
2362       case NANYOFM_tb_p8:
2363         REXEC_FBC_NON_UTF8_FIND_NEXT_SCAN(
2364            find_span_end_mask((U8 *) s, (U8 *) strend, (U8) ARG1u(c), FLAGS(c)));
2365         break;
2366
2367       case NANYOFM_t8_pb:
2368       case NANYOFM_t8_p8: /* UTF-8ness does matter because can match UTF-8
2369                                   variants. */
2370         REXEC_FBC_UTF8_FIND_NEXT_SCAN(
2371                         (char *) find_span_end_mask((U8 *) s, (U8 *) strend,
2372                                                     (U8) ARG1u(c), FLAGS(c)));
2373         break;
2374
2375       /* These nodes all require at least one code point to be in UTF-8 to
2376        * match */
2377       case ANYOFH_tb_pb:
2378       case ANYOFH_tb_p8:
2379       case ANYOFHb_tb_pb:
2380       case ANYOFHb_tb_p8:
2381       case ANYOFHbbm_tb_pb:
2382       case ANYOFHbbm_tb_p8:
2383       case ANYOFHr_tb_pb:
2384       case ANYOFHr_tb_p8:
2385       case ANYOFHs_tb_pb:
2386       case ANYOFHs_tb_p8:
2387       case EXACTFLU8_tb_pb:
2388       case EXACTFLU8_tb_p8:
2389       case EXACTFU_REQ8_tb_pb:
2390       case EXACTFU_REQ8_tb_p8:
2391         break;
2392
2393       case ANYOFH_t8_pb:
2394       case ANYOFH_t8_p8:
2395         anyofh_list = GET_ANYOFH_INVLIST(prog, c);
2396         REXEC_FBC_UTF8_CLASS_SCAN(
2397               (   (U8) NATIVE_UTF8_TO_I8(*s) >= ANYOF_FLAGS(c)
2398                && _invlist_contains_cp(anyofh_list,
2399                                        utf8_to_uvchr_buf((U8 *) s,
2400                                                          (U8 *) strend,
2401                                                          NULL))));
2402         break;
2403
2404       case ANYOFHb_t8_pb:
2405       case ANYOFHb_t8_p8:
2406         {
2407             /* We know what the first byte of any matched string should be. */
2408             U8 first_byte = FLAGS(c);
2409
2410             anyofh_list = GET_ANYOFH_INVLIST(prog, c);
2411             REXEC_FBC_FIND_NEXT_UTF8_BYTE_SCAN(first_byte,
2412                    _invlist_contains_cp(anyofh_list,
2413                                            utf8_to_uvchr_buf((U8 *) s,
2414                                                               (U8 *) strend,
2415                                                               NULL)));
2416         }
2417         break;
2418
2419       case ANYOFHbbm_t8_pb:
2420       case ANYOFHbbm_t8_p8:
2421         {
2422             /* We know what the first byte of any matched string should be. */
2423             U8 first_byte = FLAGS(c);
2424
2425             /* And a bitmap defines all the legal 2nd byte matches */
2426             REXEC_FBC_FIND_NEXT_UTF8_BYTE_SCAN(first_byte,
2427                                (    s < strend
2428                                 && BITMAP_TEST(((struct regnode_bbm *) c)->bitmap,
2429                                             (U8) s[1] & UTF_CONTINUATION_MASK)));
2430         }
2431         break;
2432
2433       case ANYOFHr_t8_pb:
2434       case ANYOFHr_t8_p8:
2435         anyofh_list = GET_ANYOFH_INVLIST(prog, c);
2436         REXEC_FBC_UTF8_CLASS_SCAN(
2437                     (   inRANGE(NATIVE_UTF8_TO_I8(*s),
2438                                 LOWEST_ANYOF_HRx_BYTE(ANYOF_FLAGS(c)),
2439                                 HIGHEST_ANYOF_HRx_BYTE(ANYOF_FLAGS(c)))
2440                    && _invlist_contains_cp(anyofh_list,
2441                                            utf8_to_uvchr_buf((U8 *) s,
2442                                                               (U8 *) strend,
2443                                                               NULL))));
2444         break;
2445
2446       case ANYOFHs_t8_pb:
2447       case ANYOFHs_t8_p8:
2448         anyofh_list = GET_ANYOFH_INVLIST(prog, c);
2449         REXEC_FBC_FIND_NEXT_UTF8_STRING_SCAN(
2450                         ((struct regnode_anyofhs *) c)->string,
2451                         /* Note FLAGS is the string length in this regnode */
2452                         ((struct regnode_anyofhs *) c)->string + FLAGS(c),
2453                         _invlist_contains_cp(anyofh_list,
2454                                              utf8_to_uvchr_buf((U8 *) s,
2455                                                                (U8 *) strend,
2456                                                                NULL)));
2457         break;
2458
2459       case ANYOFR_tb_pb:
2460       case ANYOFR_tb_p8:
2461         REXEC_FBC_NON_UTF8_CLASS_SCAN(withinCOUNT((U8) *s,
2462                                             ANYOFRbase(c), ANYOFRdelta(c)));
2463         break;
2464
2465       case ANYOFR_t8_pb:
2466       case ANYOFR_t8_p8:
2467         REXEC_FBC_UTF8_CLASS_SCAN(
2468                             (   NATIVE_UTF8_TO_I8(*s) >= ANYOF_FLAGS(c)
2469                              && withinCOUNT(utf8_to_uvchr_buf((U8 *) s,
2470                                                               (U8 *) strend,
2471                                                               NULL),
2472                                             ANYOFRbase(c), ANYOFRdelta(c))));
2473         break;
2474
2475       case ANYOFRb_tb_pb:
2476       case ANYOFRb_tb_p8:
2477         REXEC_FBC_NON_UTF8_CLASS_SCAN(withinCOUNT((U8) *s,
2478                                             ANYOFRbase(c), ANYOFRdelta(c)));
2479         break;
2480
2481       case ANYOFRb_t8_pb:
2482       case ANYOFRb_t8_p8:
2483         {   /* We know what the first byte of any matched string should be */
2484             U8 first_byte = FLAGS(c);
2485
2486             REXEC_FBC_FIND_NEXT_UTF8_BYTE_SCAN(first_byte,
2487                                 withinCOUNT(utf8_to_uvchr_buf((U8 *) s,
2488                                                               (U8 *) strend,
2489                                                               NULL),
2490                                             ANYOFRbase(c), ANYOFRdelta(c)));
2491         }
2492         break;
2493
2494       case EXACTFAA_tb_pb:
2495
2496         /* Latin1 folds are not affected by /a, except it excludes the sharp s,
2497          * which these functions don't handle anyway */
2498         fold_array = PL_fold_latin1;
2499         folder = S_foldEQ_latin1_s2_folded;
2500         goto do_exactf_non_utf8;
2501
2502       case EXACTF_tb_pb:
2503         fold_array = PL_fold;
2504         folder = Perl_foldEQ;
2505         goto do_exactf_non_utf8;
2506
2507       case EXACTFL_tb_pb:
2508         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
2509
2510         if (IN_UTF8_CTYPE_LOCALE) {
2511             utf8_fold_flags = FOLDEQ_LOCALE;
2512             goto do_exactf_utf8;
2513         }
2514
2515         fold_array = PL_fold_locale;
2516         folder = Perl_foldEQ_locale;
2517         goto do_exactf_non_utf8;
2518
2519       case EXACTFU_tb_pb:
2520         /* Any 'ss' in the pattern should have been replaced by regcomp, so we
2521          * don't have to worry here about this single special case in the
2522          * Latin1 range */
2523         fold_array = PL_fold_latin1;
2524         folder = S_foldEQ_latin1_s2_folded;
2525
2526         /* FALLTHROUGH */
2527
2528        do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there
2529                               are no glitches with fold-length differences
2530                               between the target string and pattern */
2531
2532         /* The idea in the non-utf8 EXACTF* cases is to first find the first
2533          * character of the EXACTF* node and then, if necessary,
2534          * case-insensitively compare the full text of the node.  c1 is the
2535          * first character.  c2 is its fold.  This logic will not work for
2536          * Unicode semantics and the german sharp ss, which hence should not be
2537          * compiled into a node that gets here. */
2538         pat_string = STRINGs(c);
2539         ln  = STR_LENs(c);      /* length to match in octets/bytes */
2540
2541         /* We know that we have to match at least 'ln' bytes (which is the same
2542          * as characters, since not utf8).  If we have to match 3 characters,
2543          * and there are only 2 available, we know without trying that it will
2544          * fail; so don't start a match past the required minimum number from
2545          * the far end */
2546         e = HOP3c(strend, -((SSize_t)ln), s);
2547         if (e < s)
2548             break;
2549
2550         c1 = *pat_string;
2551         c2 = fold_array[c1];
2552         if (c1 == c2) { /* If char and fold are the same */
2553             while (s <= e) {
2554                 s = (char *) memchr(s, c1, e + 1 - s);
2555                 if (s == NULL) {
2556                     break;
2557                 }
2558
2559                 /* Check that the rest of the node matches */
2560                 if (   (ln == 1 || folder(aTHX_ s + 1, pat_string + 1, ln - 1))
2561                     && (reginfo->intuit || regtry(reginfo, &s)) )
2562                 {
2563                     goto got_it;
2564                 }
2565                 s++;
2566             }
2567         }
2568         else {
2569             U8 bits_differing = c1 ^ c2;
2570
2571             /* If the folds differ in one bit position only, we can mask to
2572              * match either of them, and can use this faster find method.  Both
2573              * ASCII and EBCDIC tend to have their case folds differ in only
2574              * one position, so this is very likely */
2575             if (LIKELY(PL_bitcount[bits_differing] == 1)) {
2576                 bits_differing = ~ bits_differing;
2577                 while (s <= e) {
2578                     s = (char *) find_next_masked((U8 *) s, (U8 *) e + 1,
2579                                         (c1 & bits_differing), bits_differing);
2580                     if (s > e) {
2581                         break;
2582                     }
2583
2584                     if (   (ln == 1 || folder(aTHX_ s + 1, pat_string + 1, ln - 1))
2585                         && (reginfo->intuit || regtry(reginfo, &s)) )
2586                     {
2587                         goto got_it;
2588                     }
2589                     s++;
2590                 }
2591             }
2592             else {  /* Otherwise, stuck with looking byte-at-a-time.  This
2593                        should actually happen only in EXACTFL nodes */
2594                 while (s <= e) {
2595                     if (    (*(U8*)s == c1 || *(U8*)s == c2)
2596                         && (ln == 1 || folder(aTHX_ s + 1, pat_string + 1, ln - 1))
2597                         && (reginfo->intuit || regtry(reginfo, &s)) )
2598                     {
2599                         goto got_it;
2600                     }
2601                     s++;
2602                 }
2603             }
2604         }
2605         break;
2606
2607       case EXACTFAA_tb_p8:
2608       case EXACTFAA_t8_p8:
2609         utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII
2610                          |FOLDEQ_S2_ALREADY_FOLDED
2611                          |FOLDEQ_S2_FOLDS_SANE;
2612         goto do_exactf_utf8;
2613
2614       case EXACTFAA_NO_TRIE_tb_pb:
2615       case EXACTFAA_NO_TRIE_t8_pb:
2616       case EXACTFAA_t8_pb:
2617
2618         /* Here, and elsewhere in this file, the reason we can't consider a
2619          * non-UTF-8 pattern already folded in the presence of a UTF-8 target
2620          * is because any MICRO SIGN in the pattern won't be folded.  Since the
2621          * fold of the MICRO SIGN requires UTF-8 to represent, we can consider
2622          * a non-UTF-8 pattern folded when matching a non-UTF-8 target */
2623         utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
2624         goto do_exactf_utf8;
2625
2626       case EXACTFL_tb_p8:
2627       case EXACTFL_t8_pb:
2628       case EXACTFL_t8_p8:
2629         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
2630         utf8_fold_flags = FOLDEQ_LOCALE;
2631         goto do_exactf_utf8;
2632
2633       case EXACTFLU8_t8_pb:
2634       case EXACTFLU8_t8_p8:
2635         utf8_fold_flags =  FOLDEQ_LOCALE | FOLDEQ_S2_ALREADY_FOLDED
2636                                          | FOLDEQ_S2_FOLDS_SANE;
2637         goto do_exactf_utf8;
2638
2639       case EXACTFU_REQ8_t8_p8:
2640         utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
2641         goto do_exactf_utf8;
2642
2643       case EXACTFU_tb_p8:
2644       case EXACTFU_t8_pb:
2645       case EXACTFU_t8_p8:
2646         utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
2647         goto do_exactf_utf8;
2648
2649       /* The following are problematic even though pattern isn't UTF-8.  Use
2650        * full functionality normally not done except for UTF-8. */
2651       case EXACTF_t8_pb:
2652       case EXACTFUP_tb_pb:
2653       case EXACTFUP_t8_pb:
2654
2655        do_exactf_utf8:
2656         {
2657             unsigned expansion;
2658
2659             /* If one of the operands is in utf8, we can't use the simpler
2660              * folding above, due to the fact that many different characters
2661              * can have the same fold, or portion of a fold, or different-
2662              * length fold */
2663             pat_string = STRINGs(c);
2664             ln  = STR_LENs(c);  /* length to match in octets/bytes */
2665             pat_end = pat_string + ln;
2666             lnc = is_utf8_pat       /* length to match in characters */
2667                   ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
2668                   : ln;
2669
2670             /* We have 'lnc' characters to match in the pattern, but because of
2671              * multi-character folding, each character in the target can match
2672              * up to 3 characters (Unicode guarantees it will never exceed
2673              * this) if it is utf8-encoded; and up to 2 if not (based on the
2674              * fact that the Latin 1 folds are already determined, and the only
2675              * multi-char fold in that range is the sharp-s folding to 'ss'.
2676              * Thus, a pattern character can match as little as 1/3 of a string
2677              * character.  Adjust lnc accordingly, rounding up, so that if we
2678              * need to match at least 4+1/3 chars, that really is 5. */
2679             expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2;
2680             lnc = (lnc + expansion - 1) / expansion;
2681
2682             /* As in the non-UTF8 case, if we have to match 3 characters, and
2683              * only 2 are left, it's guaranteed to fail, so don't start a match
2684              * that would require us to go beyond the end of the string */
2685             e = HOP3c(strend, -((SSize_t)lnc), s);
2686
2687             /* XXX Note that we could recalculate e to stop the loop earlier,
2688              * as the worst case expansion above will rarely be met, and as we
2689              * go along we would usually find that e moves further to the left.
2690              * This would happen only after we reached the point in the loop
2691              * where if there were no expansion we should fail.  Unclear if
2692              * worth the expense */
2693
2694             while (s <= e) {
2695                 char *my_strend= (char *)strend;
2696                 if (   foldEQ_utf8_flags(s, &my_strend, 0,  utf8_target,
2697                                          pat_string, NULL, ln, is_utf8_pat,
2698                                          utf8_fold_flags)
2699                     && (reginfo->intuit || regtry(reginfo, &s)) )
2700                 {
2701                     goto got_it;
2702                 }
2703                 s += (utf8_target) ? UTF8_SAFE_SKIP(s, reginfo->strend) : 1;
2704             }
2705         }
2706         break;
2707
2708       case BOUNDA_tb_pb:
2709       case BOUNDA_tb_p8:
2710       case BOUND_tb_pb:  /* /d without utf8 target is /a */
2711       case BOUND_tb_p8:
2712         /* regcomp.c makes sure that these only have the traditional \b
2713          * meaning. */
2714         assert(FLAGS(c) == TRADITIONAL_BOUND);
2715
2716         FBC_BOUND_A_NON_UTF8(isWORDCHAR_A);
2717         break;
2718
2719       case BOUNDA_t8_pb: /* What /a matches is same under UTF-8 */
2720       case BOUNDA_t8_p8:
2721         /* regcomp.c makes sure that these only have the traditional \b
2722          * meaning. */
2723         assert(FLAGS(c) == TRADITIONAL_BOUND);
2724
2725         FBC_BOUND_A_UTF8(isWORDCHAR_A);
2726         break;
2727
2728       case NBOUNDA_tb_pb:
2729       case NBOUNDA_tb_p8:
2730       case NBOUND_tb_pb: /* /d without utf8 target is /a */
2731       case NBOUND_tb_p8:
2732         /* regcomp.c makes sure that these only have the traditional \b
2733          * meaning. */
2734         assert(FLAGS(c) == TRADITIONAL_BOUND);
2735
2736         FBC_NBOUND_A_NON_UTF8(isWORDCHAR_A);
2737         break;
2738
2739       case NBOUNDA_t8_pb: /* What /a matches is same under UTF-8 */
2740       case NBOUNDA_t8_p8:
2741         /* regcomp.c makes sure that these only have the traditional \b
2742          * meaning. */
2743         assert(FLAGS(c) == TRADITIONAL_BOUND);
2744
2745         FBC_NBOUND_A_UTF8(isWORDCHAR_A);
2746         break;
2747
2748       case NBOUNDU_tb_pb:
2749       case NBOUNDU_tb_p8:
2750         if ((bound_type) FLAGS(c) == TRADITIONAL_BOUND) {
2751             FBC_NBOUND_NON_UTF8(isWORDCHAR_L1);
2752             break;
2753         }
2754
2755         to_complement = 1;
2756         goto do_boundu_non_utf8;
2757
2758       case NBOUNDL_tb_pb:
2759       case NBOUNDL_tb_p8:
2760         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
2761         if (FLAGS(c) == TRADITIONAL_BOUND) {
2762             FBC_NBOUND_NON_UTF8(isWORDCHAR_LC);
2763             break;
2764         }
2765
2766         CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_BOUND;
2767
2768         to_complement = 1;
2769         goto do_boundu_non_utf8;
2770
2771       case BOUNDL_tb_pb:
2772       case BOUNDL_tb_p8:
2773         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
2774         if (FLAGS(c) == TRADITIONAL_BOUND) {
2775             FBC_BOUND_NON_UTF8(isWORDCHAR_LC);
2776             break;
2777         }
2778
2779         CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_BOUND;
2780
2781         goto do_boundu_non_utf8;
2782
2783       case BOUNDU_tb_pb:
2784       case BOUNDU_tb_p8:
2785         if ((bound_type) FLAGS(c) == TRADITIONAL_BOUND) {
2786             FBC_BOUND_NON_UTF8(isWORDCHAR_L1);
2787             break;
2788         }
2789
2790       do_boundu_non_utf8:
2791         if (s == reginfo->strbeg) {
2792             if (reginfo->intuit || regtry(reginfo, &s))
2793             {
2794                 goto got_it;
2795             }
2796
2797             /* Didn't match.  Try at the next position (if there is one) */
2798             s++;
2799             if (UNLIKELY(s >= reginfo->strend)) {
2800                 break;
2801             }
2802         }
2803
2804         switch((bound_type) FLAGS(c)) {
2805           case TRADITIONAL_BOUND: /* Should have already been handled */
2806             assert(0);
2807             break;
2808
2809           case GCB_BOUND:
2810             /* Not utf8.  Everything is a GCB except between CR and LF */
2811             while (s < strend) {
2812                 if ((to_complement ^ (   UCHARAT(s - 1) != '\r'
2813                                       || UCHARAT(s) != '\n'))
2814                     && (reginfo->intuit || regtry(reginfo, &s)))
2815                 {
2816                     goto got_it;
2817                 }
2818                 s++;
2819             }
2820
2821             break;
2822
2823           case LB_BOUND:
2824             {
2825                 LB_enum before = getLB_VAL_CP((U8) *(s -1));
2826                 while (s < strend) {
2827                     LB_enum after = getLB_VAL_CP((U8) *s);
2828                     if (to_complement ^ isLB(before,
2829                                              after,
2830                                              (U8*) reginfo->strbeg,
2831                                              (U8*) s,
2832                                              (U8*) reginfo->strend,
2833                                              0 /* target not utf8 */ )
2834                         && (reginfo->intuit || regtry(reginfo, &s)))
2835                     {
2836                         goto got_it;
2837                     }
2838                     before = after;
2839                     s++;
2840                 }
2841             }
2842
2843             break;
2844
2845           case SB_BOUND:
2846             {
2847                 SB_enum before = getSB_VAL_CP((U8) *(s -1));
2848                 while (s < strend) {
2849                     SB_enum after = getSB_VAL_CP((U8) *s);
2850                     if ((to_complement ^ isSB(before,
2851                                               after,
2852                                               (U8*) reginfo->strbeg,
2853                                               (U8*) s,
2854                                               (U8*) reginfo->strend,
2855                                              0 /* target not utf8 */ ))
2856                         && (reginfo->intuit || regtry(reginfo, &s)))
2857                     {
2858                         goto got_it;
2859                     }
2860                     before = after;
2861                     s++;
2862                 }
2863             }
2864
2865             break;
2866
2867           case WB_BOUND:
2868             {
2869                 WB_enum previous = WB_UNKNOWN;
2870                 WB_enum before = getWB_VAL_CP((U8) *(s -1));
2871                 while (s < strend) {
2872                     WB_enum after = getWB_VAL_CP((U8) *s);
2873                     if ((to_complement ^ isWB(previous,
2874                                               before,
2875                                               after,
2876                                               (U8*) reginfo->strbeg,
2877                                               (U8*) s,
2878                                               (U8*) reginfo->strend,
2879                                                0 /* target not utf8 */ ))
2880                         && (reginfo->intuit || regtry(reginfo, &s)))
2881                     {
2882                         goto got_it;
2883                     }
2884                     previous = before;
2885                     before = after;
2886                     s++;
2887                 }
2888             }
2889         }
2890
2891         /* Here are at the final position in the target string, which is a
2892          * boundary by definition, so matches, depending on other constraints.
2893          * */
2894         if (   reginfo->intuit
2895             || (s <= reginfo->strend && regtry(reginfo, &s)))
2896         {
2897             goto got_it;
2898         }
2899
2900         break;
2901
2902       case BOUNDL_t8_pb:
2903       case BOUNDL_t8_p8:
2904         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
2905         if (FLAGS(c) == TRADITIONAL_BOUND) {
2906             FBC_BOUND_UTF8(isWORDCHAR_LC, isWORDCHAR_LC_uvchr,
2907                            isWORDCHAR_LC_utf8_safe);
2908             break;
2909         }
2910
2911         CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_BOUND;
2912
2913         to_complement = 1;
2914         goto do_boundu_utf8;
2915
2916       case NBOUNDL_t8_pb:
2917       case NBOUNDL_t8_p8:
2918         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
2919         if (FLAGS(c) == TRADITIONAL_BOUND) {
2920             FBC_NBOUND_UTF8(isWORDCHAR_LC, isWORDCHAR_LC_uvchr,
2921                             isWORDCHAR_LC_utf8_safe);
2922             break;
2923         }
2924
2925         CHECK_AND_WARN_NON_UTF8_CTYPE_LOCALE_IN_BOUND;
2926
2927         to_complement = 1;
2928         goto do_boundu_utf8;
2929
2930       case NBOUND_t8_pb:
2931       case NBOUND_t8_p8:
2932         /* regcomp.c makes sure that these only have the traditional \b
2933          * meaning. */
2934         assert(FLAGS(c) == TRADITIONAL_BOUND);
2935
2936         /* FALLTHROUGH */
2937
2938       case NBOUNDU_t8_pb:
2939       case NBOUNDU_t8_p8:
2940         if ((bound_type) FLAGS(c) == TRADITIONAL_BOUND) {
2941             FBC_NBOUND_UTF8(isWORDCHAR_L1, isWORDCHAR_uni,
2942                             isWORDCHAR_utf8_safe);
2943             break;
2944         }
2945
2946         to_complement = 1;
2947         goto do_boundu_utf8;
2948
2949       case BOUND_t8_pb:
2950       case BOUND_t8_p8:
2951         /* regcomp.c makes sure that these only have the traditional \b
2952          * meaning. */
2953         assert(FLAGS(c) == TRADITIONAL_BOUND);
2954
2955         /* FALLTHROUGH */
2956
2957       case BOUNDU_t8_pb:
2958       case BOUNDU_t8_p8:
2959         if ((bound_type) FLAGS(c) == TRADITIONAL_BOUND) {
2960             FBC_BOUND_UTF8(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8_safe);
2961             break;
2962         }
2963
2964       do_boundu_utf8:
2965         if (s == reginfo->strbeg) {
2966             if (reginfo->intuit || regtry(reginfo, &s))
2967             {
2968                 goto got_it;
2969             }
2970
2971             /* Didn't match.  Try at the next position (if there is one) */
2972             s += UTF8_SAFE_SKIP(s, reginfo->strend);
2973             if (UNLIKELY(s >= reginfo->strend)) {
2974                 break;
2975             }
2976         }
2977
2978         switch((bound_type) FLAGS(c)) {
2979           case TRADITIONAL_BOUND: /* Should have already been handled */
2980             assert(0);
2981             break;
2982
2983           case GCB_BOUND:
2984             {
2985                 GCB_enum before = getGCB_VAL_UTF8(
2986                                            reghop3((U8*)s, -1,
2987                                                    (U8*)(reginfo->strbeg)),
2988                                            (U8*) reginfo->strend);
2989                 while (s < strend) {
2990                     GCB_enum after = getGCB_VAL_UTF8((U8*) s,
2991                                                     (U8*) reginfo->strend);
2992                     if (   (to_complement ^ isGCB(before,
2993                                                   after,
2994                                                   (U8*) reginfo->strbeg,
2995                                                   (U8*) s,
2996                                                   1 /* target is utf8 */ ))
2997                         && (reginfo->intuit || regtry(reginfo, &s)))
2998                     {
2999                         goto got_it;
3000                     }
3001                     before = after;
3002                     s += UTF8_SAFE_SKIP(s, reginfo->strend);
3003                 }
3004             }
3005             break;
3006
3007           case LB_BOUND:
3008             {
3009                 LB_enum before = getLB_VAL_UTF8(reghop3((U8*)s,
3010                                                         -1,
3011                                                         (U8*)(reginfo->strbeg)),
3012                                                    (U8*) reginfo->strend);
3013                 while (s < strend) {
3014                     LB_enum after = getLB_VAL_UTF8((U8*) s,
3015                                                    (U8*) reginfo->strend);
3016                     if (to_complement ^ isLB(before,
3017                                              after,
3018                                              (U8*) reginfo->strbeg,
3019                                              (U8*) s,
3020                                              (U8*) reginfo->strend,
3021                                              1 /* target is utf8 */ )
3022                         && (reginfo->intuit || regtry(reginfo, &s)))
3023                     {
3024                         goto got_it;
3025                     }
3026                     before = after;
3027                     s += UTF8_SAFE_SKIP(s, reginfo->strend);
3028                 }
3029             }
3030
3031             break;
3032
3033           case SB_BOUND:
3034             {
3035                 SB_enum before = getSB_VAL_UTF8(reghop3((U8*)s,
3036                                                     -1,
3037                                                     (U8*)(reginfo->strbeg)),
3038                                                   (U8*) reginfo->strend);
3039                 while (s < strend) {
3040                     SB_enum after = getSB_VAL_UTF8((U8*) s,
3041                                                      (U8*) reginfo->strend);
3042                     if ((to_complement ^ isSB(before,
3043                                               after,
3044                                               (U8*) reginfo->strbeg,
3045                                               (U8*) s,
3046                                               (U8*) reginfo->strend,
3047                                               1 /* target is utf8 */ ))
3048                         && (reginfo->intuit || regtry(reginfo, &s)))
3049                     {
3050                         goto got_it;
3051                     }
3052                     before = after;
3053                     s += UTF8_SAFE_SKIP(s, reginfo->strend);
3054                 }
3055             }
3056
3057             break;
3058
3059           case WB_BOUND:
3060             {
3061                 /* We are at a boundary between char_sub_0 and char_sub_1.
3062                  * We also keep track of the value for char_sub_-1 as we
3063                  * loop through the line.   Context may be needed to make a
3064                  * determination, and if so, this can save having to
3065                  * recalculate it */
3066                 WB_enum previous = WB_UNKNOWN;
3067                 WB_enum before = getWB_VAL_UTF8(
3068                                           reghop3((U8*)s,
3069                                                   -1,
3070                                                   (U8*)(reginfo->strbeg)),
3071                                           (U8*) reginfo->strend);
3072                 while (s < strend) {
3073                     WB_enum after = getWB_VAL_UTF8((U8*) s,
3074                                                     (U8*) reginfo->strend);
3075                     if ((to_complement ^ isWB(previous,
3076                                               before,
3077                                               after,
3078                                               (U8*) reginfo->strbeg,
3079                                               (U8*) s,
3080                                               (U8*) reginfo->strend,
3081                                               1 /* target is utf8 */ ))
3082                         && (reginfo->intuit || regtry(reginfo, &s)))
3083                     {
3084                         goto got_it;
3085                     }
3086                     previous = before;
3087                     before = after;
3088                     s += UTF8_SAFE_SKIP(s, reginfo->strend);
3089                 }
3090             }
3091         }
3092
3093         /* Here are at the final position in the target string, which is a
3094          * boundary by definition, so matches, depending on other constraints.
3095          * */
3096
3097         if (   reginfo->intuit
3098             || (s <= reginfo->strend && regtry(reginfo, &s)))
3099         {
3100             goto got_it;
3101         }
3102         break;
3103
3104       case LNBREAK_t8_pb:
3105       case LNBREAK_t8_p8:
3106         REXEC_FBC_UTF8_CLASS_SCAN(is_LNBREAK_utf8_safe(s, strend));
3107         break;
3108
3109       case LNBREAK_tb_pb:
3110       case LNBREAK_tb_p8:
3111         REXEC_FBC_NON_UTF8_CLASS_SCAN(is_LNBREAK_latin1_safe(s, strend));
3112         break;
3113
3114       /* The argument to all the POSIX node types is the class number to pass
3115        * to generic_isCC_() to build a mask for searching in PL_charclass[] */
3116
3117       case NPOSIXL_t8_pb:
3118       case NPOSIXL_t8_p8:
3119         to_complement = 1;
3120         /* FALLTHROUGH */
3121
3122       case POSIXL_t8_pb:
3123       case POSIXL_t8_p8:
3124         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
3125         REXEC_FBC_UTF8_CLASS_SCAN(
3126             to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s,
3127                                                           (U8 *) strend)));
3128         break;
3129
3130       case NPOSIXL_tb_pb:
3131       case NPOSIXL_tb_p8:
3132         to_complement = 1;
3133         /* FALLTHROUGH */
3134
3135       case POSIXL_tb_pb:
3136       case POSIXL_tb_p8:
3137         CHECK_AND_WARN_PROBLEMATIC_LOCALE_;
3138         REXEC_FBC_NON_UTF8_CLASS_SCAN(
3139                                 to_complement ^ cBOOL(isFOO_lc(FLAGS(c), *s)));
3140         break;
3141
3142       case NPOSIXA_t8_pb:
3143       case NPOSIXA_t8_p8:
3144         /* The complement of something that matches only ASCII matches all
3145          * non-ASCII, plus everything in ASCII that isn't in the class. */
3146         REXEC_FBC_UTF8_CLASS_SCAN(   ! isASCII_utf8_safe(s, strend)
3147                                   || ! generic_isCC_A_(*s, FLAGS(c)));
3148         break;
3149
3150       case POSIXA_t8_pb:
3151       case POSIXA_t8_p8:
3152         /* Don't need to worry about utf8, as it can match only a single
3153          * byte invariant character.  But we do anyway for performance reasons,
3154          * as otherwise we would have to examine all the continuation
3155          * characters */
3156         REXEC_FBC_UTF8_CLASS_SCAN(generic_isCC_A_(*s, FLAGS(c)));
3157         break;
3158
3159       case NPOSIXD_tb_pb:
3160       case NPOSIXD_tb_p8:
3161       case NPOSIXA_tb_pb:
3162       case NPOSIXA_tb_p8:
3163         to_complement = 1;
3164         /* FALLTHROUGH */
3165
3166       case POSIXD_tb_pb:
3167       case POSIXD_tb_p8:
3168       case POSIXA_tb_pb:
3169       case POSIXA_tb_p8:
3170         REXEC_FBC_NON_UTF8_CLASS_SCAN(
3171                         to_complement ^ cBOOL(generic_isCC_A_(*s, FLAGS(c))));
3172         break;
3173
3174       case NPOSIXU_tb_pb:
3175       case NPOSIXU_tb_p8:
3176         to_complement = 1;
3177         /* FALLTHROUGH */
3178
3179       case POSIXU_tb_pb:
3180       case POSIXU_tb_p8:
3181             REXEC_FBC_NON_UTF8_CLASS_SCAN(
3182                                  to_complement ^ cBOOL(generic_isCC_(*s,
3183                                                                     FLAGS(c))));
3184         break;
3185
3186       case NPOSIXD_t8_pb:
3187       case NPOSIXD_t8_p8:
3188       case NPOSIXU_t8_pb:
3189       case NPOSIXU_t8_p8:
3190         to_complement = 1;
3191         /* FALLTHROUGH */
3192
3193       case POSIXD_t8_pb:
3194       case POSIXD_t8_p8:
3195       case POSIXU_t8_pb:
3196       case POSIXU_t8_p8:
3197         classnum = (char_class_number_) FLAGS(c);
3198         switch (classnum) {
3199           default:
3200             REXEC_FBC_UTF8_CLASS_SCAN(
3201                         to_complement ^ cBOOL(_invlist_contains_cp(
3202                                                 PL_XPosix_ptrs[classnum],
3203                                                 utf8_to_uvchr_buf((U8 *) s,
3204                                                                 (U8 *) strend,
3205                                                                 NULL))));
3206             break;
3207
3208           case CC_ENUM_SPACE_:
3209             REXEC_FBC_UTF8_CLASS_SCAN(
3210                         to_complement ^ cBOOL(isSPACE_utf8_safe(s, strend)));
3211             break;
3212
3213           case CC_ENUM_BLANK_:
3214             REXEC_FBC_UTF8_CLASS_SCAN(
3215                         to_complement ^ cBOOL(isBLANK_utf8_safe(s, strend)));
3216             break;
3217
3218           case CC_ENUM_XDIGIT_:
3219             REXEC_FBC_UTF8_CLASS_SCAN(
3220                         to_complement ^ cBOOL(isXDIGIT_utf8_safe(s, strend)));
3221             break;
3222
3223           case CC_ENUM_VERTSPACE_:
3224             REXEC_FBC_UTF8_CLASS_SCAN(
3225                         to_complement ^ cBOOL(isVERTWS_utf8_safe(s, strend)));
3226             break;
3227
3228           case CC_ENUM_CNTRL_:
3229             REXEC_FBC_UTF8_CLASS_SCAN(
3230                         to_complement ^ cBOOL(isCNTRL_utf8_safe(s, strend)));
3231             break;
3232         }
3233         break;
3234
3235       case AHOCORASICKC_tb_pb:
3236       case AHOCORASICKC_tb_p8:
3237       case AHOCORASICKC_t8_pb:
3238       case AHOCORASICKC_t8_p8:
3239       case AHOCORASICK_tb_pb:
3240       case AHOCORASICK_tb_p8:
3241       case AHOCORASICK_t8_pb:
3242       case AHOCORASICK_t8_p8:
3243         {
3244             DECL_TRIE_TYPE(c);
3245             /* what trie are we using right now */
3246             reg_ac_data *aho = (reg_ac_data*)progi->data->data[ ARG1u( c ) ];
3247             reg_trie_data *trie = (reg_trie_data*)progi->data->data[aho->trie];
3248             HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
3249
3250             const char *last_start = strend - trie->minlen;
3251 #ifdef DEBUGGING
3252             const char *real_start = s;
3253 #endif
3254             STRLEN maxlen = trie->maxlen;
3255             SV *sv_points;
3256             U8 **points; /* map of where we were in the input string
3257                             when reading a given char. For ASCII this
3258                             is unnecessary overhead as the relationship
3259                             is always 1:1, but for Unicode, especially
3260                             case folded Unicode this is not true. */
3261             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3262             U8 *bitmap=NULL;
3263
3264
3265             DECLARE_AND_GET_RE_DEBUG_FLAGS;
3266
3267             /* We can't just allocate points here. We need to wrap it in
3268              * an SV so it gets freed properly if there is a croak while
3269              * running the match */
3270             ENTER;
3271             SAVETMPS;
3272             sv_points=newSV(maxlen * sizeof(U8 *));
3273             SvCUR_set(sv_points,
3274                 maxlen * sizeof(U8 *));
3275             SvPOK_on(sv_points);
3276             sv_2mortal(sv_points);
3277             points=(U8**)SvPV_nolen(sv_points );
3278             if ( trie_type != trie_utf8_fold
3279                  && (trie->bitmap || OP(c)==AHOCORASICKC) )
3280             {
3281                 if (trie->bitmap)
3282                     bitmap=(U8*)trie->bitmap;
3283                 else
3284                     bitmap=(U8*)ANYOF_BITMAP(c);
3285             }
3286             /* this is the Aho-Corasick algorithm modified a touch
3287                to include special handling for long "unknown char" sequences.
3288                The basic idea being that we use AC as long as we are dealing
3289                with a possible matching char, when we encounter an unknown char
3290                (and we have not encountered an accepting state) we scan forward
3291                until we find a legal starting char.
3292                AC matching is basically that of trie matching, except that when
3293                we encounter a failing transition, we fall back to the current
3294                states "fail state", and try the current char again, a process
3295                we repeat until we reach the root state, state 1, or a legal
3296                transition. If we fail on the root state then we can either
3297                terminate if we have reached an accepting state previously, or
3298                restart the entire process from the beginning if we have not.
3299
3300              */
3301             while (s <= last_start) {
3302                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
3303                 U8 *uc = (U8*)s;
3304                 U16 charid = 0;
3305                 U32 base = 1;
3306                 U32 state = 1;
3307                 UV uvc = 0;
3308                 STRLEN len = 0;
3309                 STRLEN foldlen = 0;
3310                 U8 *uscan = (U8*)NULL;
3311                 U8 *leftmost = NULL;
3312 #ifdef DEBUGGING
3313                 U32 accepted_word= 0;
3314 #endif
3315                 U32 pointpos = 0;
3316
3317                 while ( state && uc <= (U8*)strend ) {
3318                     int failed=0;
3319                     U32 word = aho->states[ state ].wordnum;
3320
3321                     if( state==1 ) {
3322                         if ( bitmap ) {
3323                             DEBUG_TRIE_EXECUTE_r(
3324                                 if (  uc <= (U8*)last_start
3325                                     && !BITMAP_TEST(bitmap,*uc) )
3326                                 {
3327                                     dump_exec_pos( (char *)uc, c, strend,
3328                                         real_start,
3329                                         (char *)uc, utf8_target, 0 );
3330                                     Perl_re_printf( aTHX_
3331                                         " Scanning for legal start char...\n");
3332                                 }
3333                             );
3334                             if (utf8_target) {
3335                                 while (  uc <= (U8*)last_start
3336                                        && !BITMAP_TEST(bitmap,*uc) )
3337                                 {
3338                                     uc += UTF8SKIP(uc);
3339                                 }
3340                             } else {
3341                                 while (  uc <= (U8*)last_start
3342                                        && ! BITMAP_TEST(bitmap,*uc) )
3343                                 {
3344                                     uc++;
3345                                 }
3346                             }
3347                             s= (char *)uc;
3348                         }
3349                         if (uc >(U8*)last_start) break;
3350                     }
3351
3352                     if ( word ) {
3353                         U8 *lpos= points[ (pointpos - trie->wordinfo[word].len)
3354                                                                     % maxlen ];
3355                         if (!leftmost || lpos < leftmost) {
3356                             DEBUG_r(accepted_word=word);
3357                             leftmost= lpos;
3358                         }
3359                         if (base==0) break;
3360
3361                     }
3362                     points[pointpos++ % maxlen]= uc;
3363                     if (foldlen || uc < (U8*)strend) {
3364                         REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3365                                              (U8 *) strend, uscan, len, uvc,
3366                                              charid, foldlen, foldbuf,
3367                                              uniflags);
3368                         DEBUG_TRIE_EXECUTE_r({
3369                             dump_exec_pos( (char *)uc, c, strend,
3370                                         real_start, s, utf8_target, 0);
3371                             Perl_re_printf( aTHX_
3372                                 " Charid:%3u CP:%4" UVxf " ",
3373                                  charid, uvc);
3374                         });
3375                     }
3376                     else {
3377                         len = 0;
3378                         charid = 0;
3379                     }
3380
3381
3382                     do {
3383 #ifdef DEBUGGING
3384                         word = aho->states[ state ].wordnum;
3385 #endif
3386                         base = aho->states[ state ].trans.base;
3387
3388                         DEBUG_TRIE_EXECUTE_r({
3389                             if (failed)
3390                                 dump_exec_pos((char *)uc, c, strend, real_start,
3391                                     s,   utf8_target, 0 );
3392                             Perl_re_printf( aTHX_
3393                                 "%sState: %4" UVxf ", word=%" UVxf,
3394                                 failed ? " Fail transition to " : "",
3395                                 (UV)state, (UV)word);
3396                         });
3397                         if ( base ) {
3398                             U32 tmp;
3399                             I32 offset;
3400                             if (charid &&
3401                                  ( ((offset = base + charid
3402                                     - 1 - trie->uniquecharcount)) >= 0)
3403                                  && ((U32)offset < trie->lasttrans)
3404                                  && trie->trans[offset].check == state
3405                                  && (tmp=trie->trans[offset].next))
3406                             {
3407                                 DEBUG_TRIE_EXECUTE_r(
3408                                     Perl_re_printf( aTHX_ " - legal\n"));
3409                                 state = tmp;
3410                                 break;
3411                             }
3412                             else {
3413                                 DEBUG_TRIE_EXECUTE_r(
3414                                     Perl_re_printf( aTHX_ " - fail\n"));
3415                                 failed = 1;
3416                                 state = aho->fail[state];
3417                             }
3418                         }
3419                         else {
3420                             /* we must be accepting here */
3421                             DEBUG_TRIE_EXECUTE_r(
3422                                     Perl_re_printf( aTHX_ " - accepting\n"));
3423                             failed = 1;
3424                             break;
3425                         }
3426                     } while(state);
3427                     uc += len;
3428                     if (failed) {
3429                         if (leftmost)
3430                             break;
3431                         if (!state) state = 1;
3432                     }
3433                 }
3434                 if ( aho->states[ state ].wordnum ) {
3435                     U8 *lpos = points[ (pointpos
3436                                       - trie->wordinfo[aho->states[ state ]
3437                                                     .wordnum].len) % maxlen ];
3438                     if (!leftmost || lpos < leftmost) {
3439                         DEBUG_r(accepted_word=aho->states[ state ].wordnum);
3440                         leftmost = lpos;
3441                     }
3442                 }
3443                 if (leftmost) {
3444                     s = (char*)leftmost;
3445                     DEBUG_TRIE_EXECUTE_r({
3446                         Perl_re_printf( aTHX_  "Matches word #%" UVxf
3447                                         " at position %" IVdf ". Trying full"
3448                                         " pattern...\n",
3449                             (UV)accepted_word, (IV)(s - real_start)
3450                         );
3451                     });
3452                     if (reginfo->intuit || regtry(reginfo, &s)) {
3453                         FREETMPS;
3454                         LEAVE;
3455                         goto got_it;
3456                     }
3457                     if (s < reginfo->strend) {
3458                         s = HOPc(s,1);
3459                     }
3460                     DEBUG_TRIE_EXECUTE_r({
3461                         Perl_re_printf( aTHX_
3462                                        "Pattern failed. Looking for new start"
3463                                        " point...\n");
3464                     });
3465                 } else {
3466                     DEBUG_TRIE_EXECUTE_r(
3467                         Perl_re_printf( aTHX_ "No match.\n"));
3468                     break;
3469                 }
3470             }
3471             FREETMPS;
3472             LEAVE;
3473         }
3474         break;
3475
3476       case EXACTFU_REQ8_t8_pb:
3477       case EXACTFUP_tb_p8:
3478       case EXACTFUP_t8_p8:
3479       case EXACTF_tb_p8:
3480       case EXACTF_t8_p8:   /* This node only generated for non-utf8 patterns */
3481       case EXACTFAA_NO_TRIE_tb_p8:
3482       case EXACTFAA_NO_TRIE_t8_p8: /* This node only generated for non-utf8
3483                                       patterns */
3484         assert(0);
3485
3486       default:
3487         Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
3488     } /* End of switch on node type */
3489
3490     return 0;
3491
3492   got_it:
3493     return s;
3494 }
3495
3496 /* set RX_SAVED_COPY, RX_SUBBEG etc.
3497  * flags have same meanings as with regexec_flags() */
3498
3499 static void
3500 S_reg_set_capture_string(pTHX_ REGEXP * const rx,
3501                             char *strbeg,
3502                             char *strend,
3503                             SV *sv,
3504                             U32 flags,
3505                             bool utf8_target)
3506 {
3507     struct regexp *const prog = ReANY(rx);
3508
3509     if (flags & REXEC_COPY_STR) {
3510 #ifdef PERL_ANY_COW
3511         if (SvCANCOW(sv)) {
3512             DEBUG_C(Perl_re_printf( aTHX_
3513                               "Copy on write: regexp capture, type %d\n",
3514                                     (int) SvTYPE(sv)));
3515             /* Create a new COW SV to share the match string and store
3516              * in saved_copy, unless the current COW SV in saved_copy
3517              * is valid and suitable for our purpose */
3518             if ((   RXp_SAVED_COPY(prog)
3519                  && SvIsCOW(RXp_SAVED_COPY(prog))
3520                  && SvPOKp(RXp_SAVED_COPY(prog))
3521                  && SvIsCOW(sv)
3522                  && SvPOKp(sv)
3523                  && SvPVX(sv) == SvPVX(RXp_SAVED_COPY(prog))))
3524             {
3525                 /* just reuse saved_copy SV */
3526                 if (RXp_MATCH_COPIED(prog)) {
3527                     Safefree(RXp_SUBBEG(prog));
3528                     RXp_MATCH_COPIED_off(prog);
3529                 }
3530             }
3531             else {
3532                 /* create new COW SV to share string */
3533                 RXp_MATCH_COPY_FREE(prog);
3534                 RXp_SAVED_COPY(prog) = sv_setsv_cow(RXp_SAVED_COPY(prog), sv);
3535             }
3536             RXp_SUBBEG(prog) = (char *)SvPVX_const(RXp_SAVED_COPY(prog));
3537             assert (SvPOKp(RXp_SAVED_COPY(prog)));
3538             RXp_SUBLEN(prog)  = strend - strbeg;
3539             RXp_SUBOFFSET(prog) = 0;
3540             RXp_SUBCOFFSET(prog) = 0;
3541         } else
3542 #endif
3543         {
3544             SSize_t min = 0;
3545             SSize_t max = strend - strbeg;
3546             SSize_t sublen;
3547
3548             if (    (flags & REXEC_COPY_SKIP_POST)
3549                 && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
3550                 && !(PL_sawampersand & SAWAMPERSAND_RIGHT)
3551             ) { /* don't copy $' part of string */
3552                 SSize_t offs_end;
3553                 U32 n = 0;
3554                 max = -1;
3555                 /* calculate the right-most part of the string covered
3556                  * by a capture. Due to lookahead, this may be to
3557                  * the right of $&, so we have to scan all captures */
3558                 while (n <= RXp_LASTPAREN(prog)) {
3559                     if ((offs_end = RXp_OFFS_END(prog,n)) > max)
3560                         max = offs_end;
3561                     n++;
3562                 }
3563                 if (max == -1)
3564                     max = (PL_sawampersand & SAWAMPERSAND_LEFT)
3565                             ? RXp_OFFS_START(prog,0)
3566                             : 0;
3567                 assert(max >= 0 && max <= strend - strbeg);
3568             }
3569
3570             if (    (flags & REXEC_COPY_SKIP_PRE)
3571                 && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
3572                 && !(PL_sawampersand & SAWAMPERSAND_LEFT)
3573             ) { /* don't copy $` part of string */
3574                 U32 n = 0;
3575                 min = max;
3576                 /* calculate the left-most part of the string covered
3577                  * by a capture. Due to lookbehind, this may be to
3578                  * the left of $&, so we have to scan all captures */
3579                 while (min && n <= RXp_LASTPAREN(prog)) {
3580                     I32 start = RXp_OFFS_START(prog,n);
3581                     if (   start != -1
3582                         && start < min)
3583                     {
3584                         min = start;
3585                     }
3586                     n++;
3587                 }
3588                 if ((PL_sawampersand & SAWAMPERSAND_RIGHT)
3589                     && min >  RXp_OFFS_END(prog,0)
3590                 )
3591                     min = RXp_OFFS_END(prog,0);
3592
3593             }
3594
3595             assert(min >= 0 && min <= max && min <= strend - strbeg);
3596             sublen = max - min;
3597
3598             if (RXp_MATCH_COPIED(prog)) {
3599                 if (sublen > RXp_SUBLEN(prog))
3600                     RXp_SUBBEG(prog) =
3601                             (char*)saferealloc(RXp_SUBBEG(prog), sublen+1);
3602             }
3603             else
3604                 RXp_SUBBEG(prog) = (char*)safemalloc(sublen+1);
3605             Copy(strbeg + min, RXp_SUBBEG(prog), sublen, char);
3606             RXp_SUBBEG(prog)[sublen] = '\0';
3607             RXp_SUBOFFSET(prog) = min;
3608             RXp_SUBLEN(prog) = sublen;
3609             RXp_MATCH_COPIED_on(prog);
3610         }
3611         RXp_SUBCOFFSET(prog) = RXp_SUBOFFSET(prog);
3612         if (RXp_SUBOFFSET(prog) && utf8_target) {
3613             /* Convert byte offset to chars.
3614              * XXX ideally should only compute this if @-/@+
3615              * has been seen, a la PL_sawampersand ??? */
3616
3617             /* If there's a direct correspondence between the
3618              * string which we're matching and the original SV,
3619              * then we can use the utf8 len cache associated with
3620              * the SV. In particular, it means that under //g,
3621              * sv_pos_b2u() will use the previously cached
3622              * position to speed up working out the new length of
3623              * subcoffset, rather than counting from the start of
3624              * the string each time. This stops
3625              *   $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g;
3626              * from going quadratic */
3627             if (SvPOKp(sv) && SvPVX(sv) == strbeg)
3628                 RXp_SUBCOFFSET(prog) = sv_pos_b2u_flags(sv, RXp_SUBCOFFSET(prog),
3629                                                 SV_GMAGIC|SV_CONST_RETURN);
3630             else
3631                 RXp_SUBCOFFSET(prog) = utf8_length((U8*)strbeg,
3632                                     (U8*)(strbeg+RXp_SUBOFFSET(prog)));
3633         }
3634     }
3635     else {
3636         RXp_MATCH_COPY_FREE(prog);
3637         RXp_SUBBEG(prog) = strbeg;
3638         RXp_SUBOFFSET(prog) = 0;
3639         RXp_SUBCOFFSET(prog) = 0;
3640         RXp_SUBLEN(prog) = strend - strbeg;
3641     }
3642 }
3643
3644
3645
3646
3647 /*
3648  - regexec_flags - match a regexp against a string
3649  */
3650 I32
3651 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
3652               char *strbeg, SSize_t minend, SV *sv, void *data, U32 flags)
3653 /* stringarg: the point in the string at which to begin matching */
3654 /* strend:    pointer to null at end of string */
3655 /* strbeg:    real beginning of string */
3656 /* minend:    end of match must be >= minend bytes after stringarg. */
3657 /* sv:        SV being matched: only used for utf8 flag, pos() etc; string
3658  *            itself is accessed via the pointers above */
3659 /* data:      May be used for some additional optimizations.
3660               Currently unused. */
3661 /* flags:     For optimizations. See REXEC_* in regexp.h */
3662
3663 {
3664     struct regexp *const prog = ReANY(rx);
3665     char *s;
3666     regnode *c;
3667     char *startpos;
3668     SSize_t minlen;             /* must match at least this many chars */
3669     SSize_t dontbother = 0;     /* how many characters not to try at end */
3670     const bool utf8_target = cBOOL(DO_UTF8(sv));
3671     I32 multiline;
3672     RXi_GET_DECL(prog,progi);
3673     regmatch_info reginfo_buf;  /* create some info to pass to regtry etc */
3674     regmatch_info *const reginfo = &reginfo_buf;
3675     regexp_paren_pair *swap = NULL;
3676     I32 oldsave;
3677     DECLARE_AND_GET_RE_DEBUG_FLAGS;
3678
3679     PERL_ARGS_ASSERT_REGEXEC_FLAGS;
3680     PERL_UNUSED_ARG(data);
3681
3682     /* Be paranoid... */
3683     if (prog == NULL) {
3684         Perl_croak(aTHX_ "NULL regexp parameter");
3685     }
3686
3687     DEBUG_EXECUTE_r(
3688         debug_start_match(rx, utf8_target, stringarg, strend,
3689         "Matching");
3690     );
3691
3692     startpos = stringarg;
3693
3694     /* set these early as they may be used by the HOP macros below */
3695     reginfo->strbeg = strbeg;
3696     reginfo->strend = strend;
3697     reginfo->is_utf8_target = cBOOL(utf8_target);
3698
3699     if (prog->intflags & PREGf_GPOS_SEEN) {
3700         MAGIC *mg;
3701
3702         /* set reginfo->ganch, the position where \G can match */
3703
3704         reginfo->ganch =
3705             (flags & REXEC_IGNOREPOS)
3706             ? stringarg /* use start pos rather than pos() */
3707             : ((mg = mg_find_mglob(sv)) && mg->mg_len >= 0)
3708               /* Defined pos(): */
3709             ? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg)
3710             : strbeg; /* pos() not defined; use start of string */
3711
3712         DEBUG_GPOS_r(Perl_re_printf( aTHX_
3713             "GPOS ganch set to strbeg[%" IVdf "]\n", (IV)(reginfo->ganch - strbeg)));
3714
3715         /* in the presence of \G, we may need to start looking earlier in
3716          * the string than the suggested start point of stringarg:
3717          * if prog->gofs is set, then that's a known, fixed minimum
3718          * offset, such as
3719          * /..\G/:   gofs = 2
3720          * /ab|c\G/: gofs = 1
3721          * or if the minimum offset isn't known, then we have to go back
3722          * to the start of the string, e.g. /w+\G/
3723          */
3724
3725         if (prog->intflags & PREGf_ANCH_GPOS) {
3726             if (prog->gofs) {
3727                 startpos = HOPBACKc(reginfo->ganch, prog->gofs);
3728                 if (!startpos ||
3729                     ((flags & REXEC_FAIL_ON_UNDERFLOW) && startpos < stringarg))
3730                 {
3731                     DEBUG_GPOS_r(Perl_re_printf( aTHX_
3732                             "fail: ganch-gofs before earliest possible start\n"));
3733                     return 0;
3734                 }
3735             }
3736             else
3737                 startpos = reginfo->ganch;
3738         }
3739         else if (prog->gofs) {
3740             startpos = HOPBACKc(startpos, prog->gofs);
3741             if (!startpos)
3742                 startpos = strbeg;
3743         }
3744         else if (prog->intflags & PREGf_GPOS_FLOAT)
3745             startpos = strbeg;
3746     }
3747
3748     minlen = prog->minlen;
3749     if ((startpos + minlen) > strend || startpos < strbeg) {
3750         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
3751                         "Regex match can't succeed, so not even tried\n"));
3752         return 0;
3753     }
3754
3755     /* at the end of this function, we'll do a LEAVE_SCOPE(oldsave),
3756      * which will call destuctors to reset PL_regmatch_state, free higher
3757      * PL_regmatch_slabs, and clean up regmatch_info_aux and
3758      * regmatch_info_aux_eval */
3759
3760     oldsave = PL_savestack_ix;
3761
3762     s = startpos;
3763
3764     if ((prog->extflags & RXf_USE_INTUIT)
3765         && !(flags & REXEC_CHECKED))
3766     {
3767         s = re_intuit_start(rx, sv, strbeg, startpos, strend,
3768                                     flags, NULL);
3769         if (!s)
3770             return 0;
3771
3772         if (prog->extflags & RXf_CHECK_ALL) {
3773             /* we can match based purely on the result of INTUIT.
3774              * Set up captures etc just for $& and $-[0]
3775              * (an intuit-only match wont have $1,$2,..) */
3776             assert(!prog->nparens);
3777
3778             /* s/// doesn't like it if $& is earlier than where we asked it to
3779              * start searching (which can happen on something like /.\G/) */
3780             if (       (flags & REXEC_FAIL_ON_UNDERFLOW)
3781                     && (s < stringarg))
3782             {
3783                 /* this should only be possible under \G */
3784                 assert(prog->intflags & PREGf_GPOS_SEEN);
3785                 DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
3786                     "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
3787                 goto phooey;
3788             }
3789
3790             /* match via INTUIT shouldn't have any captures.
3791              * Let @-, @+, $^N know */
3792             RXp_LASTPAREN(prog) = RXp_LASTCLOSEPAREN(prog) = 0;
3793             RXp_MATCH_UTF8_set(prog, utf8_target);
3794             SSize_t match_start = s - strbeg;
3795             SSize_t match_end = utf8_target
3796                 ? (char*)utf8_hop_forward((U8*)s, prog->minlenret, (U8 *) strend) - strbeg
3797                 : s - strbeg + prog->minlenret;
3798             CLOSE_ANY_CAPTURE(prog, 0, match_start, match_end);
3799             if ( !(flags & REXEC_NOT_FIRST) )
3800                 S_reg_set_capture_string(aTHX_ rx,
3801                                         strbeg, strend,
3802                                         sv, flags, utf8_target);
3803
3804             return 1;
3805         }
3806     }
3807
3808     multiline = prog->extflags & RXf_PMf_MULTILINE;
3809
3810     if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
3811         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
3812                               "String too short [regexec_flags]...\n"));
3813         goto phooey;
3814     }
3815
3816     /* Check validity of program. */
3817     if (UCHARAT(progi->program) != REG_MAGIC) {
3818         Perl_croak(aTHX_ "corrupted regexp program");
3819     }
3820
3821     RXp_MATCH_TAINTED_off(prog);
3822     RXp_MATCH_UTF8_set(prog, utf8_target);
3823
3824     reginfo->prog = rx;  /* Yes, sorry that this is confusing.  */
3825     reginfo->intuit = 0;
3826     reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx));
3827     reginfo->warned = FALSE;
3828     reginfo->sv = sv;
3829     reginfo->poscache_maxiter = 0; /* not yet started a countdown */
3830     /* see how far we have to get to not match where we matched before */
3831     reginfo->till = stringarg + minend;
3832
3833     if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv)) {
3834         /* SAVEFREESV, not sv_mortalcopy, as this SV must last until after
3835            S_cleanup_regmatch_info_aux has executed (registered by
3836            SAVEDESTRUCTOR_X below).  S_cleanup_regmatch_info_aux modifies
3837            magic belonging to this SV.
3838            Not newSVsv, either, as it does not COW.
3839         */
3840         reginfo->sv = newSV_type(SVt_NULL);
3841         SvSetSV_nosteal(reginfo->sv, sv);
3842         SAVEFREESV(reginfo->sv);
3843     }
3844
3845     /* reserve next 2 or 3 slots in PL_regmatch_state:
3846      * slot N+0: may currently be in use: skip it
3847      * slot N+1: use for regmatch_info_aux struct
3848      * slot N+2: use for regmatch_info_aux_eval struct if we have (?{})'s
3849      * slot N+3: ready for use by regmatch()
3850      */
3851
3852     {
3853         regmatch_state *old_regmatch_state;
3854         regmatch_slab  *old_regmatch_slab;
3855         int i, max = (prog->extflags & RXf_EVAL_SEEN) ? 2 : 1;
3856
3857         /* on first ever match, allocate first slab */
3858         if (!PL_regmatch_slab) {
3859             Newx(PL_regmatch_slab, 1, regmatch_slab);
3860             PL_regmatch_slab->prev = NULL;
3861             PL_regmatch_slab->next = NULL;
3862             PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
3863         }
3864
3865         old_regmatch_state = PL_regmatch_state;
3866         old_regmatch_slab  = PL_regmatch_slab;
3867
3868         for (i=0; i <= max; i++) {
3869             if (i == 1)
3870                 reginfo->info_aux = &(PL_regmatch_state->u.info_aux);
3871             else if (i ==2)
3872                 reginfo->info_aux_eval =
3873                 reginfo->info_aux->info_aux_eval =
3874                             &(PL_regmatch_state->u.info_aux_eval);
3875
3876             if (++PL_regmatch_state >  SLAB_LAST(PL_regmatch_slab))
3877                 PL_regmatch_state = S_push_slab(aTHX);
3878         }
3879
3880         /* note initial PL_regmatch_state position; at end of match we'll
3881          * pop back to there and free any higher slabs */
3882
3883         reginfo->info_aux->old_regmatch_state = old_regmatch_state;
3884         reginfo->info_aux->old_regmatch_slab  = old_regmatch_slab;
3885         reginfo->info_aux->poscache = NULL;
3886
3887         SAVEDESTRUCTOR_X(S_cleanup_regmatch_info_aux, reginfo->info_aux);
3888
3889         if ((prog->extflags & RXf_EVAL_SEEN))
3890             S_setup_eval_state(aTHX_ reginfo);
3891         else
3892             reginfo->info_aux_eval = reginfo->info_aux->info_aux_eval = NULL;
3893     }
3894
3895     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
3896         /* We have to be careful. If the previous successful match
3897            was from this regex we don't want a subsequent partially
3898            successful match to clobber the old results.
3899            So when we detect this possibility we add a swap buffer
3900            to the re, and switch the buffer each match. If we fail,
3901            we switch it back; otherwise we leave it swapped.
3902         */
3903         swap = RXp_OFFSp(prog);
3904         /* avoid leak if we die, or clean up anyway if match completes */
3905         SAVEFREEPV(swap);
3906         Newxz(RXp_OFFSp(prog), (prog->nparens + 1), regexp_paren_pair);
3907         DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
3908             "rex=0x%" UVxf " saving  offs: orig=0x%" UVxf " new=0x%" UVxf "\n",
3909             0,
3910             PTR2UV(prog),
3911             PTR2UV(swap),
3912             PTR2UV(RXp_OFFSp(prog))
3913         ));
3914     }
3915
3916     if (prog->recurse_locinput)
3917         Zero(prog->recurse_locinput,prog->nparens + 1, char *);
3918
3919     /* Simplest case: anchored match (but not \G) need be tried only once,
3920      * or with MBOL, only at the beginning of each line.
3921      *
3922      * Note that /.*.../ sets PREGf_IMPLICIT|MBOL, while /.*.../s sets
3923      * PREGf_IMPLICIT|SBOL. The idea is that with /.*.../s, if it doesn't
3924      * match at the start of the string then it won't match anywhere else
3925      * either; while with /.*.../, if it doesn't match at the beginning,
3926      * the earliest it could match is at the start of the next line */
3927
3928     if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) {
3929         char *end;
3930
3931         if (regtry(reginfo, &s))
3932             goto got_it;
3933
3934         if (!(prog->intflags & PREGf_ANCH_MBOL))
3935             goto phooey;
3936
3937         /* didn't match at start, try at other newline positions */
3938
3939         if (minlen)
3940             dontbother = minlen - 1;
3941         end = HOP3c(strend, -dontbother, strbeg) - 1;
3942
3943         /* skip to next newline */
3944
3945         while (s <= end) { /* note it could be possible to match at the end of the string */
3946             /* NB: newlines are the same in unicode as they are in latin */
3947             if (*s++ != '\n')
3948                 continue;
3949             if (prog->check_substr || prog->check_utf8) {
3950             /* note that with PREGf_IMPLICIT, intuit can only fail
3951              * or return the start position, so it's of limited utility.
3952              * Nevertheless, I made the decision that the potential for
3953              * quick fail was still worth it - DAPM */
3954                 s = re_intuit_start(rx, sv, strbeg, s, strend, flags, NULL);
3955                 if (!s)
3956                     goto phooey;
3957             }
3958             if (regtry(reginfo, &s))
3959                 goto got_it;
3960         }
3961         goto phooey;
3962     } /* end anchored search */
3963
3964     /* anchored \G match */
3965     if (prog->intflags & PREGf_ANCH_GPOS)
3966     {
3967         /* PREGf_ANCH_GPOS should never be true if PREGf_GPOS_SEEN is not true */
3968         assert(prog->intflags & PREGf_GPOS_SEEN);
3969         /* For anchored \G, the only position it can match from is
3970          * (ganch-gofs); we already set startpos to this above; if intuit
3971          * moved us on from there, we can't possibly succeed */
3972         assert(startpos == HOPBACKc(reginfo->ganch, prog->gofs));
3973         if (s == startpos && regtry(reginfo, &s))
3974             goto got_it;
3975         goto phooey;
3976     }
3977
3978     /* Messy cases:  unanchored match. */
3979
3980     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
3981         /* we have /x+whatever/ */
3982         /* it must be a one character string (XXXX Except is_utf8_pat?) */
3983         char ch;
3984 #ifdef DEBUGGING
3985         int did_match = 0;
3986 #endif
3987         if (utf8_target) {
3988             if (! prog->anchored_utf8) {
3989                 to_utf8_substr(prog);
3990             }
3991             ch = SvPVX_const(prog->anchored_utf8)[0];
3992             REXEC_FBC_UTF8_SCAN(
3993                 if (*s == ch) {
3994                     DEBUG_EXECUTE_r( did_match = 1 );
3995                     if (regtry(reginfo, &s)) goto got_it;
3996                     s += UTF8_SAFE_SKIP(s, strend);
3997                     while (s < strend && *s == ch)
3998                         s += UTF8SKIP(s);
3999                 }
4000             );
4001
4002         }
4003         else {
4004             if (! prog->anchored_substr) {
4005                 if (! to_byte_substr(prog)) {
4006                     NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
4007                 }
4008             }
4009             ch = SvPVX_const(prog->anchored_substr)[0];
4010             REXEC_FBC_NON_UTF8_SCAN(
4011                 if (*s == ch) {
4012                     DEBUG_EXECUTE_r( did_match = 1 );
4013                     if (regtry(reginfo, &s)) goto got_it;
4014                     s++;
4015                     while (s < strend && *s == ch)
4016                         s++;
4017                 }
4018             );
4019         }
4020         DEBUG_EXECUTE_r(if (!did_match)
4021                 Perl_re_printf( aTHX_
4022                                   "Did not find anchored character...\n")
4023                );
4024     }
4025     else if (prog->anchored_substr != NULL
4026               || prog->anchored_utf8 != NULL
4027               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
4028                   && prog->float_max_offset < strend - s)) {
4029         SV *must;
4030         SSize_t back_max;
4031         SSize_t back_min;
4032         char *last;
4033         char *last1;            /* Last position checked before */
4034 #ifdef DEBUGGING
4035         int did_match = 0;
4036 #endif
4037         if (prog->anchored_substr || prog->anchored_utf8) {
4038             if (utf8_target) {
4039                 if (! prog->anchored_utf8) {
4040                     to_utf8_substr(prog);
4041                 }
4042                 must = prog->anchored_utf8;
4043             }
4044             else {
4045                 if (! prog->anchored_substr) {
4046                     if (! to_byte_substr(prog)) {
4047                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
4048                     }
4049                 }
4050                 must = prog->anchored_substr;
4051             }
4052             back_max = back_min = prog->anchored_offset;
4053         } else {
4054             if (utf8_target) {
4055                 if (! prog->float_utf8) {
4056                     to_utf8_substr(prog);
4057                 }
4058                 must = prog->float_utf8;
4059             }
4060             else {
4061                 if (! prog->float_substr) {
4062                     if (! to_byte_substr(prog)) {
4063                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
4064                     }
4065                 }
4066                 must = prog->float_substr;
4067             }
4068             back_max = prog->float_max_offset;
4069             back_min = prog->float_min_offset;
4070         }
4071
4072         if (back_min<0) {
4073             last = strend;
4074         } else {
4075             last = HOP3c(strend,        /* Cannot start after this */
4076                   -(SSize_t)(CHR_SVLEN(must)
4077                          - (SvTAIL(must) != 0) + back_min), strbeg);
4078         }
4079         if (s > reginfo->strbeg)
4080             last1 = HOPc(s, -1);
4081         else
4082             last1 = s - 1;      /* bogus */
4083
4084         /* XXXX check_substr already used to find "s", can optimize if
4085            check_substr==must. */
4086         dontbother = 0;
4087         strend = HOPc(strend, -dontbother);
4088         while ( (s <= last) &&
4089                 (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg,  strend),
4090                                   (unsigned char*)strend, must,
4091                                   multiline ? FBMrf_MULTILINE : 0)) ) {
4092             DEBUG_EXECUTE_r( did_match = 1 );
4093             if (HOPc(s, -back_max) > last1) {
4094                 last1 = HOPc(s, -back_min);
4095                 s = HOPc(s, -back_max);
4096             }
4097             else {
4098                 char * const t = (last1 >= reginfo->strbeg)
4099                                     ? HOPc(last1, 1) : last1 + 1;
4100
4101                 last1 = HOPc(s, -back_min);
4102                 s = t;
4103             }
4104             if (utf8_target) {
4105                 while (s <= last1) {
4106                     if (regtry(reginfo, &s))
4107                         goto got_it;
4108                     if (s >= last1) {
4109                         s++; /* to break out of outer loop */
4110                         break;
4111                     }
4112                     s += UTF8SKIP(s);
4113                 }
4114             }
4115             else {
4116                 while (s <= last1) {
4117                     if (regtry(reginfo, &s))
4118                         goto got_it;
4119                     s++;
4120                 }
4121             }
4122         }
4123         DEBUG_EXECUTE_r(if (!did_match) {
4124             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
4125                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
4126             Perl_re_printf( aTHX_  "Did not find %s substr %s%s...\n",
4127                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
4128                                ? "anchored" : "floating"),
4129                 quoted, RE_SV_TAIL(must));
4130         });
4131         goto phooey;
4132     }
4133     else if ( (c = progi->regstclass) ) {
4134         if (minlen) {
4135             const OPCODE op = OP(progi->regstclass);
4136             /* don't bother with what can't match */
4137             if (REGNODE_TYPE(op) != EXACT && REGNODE_TYPE(op) != TRIE)
4138                 strend = HOPc(strend, -(minlen - 1));
4139         }
4140         DEBUG_EXECUTE_r({
4141             SV * const prop = sv_newmortal();
4142             regprop(prog, prop, c, reginfo, NULL);
4143             {
4144                 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
4145                     s,strend-s,PL_dump_re_max_len);
4146                 Perl_re_printf( aTHX_
4147                     "Matching stclass %.*s against %s (%d bytes)\n",
4148                     (int)SvCUR(prop), SvPVX_const(prop),
4149                      quoted, (int)(strend - s));
4150             }
4151         });
4152         if (find_byclass(prog, c, s, strend, reginfo))
4153             goto got_it;
4154         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_  "Contradicts stclass... [regexec_flags]\n"));
4155     }
4156     else {
4157         dontbother = 0;
4158         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
4159             /* Trim the end. */
4160             char *last= NULL;
4161             SV* float_real;
4162             STRLEN len;
4163             const char *little;
4164
4165             if (utf8_target) {
4166                 if (! prog->float_utf8) {
4167                     to_utf8_substr(prog);
4168                 }
4169                 float_real = prog->float_utf8;
4170             }
4171             else {
4172                 if (! prog->float_substr) {
4173                     if (! to_byte_substr(prog)) {
4174                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
4175                     }
4176                 }
4177                 float_real = prog->float_substr;
4178             }
4179
4180             little = SvPV_const(float_real, len);
4181             if (SvTAIL(float_real)) {
4182                     /* This means that float_real contains an artificial \n on
4183                      * the end due to the presence of something like this:
4184                      * /foo$/ where we can match both "foo" and "foo\n" at the
4185                      * end of the string.  So we have to compare the end of the
4186                      * string first against the float_real without the \n and
4187                      * then against the full float_real with the string.  We
4188                      * have to watch out for cases where the string might be
4189                      * smaller than the float_real or the float_real without
4190                      * the \n. */
4191                     char *checkpos= strend - len;
4192                     DEBUG_OPTIMISE_r(
4193                         Perl_re_printf( aTHX_
4194                             "%sChecking for float_real.%s\n",
4195                             PL_colors[4], PL_colors[5]));
4196                     if (checkpos + 1 < strbeg) {
4197                         /* can't match, even if we remove the trailing \n
4198                          * string is too short to match */
4199                         DEBUG_EXECUTE_r(
4200                             Perl_re_printf( aTHX_
4201                                 "%sString shorter than required trailing substring, cannot match.%s\n",
4202                                 PL_colors[4], PL_colors[5]));
4203                         goto phooey;
4204                     } else if (memEQ(checkpos + 1, little, len - 1)) {
4205                         /* can match, the end of the string matches without the
4206                          * "\n" */
4207                         last = checkpos + 1;
4208                     } else if (checkpos < strbeg) {
4209                         /* cant match, string is too short when the "\n" is
4210                          * included */
4211                         DEBUG_EXECUTE_r(
4212                             Perl_re_printf( aTHX_
4213                                 "%sString does not contain required trailing substring, cannot match.%s\n",
4214                                 PL_colors[4], PL_colors[5]));
4215                         goto phooey;
4216                     } else if (!multiline) {
4217                         /* non multiline match, so compare with the "\n" at the
4218                          * end of the string */
4219                         if (memEQ(checkpos, little, len)) {
4220                             last= checkpos;
4221                         } else {
4222                             DEBUG_EXECUTE_r(
4223                                 Perl_re_printf( aTHX_
4224                                     "%sString does not contain required trailing substring, cannot match.%s\n",
4225                                     PL_colors[4], PL_colors[5]));
4226                             goto phooey;
4227                         }
4228                     } else {
4229                         /* multiline match, so we have to search for a place
4230                          * where the full string is located */
4231                         goto find_last;
4232                     }
4233             } else {
4234                   find_last:
4235                     if (len)
4236                         last = rninstr(s, strend, little, little + len);
4237                     else
4238                         last = strend;  /* matching "$" */
4239             }
4240             if (!last) {
4241                 /* at one point this block contained a comment which was
4242                  * probably incorrect, which said that this was a "should not
4243                  * happen" case.  Even if it was true when it was written I am
4244                  * pretty sure it is not anymore, so I have removed the comment
4245                  * and replaced it with this one. Yves */
4246                 DEBUG_EXECUTE_r(
4247                     Perl_re_printf( aTHX_
4248                         "%sString does not contain required substring, cannot match.%s\n",
4249                         PL_colors[4], PL_colors[5]
4250                     ));
4251                 goto phooey;
4252             }
4253             dontbother = strend - last + prog->float_min_offset;
4254         }
4255         if (minlen && (dontbother < minlen))
4256             dontbother = minlen - 1;
4257         strend -= dontbother;              /* this one's always in bytes! */
4258         /* We don't know much -- general case. */
4259         if (utf8_target) {
4260             for (;;) {
4261                 if (regtry(reginfo, &s))
4262                     goto got_it;
4263                 if (s >= strend)
4264                     break;
4265                 s += UTF8SKIP(s);
4266             };
4267         }
4268         else {
4269             do {
4270                 if (regtry(reginfo, &s))
4271                     goto got_it;
4272             } while (s++ < strend);
4273         }
4274     }
4275
4276     /* Failure. */
4277     goto phooey;
4278
4279   got_it:
4280     /* s/// doesn't like it if $& is earlier than where we asked it to
4281      * start searching (which can happen on something like /.\G/) */
4282     if (       (flags & REXEC_FAIL_ON_UNDERFLOW)
4283             && (RXp_OFFS_START(prog,0) < stringarg - strbeg))
4284     {
4285         /* this should only be possible under \G */
4286         assert(prog->intflags & PREGf_GPOS_SEEN);
4287         DEBUG_EXECUTE_r(Perl_re_printf( aTHX_
4288             "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
4289         goto phooey;
4290     }
4291
4292     /* clean up; this will trigger destructors that will free all slabs
4293      * above the current one, and cleanup the regmatch_info_aux
4294      * and regmatch_info_aux_eval sructs */
4295
4296     LEAVE_SCOPE(oldsave);
4297
4298     if (RXp_PAREN_NAMES(prog))
4299         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
4300
4301     /* make sure $`, $&, $', and $digit will work later */
4302     if ( !(flags & REXEC_NOT_FIRST) )
4303         S_reg_set_capture_string(aTHX_ rx,
4304                                     strbeg, reginfo->strend,
4305                                     sv, flags, utf8_target);
4306
4307     return 1;
4308
4309   phooey:
4310     DEBUG_EXECUTE_r(Perl_re_printf( aTHX_  "%sMatch failed%s\n",
4311                           PL_colors[4], PL_colors[5]));
4312
4313     if (swap) {
4314         /* we failed :-( roll it back.
4315          * Since the swap buffer will be freed on scope exit which follows
4316          * shortly, restore the old captures by copying 'swap's original
4317          * data to the new offs buffer
4318          */
4319         DEBUG_BUFFERS_r(Perl_re_exec_indentf( aTHX_
4320             "rex=0x%" UVxf " rolling back offs: 0x%" UVxf " will be freed; restoring data to =0x%" UVxf "\n",
4321             0,
4322             PTR2UV(prog),
4323             PTR2UV(RXp_OFFSp(prog)),
4324             PTR2UV(swap)
4325         ));
4326
4327         Copy(swap, RXp_OFFSp(prog), prog->nparens + 1, regexp_paren_pair);
4328     }
4329
4330     /* clean up; this will trigger destructors that will free all slabs
4331      * above the current one, and cleanup the regmatch_info_aux
4332      * and regmatch_info_aux_eval sructs */
4333
4334     LEAVE_SCOPE(oldsave);
4335
4336     return 0;
4337 }
4338
4339
4340 /* Set which rex is pointed to by PL_reg_curpm, handling ref counting.
4341  * Do inc before dec, in case old and new rex are the same */
4342 #define SET_reg_curpm(Re2)                          \
4343     if (reginfo->info_aux_eval) {                   \
4344         (void)ReREFCNT_inc(Re2);                    \
4345         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));       \
4346         PM_SETRE((PL_reg_curpm), (Re2));            \
4347     }
4348
4349
4350 /*
4351  - regtry - try match at specific point
4352  */
4353 STATIC bool                     /* 0 failure, 1 success */
4354 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
4355 {
4356     CHECKPOINT lastcp;
4357     REGEXP *const rx = reginfo->prog;
4358     regexp *const prog = ReANY(rx);
4359     SSize_t result;
4360 #ifdef DEBUGGING
4361     U32 depth = 0; /* used by REGCP_SET */
4362 #endif
4363     RXi_GET_DECL(prog,progi);
4364     DECLARE_AND_GET_RE_DEBUG_FLAGS;
4365
4366     PERL_ARGS_ASSERT_REGTRY;
4367
4368     reginfo->cutpoint=NULL;
4369
4370     RXp_OFFSp(prog)[0].start = *startposp - reginfo->strbeg;
4371     RXp_LASTPAREN(prog) = 0;
4372     RXp_LASTCLOSEPAREN(prog) = 0;
4373
4374     /* XXXX What this code is doing here?!!!  There should be no need
4375        to do this again and again, RXp_LASTPAREN(prog) should take care of
4376        this!  --ilya*/
4377
4378     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
4379      * Actually, the code in regcppop() (which Ilya may be meaning by
4380      * RXp_LASTPAREN(prog)), is not needed at all by the test suite
4381      * (op/regexp, op/pat, op/split), but that code is needed otherwise
4382      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
4383      * Meanwhile, this code *is* needed for the
4384      * above-mentioned test suite tests to succeed.  The common theme
4385      * on those tests seems to be returning null fields from matches.
4386      * --jhi updated by dapm */
4387
4388     /* After encountering a variant of the issue mentioned above I think
4389      * the point Ilya was making is that if we properly unwind whenever
4390      * we set lastparen to a smaller value then we should not need to do
4391      * this every time, only when needed. So if we have tests that fail if
4392      * we remove this, then it suggests somewhere else we are improperly
4393      * unwinding the lastparen/paren buffers. See UNWIND_PARENS() and
4394      * places it is called, and related regcp() routines. - Yves */
4395 #if 1
4396     if (prog->nparens) {
4397         regexp_paren_pair *pp = RXp_OFFSp(prog);
4398         I32 i;
4399         for (i = prog->nparens; i > (I32)RXp_LASTPAREN(prog); i--) {
4400             ++pp;
4401             pp->start = -1;
4402             pp->end = -1;
4403         }
4404     }
4405 #endif
4406     REGCP_SET(lastcp);
4407     result = regmatch(reginfo, *startposp, progi->program + 1);
4408     if (result != -1) {
4409         RXp_OFFSp(prog)[0].end = result;
4410         return 1;
4411     }
4412     if (reginfo->cutpoint)
4413         *startposp= reginfo->cutpoint;
4414     REGCP_UNWIND(lastcp);
4415     return 0;
4416 }
4417
4418 /* this is used to determine how far from the left messages like
4419    'failed...' are printed in regexec.c. It should be set such that
4420    messages are inline with the regop output that created them.
4421 */
4422 #define REPORT_CODE_OFF 29
4423 #define INDENT_CHARS(depth) ((int)(depth) % 20)
4424 #ifdef DEBUGGING
4425 int
4426 Perl_re_exec_indentf(pTHX_ const char *fmt, U32 depth, ...)
4427 {
4428     va_list ap;
4429     int result;
4430     PerlIO *f= Perl_debug_log;
4431     PERL_ARGS_ASSERT_RE_EXEC_INDENTF;
4432     va_start(ap, depth);
4433     PerlIO_printf(f, "%*s|%4" UVuf "| %*s", REPORT_CODE_OFF, "", (UV)depth, INDENT_CHARS(depth), "" );
4434     result = PerlIO_vprintf(f, fmt, ap);
4435     va_end(ap);
4436     return result;
4437 }
4438 #endif /* DEBUGGING */
4439
4440 /* grab a new slab and return the first slot in it */
4441
4442 STATIC regmatch_state *
4443 S_push_slab(pTHX)
4444 {
4445     regmatch_slab *s = PL_regmatch_slab->next;
4446     if (!s) {
4447         Newx(s, 1, regmatch_slab);
4448         s->prev = PL_regmatch_slab;
4449         s->next = NULL;
4450         PL_regmatch_slab->next = s;
4451     }
4452     PL_regmatch_slab = s;
4453     return SLAB_FIRST(s);
4454 }
4455
4456 #ifdef DEBUGGING
4457
4458 STATIC void
4459 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
4460     const char *start, const char *end, const char *blurb)
4461 {
4462     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
4463
4464     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
4465
4466     if (!PL_colorset)
4467             reginitcolors();
4468     {
4469         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
4470             RX_PRECOMP_const(prog), RX_PRELEN(prog), PL_dump_re_max_len);
4471
4472         RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
4473             start, end - start, PL_dump_re_max_len);
4474
4475         Perl_re_printf( aTHX_
4476             "%s%s REx%s %s against %s\n",
4477                        PL_colors[4], blurb, PL_colors[5], s0, s1);
4478
4479         if (utf8_target||utf8_pat)
4480             Perl_re_printf( aTHX_  "UTF-8 %s%s%s...\n",
4481                 utf8_pat ? "pattern" : "",
4482                 utf8_pat && utf8_target ? " and " : "",
4483                 utf8_target ? "string" : ""
4484             );
4485     }
4486 }
4487
4488 STATIC void
4489 S_dump_exec_pos(pTHX_ const char *locinput,
4490                       const regnode *scan,
4491                       const char *loc_regeol,
4492                       const char *loc_bostr,
4493                       const char *loc_reg_starttry,
4494                       const bool utf8_target,
4495                       const U32 depth
4496                 )
4497 {
4498     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
4499     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
4500     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
4501     /* The part of the string before starttry has one color
4502        (pref0_len chars), between starttry and current
4503        position another one (pref_len - pref0_len chars),
4504        after the current position the third one.
4505        We assume that pref0_len <= pref_len, otherwise we
4506        decrease pref0_len.  */
4507     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
4508         ? (5 + taill) - l : locinput - loc_bostr;
4509     int pref0_len;
4510
4511     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
4512
4513     if (utf8_target) {
4514         while (UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len))) {
4515             pref_len++;
4516         }
4517     }
4518     pref0_len = pref_len  - (locinput - loc_reg_starttry);
4519     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)