This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Consistently use NOT_REACHED; /* NOTREACHED */
[perl5.git] / regexec.c
1 /*    regexec.c
2  */
3
4 /*
5  *      One Ring to rule them all, One Ring to find them
6  &
7  *     [p.v of _The Lord of the Rings_, opening poem]
8  *     [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
9  *     [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
10  */
11
12 /* This file contains functions for executing a regular expression.  See
13  * also regcomp.c which funnily enough, contains functions for compiling
14  * a regular expression.
15  *
16  * This file is also copied at build time to ext/re/re_exec.c, where
17  * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
18  * This causes the main functions to be compiled under new names and with
19  * debugging support added, which makes "use re 'debug'" work.
20  */
21
22 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
23  * confused with the original package (see point 3 below).  Thanks, Henry!
24  */
25
26 /* Additional note: this code is very heavily munged from Henry's version
27  * in places.  In some spots I've traded clarity for efficiency, so don't
28  * blame Henry for some of the lack of readability.
29  */
30
31 /* The names of the functions have been changed from regcomp and
32  * regexec to  pregcomp and pregexec in order to avoid conflicts
33  * with the POSIX routines of the same names.
34 */
35
36 #ifdef PERL_EXT_RE_BUILD
37 #include "re_top.h"
38 #endif
39
40 #define B_ON_NON_UTF8_LOCALE_IS_WRONG            \
41       "Use of \\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 - strpos),
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         DEBUG_OPTIMISE_MORE_r({
908             PerlIO_printf(Perl_debug_log, "  fbm_instr len=%d str=<%.*s>\n",
909                 (int)(end_point - start_point),
910                 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point), 
911                 start_point);
912         });
913
914         check_at = fbm_instr( start_point, end_point,
915                       check, multiline ? FBMrf_MULTILINE : 0);
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         /* Finish the diagnostic message */
935         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(check_at - strpos)) );
936
937         /* set rx_origin to the minimum position where the regex could start
938          * matching, given the constraint of the just-matched check substring.
939          * But don't set it lower than previously.
940          */
941
942         if (check_at - rx_origin > prog->check_offset_max)
943             rx_origin = HOP3c(check_at, -prog->check_offset_max, rx_origin);
944     }
945
946
947     /* now look for the 'other' substring if defined */
948
949     if (utf8_target ? prog->substrs->data[other_ix].utf8_substr
950                     : prog->substrs->data[other_ix].substr)
951     {
952         /* Take into account the "other" substring. */
953         char *last, *last1;
954         char *s;
955         SV* must;
956         struct reg_substr_datum *other;
957
958       do_other_substr:
959         other = &prog->substrs->data[other_ix];
960
961         /* if "other" is anchored:
962          * we've previously found a floating substr starting at check_at.
963          * This means that the regex origin must lie somewhere
964          * between min (rx_origin): HOP3(check_at, -check_offset_max)
965          * and max:                 HOP3(check_at, -check_offset_min)
966          * (except that min will be >= strpos)
967          * So the fixed  substr must lie somewhere between
968          *  HOP3(min, anchored_offset)
969          *  HOP3(max, anchored_offset) + SvCUR(substr)
970          */
971
972         /* if "other" is floating
973          * Calculate last1, the absolute latest point where the
974          * floating substr could start in the string, ignoring any
975          * constraints from the earlier fixed match. It is calculated
976          * as follows:
977          *
978          * strend - prog->minlen (in chars) is the absolute latest
979          * position within the string where the origin of the regex
980          * could appear. The latest start point for the floating
981          * substr is float_min_offset(*) on from the start of the
982          * regex.  last1 simply combines thee two offsets.
983          *
984          * (*) You might think the latest start point should be
985          * float_max_offset from the regex origin, and technically
986          * you'd be correct. However, consider
987          *    /a\d{2,4}bcd\w/
988          * Here, float min, max are 3,5 and minlen is 7.
989          * This can match either
990          *    /a\d\dbcd\w/
991          *    /a\d\d\dbcd\w/
992          *    /a\d\d\d\dbcd\w/
993          * In the first case, the regex matches minlen chars; in the
994          * second, minlen+1, in the third, minlen+2.
995          * In the first case, the floating offset is 3 (which equals
996          * float_min), in the second, 4, and in the third, 5 (which
997          * equals float_max). In all cases, the floating string bcd
998          * can never start more than 4 chars from the end of the
999          * string, which equals minlen - float_min. As the substring
1000          * starts to match more than float_min from the start of the
1001          * regex, it makes the regex match more than minlen chars,
1002          * and the two cancel each other out. So we can always use
1003          * float_min - minlen, rather than float_max - minlen for the
1004          * latest position in the string.
1005          *
1006          * Note that -minlen + float_min_offset is equivalent (AFAIKT)
1007          * to CHR_SVLEN(must) - !!SvTAIL(must) + prog->float_end_shift
1008          */
1009
1010         assert(prog->minlen >= other->min_offset);
1011         last1 = HOP3c(strend,
1012                         other->min_offset - prog->minlen, strbeg);
1013
1014         if (other_ix) {/* i.e. if (other-is-float) */
1015             /* last is the latest point where the floating substr could
1016              * start, *given* any constraints from the earlier fixed
1017              * match. This constraint is that the floating string starts
1018              * <= float_max_offset chars from the regex origin (rx_origin).
1019              * If this value is less than last1, use it instead.
1020              */
1021             assert(rx_origin <= last1);
1022             last =
1023                 /* this condition handles the offset==infinity case, and
1024                  * is a short-cut otherwise. Although it's comparing a
1025                  * byte offset to a char length, it does so in a safe way,
1026                  * since 1 char always occupies 1 or more bytes,
1027                  * so if a string range is  (last1 - rx_origin) bytes,
1028                  * it will be less than or equal to  (last1 - rx_origin)
1029                  * chars; meaning it errs towards doing the accurate HOP3
1030                  * rather than just using last1 as a short-cut */
1031                 (last1 - rx_origin) < other->max_offset
1032                     ? last1
1033                     : (char*)HOP3lim(rx_origin, other->max_offset, last1);
1034         }
1035         else {
1036             assert(strpos + start_shift <= check_at);
1037             last = HOP4c(check_at, other->min_offset - start_shift,
1038                         strbeg, strend);
1039         }
1040
1041         s = HOP3c(rx_origin, other->min_offset, strend);
1042         if (s < other_last)     /* These positions already checked */
1043             s = other_last;
1044
1045         must = utf8_target ? other->utf8_substr : other->substr;
1046         assert(SvPOK(must));
1047         s = fbm_instr(
1048             (unsigned char*)s,
1049             (unsigned char*)last + SvCUR(must) - (SvTAIL(must)!=0),
1050             must,
1051             multiline ? FBMrf_MULTILINE : 0
1052         );
1053         DEBUG_EXECUTE_r({
1054             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
1055                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1056             PerlIO_printf(Perl_debug_log, "  %s %s substr %s%s",
1057                 s ? "Found" : "Contradicts",
1058                 other_ix ? "floating" : "anchored",
1059                 quoted, RE_SV_TAIL(must));
1060         });
1061
1062
1063         if (!s) {
1064             /* last1 is latest possible substr location. If we didn't
1065              * find it before there, we never will */
1066             if (last >= last1) {
1067                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1068                                         ", giving up...\n"));
1069                 goto fail_finish;
1070             }
1071
1072             /* try to find the check substr again at a later
1073              * position. Maybe next time we'll find the "other" substr
1074              * in range too */
1075             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1076                 ", trying %s at offset %ld...\n",
1077                 (other_ix ? "floating" : "anchored"),
1078                 (long)(HOP3c(check_at, 1, strend) - strpos)));
1079
1080             other_last = HOP3c(last, 1, strend) /* highest failure */;
1081             rx_origin =
1082                 other_ix /* i.e. if other-is-float */
1083                     ? HOP3c(rx_origin, 1, strend)
1084                     : HOP4c(last, 1 - other->min_offset, strbeg, strend);
1085             goto restart;
1086         }
1087         else {
1088             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
1089                   (long)(s - strpos)));
1090
1091             if (other_ix) { /* if (other-is-float) */
1092                 /* other_last is set to s, not s+1, since its possible for
1093                  * a floating substr to fail first time, then succeed
1094                  * second time at the same floating position; e.g.:
1095                  *     "-AB--AABZ" =~ /\wAB\d*Z/
1096                  * The first time round, anchored and float match at
1097                  * "-(AB)--AAB(Z)" then fail on the initial \w character
1098                  * class. Second time round, they match at "-AB--A(AB)(Z)".
1099                  */
1100                 other_last = s;
1101             }
1102             else {
1103                 rx_origin = HOP3c(s, -other->min_offset, strbeg);
1104                 other_last = HOP3c(s, 1, strend);
1105             }
1106         }
1107     }
1108     else {
1109         DEBUG_OPTIMISE_MORE_r(
1110             PerlIO_printf(Perl_debug_log,
1111                 "  Check-only match: offset min:%"IVdf" max:%"IVdf
1112                 " check_at:%"IVdf" rx_origin:%"IVdf" rx_origin-check_at:%"IVdf
1113                 " strend-strpos:%"IVdf"\n",
1114                 (IV)prog->check_offset_min,
1115                 (IV)prog->check_offset_max,
1116                 (IV)(check_at-strpos),
1117                 (IV)(rx_origin-strpos),
1118                 (IV)(rx_origin-check_at),
1119                 (IV)(strend-strpos)
1120             )
1121         );
1122     }
1123
1124   postprocess_substr_matches:
1125
1126     /* handle the extra constraint of /^.../m if present */
1127
1128     if (ml_anch && rx_origin != strbeg && rx_origin[-1] != '\n') {
1129         char *s;
1130
1131         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1132                         "  looking for /^/m anchor"));
1133
1134         /* we have failed the constraint of a \n before rx_origin.
1135          * Find the next \n, if any, even if it's beyond the current
1136          * anchored and/or floating substrings. Whether we should be
1137          * scanning ahead for the next \n or the next substr is debatable.
1138          * On the one hand you'd expect rare substrings to appear less
1139          * often than \n's. On the other hand, searching for \n means
1140          * we're effectively flipping been check_substr and "\n" on each
1141          * iteration as the current "rarest" string candidate, which
1142          * means for example that we'll quickly reject the whole string if
1143          * hasn't got a \n, rather than trying every substr position
1144          * first
1145          */
1146
1147         s = HOP3c(strend, - prog->minlen, strpos);
1148         if (s <= rx_origin ||
1149             ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin)))
1150         {
1151             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1152                             "  Did not find /%s^%s/m...\n",
1153                             PL_colors[0], PL_colors[1]));
1154             goto fail_finish;
1155         }
1156
1157         /* earliest possible origin is 1 char after the \n.
1158          * (since *rx_origin == '\n', it's safe to ++ here rather than
1159          * HOP(rx_origin, 1)) */
1160         rx_origin++;
1161
1162         if (prog->substrs->check_ix == 0  /* check is anchored */
1163             || rx_origin >= HOP3c(check_at,  - prog->check_offset_min, strpos))
1164         {
1165             /* Position contradicts check-string; either because
1166              * check was anchored (and thus has no wiggle room),
1167              * or check was float and rx_origin is above the float range */
1168             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1169                 "  Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
1170                 PL_colors[0], PL_colors[1], (long)(rx_origin - strpos)));
1171             goto restart;
1172         }
1173
1174         /* if we get here, the check substr must have been float,
1175          * is in range, and we may or may not have had an anchored
1176          * "other" substr which still contradicts */
1177         assert(prog->substrs->check_ix); /* check is float */
1178
1179         if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
1180             /* whoops, the anchored "other" substr exists, so we still
1181              * contradict. On the other hand, the float "check" substr
1182              * didn't contradict, so just retry the anchored "other"
1183              * substr */
1184             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1185                 "  Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
1186                 PL_colors[0], PL_colors[1],
1187                 (long)(rx_origin - strpos),
1188                 (long)(rx_origin - strpos + prog->anchored_offset)));
1189             goto do_other_substr;
1190         }
1191
1192         /* success: we don't contradict the found floating substring
1193          * (and there's no anchored substr). */
1194         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1195             "  Found /%s^%s/m at offset %ld...\n",
1196             PL_colors[0], PL_colors[1], (long)(rx_origin - strpos)));
1197     }
1198     else {
1199         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1200             "  (multiline anchor test skipped)\n"));
1201     }
1202
1203   success_at_start:
1204
1205
1206     /* if we have a starting character class, then test that extra constraint.
1207      * (trie stclasses are too expensive to use here, we are better off to
1208      * leave it to regmatch itself) */
1209
1210     if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1211         const U8* const str = (U8*)STRING(progi->regstclass);
1212
1213         /* XXX this value could be pre-computed */
1214         const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1215                     ?  (reginfo->is_utf8_pat
1216                         ? utf8_distance(str + STR_LEN(progi->regstclass), str)
1217                         : STR_LEN(progi->regstclass))
1218                     : 1);
1219         char * endpos;
1220         char *s;
1221         /* latest pos that a matching float substr constrains rx start to */
1222         char *rx_max_float = NULL;
1223
1224         /* if the current rx_origin is anchored, either by satisfying an
1225          * anchored substring constraint, or a /^.../m constraint, then we
1226          * can reject the current origin if the start class isn't found
1227          * at the current position. If we have a float-only match, then
1228          * rx_origin is constrained to a range; so look for the start class
1229          * in that range. if neither, then look for the start class in the
1230          * whole rest of the string */
1231
1232         /* XXX DAPM it's not clear what the minlen test is for, and why
1233          * it's not used in the floating case. Nothing in the test suite
1234          * causes minlen == 0 here. See <20140313134639.GS12844@iabyn.com>.
1235          * Here are some old comments, which may or may not be correct:
1236          *
1237          *   minlen == 0 is possible if regstclass is \b or \B,
1238          *   and the fixed substr is ''$.
1239          *   Since minlen is already taken into account, rx_origin+1 is
1240          *   before strend; accidentally, minlen >= 1 guaranties no false
1241          *   positives at rx_origin + 1 even for \b or \B.  But (minlen? 1 :
1242          *   0) below assumes that regstclass does not come from lookahead...
1243          *   If regstclass takes bytelength more than 1: If charlength==1, OK.
1244          *   This leaves EXACTF-ish only, which are dealt with in
1245          *   find_byclass().
1246          */
1247
1248         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1249             endpos= HOP3c(rx_origin, (prog->minlen ? cl_l : 0), strend);
1250         else if (prog->float_substr || prog->float_utf8) {
1251             rx_max_float = HOP3c(check_at, -start_shift, strbeg);
1252             endpos= HOP3c(rx_max_float, cl_l, strend);
1253         }
1254         else 
1255             endpos= strend;
1256                     
1257         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1258             "  looking for class: start_shift: %"IVdf" check_at: %"IVdf
1259             " rx_origin: %"IVdf" endpos: %"IVdf"\n",
1260               (IV)start_shift, (IV)(check_at - strbeg),
1261               (IV)(rx_origin - strbeg), (IV)(endpos - strbeg)));
1262
1263         s = find_byclass(prog, progi->regstclass, rx_origin, endpos,
1264                             reginfo);
1265         if (!s) {
1266             if (endpos == strend) {
1267                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1268                                 "  Could not match STCLASS...\n") );
1269                 goto fail;
1270             }
1271             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1272                                "  This position contradicts STCLASS...\n") );
1273             if ((prog->intflags & PREGf_ANCH) && !ml_anch
1274                         && !(prog->intflags & PREGf_IMPLICIT))
1275                 goto fail;
1276
1277             /* Contradict one of substrings */
1278             if (prog->anchored_substr || prog->anchored_utf8) {
1279                 if (prog->substrs->check_ix == 1) { /* check is float */
1280                     /* Have both, check_string is floating */
1281                     assert(rx_origin + start_shift <= check_at);
1282                     if (rx_origin + start_shift != check_at) {
1283                         /* not at latest position float substr could match:
1284                          * Recheck anchored substring, but not floating.
1285                          * The condition above is in bytes rather than
1286                          * chars for efficiency. It's conservative, in
1287                          * that it errs on the side of doing 'goto
1288                          * do_other_substr', where a more accurate
1289                          * char-based calculation will be done */
1290                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1291                                   "  Looking for anchored substr starting at offset %ld...\n",
1292                                   (long)(other_last - strpos)) );
1293                         goto do_other_substr;
1294                     }
1295                 }
1296             }
1297             else {
1298                 /* float-only */
1299
1300                 if (ml_anch) {
1301                     /* In the presence of ml_anch, we might be able to
1302                      * find another \n without breaking the current float
1303                      * constraint. */
1304
1305                     /* strictly speaking this should be HOP3c(..., 1, ...),
1306                      * but since we goto a block of code that's going to
1307                      * search for the next \n if any, its safe here */
1308                     rx_origin++;
1309                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1310                               "  Looking for /%s^%s/m starting at offset %ld...\n",
1311                               PL_colors[0], PL_colors[1],
1312                               (long)(rx_origin - strpos)) );
1313                     goto postprocess_substr_matches;
1314                 }
1315
1316                 /* strictly speaking this can never be true; but might
1317                  * be if we ever allow intuit without substrings */
1318                 if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
1319                     goto fail;
1320
1321                 rx_origin = rx_max_float;
1322             }
1323
1324             /* at this point, any matching substrings have been
1325              * contradicted. Start again... */
1326
1327             rx_origin = HOP3c(rx_origin, 1, strend);
1328
1329             /* uses bytes rather than char calculations for efficiency.
1330              * It's conservative: it errs on the side of doing 'goto restart',
1331              * where there is code that does a proper char-based test */
1332             if (rx_origin + start_shift + end_shift > strend) {
1333                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1334                                        "  Could not match STCLASS...\n") );
1335                 goto fail;
1336             }
1337             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1338                 "  Looking for %s substr starting at offset %ld...\n",
1339                 (prog->substrs->check_ix ? "floating" : "anchored"),
1340                 (long)(rx_origin + start_shift - strpos)) );
1341             goto restart;
1342         }
1343
1344         /* Success !!! */
1345
1346         if (rx_origin != s) {
1347             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1348                         "  By STCLASS: moving %ld --> %ld\n",
1349                                   (long)(rx_origin - strpos), (long)(s - strpos))
1350                    );
1351         }
1352         else {
1353             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1354                                   "  Does not contradict STCLASS...\n");
1355                    );
1356         }
1357     }
1358
1359     /* Decide whether using the substrings helped */
1360
1361     if (rx_origin != strpos) {
1362         /* Fixed substring is found far enough so that the match
1363            cannot start at strpos. */
1364
1365         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "  try at offset...\n"));
1366         ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr);        /* hooray/5 */
1367     }
1368     else {
1369         /* The found rx_origin position does not prohibit matching at
1370          * strpos, so calling intuit didn't gain us anything. Decrement
1371          * the BmUSEFUL() count on the check substring, and if we reach
1372          * zero, free it.  */
1373         if (!(prog->intflags & PREGf_NAUGHTY)
1374             && (utf8_target ? (
1375                 prog->check_utf8                /* Could be deleted already */
1376                 && --BmUSEFUL(prog->check_utf8) < 0
1377                 && (prog->check_utf8 == prog->float_utf8)
1378             ) : (
1379                 prog->check_substr              /* Could be deleted already */
1380                 && --BmUSEFUL(prog->check_substr) < 0
1381                 && (prog->check_substr == prog->float_substr)
1382             )))
1383         {
1384             /* If flags & SOMETHING - do not do it many times on the same match */
1385             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "  ... Disabling check substring...\n"));
1386             /* XXX Does the destruction order has to change with utf8_target? */
1387             SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
1388             SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
1389             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
1390             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
1391             check = NULL;                       /* abort */
1392             /* XXXX This is a remnant of the old implementation.  It
1393                     looks wasteful, since now INTUIT can use many
1394                     other heuristics. */
1395             prog->extflags &= ~RXf_USE_INTUIT;
1396         }
1397     }
1398
1399     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1400             "Intuit: %sSuccessfully guessed:%s match at offset %ld\n",
1401              PL_colors[4], PL_colors[5], (long)(rx_origin - strpos)) );
1402
1403     return rx_origin;
1404
1405   fail_finish:                          /* Substring not found */
1406     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
1407         BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1408   fail:
1409     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1410                           PL_colors[4], PL_colors[5]));
1411     return NULL;
1412 }
1413
1414
1415 #define DECL_TRIE_TYPE(scan) \
1416     const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold,       \
1417                  trie_utf8_exactfa_fold, trie_latin_utf8_exactfa_fold,              \
1418                  trie_utf8l, trie_flu8 }                                            \
1419                     trie_type = ((scan->flags == EXACT)                             \
1420                                  ? (utf8_target ? trie_utf8 : trie_plain)           \
1421                                  : (scan->flags == EXACTL)                          \
1422                                     ? (utf8_target ? trie_utf8l : trie_plain)       \
1423                                     : (scan->flags == EXACTFA)                      \
1424                                       ? (utf8_target                                \
1425                                          ? trie_utf8_exactfa_fold                   \
1426                                          : trie_latin_utf8_exactfa_fold)            \
1427                                       : (scan->flags == EXACTFLU8                   \
1428                                          ? trie_flu8                                \
1429                                          : (utf8_target                             \
1430                                            ? trie_utf8_fold                         \
1431                                            :   trie_latin_utf8_fold)))
1432
1433 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \
1434 STMT_START {                                                                        \
1435     STRLEN skiplen;                                                                 \
1436     U8 flags = FOLD_FLAGS_FULL;                                                     \
1437     switch (trie_type) {                                                            \
1438     case trie_flu8:                                                                 \
1439         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;                                         \
1440         if (utf8_target && UTF8_IS_ABOVE_LATIN1(*uc)) {                             \
1441             _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc + UTF8SKIP(uc));          \
1442         }                                                                           \
1443         goto do_trie_utf8_fold;                                                     \
1444     case trie_utf8_exactfa_fold:                                                    \
1445         flags |= FOLD_FLAGS_NOMIX_ASCII;                                            \
1446         /* FALLTHROUGH */                                                           \
1447     case trie_utf8_fold:                                                            \
1448       do_trie_utf8_fold:                                                            \
1449         if ( foldlen>0 ) {                                                          \
1450             uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1451             foldlen -= len;                                                         \
1452             uscan += len;                                                           \
1453             len=0;                                                                  \
1454         } else {                                                                    \
1455             uvc = _to_utf8_fold_flags( (const U8*) uc, foldbuf, &foldlen, flags);   \
1456             len = UTF8SKIP(uc);                                                     \
1457             skiplen = UNISKIP( uvc );                                               \
1458             foldlen -= skiplen;                                                     \
1459             uscan = foldbuf + skiplen;                                              \
1460         }                                                                           \
1461         break;                                                                      \
1462     case trie_latin_utf8_exactfa_fold:                                              \
1463         flags |= FOLD_FLAGS_NOMIX_ASCII;                                            \
1464         /* FALLTHROUGH */                                                           \
1465     case trie_latin_utf8_fold:                                                      \
1466         if ( foldlen>0 ) {                                                          \
1467             uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1468             foldlen -= len;                                                         \
1469             uscan += len;                                                           \
1470             len=0;                                                                  \
1471         } else {                                                                    \
1472             len = 1;                                                                \
1473             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, flags);             \
1474             skiplen = UNISKIP( uvc );                                               \
1475             foldlen -= skiplen;                                                     \
1476             uscan = foldbuf + skiplen;                                              \
1477         }                                                                           \
1478         break;                                                                      \
1479     case trie_utf8l:                                                                \
1480         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;                                         \
1481         if (utf8_target && UTF8_IS_ABOVE_LATIN1(*uc)) {                             \
1482             _CHECK_AND_OUTPUT_WIDE_LOCALE_UTF8_MSG(uc, uc + UTF8SKIP(uc));          \
1483         }                                                                           \
1484         /* FALLTHROUGH */                                                           \
1485     case trie_utf8:                                                                 \
1486         uvc = utf8n_to_uvchr( (const U8*) uc, UTF8_MAXLEN, &len, uniflags );        \
1487         break;                                                                      \
1488     case trie_plain:                                                                \
1489         uvc = (UV)*uc;                                                              \
1490         len = 1;                                                                    \
1491     }                                                                               \
1492     if (uvc < 256) {                                                                \
1493         charid = trie->charmap[ uvc ];                                              \
1494     }                                                                               \
1495     else {                                                                          \
1496         charid = 0;                                                                 \
1497         if (widecharmap) {                                                          \
1498             SV** const svpp = hv_fetch(widecharmap,                                 \
1499                         (char*)&uvc, sizeof(UV), 0);                                \
1500             if (svpp)                                                               \
1501                 charid = (U16)SvIV(*svpp);                                          \
1502         }                                                                           \
1503     }                                                                               \
1504 } STMT_END
1505
1506 #define DUMP_EXEC_POS(li,s,doutf8)                          \
1507     dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \
1508                 startpos, doutf8)
1509
1510 #define REXEC_FBC_EXACTISH_SCAN(COND)                     \
1511 STMT_START {                                              \
1512     while (s <= e) {                                      \
1513         if ( (COND)                                       \
1514              && (ln == 1 || folder(s, pat_string, ln))    \
1515              && (reginfo->intuit || regtry(reginfo, &s)) )\
1516             goto got_it;                                  \
1517         s++;                                              \
1518     }                                                     \
1519 } STMT_END
1520
1521 #define REXEC_FBC_UTF8_SCAN(CODE)                     \
1522 STMT_START {                                          \
1523     while (s < strend) {                              \
1524         CODE                                          \
1525         s += UTF8SKIP(s);                             \
1526     }                                                 \
1527 } STMT_END
1528
1529 #define REXEC_FBC_SCAN(CODE)                          \
1530 STMT_START {                                          \
1531     while (s < strend) {                              \
1532         CODE                                          \
1533         s++;                                          \
1534     }                                                 \
1535 } STMT_END
1536
1537 #define REXEC_FBC_UTF8_CLASS_SCAN(COND)                        \
1538 REXEC_FBC_UTF8_SCAN( /* Loops while (s < strend) */            \
1539     if (COND) {                                                \
1540         if (tmp && (reginfo->intuit || regtry(reginfo, &s)))   \
1541             goto got_it;                                       \
1542         else                                                   \
1543             tmp = doevery;                                     \
1544     }                                                          \
1545     else                                                       \
1546         tmp = 1;                                               \
1547 )
1548
1549 #define REXEC_FBC_CLASS_SCAN(COND)                             \
1550 REXEC_FBC_SCAN( /* Loops while (s < strend) */                 \
1551     if (COND) {                                                \
1552         if (tmp && (reginfo->intuit || regtry(reginfo, &s)))   \
1553             goto got_it;                                       \
1554         else                                                   \
1555             tmp = doevery;                                     \
1556     }                                                          \
1557     else                                                       \
1558         tmp = 1;                                               \
1559 )
1560
1561 #define REXEC_FBC_CSCAN(CONDUTF8,COND)                         \
1562     if (utf8_target) {                                         \
1563         REXEC_FBC_UTF8_CLASS_SCAN(CONDUTF8);                   \
1564     }                                                          \
1565     else {                                                     \
1566         REXEC_FBC_CLASS_SCAN(COND);                            \
1567     }
1568
1569 /* The three macros below are slightly different versions of the same logic.
1570  *
1571  * The first is for /a and /aa when the target string is UTF-8.  This can only
1572  * match ascii, but it must advance based on UTF-8.   The other two handle the
1573  * non-UTF-8 and the more generic UTF-8 cases.   In all three, we are looking
1574  * for the boundary (or non-boundary) between a word and non-word character.
1575  * The utf8 and non-utf8 cases have the same logic, but the details must be
1576  * different.  Find the "wordness" of the character just prior to this one, and
1577  * compare it with the wordness of this one.  If they differ, we have a
1578  * boundary.  At the beginning of the string, pretend that the previous
1579  * character was a new-line.
1580  *
1581  * All these macros uncleanly have side-effects with each other and outside
1582  * variables.  So far it's been too much trouble to clean-up
1583  *
1584  * TEST_NON_UTF8 is the macro or function to call to test if its byte input is
1585  *               a word character or not.
1586  * IF_SUCCESS    is code to do if it finds that we are at a boundary between
1587  *               word/non-word
1588  * IF_FAIL       is code to do if we aren't at a boundary between word/non-word
1589  *
1590  * Exactly one of the two IF_FOO parameters is a no-op, depending on whether we
1591  * are looking for a boundary or for a non-boundary.  If we are looking for a
1592  * boundary, we want IF_FAIL to be the no-op, and for IF_SUCCESS to go out and
1593  * see if this tentative match actually works, and if so, to quit the loop
1594  * here.  And vice-versa if we are looking for a non-boundary.
1595  *
1596  * 'tmp' below in the next three macros in the REXEC_FBC_SCAN and
1597  * REXEC_FBC_UTF8_SCAN loops is a loop invariant, a bool giving the return of
1598  * TEST_NON_UTF8(s-1).  To see this, note that that's what it is defined to be
1599  * at entry to the loop, and to get to the IF_FAIL branch, tmp must equal
1600  * TEST_NON_UTF8(s), and in the opposite branch, IF_SUCCESS, tmp is that
1601  * complement.  But in that branch we complement tmp, meaning that at the
1602  * bottom of the loop tmp is always going to be equal to TEST_NON_UTF8(s),
1603  * which means at the top of the loop in the next iteration, it is
1604  * TEST_NON_UTF8(s-1) */
1605 #define FBC_UTF8_A(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL)                         \
1606     tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n';                      \
1607     tmp = TEST_NON_UTF8(tmp);                                                  \
1608     REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */                     \
1609         if (tmp == ! TEST_NON_UTF8((U8) *s)) {                                 \
1610             tmp = !tmp;                                                        \
1611             IF_SUCCESS; /* Is a boundary if values for s-1 and s differ */     \
1612         }                                                                      \
1613         else {                                                                 \
1614             IF_FAIL;                                                           \
1615         }                                                                      \
1616     );                                                                         \
1617
1618 /* Like FBC_UTF8_A, but TEST_UV is a macro which takes a UV as its input, and
1619  * TEST_UTF8 is a macro that for the same input code points returns identically
1620  * to TEST_UV, but takes a pointer to a UTF-8 encoded string instead */
1621 #define FBC_UTF8(TEST_UV, TEST_UTF8, IF_SUCCESS, IF_FAIL)                      \
1622     if (s == reginfo->strbeg) {                                                \
1623         tmp = '\n';                                                            \
1624     }                                                                          \
1625     else { /* Back-up to the start of the previous character */                \
1626         U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg);              \
1627         tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r,                     \
1628                                                        0, UTF8_ALLOW_DEFAULT); \
1629     }                                                                          \
1630     tmp = TEST_UV(tmp);                                                        \
1631     LOAD_UTF8_CHARCLASS_ALNUM();                                               \
1632     REXEC_FBC_UTF8_SCAN( /* advances s while s < strend */                     \
1633         if (tmp == ! (TEST_UTF8((U8 *) s))) {                                  \
1634             tmp = !tmp;                                                        \
1635             IF_SUCCESS;                                                        \
1636         }                                                                      \
1637         else {                                                                 \
1638             IF_FAIL;                                                           \
1639         }                                                                      \
1640     );
1641
1642 /* Like the above two macros.  UTF8_CODE is the complete code for handling
1643  * UTF-8.  Common to the BOUND and NBOUND cases, set-up by the FBC_BOUND, etc
1644  * macros below */
1645 #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL)        \
1646     if (utf8_target) {                                                         \
1647         UTF8_CODE                                                              \
1648     }                                                                          \
1649     else {  /* Not utf8 */                                                     \
1650         tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n';                  \
1651         tmp = TEST_NON_UTF8(tmp);                                              \
1652         REXEC_FBC_SCAN( /* advances s while s < strend */                      \
1653             if (tmp == ! TEST_NON_UTF8((U8) *s)) {                             \
1654                 IF_SUCCESS;                                                    \
1655                 tmp = !tmp;                                                    \
1656             }                                                                  \
1657             else {                                                             \
1658                 IF_FAIL;                                                       \
1659             }                                                                  \
1660         );                                                                     \
1661     }                                                                          \
1662     /* Here, things have been set up by the previous code so that tmp is the   \
1663      * return of TEST_NON_UTF(s-1) or TEST_UTF8(s-1) (depending on the         \
1664      * utf8ness of the target).  We also have to check if this matches against \
1665      * the EOS, which we treat as a \n (which is the same value in both UTF-8  \
1666      * or non-UTF8, so can use the non-utf8 test condition even for a UTF-8    \
1667      * string */                                                               \
1668     if (tmp == ! TEST_NON_UTF8('\n')) {                                        \
1669         IF_SUCCESS;                                                            \
1670     }                                                                          \
1671     else {                                                                     \
1672         IF_FAIL;                                                               \
1673     }
1674
1675 /* This is the macro to use when we want to see if something that looks like it
1676  * could match, actually does, and if so exits the loop */
1677 #define REXEC_FBC_TRYIT                            \
1678     if ((reginfo->intuit || regtry(reginfo, &s)))  \
1679         goto got_it
1680
1681 /* The only difference between the BOUND and NBOUND cases is that
1682  * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
1683  * NBOUND.  This is accomplished by passing it as either the if or else clause,
1684  * with the other one being empty (PLACEHOLDER is defined as empty).
1685  *
1686  * The TEST_FOO parameters are for operating on different forms of input, but
1687  * all should be ones that return identically for the same underlying code
1688  * points */
1689 #define FBC_BOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8)                           \
1690     FBC_BOUND_COMMON(                                                          \
1691           FBC_UTF8(TEST_UV, TEST_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER),          \
1692           TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1693
1694 #define FBC_BOUND_A(TEST_NON_UTF8)                                             \
1695     FBC_BOUND_COMMON(                                                          \
1696             FBC_UTF8_A(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER),           \
1697             TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1698
1699 #define FBC_NBOUND(TEST_NON_UTF8, TEST_UV, TEST_UTF8)                          \
1700     FBC_BOUND_COMMON(                                                          \
1701           FBC_UTF8(TEST_UV, TEST_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT),          \
1702           TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1703
1704 #define FBC_NBOUND_A(TEST_NON_UTF8)                                            \
1705     FBC_BOUND_COMMON(                                                          \
1706             FBC_UTF8_A(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT),           \
1707             TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1708
1709 /* Takes a pointer to an inversion list, a pointer to its corresponding
1710  * inversion map, and a code point, and returns the code point's value
1711  * according to the two arrays.  It assumes that all code points have a value.
1712  * This is used as the base macro for macros for particular properties */
1713 #define _generic_GET_BREAK_VAL_CP(invlist, invmap, cp)              \
1714                              invmap[_invlist_search(invlist, cp)]
1715
1716 /* Same as above, but takes begin, end ptrs to a UTF-8 encoded string instead
1717  * of a code point, returning the value for the first code point in the string.
1718  * And it takes the particular macro name that finds the desired value given a
1719  * code point.  Merely convert the UTF-8 to code point and call the cp macro */
1720 #define _generic_GET_BREAK_VAL_UTF8(cp_macro, pos, strend)                     \
1721              (__ASSERT_(pos < strend)                                          \
1722                  /* Note assumes is valid UTF-8 */                             \
1723              (cp_macro(utf8_to_uvchr_buf((pos), (strend), NULL))))
1724
1725 /* Returns the GCB value for the input code point */
1726 #define getGCB_VAL_CP(cp)                                                      \
1727           _generic_GET_BREAK_VAL_CP(                                           \
1728                                     PL_GCB_invlist,                            \
1729                                     Grapheme_Cluster_Break_invmap,             \
1730                                     (cp))
1731
1732 /* Returns the GCB value for the first code point in the UTF-8 encoded string
1733  * bounded by pos and strend */
1734 #define getGCB_VAL_UTF8(pos, strend)                                           \
1735     _generic_GET_BREAK_VAL_UTF8(getGCB_VAL_CP, pos, strend)
1736
1737
1738 /* Returns the SB value for the input code point */
1739 #define getSB_VAL_CP(cp)                                                       \
1740           _generic_GET_BREAK_VAL_CP(                                           \
1741                                     PL_SB_invlist,                             \
1742                                     Sentence_Break_invmap,                     \
1743                                     (cp))
1744
1745 /* Returns the SB value for the first code point in the UTF-8 encoded string
1746  * bounded by pos and strend */
1747 #define getSB_VAL_UTF8(pos, strend)                                            \
1748     _generic_GET_BREAK_VAL_UTF8(getSB_VAL_CP, pos, strend)
1749
1750 /* Returns the WB value for the input code point */
1751 #define getWB_VAL_CP(cp)                                                       \
1752           _generic_GET_BREAK_VAL_CP(                                           \
1753                                     PL_WB_invlist,                             \
1754                                     Word_Break_invmap,                         \
1755                                     (cp))
1756
1757 /* Returns the WB value for the first code point in the UTF-8 encoded string
1758  * bounded by pos and strend */
1759 #define getWB_VAL_UTF8(pos, strend)                                            \
1760     _generic_GET_BREAK_VAL_UTF8(getWB_VAL_CP, pos, strend)
1761
1762 /* We know what class REx starts with.  Try to find this position... */
1763 /* if reginfo->intuit, its a dryrun */
1764 /* annoyingly all the vars in this routine have different names from their counterparts
1765    in regmatch. /grrr */
1766 STATIC char *
1767 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 
1768     const char *strend, regmatch_info *reginfo)
1769 {
1770     dVAR;
1771     const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1772     char *pat_string;   /* The pattern's exactish string */
1773     char *pat_end;          /* ptr to end char of pat_string */
1774     re_fold_t folder;   /* Function for computing non-utf8 folds */
1775     const U8 *fold_array;   /* array for folding ords < 256 */
1776     STRLEN ln;
1777     STRLEN lnc;
1778     U8 c1;
1779     U8 c2;
1780     char *e;
1781     I32 tmp = 1;        /* Scratch variable? */
1782     const bool utf8_target = reginfo->is_utf8_target;
1783     UV utf8_fold_flags = 0;
1784     const bool is_utf8_pat = reginfo->is_utf8_pat;
1785     bool to_complement = FALSE; /* Invert the result?  Taking the xor of this
1786                                    with a result inverts that result, as 0^1 =
1787                                    1 and 1^1 = 0 */
1788     _char_class_number classnum;
1789
1790     RXi_GET_DECL(prog,progi);
1791
1792     PERL_ARGS_ASSERT_FIND_BYCLASS;
1793
1794     /* We know what class it must start with. */
1795     switch (OP(c)) {
1796     case ANYOFL:
1797         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1798         /* FALLTHROUGH */
1799     case ANYOF:
1800         if (utf8_target) {
1801             REXEC_FBC_UTF8_CLASS_SCAN(
1802                       reginclass(prog, c, (U8*)s, (U8*) strend, utf8_target));
1803         }
1804         else {
1805             REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
1806         }
1807         break;
1808     case CANY:
1809         REXEC_FBC_SCAN(
1810             if (tmp && (reginfo->intuit || regtry(reginfo, &s)))
1811                 goto got_it;
1812             else
1813                 tmp = doevery;
1814         );
1815         break;
1816
1817     case EXACTFA_NO_TRIE:   /* This node only generated for non-utf8 patterns */
1818         assert(! is_utf8_pat);
1819         /* FALLTHROUGH */
1820     case EXACTFA:
1821         if (is_utf8_pat || utf8_target) {
1822             utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
1823             goto do_exactf_utf8;
1824         }
1825         fold_array = PL_fold_latin1;    /* Latin1 folds are not affected by */
1826         folder = foldEQ_latin1;         /* /a, except the sharp s one which */
1827         goto do_exactf_non_utf8;        /* isn't dealt with by these */
1828
1829     case EXACTF:   /* This node only generated for non-utf8 patterns */
1830         assert(! is_utf8_pat);
1831         if (utf8_target) {
1832             utf8_fold_flags = 0;
1833             goto do_exactf_utf8;
1834         }
1835         fold_array = PL_fold;
1836         folder = foldEQ;
1837         goto do_exactf_non_utf8;
1838
1839     case EXACTFL:
1840         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1841         if (is_utf8_pat || utf8_target || IN_UTF8_CTYPE_LOCALE) {
1842             utf8_fold_flags = FOLDEQ_LOCALE;
1843             goto do_exactf_utf8;
1844         }
1845         fold_array = PL_fold_locale;
1846         folder = foldEQ_locale;
1847         goto do_exactf_non_utf8;
1848
1849     case EXACTFU_SS:
1850         if (is_utf8_pat) {
1851             utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
1852         }
1853         goto do_exactf_utf8;
1854
1855     case EXACTFLU8:
1856             if (! utf8_target) {    /* All code points in this node require
1857                                        UTF-8 to express.  */
1858                 break;
1859             }
1860             utf8_fold_flags =  FOLDEQ_LOCALE | FOLDEQ_S2_ALREADY_FOLDED
1861                                              | FOLDEQ_S2_FOLDS_SANE;
1862             goto do_exactf_utf8;
1863
1864     case EXACTFU:
1865         if (is_utf8_pat || utf8_target) {
1866             utf8_fold_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
1867             goto do_exactf_utf8;
1868         }
1869
1870         /* Any 'ss' in the pattern should have been replaced by regcomp,
1871          * so we don't have to worry here about this single special case
1872          * in the Latin1 range */
1873         fold_array = PL_fold_latin1;
1874         folder = foldEQ_latin1;
1875
1876         /* FALLTHROUGH */
1877
1878       do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there
1879                            are no glitches with fold-length differences
1880                            between the target string and pattern */
1881
1882         /* The idea in the non-utf8 EXACTF* cases is to first find the
1883          * first character of the EXACTF* node and then, if necessary,
1884          * case-insensitively compare the full text of the node.  c1 is the
1885          * first character.  c2 is its fold.  This logic will not work for
1886          * Unicode semantics and the german sharp ss, which hence should
1887          * not be compiled into a node that gets here. */
1888         pat_string = STRING(c);
1889         ln  = STR_LEN(c);       /* length to match in octets/bytes */
1890
1891         /* We know that we have to match at least 'ln' bytes (which is the
1892          * same as characters, since not utf8).  If we have to match 3
1893          * characters, and there are only 2 availabe, we know without
1894          * trying that it will fail; so don't start a match past the
1895          * required minimum number from the far end */
1896         e = HOP3c(strend, -((SSize_t)ln), s);
1897
1898         if (reginfo->intuit && e < s) {
1899             e = s;                      /* Due to minlen logic of intuit() */
1900         }
1901
1902         c1 = *pat_string;
1903         c2 = fold_array[c1];
1904         if (c1 == c2) { /* If char and fold are the same */
1905             REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1906         }
1907         else {
1908             REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1909         }
1910         break;
1911
1912       do_exactf_utf8:
1913       {
1914         unsigned expansion;
1915
1916         /* If one of the operands is in utf8, we can't use the simpler folding
1917          * above, due to the fact that many different characters can have the
1918          * same fold, or portion of a fold, or different- length fold */
1919         pat_string = STRING(c);
1920         ln  = STR_LEN(c);       /* length to match in octets/bytes */
1921         pat_end = pat_string + ln;
1922         lnc = is_utf8_pat       /* length to match in characters */
1923                 ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
1924                 : ln;
1925
1926         /* We have 'lnc' characters to match in the pattern, but because of
1927          * multi-character folding, each character in the target can match
1928          * up to 3 characters (Unicode guarantees it will never exceed
1929          * this) if it is utf8-encoded; and up to 2 if not (based on the
1930          * fact that the Latin 1 folds are already determined, and the
1931          * only multi-char fold in that range is the sharp-s folding to
1932          * 'ss'.  Thus, a pattern character can match as little as 1/3 of a
1933          * string character.  Adjust lnc accordingly, rounding up, so that
1934          * if we need to match at least 4+1/3 chars, that really is 5. */
1935         expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2;
1936         lnc = (lnc + expansion - 1) / expansion;
1937
1938         /* As in the non-UTF8 case, if we have to match 3 characters, and
1939          * only 2 are left, it's guaranteed to fail, so don't start a
1940          * match that would require us to go beyond the end of the string
1941          */
1942         e = HOP3c(strend, -((SSize_t)lnc), s);
1943
1944         if (reginfo->intuit && e < s) {
1945             e = s;                      /* Due to minlen logic of intuit() */
1946         }
1947
1948         /* XXX Note that we could recalculate e to stop the loop earlier,
1949          * as the worst case expansion above will rarely be met, and as we
1950          * go along we would usually find that e moves further to the left.
1951          * This would happen only after we reached the point in the loop
1952          * where if there were no expansion we should fail.  Unclear if
1953          * worth the expense */
1954
1955         while (s <= e) {
1956             char *my_strend= (char *)strend;
1957             if (foldEQ_utf8_flags(s, &my_strend, 0,  utf8_target,
1958                   pat_string, NULL, ln, is_utf8_pat, utf8_fold_flags)
1959                 && (reginfo->intuit || regtry(reginfo, &s)) )
1960             {
1961                 goto got_it;
1962             }
1963             s += (utf8_target) ? UTF8SKIP(s) : 1;
1964         }
1965         break;
1966     }
1967
1968     case BOUNDL:
1969         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1970         if (FLAGS(c) != TRADITIONAL_BOUND) {
1971             Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
1972                                                 B_ON_NON_UTF8_LOCALE_IS_WRONG);
1973             goto do_boundu;
1974         }
1975
1976         FBC_BOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8);
1977         break;
1978
1979     case NBOUNDL:
1980         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
1981         if (FLAGS(c) != TRADITIONAL_BOUND) {
1982             Perl_ck_warner(aTHX_ packWARN(WARN_LOCALE),
1983                                                 B_ON_NON_UTF8_LOCALE_IS_WRONG);
1984             goto do_nboundu;
1985         }
1986
1987         FBC_NBOUND(isWORDCHAR_LC, isWORDCHAR_LC_uvchr, isWORDCHAR_LC_utf8);
1988         break;
1989
1990     case BOUND: /* regcomp.c makes sure that this only has the traditional \b
1991                    meaning */
1992         assert(FLAGS(c) == TRADITIONAL_BOUND);
1993
1994         FBC_BOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8);
1995         break;
1996
1997     case BOUNDA: /* regcomp.c makes sure that this only has the traditional \b
1998                    meaning */
1999         assert(FLAGS(c) == TRADITIONAL_BOUND);
2000
2001         FBC_BOUND_A(isWORDCHAR_A);
2002         break;
2003
2004     case NBOUND: /* regcomp.c makes sure that this only has the traditional \b
2005                    meaning */
2006         assert(FLAGS(c) == TRADITIONAL_BOUND);
2007
2008         FBC_NBOUND(isWORDCHAR, isWORDCHAR_uni, isWORDCHAR_utf8);
2009         break;
2010
2011     case NBOUNDA: /* regcomp.c makes sure that this only has the traditional \b
2012                    meaning */
2013         assert(FLAGS(c) == TRADITIONAL_BOUND);
2014
2015         FBC_NBOUND_A(isWORDCHAR_A);
2016         break;
2017
2018     case NBOUNDU:
2019         if ((bound_type) FLAGS(c) == TRADITIONAL_BOUND) {
2020             FBC_NBOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8);
2021             break;
2022         }
2023
2024       do_nboundu:
2025
2026         to_complement = 1;
2027         /* FALLTHROUGH */
2028
2029     case BOUNDU:
2030       do_boundu:
2031         switch((bound_type) FLAGS(c)) {
2032             case TRADITIONAL_BOUND:
2033                 FBC_BOUND(isWORDCHAR_L1, isWORDCHAR_uni, isWORDCHAR_utf8);
2034                 break;
2035             case GCB_BOUND:
2036                 if (s == reginfo->strbeg) { /* GCB always matches at begin and
2037                                                end */
2038                     if (to_complement ^ cBOOL(reginfo->intuit
2039                                                       || regtry(reginfo, &s)))
2040                     {
2041                         goto got_it;
2042                     }
2043                     s += (utf8_target) ? UTF8SKIP(s) : 1;
2044                 }
2045
2046                 if (utf8_target) {
2047                     PL_GCB_enum before = getGCB_VAL_UTF8(
2048                                                reghop3((U8*)s, -1,
2049                                                        (U8*)(reginfo->strbeg)),
2050                                                (U8*) reginfo->strend);
2051                     while (s < strend) {
2052                         PL_GCB_enum after = getGCB_VAL_UTF8((U8*) s,
2053                                                         (U8*) reginfo->strend);
2054                         if (to_complement ^ isGCB(before, after)) {
2055                             if (reginfo->intuit || regtry(reginfo, &s)) {
2056                                 goto got_it;
2057                             }
2058                             before = after;
2059                         }
2060                         s += UTF8SKIP(s);
2061                     }
2062                 }
2063                 else {  /* Not utf8.  Everything is a GCB except between CR and
2064                            LF */
2065                     while (s < strend) {
2066                         if (to_complement ^ (UCHARAT(s - 1) != '\r'
2067                                              || UCHARAT(s) != '\n'))
2068                         {
2069                             if (reginfo->intuit || regtry(reginfo, &s)) {
2070                                 goto got_it;
2071                             }
2072                             s++;
2073                         }
2074                     }
2075                 }
2076
2077                 if (to_complement ^ cBOOL(reginfo->intuit || regtry(reginfo, &s))) {
2078                     goto got_it;
2079                 }
2080                 break;
2081
2082             case SB_BOUND:
2083                 if (s == reginfo->strbeg) { /* SB always matches at beginning */
2084                     if (to_complement
2085                                 ^ cBOOL(reginfo->intuit || regtry(reginfo, &s)))
2086                     {
2087                         goto got_it;
2088                     }
2089
2090                     /* Didn't match.  Go try at the next position */
2091                     s += (utf8_target) ? UTF8SKIP(s) : 1;
2092                 }
2093
2094                 if (utf8_target) {
2095                     PL_SB_enum before = getSB_VAL_UTF8(reghop3((U8*)s,
2096                                                         -1,
2097                                                         (U8*)(reginfo->strbeg)),
2098                                                       (U8*) reginfo->strend);
2099                     while (s < strend) {
2100                         PL_SB_enum after = getSB_VAL_UTF8((U8*) s,
2101                                                          (U8*) reginfo->strend);
2102                         if (to_complement ^ isSB(before,
2103                                                  after,
2104                                                  (U8*) reginfo->strbeg,
2105                                                  (U8*) s,
2106                                                  (U8*) reginfo->strend,
2107                                                  utf8_target))
2108                         {
2109                             if (reginfo->intuit || regtry(reginfo, &s)) {
2110                                 goto got_it;
2111                             }
2112                             before = after;
2113                         }
2114                         s += UTF8SKIP(s);
2115                     }
2116                 }
2117                 else {  /* Not utf8. */
2118                     PL_SB_enum before = getSB_VAL_CP((U8) *(s -1));
2119                     while (s < strend) {
2120                         PL_SB_enum after = getSB_VAL_CP((U8) *s);
2121                         if (to_complement ^ isSB(before,
2122                                                  after,
2123                                                  (U8*) reginfo->strbeg,
2124                                                  (U8*) s,
2125                                                  (U8*) reginfo->strend,
2126                                                  utf8_target))
2127                         {
2128                             if (reginfo->intuit || regtry(reginfo, &s)) {
2129                                 goto got_it;
2130                             }
2131                             before = after;
2132                         }
2133                         s++;
2134                     }
2135                 }
2136
2137                 /* Here are at the final position in the target string.  The SB
2138                  * value is always true here, so matches, depending on other
2139                  * constraints */
2140                 if (to_complement ^ cBOOL(reginfo->intuit
2141                                                       || regtry(reginfo, &s)))
2142                 {
2143                     goto got_it;
2144                 }
2145
2146                 break;
2147
2148             case WB_BOUND:
2149                 if (s == reginfo->strbeg) {
2150                     if (to_complement ^ cBOOL(reginfo->intuit
2151                                               || regtry(reginfo, &s)))
2152                     {
2153                         goto got_it;
2154                     }
2155                     s += (utf8_target) ? UTF8SKIP(s) : 1;
2156                 }
2157
2158                 if (utf8_target) {
2159                     /* We are at a boundary between char_sub_0 and char_sub_1.
2160                      * We also keep track of the value for char_sub_-1 as we
2161                      * loop through the line.   Context may be needed to make a
2162                      * determination, and if so, this can save having to
2163                      * recalculate it */
2164                     PL_WB_enum previous = PL_WB_UNKNOWN;
2165                     PL_WB_enum before = getWB_VAL_UTF8(
2166                                               reghop3((U8*)s,
2167                                                       -1,
2168                                                       (U8*)(reginfo->strbeg)),
2169                                               (U8*) reginfo->strend);
2170                     while (s < strend) {
2171                         PL_WB_enum after = getWB_VAL_UTF8((U8*) s,
2172                                                         (U8*) reginfo->strend);
2173                         if (to_complement ^ isWB(previous,
2174                                                  before,
2175                                                  after,
2176                                                  (U8*) reginfo->strbeg,
2177                                                  (U8*) s,
2178                                                  (U8*) reginfo->strend,
2179                                                  utf8_target))
2180                         {
2181                             if (reginfo->intuit || regtry(reginfo, &s)) {
2182                                 goto got_it;
2183                             }
2184                             previous = before;
2185                             before = after;
2186                         }
2187                         s += UTF8SKIP(s);
2188                     }
2189                 }
2190                 else {  /* Not utf8. */
2191                     PL_WB_enum previous = PL_WB_UNKNOWN;
2192                     PL_WB_enum before = getWB_VAL_CP((U8) *(s -1));
2193                     while (s < strend) {
2194                         PL_WB_enum after = getWB_VAL_CP((U8) *s);
2195                         if (to_complement ^ isWB(previous,
2196                                                  before,
2197                                                  after,
2198                                                  (U8*) reginfo->strbeg,
2199                                                  (U8*) s,
2200                                                  (U8*) reginfo->strend,
2201                                                  utf8_target))
2202                         {
2203                             if (reginfo->intuit || regtry(reginfo, &s)) {
2204                                 goto got_it;
2205                             }
2206                             previous = before;
2207                             before = after;
2208                         }
2209                         s++;
2210                     }
2211                 }
2212
2213                 if (to_complement ^ cBOOL(reginfo->intuit
2214                                           || regtry(reginfo, &s)))
2215                 {
2216                     goto got_it;
2217                 }
2218
2219                 break;
2220         }
2221         break;
2222
2223     case LNBREAK:
2224         REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend),
2225                         is_LNBREAK_latin1_safe(s, strend)
2226         );
2227         break;
2228
2229     /* The argument to all the POSIX node types is the class number to pass to
2230      * _generic_isCC() to build a mask for searching in PL_charclass[] */
2231
2232     case NPOSIXL:
2233         to_complement = 1;
2234         /* FALLTHROUGH */
2235
2236     case POSIXL:
2237         _CHECK_AND_WARN_PROBLEMATIC_LOCALE;
2238         REXEC_FBC_CSCAN(to_complement ^ cBOOL(isFOO_utf8_lc(FLAGS(c), (U8 *) s)),
2239                         to_complement ^ cBOOL(isFOO_lc(FLAGS(c), *s)));
2240         break;
2241
2242     case NPOSIXD:
2243         to_complement = 1;
2244         /* FALLTHROUGH */
2245
2246     case POSIXD:
2247         if (utf8_target) {
2248             goto posix_utf8;
2249         }
2250         goto posixa;
2251
2252     case NPOSIXA:
2253         if (utf8_target) {
2254             /* The complement of something that matches only ASCII matches all
2255              * non-ASCII, plus everything in ASCII that isn't in the class. */
2256             REXEC_FBC_UTF8_CLASS_SCAN(! isASCII_utf8(s)
2257                                       || ! _generic_isCC_A(*s, FLAGS(c)));
2258             break;
2259         }
2260
2261         to_complement = 1;
2262         /* FALLTHROUGH */
2263
2264     case POSIXA:
2265       posixa:
2266         /* Don't need to worry about utf8, as it can match only a single
2267          * byte invariant character. */
2268         REXEC_FBC_CLASS_SCAN(
2269                         to_complement ^ cBOOL(_generic_isCC_A(*s, FLAGS(c))));
2270         break;
2271
2272     case NPOSIXU:
2273         to_complement = 1;
2274         /* FALLTHROUGH */
2275
2276     case POSIXU:
2277         if (! utf8_target) {
2278             REXEC_FBC_CLASS_SCAN(to_complement ^ cBOOL(_generic_isCC(*s,
2279                                                                     FLAGS(c))));
2280         }
2281         else {
2282
2283           posix_utf8:
2284             classnum = (_char_class_number) FLAGS(c);
2285             if (classnum < _FIRST_NON_SWASH_CC) {
2286                 while (s < strend) {
2287
2288                     /* We avoid loading in the swash as long as possible, but
2289                      * should we have to, we jump to a separate loop.  This
2290                      * extra 'if' statement is what keeps this code from being
2291                      * just a call to REXEC_FBC_UTF8_CLASS_SCAN() */
2292                     if (UTF8_IS_ABOVE_LATIN1(*s)) {
2293                         goto found_above_latin1;
2294                     }
2295                     if ((UTF8_IS_INVARIANT(*s)
2296                          && to_complement ^ cBOOL(_generic_isCC((U8) *s,
2297                                                                 classnum)))
2298                         || (UTF8_IS_DOWNGRADEABLE_START(*s)
2299                             && to_complement ^ cBOOL(
2300                                 _generic_isCC(TWO_BYTE_UTF8_TO_NATIVE(*s,
2301                                                                       *(s + 1)),
2302                                               classnum))))
2303                     {
2304                         if (tmp && (reginfo->intuit || regtry(reginfo, &s)))
2305                             goto got_it;
2306                         else {
2307                             tmp = doevery;
2308                         }
2309                     }
2310                     else {
2311                         tmp = 1;
2312                     }
2313                     s += UTF8SKIP(s);
2314                 }
2315             }
2316             else switch (classnum) {    /* These classes are implemented as
2317                                            macros */
2318                 case _CC_ENUM_SPACE:
2319                     REXEC_FBC_UTF8_CLASS_SCAN(
2320                                         to_complement ^ cBOOL(isSPACE_utf8(s)));
2321                     break;
2322
2323                 case _CC_ENUM_BLANK:
2324                     REXEC_FBC_UTF8_CLASS_SCAN(
2325                                         to_complement ^ cBOOL(isBLANK_utf8(s)));
2326                     break;
2327
2328                 case _CC_ENUM_XDIGIT:
2329                     REXEC_FBC_UTF8_CLASS_SCAN(
2330                                        to_complement ^ cBOOL(isXDIGIT_utf8(s)));
2331                     break;
2332
2333                 case _CC_ENUM_VERTSPACE:
2334                     REXEC_FBC_UTF8_CLASS_SCAN(
2335                                        to_complement ^ cBOOL(isVERTWS_utf8(s)));
2336                     break;
2337
2338                 case _CC_ENUM_CNTRL:
2339                     REXEC_FBC_UTF8_CLASS_SCAN(
2340                                         to_complement ^ cBOOL(isCNTRL_utf8(s)));
2341                     break;
2342
2343                 default:
2344                     Perl_croak(aTHX_ "panic: find_byclass() node %d='%s' has an unexpected character class '%d'", OP(c), PL_reg_name[OP(c)], classnum);
2345                     NOT_REACHED; /* NOTREACHED */
2346             }
2347         }
2348         break;
2349
2350       found_above_latin1:   /* Here we have to load a swash to get the result
2351                                for the current code point */
2352         if (! PL_utf8_swash_ptrs[classnum]) {
2353             U8 flags = _CORE_SWASH_INIT_ACCEPT_INVLIST;
2354             PL_utf8_swash_ptrs[classnum] =
2355                     _core_swash_init("utf8",
2356                                      "",
2357                                      &PL_sv_undef, 1, 0,
2358                                      PL_XPosix_ptrs[classnum], &flags);
2359         }
2360
2361         /* This is a copy of the loop above for swash classes, though using the
2362          * FBC macro instead of being expanded out.  Since we've loaded the
2363          * swash, we don't have to check for that each time through the loop */
2364         REXEC_FBC_UTF8_CLASS_SCAN(
2365                 to_complement ^ cBOOL(_generic_utf8(
2366                                       classnum,
2367                                       s,
2368                                       swash_fetch(PL_utf8_swash_ptrs[classnum],
2369                                                   (U8 *) s, TRUE))));
2370         break;
2371
2372     case AHOCORASICKC:
2373     case AHOCORASICK:
2374         {
2375             DECL_TRIE_TYPE(c);
2376             /* what trie are we using right now */
2377             reg_ac_data *aho = (reg_ac_data*)progi->data->data[ ARG( c ) ];
2378             reg_trie_data *trie = (reg_trie_data*)progi->data->data[ aho->trie ];
2379             HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
2380
2381             const char *last_start = strend - trie->minlen;
2382 #ifdef DEBUGGING
2383             const char *real_start = s;
2384 #endif
2385             STRLEN maxlen = trie->maxlen;
2386             SV *sv_points;
2387             U8 **points; /* map of where we were in the input string
2388                             when reading a given char. For ASCII this
2389                             is unnecessary overhead as the relationship
2390                             is always 1:1, but for Unicode, especially
2391                             case folded Unicode this is not true. */
2392             U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2393             U8 *bitmap=NULL;
2394
2395
2396             GET_RE_DEBUG_FLAGS_DECL;
2397
2398             /* We can't just allocate points here. We need to wrap it in
2399              * an SV so it gets freed properly if there is a croak while
2400              * running the match */
2401             ENTER;
2402             SAVETMPS;
2403             sv_points=newSV(maxlen * sizeof(U8 *));
2404             SvCUR_set(sv_points,
2405                 maxlen * sizeof(U8 *));
2406             SvPOK_on(sv_points);
2407             sv_2mortal(sv_points);
2408             points=(U8**)SvPV_nolen(sv_points );
2409             if ( trie_type != trie_utf8_fold
2410                  && (trie->bitmap || OP(c)==AHOCORASICKC) )
2411             {
2412                 if (trie->bitmap)
2413                     bitmap=(U8*)trie->bitmap;
2414                 else
2415                     bitmap=(U8*)ANYOF_BITMAP(c);
2416             }
2417             /* this is the Aho-Corasick algorithm modified a touch
2418                to include special handling for long "unknown char" sequences.
2419                The basic idea being that we use AC as long as we are dealing
2420                with a possible matching char, when we encounter an unknown char
2421                (and we have not encountered an accepting state) we scan forward
2422                until we find a legal starting char.
2423                AC matching is basically that of trie matching, except that when
2424                we encounter a failing transition, we fall back to the current
2425                states "fail state", and try the current char again, a process
2426                we repeat until we reach the root state, state 1, or a legal
2427                transition. If we fail on the root state then we can either
2428                terminate if we have reached an accepting state previously, or
2429                restart the entire process from the beginning if we have not.
2430
2431              */
2432             while (s <= last_start) {
2433                 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2434                 U8 *uc = (U8*)s;
2435                 U16 charid = 0;
2436                 U32 base = 1;
2437                 U32 state = 1;
2438                 UV uvc = 0;
2439                 STRLEN len = 0;
2440                 STRLEN foldlen = 0;
2441                 U8 *uscan = (U8*)NULL;
2442                 U8 *leftmost = NULL;
2443 #ifdef DEBUGGING
2444                 U32 accepted_word= 0;
2445 #endif
2446                 U32 pointpos = 0;
2447
2448                 while ( state && uc <= (U8*)strend ) {
2449                     int failed=0;
2450                     U32 word = aho->states[ state ].wordnum;
2451
2452                     if( state==1 ) {
2453                         if ( bitmap ) {
2454                             DEBUG_TRIE_EXECUTE_r(
2455                                 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
2456                                     dump_exec_pos( (char *)uc, c, strend, real_start,
2457                                         (char *)uc, utf8_target );
2458                                     PerlIO_printf( Perl_debug_log,
2459                                         " Scanning for legal start char...\n");
2460                                 }
2461                             );
2462                             if (utf8_target) {
2463                                 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
2464                                     uc += UTF8SKIP(uc);
2465                                 }
2466                             } else {
2467                                 while ( uc <= (U8*)last_start  && !BITMAP_TEST(bitmap,*uc) ) {
2468                                     uc++;
2469                                 }
2470                             }
2471                             s= (char *)uc;
2472                         }
2473                         if (uc >(U8*)last_start) break;
2474                     }
2475
2476                     if ( word ) {
2477                         U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
2478                         if (!leftmost || lpos < leftmost) {
2479                             DEBUG_r(accepted_word=word);
2480                             leftmost= lpos;
2481                         }
2482                         if (base==0) break;
2483
2484                     }
2485                     points[pointpos++ % maxlen]= uc;
2486                     if (foldlen || uc < (U8*)strend) {
2487                         REXEC_TRIE_READ_CHAR(trie_type, trie,
2488                                          widecharmap, uc,
2489                                          uscan, len, uvc, charid, foldlen,
2490                                          foldbuf, uniflags);
2491                         DEBUG_TRIE_EXECUTE_r({
2492                             dump_exec_pos( (char *)uc, c, strend,
2493                                         real_start, s, utf8_target);
2494                             PerlIO_printf(Perl_debug_log,
2495                                 " Charid:%3u CP:%4"UVxf" ",
2496                                  charid, uvc);
2497                         });
2498                     }
2499                     else {
2500                         len = 0;
2501                         charid = 0;
2502                     }
2503
2504
2505                     do {
2506 #ifdef DEBUGGING
2507                         word = aho->states[ state ].wordnum;
2508 #endif
2509                         base = aho->states[ state ].trans.base;
2510
2511                         DEBUG_TRIE_EXECUTE_r({
2512                             if (failed)
2513                                 dump_exec_pos( (char *)uc, c, strend, real_start,
2514                                     s,   utf8_target );
2515                             PerlIO_printf( Perl_debug_log,
2516                                 "%sState: %4"UVxf", word=%"UVxf,
2517                                 failed ? " Fail transition to " : "",
2518                                 (UV)state, (UV)word);
2519                         });
2520                         if ( base ) {
2521                             U32 tmp;
2522                             I32 offset;
2523                             if (charid &&
2524                                  ( ((offset = base + charid
2525                                     - 1 - trie->uniquecharcount)) >= 0)
2526                                  && ((U32)offset < trie->lasttrans)
2527                                  && trie->trans[offset].check == state
2528                                  && (tmp=trie->trans[offset].next))
2529                             {
2530                                 DEBUG_TRIE_EXECUTE_r(
2531                                     PerlIO_printf( Perl_debug_log," - legal\n"));
2532                                 state = tmp;
2533                                 break;
2534                             }
2535                             else {
2536                                 DEBUG_TRIE_EXECUTE_r(
2537                                     PerlIO_printf( Perl_debug_log," - fail\n"));
2538                                 failed = 1;
2539                                 state = aho->fail[state];
2540                             }
2541                         }
2542                         else {
2543                             /* we must be accepting here */
2544                             DEBUG_TRIE_EXECUTE_r(
2545                                     PerlIO_printf( Perl_debug_log," - accepting\n"));
2546                             failed = 1;
2547                             break;
2548                         }
2549                     } while(state);
2550                     uc += len;
2551                     if (failed) {
2552                         if (leftmost)
2553                             break;
2554                         if (!state) state = 1;
2555                     }
2556                 }
2557                 if ( aho->states[ state ].wordnum ) {
2558                     U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
2559                     if (!leftmost || lpos < leftmost) {
2560                         DEBUG_r(accepted_word=aho->states[ state ].wordnum);
2561                         leftmost = lpos;
2562                     }
2563                 }
2564                 if (leftmost) {
2565                     s = (char*)leftmost;
2566                     DEBUG_TRIE_EXECUTE_r({
2567                         PerlIO_printf(
2568                             Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
2569                             (UV)accepted_word, (IV)(s - real_start)
2570                         );
2571                     });
2572                     if (reginfo->intuit || regtry(reginfo, &s)) {
2573                         FREETMPS;
2574                         LEAVE;
2575                         goto got_it;
2576                     }
2577                     s = HOPc(s,1);
2578                     DEBUG_TRIE_EXECUTE_r({
2579                         PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
2580                     });
2581                 } else {
2582                     DEBUG_TRIE_EXECUTE_r(
2583                         PerlIO_printf( Perl_debug_log,"No match.\n"));
2584                     break;
2585                 }
2586             }
2587             FREETMPS;
2588             LEAVE;
2589         }
2590         break;
2591     default:
2592         Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
2593     }
2594     return 0;
2595   got_it:
2596     return s;
2597 }
2598
2599 /* set RX_SAVED_COPY, RX_SUBBEG etc.
2600  * flags have same meanings as with regexec_flags() */
2601
2602 static void
2603 S_reg_set_capture_string(pTHX_ REGEXP * const rx,
2604                             char *strbeg,
2605                             char *strend,
2606                             SV *sv,
2607                             U32 flags,
2608                             bool utf8_target)
2609 {
2610     struct regexp *const prog = ReANY(rx);
2611
2612     if (flags & REXEC_COPY_STR) {
2613 #ifdef PERL_ANY_COW
2614         if (SvCANCOW(sv)) {
2615             if (DEBUG_C_TEST) {
2616                 PerlIO_printf(Perl_debug_log,
2617                               "Copy on write: regexp capture, type %d\n",
2618                               (int) SvTYPE(sv));
2619             }
2620             /* Create a new COW SV to share the match string and store
2621              * in saved_copy, unless the current COW SV in saved_copy
2622              * is valid and suitable for our purpose */
2623             if ((   prog->saved_copy
2624                  && SvIsCOW(prog->saved_copy)
2625                  && SvPOKp(prog->saved_copy)
2626                  && SvIsCOW(sv)
2627                  && SvPOKp(sv)
2628                  && SvPVX(sv) == SvPVX(prog->saved_copy)))
2629             {
2630                 /* just reuse saved_copy SV */
2631                 if (RXp_MATCH_COPIED(prog)) {
2632                     Safefree(prog->subbeg);
2633                     RXp_MATCH_COPIED_off(prog);
2634                 }
2635             }
2636             else {
2637                 /* create new COW SV to share string */
2638                 RX_MATCH_COPY_FREE(rx);
2639                 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2640             }
2641             prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2642             assert (SvPOKp(prog->saved_copy));
2643             prog->sublen  = strend - strbeg;
2644             prog->suboffset = 0;
2645             prog->subcoffset = 0;
2646         } else
2647 #endif
2648         {
2649             SSize_t min = 0;
2650             SSize_t max = strend - strbeg;
2651             SSize_t sublen;
2652
2653             if (    (flags & REXEC_COPY_SKIP_POST)
2654                 && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
2655                 && !(PL_sawampersand & SAWAMPERSAND_RIGHT)
2656             ) { /* don't copy $' part of string */
2657                 U32 n = 0;
2658                 max = -1;
2659                 /* calculate the right-most part of the string covered
2660                  * by a capture. Due to look-ahead, this may be to
2661                  * the right of $&, so we have to scan all captures */
2662                 while (n <= prog->lastparen) {
2663                     if (prog->offs[n].end > max)
2664                         max = prog->offs[n].end;
2665                     n++;
2666                 }
2667                 if (max == -1)
2668                     max = (PL_sawampersand & SAWAMPERSAND_LEFT)
2669                             ? prog->offs[0].start
2670                             : 0;
2671                 assert(max >= 0 && max <= strend - strbeg);
2672             }
2673
2674             if (    (flags & REXEC_COPY_SKIP_PRE)
2675                 && !(prog->extflags & RXf_PMf_KEEPCOPY) /* //p */
2676                 && !(PL_sawampersand & SAWAMPERSAND_LEFT)
2677             ) { /* don't copy $` part of string */
2678                 U32 n = 0;
2679                 min = max;
2680                 /* calculate the left-most part of the string covered
2681                  * by a capture. Due to look-behind, this may be to
2682                  * the left of $&, so we have to scan all captures */
2683                 while (min && n <= prog->lastparen) {
2684                     if (   prog->offs[n].start != -1
2685                         && prog->offs[n].start < min)
2686                     {
2687                         min = prog->offs[n].start;
2688                     }
2689                     n++;
2690                 }
2691                 if ((PL_sawampersand & SAWAMPERSAND_RIGHT)
2692                     && min >  prog->offs[0].end
2693                 )
2694                     min = prog->offs[0].end;
2695
2696             }
2697
2698             assert(min >= 0 && min <= max && min <= strend - strbeg);
2699             sublen = max - min;
2700
2701             if (RX_MATCH_COPIED(rx)) {
2702                 if (sublen > prog->sublen)
2703                     prog->subbeg =
2704                             (char*)saferealloc(prog->subbeg, sublen+1);
2705             }
2706             else
2707                 prog->subbeg = (char*)safemalloc(sublen+1);
2708             Copy(strbeg + min, prog->subbeg, sublen, char);
2709             prog->subbeg[sublen] = '\0';
2710             prog->suboffset = min;
2711             prog->sublen = sublen;
2712             RX_MATCH_COPIED_on(rx);
2713         }
2714         prog->subcoffset = prog->suboffset;
2715         if (prog->suboffset && utf8_target) {
2716             /* Convert byte offset to chars.
2717              * XXX ideally should only compute this if @-/@+
2718              * has been seen, a la PL_sawampersand ??? */
2719
2720             /* If there's a direct correspondence between the
2721              * string which we're matching and the original SV,
2722              * then we can use the utf8 len cache associated with
2723              * the SV. In particular, it means that under //g,
2724              * sv_pos_b2u() will use the previously cached
2725              * position to speed up working out the new length of
2726              * subcoffset, rather than counting from the start of
2727              * the string each time. This stops
2728              *   $x = "\x{100}" x 1E6; 1 while $x =~ /(.)/g;
2729              * from going quadratic */
2730             if (SvPOKp(sv) && SvPVX(sv) == strbeg)
2731                 prog->subcoffset = sv_pos_b2u_flags(sv, prog->subcoffset,
2732                                                 SV_GMAGIC|SV_CONST_RETURN);
2733             else
2734                 prog->subcoffset = utf8_length((U8*)strbeg,
2735                                     (U8*)(strbeg+prog->suboffset));
2736         }
2737     }
2738     else {
2739         RX_MATCH_COPY_FREE(rx);
2740         prog->subbeg = strbeg;
2741         prog->suboffset = 0;
2742         prog->subcoffset = 0;
2743         prog->sublen = strend - strbeg;
2744     }
2745 }
2746
2747
2748
2749
2750 /*
2751  - regexec_flags - match a regexp against a string
2752  */
2753 I32
2754 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
2755               char *strbeg, SSize_t minend, SV *sv, void *data, U32 flags)
2756 /* stringarg: the point in the string at which to begin matching */
2757 /* strend:    pointer to null at end of string */
2758 /* strbeg:    real beginning of string */
2759 /* minend:    end of match must be >= minend bytes after stringarg. */
2760 /* sv:        SV being matched: only used for utf8 flag, pos() etc; string
2761  *            itself is accessed via the pointers above */
2762 /* data:      May be used for some additional optimizations.
2763               Currently unused. */
2764 /* flags:     For optimizations. See REXEC_* in regexp.h */
2765
2766 {
2767     struct regexp *const prog = ReANY(rx);
2768     char *s;
2769     regnode *c;
2770     char *startpos;
2771     SSize_t minlen;             /* must match at least this many chars */
2772     SSize_t dontbother = 0;     /* how many characters not to try at end */
2773     const bool utf8_target = cBOOL(DO_UTF8(sv));
2774     I32 multiline;
2775     RXi_GET_DECL(prog,progi);
2776     regmatch_info reginfo_buf;  /* create some info to pass to regtry etc */
2777     regmatch_info *const reginfo = &reginfo_buf;
2778     regexp_paren_pair *swap = NULL;
2779     I32 oldsave;
2780     GET_RE_DEBUG_FLAGS_DECL;
2781
2782     PERL_ARGS_ASSERT_REGEXEC_FLAGS;
2783     PERL_UNUSED_ARG(data);
2784
2785     /* Be paranoid... */
2786     if (prog == NULL || stringarg == NULL) {
2787         Perl_croak(aTHX_ "NULL regexp parameter");
2788     }
2789
2790     DEBUG_EXECUTE_r(
2791         debug_start_match(rx, utf8_target, stringarg, strend,
2792         "Matching");
2793     );
2794
2795     startpos = stringarg;
2796
2797     if (prog->intflags & PREGf_GPOS_SEEN) {
2798         MAGIC *mg;
2799
2800         /* set reginfo->ganch, the position where \G can match */
2801
2802         reginfo->ganch =
2803             (flags & REXEC_IGNOREPOS)
2804             ? stringarg /* use start pos rather than pos() */
2805             : (sv && (mg = mg_find_mglob(sv)) && mg->mg_len >= 0)
2806               /* Defined pos(): */
2807             ? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg)
2808             : strbeg; /* pos() not defined; use start of string */
2809
2810         DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2811             "GPOS ganch set to strbeg[%"IVdf"]\n", (IV)(reginfo->ganch - strbeg)));
2812
2813         /* in the presence of \G, we may need to start looking earlier in
2814          * the string than the suggested start point of stringarg:
2815          * if prog->gofs is set, then that's a known, fixed minimum
2816          * offset, such as
2817          * /..\G/:   gofs = 2
2818          * /ab|c\G/: gofs = 1
2819          * or if the minimum offset isn't known, then we have to go back
2820          * to the start of the string, e.g. /w+\G/
2821          */
2822
2823         if (prog->intflags & PREGf_ANCH_GPOS) {
2824             startpos  = reginfo->ganch - prog->gofs;
2825             if (startpos <
2826                 ((flags & REXEC_FAIL_ON_UNDERFLOW) ? stringarg : strbeg))
2827             {
2828                 DEBUG_r(PerlIO_printf(Perl_debug_log,
2829                         "fail: ganch-gofs before earliest possible start\n"));
2830                 return 0;
2831             }
2832         }
2833         else if (prog->gofs) {
2834             if (startpos - prog->gofs < strbeg)
2835                 startpos = strbeg;
2836             else
2837                 startpos -= prog->gofs;
2838         }
2839         else if (prog->intflags & PREGf_GPOS_FLOAT)
2840             startpos = strbeg;
2841     }
2842
2843     minlen = prog->minlen;
2844     if ((startpos + minlen) > strend || startpos < strbeg) {
2845         DEBUG_r(PerlIO_printf(Perl_debug_log,
2846                     "Regex match can't succeed, so not even tried\n"));
2847         return 0;
2848     }
2849
2850     /* at the end of this function, we'll do a LEAVE_SCOPE(oldsave),
2851      * which will call destuctors to reset PL_regmatch_state, free higher
2852      * PL_regmatch_slabs, and clean up regmatch_info_aux and
2853      * regmatch_info_aux_eval */
2854
2855     oldsave = PL_savestack_ix;
2856
2857     s = startpos;
2858
2859     if ((prog->extflags & RXf_USE_INTUIT)
2860         && !(flags & REXEC_CHECKED))
2861     {
2862         s = re_intuit_start(rx, sv, strbeg, startpos, strend,
2863                                     flags, NULL);
2864         if (!s)
2865             return 0;
2866
2867         if (prog->extflags & RXf_CHECK_ALL) {
2868             /* we can match based purely on the result of INTUIT.
2869              * Set up captures etc just for $& and $-[0]
2870              * (an intuit-only match wont have $1,$2,..) */
2871             assert(!prog->nparens);
2872
2873             /* s/// doesn't like it if $& is earlier than where we asked it to
2874              * start searching (which can happen on something like /.\G/) */
2875             if (       (flags & REXEC_FAIL_ON_UNDERFLOW)
2876                     && (s < stringarg))
2877             {
2878                 /* this should only be possible under \G */
2879                 assert(prog->intflags & PREGf_GPOS_SEEN);
2880                 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2881                     "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
2882                 goto phooey;
2883             }
2884
2885             /* match via INTUIT shouldn't have any captures.
2886              * Let @-, @+, $^N know */
2887             prog->lastparen = prog->lastcloseparen = 0;
2888             RX_MATCH_UTF8_set(rx, utf8_target);
2889             prog->offs[0].start = s - strbeg;
2890             prog->offs[0].end = utf8_target
2891                 ? (char*)utf8_hop((U8*)s, prog->minlenret) - strbeg
2892                 : s - strbeg + prog->minlenret;
2893             if ( !(flags & REXEC_NOT_FIRST) )
2894                 S_reg_set_capture_string(aTHX_ rx,
2895                                         strbeg, strend,
2896                                         sv, flags, utf8_target);
2897
2898             return 1;
2899         }
2900     }
2901
2902     multiline = prog->extflags & RXf_PMf_MULTILINE;
2903     
2904     if (strend - s < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
2905         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2906                               "String too short [regexec_flags]...\n"));
2907         goto phooey;
2908     }
2909     
2910     /* Check validity of program. */
2911     if (UCHARAT(progi->program) != REG_MAGIC) {
2912         Perl_croak(aTHX_ "corrupted regexp program");
2913     }
2914
2915     RX_MATCH_TAINTED_off(rx);
2916     RX_MATCH_UTF8_set(rx, utf8_target);
2917
2918     reginfo->prog = rx;  /* Yes, sorry that this is confusing.  */
2919     reginfo->intuit = 0;
2920     reginfo->is_utf8_target = cBOOL(utf8_target);
2921     reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx));
2922     reginfo->warned = FALSE;
2923     reginfo->strbeg  = strbeg;
2924     reginfo->sv = sv;
2925     reginfo->poscache_maxiter = 0; /* not yet started a countdown */
2926     reginfo->strend = strend;
2927     /* see how far we have to get to not match where we matched before */
2928     reginfo->till = stringarg + minend;
2929
2930     if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv)) {
2931         /* SAVEFREESV, not sv_mortalcopy, as this SV must last until after
2932            S_cleanup_regmatch_info_aux has executed (registered by
2933            SAVEDESTRUCTOR_X below).  S_cleanup_regmatch_info_aux modifies
2934            magic belonging to this SV.
2935            Not newSVsv, either, as it does not COW.
2936         */
2937         reginfo->sv = newSV(0);
2938         SvSetSV_nosteal(reginfo->sv, sv);
2939         SAVEFREESV(reginfo->sv);
2940     }
2941
2942     /* reserve next 2 or 3 slots in PL_regmatch_state:
2943      * slot N+0: may currently be in use: skip it
2944      * slot N+1: use for regmatch_info_aux struct
2945      * slot N+2: use for regmatch_info_aux_eval struct if we have (?{})'s
2946      * slot N+3: ready for use by regmatch()
2947      */
2948
2949     {
2950         regmatch_state *old_regmatch_state;
2951         regmatch_slab  *old_regmatch_slab;
2952         int i, max = (prog->extflags & RXf_EVAL_SEEN) ? 2 : 1;
2953
2954         /* on first ever match, allocate first slab */
2955         if (!PL_regmatch_slab) {
2956             Newx(PL_regmatch_slab, 1, regmatch_slab);
2957             PL_regmatch_slab->prev = NULL;
2958             PL_regmatch_slab->next = NULL;
2959             PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2960         }
2961
2962         old_regmatch_state = PL_regmatch_state;
2963         old_regmatch_slab  = PL_regmatch_slab;
2964
2965         for (i=0; i <= max; i++) {
2966             if (i == 1)
2967                 reginfo->info_aux = &(PL_regmatch_state->u.info_aux);
2968             else if (i ==2)
2969                 reginfo->info_aux_eval =
2970                 reginfo->info_aux->info_aux_eval =
2971                             &(PL_regmatch_state->u.info_aux_eval);
2972
2973             if (++PL_regmatch_state >  SLAB_LAST(PL_regmatch_slab))
2974                 PL_regmatch_state = S_push_slab(aTHX);
2975         }
2976
2977         /* note initial PL_regmatch_state position; at end of match we'll
2978          * pop back to there and free any higher slabs */
2979
2980         reginfo->info_aux->old_regmatch_state = old_regmatch_state;
2981         reginfo->info_aux->old_regmatch_slab  = old_regmatch_slab;
2982         reginfo->info_aux->poscache = NULL;
2983
2984         SAVEDESTRUCTOR_X(S_cleanup_regmatch_info_aux, reginfo->info_aux);
2985
2986         if ((prog->extflags & RXf_EVAL_SEEN))
2987             S_setup_eval_state(aTHX_ reginfo);
2988         else
2989             reginfo->info_aux_eval = reginfo->info_aux->info_aux_eval = NULL;
2990     }
2991
2992     /* If there is a "must appear" string, look for it. */
2993
2994     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
2995         /* We have to be careful. If the previous successful match
2996            was from this regex we don't want a subsequent partially
2997            successful match to clobber the old results.
2998            So when we detect this possibility we add a swap buffer
2999            to the re, and switch the buffer each match. If we fail,
3000            we switch it back; otherwise we leave it swapped.
3001         */
3002         swap = prog->offs;
3003         /* do we need a save destructor here for eval dies? */
3004         Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
3005         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
3006             "rex=0x%"UVxf" saving  offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
3007             PTR2UV(prog),
3008             PTR2UV(swap),
3009             PTR2UV(prog->offs)
3010         ));
3011     }
3012
3013     /* Simplest case: anchored match need be tried only once, or with
3014      * MBOL, only at the beginning of each line.
3015      *
3016      * Note that /.*.../ sets PREGf_IMPLICIT|MBOL, while /.*.../s sets
3017      * PREGf_IMPLICIT|SBOL. The idea is that with /.*.../s, if it doesn't
3018      * match at the start of the string then it won't match anywhere else
3019      * either; while with /.*.../, if it doesn't match at the beginning,
3020      * the earliest it could match is at the start of the next line */
3021
3022     if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) {
3023         char *end;
3024
3025         if (regtry(reginfo, &s))
3026             goto got_it;
3027
3028         if (!(prog->intflags & PREGf_ANCH_MBOL))
3029             goto phooey;
3030
3031         /* didn't match at start, try at other newline positions */
3032
3033         if (minlen)
3034             dontbother = minlen - 1;
3035         end = HOP3c(strend, -dontbother, strbeg) - 1;
3036
3037         /* skip to next newline */
3038
3039         while (s <= end) { /* note it could be possible to match at the end of the string */
3040             /* NB: newlines are the same in unicode as they are in latin */
3041             if (*s++ != '\n')
3042                 continue;
3043             if (prog->check_substr || prog->check_utf8) {
3044             /* note that with PREGf_IMPLICIT, intuit can only fail
3045              * or return the start position, so it's of limited utility.
3046              * Nevertheless, I made the decision that the potential for
3047              * quick fail was still worth it - DAPM */
3048                 s = re_intuit_start(rx, sv, strbeg, s, strend, flags, NULL);
3049                 if (!s)
3050                     goto phooey;
3051             }
3052             if (regtry(reginfo, &s))
3053                 goto got_it;
3054         }
3055         goto phooey;
3056     } /* end anchored search */
3057
3058     if (prog->intflags & PREGf_ANCH_GPOS)
3059     {
3060         /* PREGf_ANCH_GPOS should never be true if PREGf_GPOS_SEEN is not true */
3061         assert(prog->intflags & PREGf_GPOS_SEEN);
3062         /* For anchored \G, the only position it can match from is
3063          * (ganch-gofs); we already set startpos to this above; if intuit
3064          * moved us on from there, we can't possibly succeed */
3065         assert(startpos == reginfo->ganch - prog->gofs);
3066         if (s == startpos && regtry(reginfo, &s))
3067             goto got_it;
3068         goto phooey;
3069     }
3070
3071     /* Messy cases:  unanchored match. */
3072     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
3073         /* we have /x+whatever/ */
3074         /* it must be a one character string (XXXX Except is_utf8_pat?) */
3075         char ch;
3076 #ifdef DEBUGGING
3077         int did_match = 0;
3078 #endif
3079         if (utf8_target) {
3080             if (! prog->anchored_utf8) {
3081                 to_utf8_substr(prog);
3082             }
3083             ch = SvPVX_const(prog->anchored_utf8)[0];
3084             REXEC_FBC_SCAN(
3085                 if (*s == ch) {
3086                     DEBUG_EXECUTE_r( did_match = 1 );
3087                     if (regtry(reginfo, &s)) goto got_it;
3088                     s += UTF8SKIP(s);
3089                     while (s < strend && *s == ch)
3090                         s += UTF8SKIP(s);
3091                 }
3092             );
3093
3094         }
3095         else {
3096             if (! prog->anchored_substr) {
3097                 if (! to_byte_substr(prog)) {
3098                     NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3099                 }
3100             }
3101             ch = SvPVX_const(prog->anchored_substr)[0];
3102             REXEC_FBC_SCAN(
3103                 if (*s == ch) {
3104                     DEBUG_EXECUTE_r( did_match = 1 );
3105                     if (regtry(reginfo, &s)) goto got_it;
3106                     s++;
3107                     while (s < strend && *s == ch)
3108                         s++;
3109                 }
3110             );
3111         }
3112         DEBUG_EXECUTE_r(if (!did_match)
3113                 PerlIO_printf(Perl_debug_log,
3114                                   "Did not find anchored character...\n")
3115                );
3116     }
3117     else if (prog->anchored_substr != NULL
3118               || prog->anchored_utf8 != NULL
3119               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
3120                   && prog->float_max_offset < strend - s)) {
3121         SV *must;
3122         SSize_t back_max;
3123         SSize_t back_min;
3124         char *last;
3125         char *last1;            /* Last position checked before */
3126 #ifdef DEBUGGING
3127         int did_match = 0;
3128 #endif
3129         if (prog->anchored_substr || prog->anchored_utf8) {
3130             if (utf8_target) {
3131                 if (! prog->anchored_utf8) {
3132                     to_utf8_substr(prog);
3133                 }
3134                 must = prog->anchored_utf8;
3135             }
3136             else {
3137                 if (! prog->anchored_substr) {
3138                     if (! to_byte_substr(prog)) {
3139                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3140                     }
3141                 }
3142                 must = prog->anchored_substr;
3143             }
3144             back_max = back_min = prog->anchored_offset;
3145         } else {
3146             if (utf8_target) {
3147                 if (! prog->float_utf8) {
3148                     to_utf8_substr(prog);
3149                 }
3150                 must = prog->float_utf8;
3151             }
3152             else {
3153                 if (! prog->float_substr) {
3154                     if (! to_byte_substr(prog)) {
3155                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3156                     }
3157                 }
3158                 must = prog->float_substr;
3159             }
3160             back_max = prog->float_max_offset;
3161             back_min = prog->float_min_offset;
3162         }
3163             
3164         if (back_min<0) {
3165             last = strend;
3166         } else {
3167             last = HOP3c(strend,        /* Cannot start after this */
3168                   -(SSize_t)(CHR_SVLEN(must)
3169                          - (SvTAIL(must) != 0) + back_min), strbeg);
3170         }
3171         if (s > reginfo->strbeg)
3172             last1 = HOPc(s, -1);
3173         else
3174             last1 = s - 1;      /* bogus */
3175
3176         /* XXXX check_substr already used to find "s", can optimize if
3177            check_substr==must. */
3178         dontbother = 0;
3179         strend = HOPc(strend, -dontbother);
3180         while ( (s <= last) &&
3181                 (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg,  strend),
3182                                   (unsigned char*)strend, must,
3183                                   multiline ? FBMrf_MULTILINE : 0)) ) {
3184             DEBUG_EXECUTE_r( did_match = 1 );
3185             if (HOPc(s, -back_max) > last1) {
3186                 last1 = HOPc(s, -back_min);
3187                 s = HOPc(s, -back_max);
3188             }
3189             else {
3190                 char * const t = (last1 >= reginfo->strbeg)
3191                                     ? HOPc(last1, 1) : last1 + 1;
3192
3193                 last1 = HOPc(s, -back_min);
3194                 s = t;
3195             }
3196             if (utf8_target) {
3197                 while (s <= last1) {
3198                     if (regtry(reginfo, &s))
3199                         goto got_it;
3200                     if (s >= last1) {
3201                         s++; /* to break out of outer loop */
3202                         break;
3203                     }
3204                     s += UTF8SKIP(s);
3205                 }
3206             }
3207             else {
3208                 while (s <= last1) {
3209                     if (regtry(reginfo, &s))
3210                         goto got_it;
3211                     s++;
3212                 }
3213             }
3214         }
3215         DEBUG_EXECUTE_r(if (!did_match) {
3216             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
3217                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
3218             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
3219                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
3220                                ? "anchored" : "floating"),
3221                 quoted, RE_SV_TAIL(must));
3222         });                 
3223         goto phooey;
3224     }
3225     else if ( (c = progi->regstclass) ) {
3226         if (minlen) {
3227             const OPCODE op = OP(progi->regstclass);
3228             /* don't bother with what can't match */
3229             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
3230                 strend = HOPc(strend, -(minlen - 1));
3231         }
3232         DEBUG_EXECUTE_r({
3233             SV * const prop = sv_newmortal();
3234             regprop(prog, prop, c, reginfo, NULL);
3235             {
3236                 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
3237                     s,strend-s,60);
3238                 PerlIO_printf(Perl_debug_log,
3239                     "Matching stclass %.*s against %s (%d bytes)\n",
3240                     (int)SvCUR(prop), SvPVX_const(prop),
3241                      quoted, (int)(strend - s));
3242             }
3243         });
3244         if (find_byclass(prog, c, s, strend, reginfo))
3245             goto got_it;
3246         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
3247     }
3248     else {
3249         dontbother = 0;
3250         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
3251             /* Trim the end. */
3252             char *last= NULL;
3253             SV* float_real;
3254             STRLEN len;
3255             const char *little;
3256
3257             if (utf8_target) {
3258                 if (! prog->float_utf8) {
3259                     to_utf8_substr(prog);
3260                 }
3261                 float_real = prog->float_utf8;
3262             }
3263             else {
3264                 if (! prog->float_substr) {
3265                     if (! to_byte_substr(prog)) {
3266                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
3267                     }
3268                 }
3269                 float_real = prog->float_substr;
3270             }
3271
3272             little = SvPV_const(float_real, len);
3273             if (SvTAIL(float_real)) {
3274                     /* This means that float_real contains an artificial \n on
3275                      * the end due to the presence of something like this:
3276                      * /foo$/ where we can match both "foo" and "foo\n" at the
3277                      * end of the string.  So we have to compare the end of the
3278                      * string first against the float_real without the \n and
3279                      * then against the full float_real with the string.  We
3280                      * have to watch out for cases where the string might be
3281                      * smaller than the float_real or the float_real without
3282                      * the \n. */
3283                     char *checkpos= strend - len;
3284                     DEBUG_OPTIMISE_r(
3285                         PerlIO_printf(Perl_debug_log,
3286                             "%sChecking for float_real.%s\n",
3287                             PL_colors[4], PL_colors[5]));
3288                     if (checkpos + 1 < strbeg) {
3289                         /* can't match, even if we remove the trailing \n
3290                          * string is too short to match */
3291                         DEBUG_EXECUTE_r(
3292                             PerlIO_printf(Perl_debug_log,
3293                                 "%sString shorter than required trailing substring, cannot match.%s\n",
3294                                 PL_colors[4], PL_colors[5]));
3295                         goto phooey;
3296                     } else if (memEQ(checkpos + 1, little, len - 1)) {
3297                         /* can match, the end of the string matches without the
3298                          * "\n" */
3299                         last = checkpos + 1;
3300                     } else if (checkpos < strbeg) {
3301                         /* cant match, string is too short when the "\n" is
3302                          * included */
3303                         DEBUG_EXECUTE_r(
3304                             PerlIO_printf(Perl_debug_log,
3305                                 "%sString does not contain required trailing substring, cannot match.%s\n",
3306                                 PL_colors[4], PL_colors[5]));
3307                         goto phooey;
3308                     } else if (!multiline) {
3309                         /* non multiline match, so compare with the "\n" at the
3310                          * end of the string */
3311                         if (memEQ(checkpos, little, len)) {
3312                             last= checkpos;
3313                         } else {
3314                             DEBUG_EXECUTE_r(
3315                                 PerlIO_printf(Perl_debug_log,
3316                                     "%sString does not contain required trailing substring, cannot match.%s\n",
3317                                     PL_colors[4], PL_colors[5]));
3318                             goto phooey;
3319                         }
3320                     } else {
3321                         /* multiline match, so we have to search for a place
3322                          * where the full string is located */
3323                         goto find_last;
3324                     }
3325             } else {
3326                   find_last:
3327                     if (len)
3328                         last = rninstr(s, strend, little, little + len);
3329                     else
3330                         last = strend;  /* matching "$" */
3331             }
3332             if (!last) {
3333                 /* at one point this block contained a comment which was
3334                  * probably incorrect, which said that this was a "should not
3335                  * happen" case.  Even if it was true when it was written I am
3336                  * pretty sure it is not anymore, so I have removed the comment
3337                  * and replaced it with this one. Yves */
3338                 DEBUG_EXECUTE_r(
3339                     PerlIO_printf(Perl_debug_log,
3340                         "%sString does not contain required substring, cannot match.%s\n",
3341                         PL_colors[4], PL_colors[5]
3342                     ));
3343                 goto phooey;
3344             }
3345             dontbother = strend - last + prog->float_min_offset;
3346         }
3347         if (minlen && (dontbother < minlen))
3348             dontbother = minlen - 1;
3349         strend -= dontbother;              /* this one's always in bytes! */
3350         /* We don't know much -- general case. */
3351         if (utf8_target) {
3352             for (;;) {
3353                 if (regtry(reginfo, &s))
3354                     goto got_it;
3355                 if (s >= strend)
3356                     break;
3357                 s += UTF8SKIP(s);
3358             };
3359         }
3360         else {
3361             do {
3362                 if (regtry(reginfo, &s))
3363                     goto got_it;
3364             } while (s++ < strend);
3365         }
3366     }
3367
3368     /* Failure. */
3369     goto phooey;
3370
3371   got_it:
3372     /* s/// doesn't like it if $& is earlier than where we asked it to
3373      * start searching (which can happen on something like /.\G/) */
3374     if (       (flags & REXEC_FAIL_ON_UNDERFLOW)
3375             && (prog->offs[0].start < stringarg - strbeg))
3376     {
3377         /* this should only be possible under \G */
3378         assert(prog->intflags & PREGf_GPOS_SEEN);
3379         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
3380             "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
3381         goto phooey;
3382     }
3383
3384     DEBUG_BUFFERS_r(
3385         if (swap)
3386             PerlIO_printf(Perl_debug_log,
3387                 "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
3388                 PTR2UV(prog),
3389                 PTR2UV(swap)
3390             );
3391     );
3392     Safefree(swap);
3393
3394     /* clean up; this will trigger destructors that will free all slabs
3395      * above the current one, and cleanup the regmatch_info_aux
3396      * and regmatch_info_aux_eval sructs */
3397
3398     LEAVE_SCOPE(oldsave);
3399
3400     if (RXp_PAREN_NAMES(prog)) 
3401         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
3402
3403     /* make sure $`, $&, $', and $digit will work later */
3404     if ( !(flags & REXEC_NOT_FIRST) )
3405         S_reg_set_capture_string(aTHX_ rx,
3406                                     strbeg, reginfo->strend,
3407                                     sv, flags, utf8_target);
3408
3409     return 1;
3410
3411   phooey:
3412     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
3413                           PL_colors[4], PL_colors[5]));
3414
3415     /* clean up; this will trigger destructors that will free all slabs
3416      * above the current one, and cleanup the regmatch_info_aux
3417      * and regmatch_info_aux_eval sructs */
3418
3419     LEAVE_SCOPE(oldsave);
3420
3421     if (swap) {
3422         /* we failed :-( roll it back */
3423         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
3424             "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
3425             PTR2UV(prog),
3426             PTR2UV(prog->offs),
3427             PTR2UV(swap)
3428         ));
3429         Safefree(prog->offs);
3430         prog->offs = swap;
3431     }
3432     return 0;
3433 }
3434
3435
3436 /* Set which rex is pointed to by PL_reg_curpm, handling ref counting.
3437  * Do inc before dec, in case old and new rex are the same */
3438 #define SET_reg_curpm(Re2)                          \
3439     if (reginfo->info_aux_eval) {                   \
3440         (void)ReREFCNT_inc(Re2);                    \
3441         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));       \
3442         PM_SETRE((PL_reg_curpm), (Re2));            \
3443     }
3444
3445
3446 /*
3447  - regtry - try match at specific point
3448  */
3449 STATIC I32                      /* 0 failure, 1 success */
3450 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
3451 {
3452     CHECKPOINT lastcp;
3453     REGEXP *const rx = reginfo->prog;
3454     regexp *const prog = ReANY(rx);
3455     SSize_t result;
3456     RXi_GET_DECL(prog,progi);
3457     GET_RE_DEBUG_FLAGS_DECL;
3458
3459     PERL_ARGS_ASSERT_REGTRY;
3460
3461     reginfo->cutpoint=NULL;
3462
3463     prog->offs[0].start = *startposp - reginfo->strbeg;
3464     prog->lastparen = 0;
3465     prog->lastcloseparen = 0;
3466
3467     /* XXXX What this code is doing here?!!!  There should be no need
3468        to do this again and again, prog->lastparen should take care of
3469        this!  --ilya*/
3470
3471     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
3472      * Actually, the code in regcppop() (which Ilya may be meaning by
3473      * prog->lastparen), is not needed at all by the test suite
3474      * (op/regexp, op/pat, op/split), but that code is needed otherwise
3475      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
3476      * Meanwhile, this code *is* needed for the
3477      * above-mentioned test suite tests to succeed.  The common theme
3478      * on those tests seems to be returning null fields from matches.
3479      * --jhi updated by dapm */
3480 #if 1
3481     if (prog->nparens) {
3482         regexp_paren_pair *pp = prog->offs;
3483         I32 i;
3484         for (i = prog->nparens; i > (I32)prog->lastparen; i--) {
3485             ++pp;
3486             pp->start = -1;
3487             pp->end = -1;
3488         }
3489     }
3490 #endif
3491     REGCP_SET(lastcp);
3492     result = regmatch(reginfo, *startposp, progi->program + 1);
3493     if (result != -1) {
3494         prog->offs[0].end = result;
3495         return 1;
3496     }
3497     if (reginfo->cutpoint)
3498         *startposp= reginfo->cutpoint;
3499     REGCP_UNWIND(lastcp);
3500     return 0;
3501 }
3502
3503
3504 #define sayYES goto yes
3505 #define sayNO goto no
3506 #define sayNO_SILENT goto no_silent
3507
3508 /* we dont use STMT_START/END here because it leads to 
3509    "unreachable code" warnings, which are bogus, but distracting. */
3510 #define CACHEsayNO \
3511     if (ST.cache_mask) \
3512        reginfo->info_aux->poscache[ST.cache_offset] |= ST.cache_mask; \
3513     sayNO
3514
3515 /* this is used to determine how far from the left messages like
3516    'failed...' are printed. It should be set such that messages 
3517    are inline with the regop output that created them.
3518 */
3519 #define REPORT_CODE_OFF 32
3520
3521
3522 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
3523 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
3524 #define CHRTEST_NOT_A_CP_1 -999
3525 #define CHRTEST_NOT_A_CP_2 -998
3526
3527 /* grab a new slab and return the first slot in it */
3528
3529 STATIC regmatch_state *
3530 S_push_slab(pTHX)
3531 {
3532 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3533     dMY_CXT;
3534 #endif
3535     regmatch_slab *s = PL_regmatch_slab->next;
3536     if (!s) {
3537         Newx(s, 1, regmatch_slab);
3538         s->prev = PL_regmatch_slab;
3539         s->next = NULL;
3540         PL_regmatch_slab->next = s;
3541     }
3542     PL_regmatch_slab = s;
3543     return SLAB_FIRST(s);
3544 }
3545
3546
3547 /* push a new state then goto it */
3548
3549 #define PUSH_STATE_GOTO(state, node, input) \
3550     pushinput = input; \
3551     scan = node; \
3552     st->resume_state = state; \
3553     goto push_state;
3554
3555 /* push a new state with success backtracking, then goto it */
3556
3557 #define PUSH_YES_STATE_GOTO(state, node, input) \
3558     pushinput = input; \
3559     scan = node; \
3560     st->resume_state = state; \
3561     goto push_yes_state;
3562
3563
3564
3565
3566 /*
3567
3568 regmatch() - main matching routine
3569
3570 This is basically one big switch statement in a loop. We execute an op,
3571 set 'next' to point the next op, and continue. If we come to a point which
3572 we may need to backtrack to on failure such as (A|B|C), we push a
3573 backtrack state onto the backtrack stack. On failure, we pop the top
3574 state, and re-enter the loop at the state indicated. If there are no more
3575 states to pop, we return failure.
3576
3577 Sometimes we also need to backtrack on success; for example /A+/, where
3578 after successfully matching one A, we need to go back and try to
3579 match another one; similarly for lookahead assertions: if the assertion
3580 completes successfully, we backtrack to the state just before the assertion
3581 and then carry on.  In these cases, the pushed state is marked as
3582 'backtrack on success too'. This marking is in fact done by a chain of
3583 pointers, each pointing to the previous 'yes' state. On success, we pop to
3584 the nearest yes state, discarding any intermediate failure-only states.
3585 Sometimes a yes state is pushed just to force some cleanup code to be
3586 called at the end of a successful match or submatch; e.g. (??{$re}) uses
3587 it to free the inner regex.
3588
3589 Note that failure backtracking rewinds the cursor position, while
3590 success backtracking leaves it alone.
3591
3592 A pattern is complete when the END op is executed, while a subpattern
3593 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
3594 ops trigger the "pop to last yes state if any, otherwise return true"
3595 behaviour.
3596
3597 A common convention in this function is to use A and B to refer to the two
3598 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
3599 the subpattern to be matched possibly multiple times, while B is the entire
3600 rest of the pattern. Variable and state names reflect this convention.
3601
3602 The states in the main switch are the union of ops and failure/success of
3603 substates associated with with that op.  For example, IFMATCH is the op
3604 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
3605 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
3606 successfully matched A and IFMATCH_A_fail is a state saying that we have
3607 just failed to match A. Resume states always come in pairs. The backtrack
3608 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
3609 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
3610 on success or failure.
3611
3612 The struct that holds a backtracking state is actually a big union, with
3613 one variant for each major type of op. The variable st points to the
3614 top-most backtrack struct. To make the code clearer, within each
3615 block of code we #define ST to alias the relevant union.
3616
3617 Here's a concrete example of a (vastly oversimplified) IFMATCH
3618 implementation:
3619
3620     switch (state) {
3621     ....
3622
3623 #define ST st->u.ifmatch
3624
3625     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3626         ST.foo = ...; // some state we wish to save
3627         ...
3628         // push a yes backtrack state with a resume value of
3629         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
3630         // first node of A:
3631         PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput);
3632         // NOTREACHED
3633
3634     case IFMATCH_A: // we have successfully executed A; now continue with B
3635         next = B;
3636         bar = ST.foo; // do something with the preserved value
3637         break;
3638
3639     case IFMATCH_A_fail: // A failed, so the assertion failed
3640         ...;   // do some housekeeping, then ...
3641         sayNO; // propagate the failure
3642
3643 #undef ST
3644
3645     ...
3646     }
3647
3648 For any old-timers reading this who are familiar with the old recursive
3649 approach, the code above is equivalent to:
3650
3651     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3652     {
3653         int foo = ...
3654         ...
3655         if (regmatch(A)) {
3656             next = B;
3657             bar = foo;
3658             break;
3659         }
3660         ...;   // do some housekeeping, then ...
3661         sayNO; // propagate the failure
3662     }
3663
3664 The topmost backtrack state, pointed to by st, is usually free. If you
3665 want to claim it, populate any ST.foo fields in it with values you wish to
3666 save, then do one of
3667
3668         PUSH_STATE_GOTO(resume_state, node, newinput);
3669         PUSH_YES_STATE_GOTO(resume_state, node, newinput);
3670
3671 which sets that backtrack state's resume value to 'resume_state', pushes a
3672 new free entry to the top of the backtrack stack, then goes to 'node'.
3673 On backtracking, the free slot is popped, and the saved state becomes the
3674 new free state. An ST.foo field in this new top state can be temporarily
3675 accessed to retrieve values, but once the main loop is re-entered, it
3676 becomes available for reuse.
3677
3678 Note that the depth of the backtrack stack constantly increases during the
3679 left-to-right execution of the pattern, rather than going up and down with
3680 the pattern nesting. For example the stack is at its maximum at Z at the
3681 end of the pattern, rather than at X in the following:
3682
3683     /(((X)+)+)+....(Y)+....Z/
3684
3685 The only exceptions to this are lookahead/behind assertions and the cut,
3686 (?>A), which pop all the backtrack states associated with A before
3687 continuing.
3688  
3689 Backtrack state structs are allocated in slabs of about 4K in size.
3690 PL_regmatch_state and st always point to the currently active state,
3691 and PL_regmatch_slab points to the slab currently containing
3692 PL_regmatch_state.  The first time regmatch() is called, the first slab is
3693 allocated, and is never freed until interpreter destruction. When the slab
3694 is full, a new one is allocated and chained to the end. At exit from
3695 regmatch(), slabs allocated since entry are freed.
3696
3697 */
3698  
3699
3700 #define DEBUG_STATE_pp(pp)                                  \
3701     DEBUG_STATE_r({                                         \
3702         DUMP_EXEC_POS(locinput, scan, utf8_target);         \
3703         PerlIO_printf(Perl_debug_log,                       \
3704             "    %*s"pp" %s%s%s%s%s\n",                     \
3705             depth*2, "",                                    \
3706             PL_reg_name[st->resume_state],                  \
3707             ((st==yes_state||st==mark_state) ? "[" : ""),   \
3708             ((st==yes_state) ? "Y" : ""),                   \
3709             ((st==mark_state) ? "M" : ""),                  \
3710             ((st==yes_state||st==mark_state) ? "]" : "")    \
3711         );                                                  \
3712     });
3713
3714
3715 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
3716
3717 #ifdef DEBUGGING
3718
3719 STATIC void
3720 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
3721     const char *start, const char *end, const char *blurb)
3722 {
3723     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
3724
3725     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
3726
3727     if (!PL_colorset)   
3728             reginitcolors();    
3729     {
3730         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), 
3731             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);   
3732         
3733         RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
3734             start, end - start, 60); 
3735         
3736         PerlIO_printf(Perl_debug_log, 
3737             "%s%s REx%s %s against %s\n", 
3738                        PL_colors[4], blurb, PL_colors[5], s0, s1); 
3739         
3740         if (utf8_target||utf8_pat)
3741             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
3742                 utf8_pat ? "pattern" : "",
3743                 utf8_pat && utf8_target ? " and " : "",
3744                 utf8_target ? "string" : ""
3745             ); 
3746     }
3747 }
3748
3749 STATIC void
3750 S_dump_exec_pos(pTHX_ const char *locinput, 
3751                       const regnode *scan, 
3752                       const char *loc_regeol, 
3753                       const char *loc_bostr, 
3754                       const char *loc_reg_starttry,
3755                       const bool utf8_target)
3756 {
3757     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
3758     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
3759     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
3760     /* The part of the string before starttry has one color
3761        (pref0_len chars), between starttry and current
3762        position another one (pref_len - pref0_len chars),
3763        after the current position the third one.
3764        We assume that pref0_len <= pref_len, otherwise we
3765        decrease pref0_len.  */
3766     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
3767         ? (5 + taill) - l : locinput - loc_bostr;
3768     int pref0_len;
3769
3770     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
3771
3772     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
3773         pref_len++;
3774     pref0_len = pref_len  - (locinput - loc_reg_starttry);
3775     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
3776         l = ( loc_regeol - locinput > (5 + taill) - pref_len
3777               ? (5 + taill) - pref_len : loc_regeol - locinput);
3778     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
3779         l--;
3780     if (pref0_len < 0)
3781         pref0_len = 0;
3782     if (pref0_len > pref_len)
3783         pref0_len = pref_len;
3784     {
3785         const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
3786
3787         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
3788             (locinput - pref_len),pref0_len, 60, 4, 5);
3789         
3790         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3791                     (locinput - pref_len + pref0_len),
3792                     pref_len - pref0_len, 60, 2, 3);
3793         
3794         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
3795                     locinput, loc_regeol - locinput, 10, 0, 1);
3796
3797         const STRLEN tlen=len0+len1+len2;
3798         PerlIO_printf(Perl_debug_log,
3799                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
3800                     (IV)(locinput - loc_bostr),
3801                     len0, s0,
3802                     len1, s1,
3803                     (docolor ? "" : "> <"),
3804                     len2, s2,
3805                     (int)(tlen > 19 ? 0 :  19 - tlen),
3806                     "");
3807     }
3808 }
3809
3810 #endif
3811
3812 /* reg_check_named_buff_matched()
3813  * Checks to see if a named buffer has matched. The data array of 
3814  * buffer numbers corresponding to the buffer is expected to reside
3815  * in the regexp->data->data array in the slot stored in the ARG() of
3816  * node involved. Note that this routine doesn't actually care about the
3817  * name, that information is not preserved from compilation to execution.
3818  * Returns the index of the leftmost defined buffer with the given name
3819  * or 0 if non of the buffers matched.
3820  */
3821 STATIC I32
3822 S_reg_check_named_buff_matched(const regexp *rex, const regnode *scan)
3823 {
3824     I32 n;
3825     RXi_GET_DECL(rex,rexi);
3826     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
3827     I32 *nums=(I32*)SvPVX(sv_dat);
3828
3829     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3830
3831     for ( n=0; n<SvIVX(sv_dat); n++ ) {
3832         if ((I32)rex->lastparen >= nums[n] &&
3833             rex->offs[nums[n]].end != -1)
3834         {
3835             return nums[n];
3836         }
3837     }
3838     return 0;
3839 }
3840
3841
3842 static bool
3843 S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p,
3844         U8* c1_utf8, int *c2p, U8* c2_utf8, regmatch_info *reginfo)
3845 {
3846     /* This function determines if there are one or two characters that match
3847      * the first character of the passed-in EXACTish node <text_node>, and if
3848      * so, returns them in the passed-in pointers.
3849      *
3850      * If it determines that no possible character in the target string can
3851      * match, it returns FALSE; otherwise TRUE.  (The FALSE situation occurs if
3852      * the first character in <text_node> requires UTF-8 to represent, and the
3853      * target string isn't in UTF-8.)
3854      *
3855      * If there are more than two characters that could match the beginning of
3856      * <text_node>, or if more context is required to determine a match or not,
3857      * it sets both *<c1p> and *<c2p> to CHRTEST_VOID.
3858      *
3859      * The motiviation behind this function is to allow the caller to set up
3860      * tight loops for matching.  If <text_node> is of type EXACT, there is
3861      * only one possible character that can match its first character, and so
3862      * the situation is quite simple.  But things get much more complicated if
3863      * folding is involved.  It may be that the first character of an EXACTFish
3864      * node doesn't participate in any possible fold, e.g., punctuation, so it
3865      * can be matched only by itself.  The vast majority of characters that are
3866      * in folds match just two things, their lower and upper-case equivalents.
3867      * But not all are like that; some have multiple possible matches, or match
3868      * sequences of more than one character.  This function sorts all that out.
3869      *
3870      * Consider the patterns A*B or A*?B where A and B are arbitrary.  In a
3871      * loop of trying to match A*, we know we can't exit where the thing
3872      * following it isn't a B.  And something can't be a B unless it is the
3873      * beginning of B.  By putting a quick test for that beginning in a tight
3874      * loop, we can rule out things that can't possibly be B without having to
3875      * break out of the loop, thus avoiding work.  Similarly, if A is a single
3876      * character, we can make a tight loop matching A*, using the outputs of
3877      * this function.
3878      *
3879      * If the target string to match isn't in UTF-8, and there aren't