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