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