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