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