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