This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Improve how regprop dumps REF-like nodes during execution
[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         char *s;
1100
1101         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1102                         "  looking for /^/m anchor"));
1103
1104         /* we have failed the constraint of a \n before rx_origin.
1105          * Find the next \n, if any, even if it's beyond the current
1106          * anchored and/or floating substrings. Whether we should be
1107          * scanning ahead for the next \n or the next substr is debatable.
1108          * On the one hand you'd expect rare substrings to appear less
1109          * often than \n's. On the other hand, searching for \n means
1110          * we're effectively flipping been check_substr and "\n" on each
1111          * iteration as the current "rarest" string candidate, which
1112          * means for example that we'll quickly reject the whole string if
1113          * hasn't got a \n, rather than trying every substr position
1114          * first
1115          */
1116
1117         s = HOP3c(strend, - prog->minlen, strpos);
1118         if (s <= rx_origin ||
1119             ! ( rx_origin = (char *)memchr(rx_origin, '\n', s - rx_origin)))
1120         {
1121             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1122                             "  Did not find /%s^%s/m...\n",
1123                             PL_colors[0], PL_colors[1]));
1124             goto fail_finish;
1125         }
1126
1127         /* earliest possible origin is 1 char after the \n.
1128          * (since *rx_origin == '\n', it's safe to ++ here rather than
1129          * HOP(rx_origin, 1)) */
1130         rx_origin++;
1131
1132         if (prog->substrs->check_ix == 0  /* check is anchored */
1133             || rx_origin >= HOP3c(check_at,  - prog->check_offset_min, strpos))
1134         {
1135             /* Position contradicts check-string; either because
1136              * check was anchored (and thus has no wiggle room),
1137              * or check was float and rx_origin is above the float range */
1138             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1139                 "  Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
1140                 PL_colors[0], PL_colors[1], (long)(rx_origin - strpos)));
1141             goto restart;
1142         }
1143
1144         /* if we get here, the check substr must have been float,
1145          * is in range, and we may or may not have had an anchored
1146          * "other" substr which still contradicts */
1147         assert(prog->substrs->check_ix); /* check is float */
1148
1149         if (utf8_target ? prog->anchored_utf8 : prog->anchored_substr) {
1150             /* whoops, the anchored "other" substr exists, so we still
1151              * contradict. On the other hand, the float "check" substr
1152              * didn't contradict, so just retry the anchored "other"
1153              * substr */
1154             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1155                 "  Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
1156                 PL_colors[0], PL_colors[1],
1157                 (long)(rx_origin - strpos),
1158                 (long)(rx_origin - strpos + prog->anchored_offset)));
1159             goto do_other_substr;
1160         }
1161
1162         /* success: we don't contradict the found floating substring
1163          * (and there's no anchored substr). */
1164         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1165             "  Found /%s^%s/m at offset %ld...\n",
1166             PL_colors[0], PL_colors[1], (long)(rx_origin - strpos)));
1167     }
1168     else {
1169         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1170             "  Starting position does not contradict /%s^%s/m...\n",
1171             PL_colors[0], PL_colors[1]));
1172     }
1173
1174
1175     /* Decide whether using the substrings helped */
1176
1177     if (rx_origin != strpos) {
1178         /* Fixed substring is found far enough so that the match
1179            cannot start at strpos. */
1180
1181         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "  try at offset...\n"));
1182         ++BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr);        /* hooray/5 */
1183     }
1184     else {
1185         /* The found string does not prohibit matching at strpos,
1186            - no optimization of calling REx engine can be performed,
1187            unless it was an MBOL and we are not after MBOL,
1188            or a future STCLASS check will fail this. */
1189       success_at_start:
1190         if (!(prog->intflags & PREGf_NAUGHTY)   /* XXXX If strpos moved? */
1191             && (utf8_target ? (
1192                 prog->check_utf8                /* Could be deleted already */
1193                 && --BmUSEFUL(prog->check_utf8) < 0
1194                 && (prog->check_utf8 == prog->float_utf8)
1195             ) : (
1196                 prog->check_substr              /* Could be deleted already */
1197                 && --BmUSEFUL(prog->check_substr) < 0
1198                 && (prog->check_substr == prog->float_substr)
1199             )))
1200         {
1201             /* If flags & SOMETHING - do not do it many times on the same match */
1202             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "  ... Disabling check substring...\n"));
1203             /* XXX Does the destruction order has to change with utf8_target? */
1204             SvREFCNT_dec(utf8_target ? prog->check_utf8 : prog->check_substr);
1205             SvREFCNT_dec(utf8_target ? prog->check_substr : prog->check_utf8);
1206             prog->check_substr = prog->check_utf8 = NULL;       /* disable */
1207             prog->float_substr = prog->float_utf8 = NULL;       /* clear */
1208             check = NULL;                       /* abort */
1209             /* XXXX If the check string was an implicit check MBOL, then we need to unset the relevant flag
1210                     see http://bugs.activestate.com/show_bug.cgi?id=87173 */
1211             if (prog->intflags & PREGf_IMPLICIT) {
1212                 prog->intflags &= ~PREGf_ANCH_MBOL;
1213                 /* maybe we have no anchors left after this... */
1214                 if (!(prog->intflags & PREGf_ANCH))
1215                     prog->extflags &= ~RXf_IS_ANCHORED;
1216             }
1217             /* XXXX This is a remnant of the old implementation.  It
1218                     looks wasteful, since now INTUIT can use many
1219                     other heuristics. */
1220             prog->extflags &= ~RXf_USE_INTUIT;
1221             /* XXXX What other flags might need to be cleared in this branch? */
1222         }
1223     }
1224
1225     /* Last resort... */
1226     /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
1227     /* trie stclasses are too expensive to use here, we are better off to
1228        leave it to regmatch itself */
1229     if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1230         /* minlen == 0 is possible if regstclass is \b or \B,
1231            and the fixed substr is ''$.
1232            Since minlen is already taken into account, rx_origin+1 is before strend;
1233            accidentally, minlen >= 1 guaranties no false positives at rx_origin + 1
1234            even for \b or \B.  But (minlen? 1 : 0) below assumes that
1235            regstclass does not come from lookahead...  */
1236         /* If regstclass takes bytelength more than 1: If charlength==1, OK.
1237            This leaves EXACTF-ish only, which are dealt with in find_byclass().  */
1238         const U8* const str = (U8*)STRING(progi->regstclass);
1239         char *t;
1240
1241         /* XXX this value could be pre-computed */
1242         const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1243                     ?  (reginfo->is_utf8_pat
1244                         ? utf8_distance(str + STR_LEN(progi->regstclass), str)
1245                         : STR_LEN(progi->regstclass))
1246                     : 1);
1247         char * endpos;
1248         char *s = rx_origin;
1249         if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1250             endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
1251         else if (prog->float_substr || prog->float_utf8)
1252             endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
1253         else 
1254             endpos= strend;
1255                     
1256         if (checked_upto < s)
1257            checked_upto = s;
1258         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1259             "  looking for class: start_shift: %"IVdf" check_at: %"IVdf
1260             " s: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
1261               (IV)start_shift, (IV)(check_at - strbeg),
1262               (IV)(s - strbeg), (IV)(endpos - strbeg),
1263               (IV)(checked_upto- strbeg)));
1264
1265         t = s;
1266         s = find_byclass(prog, progi->regstclass, checked_upto, endpos,
1267                             reginfo);
1268         if (s) {
1269             checked_upto = s;
1270         } else {
1271 #ifdef DEBUGGING
1272             const char *what = NULL;
1273 #endif
1274             if (endpos == strend) {
1275                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1276                                 "  Could not match STCLASS...\n") );
1277                 goto fail;
1278             }
1279             DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1280                                "  This position contradicts STCLASS...\n") );
1281             if ((prog->intflags & PREGf_ANCH) && !ml_anch)
1282                 goto fail;
1283             checked_upto = HOPBACKc(endpos, start_shift);
1284             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "  start_shift: %"IVdf" check_at: %"IVdf" endpos: %"IVdf" checked_upto: %"IVdf"\n",
1285                                       (IV)start_shift, (IV)(check_at - strbeg), (IV)(endpos - strbeg), (IV)(checked_upto- strbeg)));
1286             /* Contradict one of substrings */
1287             if (prog->anchored_substr || prog->anchored_utf8) {
1288                 if ((utf8_target ? prog->anchored_utf8 : prog->anchored_substr) == check) {
1289                     DEBUG_EXECUTE_r( what = "anchored" );
1290                   hop_and_restart:
1291                     s = HOP3c(t, 1, strend);
1292                     if (s + start_shift + end_shift > strend) {
1293                         /* XXXX Should be taken into account earlier? */
1294                         DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1295                                                "  Could not match STCLASS...\n") );
1296                         goto fail;
1297                     }
1298                     rx_origin = s;
1299                     if (!check)
1300                         goto giveup;
1301                     DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1302                                 "  Looking for %s substr starting at offset %ld...\n",
1303                                  what, (long)(rx_origin + start_shift - strpos)) );
1304                     goto restart;
1305                 }
1306                 /* Have both, check_string is floating */
1307                 if (t + start_shift >= check_at) /* Contradicts floating=check */
1308                     goto retry_floating_check;
1309                 /* Recheck anchored substring, but not floating... */
1310                 if (!check) {
1311                     rx_origin = NULL;
1312                     goto giveup;
1313                 }
1314                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1315                           "  Looking for anchored substr starting at offset %ld...\n",
1316                           (long)(other_last - strpos)) );
1317                 assert(prog->substrs->check_ix); /* other is float */
1318                 goto do_other_substr;
1319             }
1320             /* Another way we could have checked stclass at the
1321                current position only: */
1322             if (ml_anch) {
1323                 s = rx_origin = t + 1;
1324                 if (!check)
1325                     goto giveup;
1326                 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1327                           "  Looking for /%s^%s/m starting at offset %ld...\n",
1328                           PL_colors[0], PL_colors[1],
1329                           (long)(rx_origin - strpos)) );
1330                 /* XXX DAPM I don't yet know why this is true, but the code
1331                  * assumed it when it used to do goto try_at_offset */
1332                 assert(rx_origin != strpos);
1333                 goto postprocess_substr_matches;
1334             }
1335             if (!(utf8_target ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
1336                 goto fail;
1337             /* Check is floating substring. */
1338           retry_floating_check:
1339             t = check_at - start_shift;
1340             DEBUG_EXECUTE_r( what = "floating" );
1341             goto hop_and_restart;
1342         }
1343         if (t != s) {
1344             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1345                         "  By STCLASS: moving %ld --> %ld\n",
1346                                   (long)(t - strpos), (long)(s - strpos))
1347                    );
1348         }
1349         else {
1350             DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1351                                   "  Does not contradict STCLASS...\n");
1352                    );
1353         }
1354     }
1355   giveup:
1356     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Intuit: %s%s:%s match at offset %ld\n",
1357                           PL_colors[4], (check ? "Successfully guessed" : "Giving up"),
1358                           PL_colors[5], (long)(rx_origin - strpos)) );
1359     return rx_origin;
1360
1361   fail_finish:                          /* Substring not found */
1362     if (prog->check_substr || prog->check_utf8)         /* could be removed already */
1363         BmUSEFUL(utf8_target ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1364   fail:
1365     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1366                           PL_colors[4], PL_colors[5]));
1367     return NULL;
1368 }
1369
1370 #define DECL_TRIE_TYPE(scan) \
1371     const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold, \
1372                  trie_utf8_exactfa_fold, trie_latin_utf8_exactfa_fold } \
1373                     trie_type = ((scan->flags == EXACT) \
1374                               ? (utf8_target ? trie_utf8 : trie_plain) \
1375                               : (scan->flags == EXACTFA) \
1376                                 ? (utf8_target ? trie_utf8_exactfa_fold : trie_latin_utf8_exactfa_fold) \
1377                                 : (utf8_target ? trie_utf8_fold : trie_latin_utf8_fold))
1378
1379 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, uvc, charid, foldlen, foldbuf, uniflags) \
1380 STMT_START {                                                                        \
1381     STRLEN skiplen;                                                                 \
1382     U8 flags = FOLD_FLAGS_FULL;                                                     \
1383     switch (trie_type) {                                                            \
1384     case trie_utf8_exactfa_fold:                                                    \
1385         flags |= FOLD_FLAGS_NOMIX_ASCII;                                            \
1386         /* FALL THROUGH */                                                          \
1387     case trie_utf8_fold:                                                            \
1388         if ( foldlen>0 ) {                                                          \
1389             uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1390             foldlen -= len;                                                         \
1391             uscan += len;                                                           \
1392             len=0;                                                                  \
1393         } else {                                                                    \
1394             uvc = _to_utf8_fold_flags( (const U8*) uc, foldbuf, &foldlen, flags);   \
1395             len = UTF8SKIP(uc);                                                     \
1396             skiplen = UNISKIP( uvc );                                               \
1397             foldlen -= skiplen;                                                     \
1398             uscan = foldbuf + skiplen;                                              \
1399         }                                                                           \
1400         break;                                                                      \
1401     case trie_latin_utf8_exactfa_fold:                                              \
1402         flags |= FOLD_FLAGS_NOMIX_ASCII;                                            \
1403         /* FALL THROUGH */                                                          \
1404     case trie_latin_utf8_fold:                                                      \
1405         if ( foldlen>0 ) {                                                          \
1406             uvc = utf8n_to_uvchr( (const U8*) uscan, UTF8_MAXLEN, &len, uniflags ); \
1407             foldlen -= len;                                                         \
1408             uscan += len;                                                           \
1409             len=0;                                                                  \
1410         } else {                                                                    \
1411             len = 1;                                                                \
1412             uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, flags);             \
1413             skiplen = UNISKIP( uvc );                                               \
1414             foldlen -= skiplen;                                                     \
1415             uscan = foldbuf + skiplen;                                              \
1416         }                                                                           \
1417         break;                                                                      \
1418     case trie_utf8:                                                                 \
1419         uvc = utf8n_to_uvchr( (const U8*) uc, UTF8_MAXLEN, &len, uniflags );        \
1420         break;                                                                      \
1421     case trie_plain:                                                                \
1422         uvc = (UV)*uc;                                                              \
1423         len = 1;                                                                    \
1424     }                                                                               \
1425     if (uvc < 256) {                                                                \
1426         charid = trie->charmap[ uvc ];                                              \
1427     }                                                                               \
1428     else {                                                                          \
1429         charid = 0;                                                                 \
1430         if (widecharmap) {                                                          \
1431             SV** const svpp = hv_fetch(widecharmap,                                 \
1432                         (char*)&uvc, sizeof(UV), 0);                                \
1433             if (svpp)                                                               \
1434                 charid = (U16)SvIV(*svpp);                                          \
1435         }                                                                           \
1436     }                                                                               \
1437 } STMT_END
1438
1439 #define REXEC_FBC_EXACTISH_SCAN(CoNd)                     \
1440 STMT_START {                                              \
1441     while (s <= e) {                                      \
1442         if ( (CoNd)                                       \
1443              && (ln == 1 || folder(s, pat_string, ln))    \
1444              && (reginfo->intuit || regtry(reginfo, &s)) )\
1445             goto got_it;                                  \
1446         s++;                                              \
1447     }                                                     \
1448 } STMT_END
1449
1450 #define REXEC_FBC_UTF8_SCAN(CoDe)                     \
1451 STMT_START {                                          \
1452     while (s < strend) {                              \
1453         CoDe                                          \
1454         s += UTF8SKIP(s);                             \
1455     }                                                 \
1456 } STMT_END
1457
1458 #define REXEC_FBC_SCAN(CoDe)                          \
1459 STMT_START {                                          \
1460     while (s < strend) {                              \
1461         CoDe                                          \
1462         s++;                                          \
1463     }                                                 \
1464 } STMT_END
1465
1466 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd)               \
1467 REXEC_FBC_UTF8_SCAN(                                  \
1468     if (CoNd) {                                       \
1469         if (tmp && (reginfo->intuit || regtry(reginfo, &s))) \
1470             goto got_it;                              \
1471         else                                          \
1472             tmp = doevery;                            \
1473     }                                                 \
1474     else                                              \
1475         tmp = 1;                                      \
1476 )
1477
1478 #define REXEC_FBC_CLASS_SCAN(CoNd)                    \
1479 REXEC_FBC_SCAN(                                       \
1480     if (CoNd) {                                       \
1481         if (tmp && (reginfo->intuit || regtry(reginfo, &s)))  \
1482             goto got_it;                              \
1483         else                                          \
1484             tmp = doevery;                            \
1485     }                                                 \
1486     else                                              \
1487         tmp = 1;                                      \
1488 )
1489
1490 #define REXEC_FBC_TRYIT                       \
1491 if ((reginfo->intuit || regtry(reginfo, &s))) \
1492     goto got_it
1493
1494 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd)                         \
1495     if (utf8_target) {                                         \
1496         REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8);                   \
1497     }                                                          \
1498     else {                                                     \
1499         REXEC_FBC_CLASS_SCAN(CoNd);                            \
1500     }
1501     
1502 #define DUMP_EXEC_POS(li,s,doutf8)                          \
1503     dump_exec_pos(li,s,(reginfo->strend),(reginfo->strbeg), \
1504                 startpos, doutf8)
1505
1506
1507 #define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL)                        \
1508         tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n';                  \
1509         tmp = TEST_NON_UTF8(tmp);                                              \
1510         REXEC_FBC_UTF8_SCAN(                                                   \
1511             if (tmp == ! TEST_NON_UTF8((U8) *s)) {                             \
1512                 tmp = !tmp;                                                    \
1513                 IF_SUCCESS;                                                    \
1514             }                                                                  \
1515             else {                                                             \
1516                 IF_FAIL;                                                       \
1517             }                                                                  \
1518         );                                                                     \
1519
1520 #define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL)                 \
1521         if (s == reginfo->strbeg) {                                            \
1522             tmp = '\n';                                                        \
1523         }                                                                      \
1524         else {                                                                 \
1525             U8 * const r = reghop3((U8*)s, -1, (U8*)reginfo->strbeg);          \
1526             tmp = utf8n_to_uvchr(r, (U8*) reginfo->strend - r,                 \
1527                                                        0, UTF8_ALLOW_DEFAULT); \
1528         }                                                                      \
1529         tmp = TeSt1_UtF8;                                                      \
1530         LOAD_UTF8_CHARCLASS_ALNUM();                                           \
1531         REXEC_FBC_UTF8_SCAN(                                                   \
1532             if (tmp == ! (TeSt2_UtF8)) {                                       \
1533                 tmp = !tmp;                                                    \
1534                 IF_SUCCESS;                                                    \
1535             }                                                                  \
1536             else {                                                             \
1537                 IF_FAIL;                                                       \
1538             }                                                                  \
1539         );                                                                     \
1540
1541 /* The only difference between the BOUND and NBOUND cases is that
1542  * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
1543  * NBOUND.  This is accomplished by passing it in either the if or else clause,
1544  * with the other one being empty */
1545 #define FBC_BOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1546     FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1547
1548 #define FBC_BOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1549     FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
1550
1551 #define FBC_NBOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1552     FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1553
1554 #define FBC_NBOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1555     FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
1556
1557
1558 /* Common to the BOUND and NBOUND cases.  Unfortunately the UTF8 tests need to
1559  * be passed in completely with the variable name being tested, which isn't
1560  * such a clean interface, but this is easier to read than it was before.  We
1561  * are looking for the boundary (or non-boundary between a word and non-word
1562  * character.  The utf8 and non-utf8 cases have the same logic, but the details
1563  * must be different.  Find the "wordness" of the character just prior to this
1564  * one, and compare it with the wordness of this one.  If they differ, we have
1565  * a boundary.  At the beginning of the string, pretend that the previous
1566  * character was a new-line */
1567 #define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL)        \
1568     if (utf8_target) {                                                         \
1569                 UTF8_CODE                                                      \
1570     }                                                                          \
1571     else {  /* Not utf8 */                                                     \
1572         tmp = (s != reginfo->strbeg) ? UCHARAT(s - 1) : '\n';                  \
1573         tmp = TEST_NON_UTF8(tmp);                                              \
1574         REXEC_FBC_SCAN(                                                        \
1575             if (tmp == ! TEST_NON_UTF8((U8) *s)) {                             \
1576                 tmp = !tmp;                                                    \
1577                 IF_SUCCESS;                                                    \
1578             }                                                                  \
1579             else {                                                             \
1580                 IF_FAIL;                                                       \
1581             }                                                                  \
1582         );                                                                     \
1583     }                                                                          \
1584     if ((!prog->minlen && tmp) && (reginfo->intuit || regtry(reginfo, &s)))    \
1585         goto got_it;
1586
1587 /* We know what class REx starts with.  Try to find this position... */
1588 /* if reginfo->intuit, its a dryrun */
1589 /* annoyingly all the vars in this routine have different names from their counterparts
1590    in regmatch. /grrr */
1591
1592 STATIC char *
1593 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 
1594     const char *strend, regmatch_info *reginfo)
1595 {
1596     dVAR;
1597     const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1598     char *pat_string;   /* The pattern's exactish string */
1599     char *pat_end;          /* ptr to end char of pat_string */
1600     re_fold_t folder;   /* Function for computing non-utf8 folds */
1601     const U8 *fold_array;   /* array for folding ords < 256 */
1602     STRLEN ln;
1603     STRLEN lnc;
1604     U8 c1;
1605     U8 c2;
1606     char *e;
1607     I32 tmp = 1;        /* Scratch variable? */
1608     const bool utf8_target = reginfo->is_utf8_target;
1609     UV utf8_fold_flags = 0;
1610     const bool is_utf8_pat = reginfo->is_utf8_pat;
1611     bool to_complement = FALSE; /* Invert the result?  Taking the xor of this
1612                                    with a result inverts that result, as 0^1 =
1613                                    1 and 1^1 = 0 */
1614     _char_class_number classnum;
1615
1616     RXi_GET_DECL(prog,progi);
1617
1618     PERL_ARGS_ASSERT_FIND_BYCLASS;
1619
1620     /* We know what class it must start with. */
1621     switch (OP(c)) {
1622     case ANYOF:
1623         if (utf8_target) {
1624             REXEC_FBC_UTF8_CLASS_SCAN(
1625                       reginclass(prog, c, (U8*)s, (U8*) strend, utf8_target));
1626         }
1627         else {
1628             REXEC_FBC_CLASS_SCAN(REGINCLASS(prog, c, (U8*)s));
1629         }
1630         break;
1631     case CANY:
1632         REXEC_FBC_SCAN(
1633             if (tmp && (reginfo->intuit || regtry(reginfo, &s)))
1634                 goto got_it;
1635             else
1636                 tmp = doevery;
1637         );
1638         break;
1639
1640     case EXACTFA_NO_TRIE:   /* This node only generated for non-utf8 patterns */
1641         assert(! is_utf8_pat);
1642         /* FALL THROUGH */
1643     case EXACTFA:
1644         if (is_utf8_pat || utf8_target) {
1645             utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
1646             goto do_exactf_utf8;
1647         }
1648         fold_array = PL_fold_latin1;    /* Latin1 folds are not affected by */
1649         folder = foldEQ_latin1;         /* /a, except the sharp s one which */
1650         goto do_exactf_non_utf8;        /* isn't dealt with by these */
1651
1652     case EXACTF:   /* This node only generated for non-utf8 patterns */
1653         assert(! is_utf8_pat);
1654         if (utf8_target) {
1655             utf8_fold_flags = 0;
1656             goto do_exactf_utf8;
1657         }
1658         fold_array = PL_fold;
1659         folder = foldEQ;
1660         goto do_exactf_non_utf8;
1661
1662     case EXACTFL:
1663         if (is_utf8_pat || utf8_target || IN_UTF8_CTYPE_LOCALE) {
1664             utf8_fold_flags = FOLDEQ_LOCALE;
1665             goto do_exactf_utf8;
1666         }
1667         fold_array = PL_fold_locale;
1668         folder = foldEQ_locale;
1669         goto do_exactf_non_utf8;
1670
1671     case EXACTFU_SS:
1672         if (is_utf8_pat) {
1673             utf8_fold_flags = FOLDEQ_S2_ALREADY_FOLDED;
1674         }
1675         goto do_exactf_utf8;
1676
1677     case EXACTFU:
1678         if (is_utf8_pat || utf8_target) {
1679             utf8_fold_flags = is_utf8_pat ? FOLDEQ_S2_ALREADY_FOLDED : 0;
1680             goto do_exactf_utf8;
1681         }
1682
1683         /* Any 'ss' in the pattern should have been replaced by regcomp,
1684          * so we don't have to worry here about this single special case
1685          * in the Latin1 range */
1686         fold_array = PL_fold_latin1;
1687         folder = foldEQ_latin1;
1688
1689         /* FALL THROUGH */
1690
1691     do_exactf_non_utf8: /* Neither pattern nor string are UTF8, and there
1692                            are no glitches with fold-length differences
1693                            between the target string and pattern */
1694
1695         /* The idea in the non-utf8 EXACTF* cases is to first find the
1696          * first character of the EXACTF* node and then, if necessary,
1697          * case-insensitively compare the full text of the node.  c1 is the
1698          * first character.  c2 is its fold.  This logic will not work for
1699          * Unicode semantics and the german sharp ss, which hence should
1700          * not be compiled into a node that gets here. */
1701         pat_string = STRING(c);
1702         ln  = STR_LEN(c);       /* length to match in octets/bytes */
1703
1704         /* We know that we have to match at least 'ln' bytes (which is the
1705          * same as characters, since not utf8).  If we have to match 3
1706          * characters, and there are only 2 availabe, we know without
1707          * trying that it will fail; so don't start a match past the
1708          * required minimum number from the far end */
1709         e = HOP3c(strend, -((SSize_t)ln), s);
1710
1711         if (reginfo->intuit && e < s) {
1712             e = s;                      /* Due to minlen logic of intuit() */
1713         }
1714
1715         c1 = *pat_string;
1716         c2 = fold_array[c1];
1717         if (c1 == c2) { /* If char and fold are the same */
1718             REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1719         }
1720         else {
1721             REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1722         }
1723         break;
1724
1725     do_exactf_utf8:
1726     {
1727         unsigned expansion;
1728
1729         /* If one of the operands is in utf8, we can't use the simpler folding
1730          * above, due to the fact that many different characters can have the
1731          * same fold, or portion of a fold, or different- length fold */
1732         pat_string = STRING(c);
1733         ln  = STR_LEN(c);       /* length to match in octets/bytes */
1734         pat_end = pat_string + ln;
1735         lnc = is_utf8_pat       /* length to match in characters */
1736                 ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
1737                 : ln;
1738
1739         /* We have 'lnc' characters to match in the pattern, but because of
1740          * multi-character folding, each character in the target can match
1741          * up to 3 characters (Unicode guarantees it will never exceed
1742          * this) if it is utf8-encoded; and up to 2 if not (based on the
1743          * fact that the Latin 1 folds are already determined, and the
1744          * only multi-char fold in that range is the sharp-s folding to
1745          * 'ss'.  Thus, a pattern character can match as little as 1/3 of a
1746          * string character.  Adjust lnc accordingly, rounding up, so that
1747          * if we need to match at least 4+1/3 chars, that really is 5. */
1748         expansion = (utf8_target) ? UTF8_MAX_FOLD_CHAR_EXPAND : 2;
1749         lnc = (lnc + expansion - 1) / expansion;
1750
1751         /* As in the non-UTF8 case, if we have to match 3 characters, and
1752          * only 2 are left, it's guaranteed to fail, so don't start a
1753          * match that would require us to go beyond the end of the string
1754          */
1755         e = HOP3c(strend, -((SSize_t)lnc), s);
1756
1757         if (reginfo->intuit && e < s) {
1758             e = s;                      /* Due to minlen logic of intuit() */
1759         }
1760
1761         /* XXX Note that we could recalculate e to stop the loop earlier,
1762          * as the worst case expansion above will rarely be met, and as we
1763          * go along we would usually find that e moves further to the left.
1764          * This would happen only after we reached the point in the loop
1765          * where if there were no expansion we should fail.  Unclear if
1766          * worth the expense */
1767
1768         while (s <= e) {
1769             char *my_strend= (char *)strend;
1770             if (foldEQ_utf8_flags(s, &my_strend, 0,  utf8_target,
1771                   pat_string, NULL, ln, is_utf8_pat, utf8_fold_flags)
1772                 && (reginfo->intuit || regtry(reginfo, &s)) )
1773             {
1774                 goto got_it;
1775             }
1776             s += (utf8_target) ? UTF8SKIP(s) : 1;
1777         }
1778         break;
1779     }
1780     case BOUNDL:
1781         FBC_BOUND(isWORDCHAR_LC,
1782                   isWORDCHAR_LC_uvchr(tmp),
1783                   isWORDCHAR_LC_utf8((U8*)s));
1784         break;
1785     case NBOUNDL:
1786         FBC_NBOUND(isWORDCHAR_LC,
1787                    isWORDCHAR_LC_uvchr(tmp),
1788                    isWORDCHAR_LC_utf8((U8*)s));
1789         break;
1790     case BOUND:
1791         FBC_BOUND(isWORDCHAR,
1792                   isWORDCHAR_uni(tmp),
1793                   cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
1794         break;
1795     case BOUNDA:
1796         FBC_BOUND_NOLOAD(isWORDCHAR_A,
1797                          isWORDCHAR_A(tmp),
1798                          isWORDCHAR_A((U8*)s));
1799         break;
1800     case NBOUND:
1801         FBC_NBOUND(isWORDCHAR,
1802                    isWORDCHAR_uni(tmp),
1803                    cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
1804         break;
1805     case NBOUNDA:
1806         FBC_NBOUND_NOLOAD(isWORDCHAR_A,
1807                           isWORDCHAR_A(tmp),
1808                           isWORDCHAR_A((U8*)s));
1809         break;
1810     case BOUNDU:
1811         FBC_BOUND(isWORDCHAR_L1,
1812                   isWORDCHAR_uni(tmp),
1813                   cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
1814         break;
1815     case NBOUNDU:
1816         FBC_NBOUND(isWORDCHAR_L1,
1817                    isWORDCHAR_uni(tmp),
1818                    cBOOL(swash_fetch(PL_utf8_swash_ptrs[_CC_WORDCHAR], (U8*)s, utf8_target)));
1819         break;
1820     case LNBREAK:
1821         REXEC_FBC_CSCAN(is_LNBREAK_utf8_safe(s, strend),
1822                         is_LNBREAK_latin1_safe(s, strend)
1823         );
1824         break;
1825
1826     /* The argument to all the POSIX node types is the class number to pass to
1827      * _generic_isCC() to build a mask for searching in PL_charclass[] */
1828
1829     case NPOSIXL:
1830         to_complement = 1;
1831         /* FALLTHROUGH */
1832
1833     case POSIXL:
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     reginfo->prog = rx;  /* Yes, sorry that this is confusing.  */
2520     reginfo->intuit = 0;
2521     reginfo->is_utf8_target = cBOOL(utf8_target);
2522     reginfo->is_utf8_pat = cBOOL(RX_UTF8(rx));
2523     reginfo->warned = FALSE;
2524     reginfo->strbeg  = strbeg;
2525     reginfo->sv = sv;
2526     reginfo->poscache_maxiter = 0; /* not yet started a countdown */
2527     reginfo->strend = strend;
2528     /* see how far we have to get to not match where we matched before */
2529     reginfo->till = stringarg + minend;
2530
2531     if (prog->extflags & RXf_EVAL_SEEN && SvPADTMP(sv) && !IS_PADGV(sv)) {
2532         /* SAVEFREESV, not sv_mortalcopy, as this SV must last until after
2533            S_cleanup_regmatch_info_aux has executed (registered by
2534            SAVEDESTRUCTOR_X below).  S_cleanup_regmatch_info_aux modifies
2535            magic belonging to this SV.
2536            Not newSVsv, either, as it does not COW.
2537         */
2538         reginfo->sv = newSV(0);
2539         SvSetSV_nosteal(reginfo->sv, sv);
2540         SAVEFREESV(reginfo->sv);
2541     }
2542
2543     /* reserve next 2 or 3 slots in PL_regmatch_state:
2544      * slot N+0: may currently be in use: skip it
2545      * slot N+1: use for regmatch_info_aux struct
2546      * slot N+2: use for regmatch_info_aux_eval struct if we have (?{})'s
2547      * slot N+3: ready for use by regmatch()
2548      */
2549
2550     {
2551         regmatch_state *old_regmatch_state;
2552         regmatch_slab  *old_regmatch_slab;
2553         int i, max = (prog->extflags & RXf_EVAL_SEEN) ? 2 : 1;
2554
2555         /* on first ever match, allocate first slab */
2556         if (!PL_regmatch_slab) {
2557             Newx(PL_regmatch_slab, 1, regmatch_slab);
2558             PL_regmatch_slab->prev = NULL;
2559             PL_regmatch_slab->next = NULL;
2560             PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2561         }
2562
2563         old_regmatch_state = PL_regmatch_state;
2564         old_regmatch_slab  = PL_regmatch_slab;
2565
2566         for (i=0; i <= max; i++) {
2567             if (i == 1)
2568                 reginfo->info_aux = &(PL_regmatch_state->u.info_aux);
2569             else if (i ==2)
2570                 reginfo->info_aux_eval =
2571                 reginfo->info_aux->info_aux_eval =
2572                             &(PL_regmatch_state->u.info_aux_eval);
2573
2574             if (++PL_regmatch_state >  SLAB_LAST(PL_regmatch_slab))
2575                 PL_regmatch_state = S_push_slab(aTHX);
2576         }
2577
2578         /* note initial PL_regmatch_state position; at end of match we'll
2579          * pop back to there and free any higher slabs */
2580
2581         reginfo->info_aux->old_regmatch_state = old_regmatch_state;
2582         reginfo->info_aux->old_regmatch_slab  = old_regmatch_slab;
2583         reginfo->info_aux->poscache = NULL;
2584
2585         SAVEDESTRUCTOR_X(S_cleanup_regmatch_info_aux, reginfo->info_aux);
2586
2587         if ((prog->extflags & RXf_EVAL_SEEN))
2588             S_setup_eval_state(aTHX_ reginfo);
2589         else
2590             reginfo->info_aux_eval = reginfo->info_aux->info_aux_eval = NULL;
2591     }
2592
2593     /* If there is a "must appear" string, look for it. */
2594
2595     if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
2596         /* We have to be careful. If the previous successful match
2597            was from this regex we don't want a subsequent partially
2598            successful match to clobber the old results.
2599            So when we detect this possibility we add a swap buffer
2600            to the re, and switch the buffer each match. If we fail,
2601            we switch it back; otherwise we leave it swapped.
2602         */
2603         swap = prog->offs;
2604         /* do we need a save destructor here for eval dies? */
2605         Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
2606         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
2607             "rex=0x%"UVxf" saving  offs: orig=0x%"UVxf" new=0x%"UVxf"\n",
2608             PTR2UV(prog),
2609             PTR2UV(swap),
2610             PTR2UV(prog->offs)
2611         ));
2612     }
2613
2614     /* Simplest case:  anchored match need be tried only once. */
2615     /*  [unless only anchor is BOL and multiline is set] */
2616     if (prog->intflags & (PREGf_ANCH & ~PREGf_ANCH_GPOS)) {
2617         if (s == startpos && regtry(reginfo, &s))
2618             goto got_it;
2619         else if (multiline || (prog->intflags & (PREGf_IMPLICIT | PREGf_ANCH_MBOL))) /* XXXX SBOL? */
2620         {
2621             char *end;
2622
2623             if (minlen)
2624                 dontbother = minlen - 1;
2625             end = HOP3c(strend, -dontbother, strbeg) - 1;
2626             /* for multiline we only have to try after newlines */
2627             if (prog->check_substr || prog->check_utf8) {
2628                 /* because of the goto we can not easily reuse the macros for bifurcating the
2629                    unicode/non-unicode match modes here like we do elsewhere - demerphq */
2630                 if (utf8_target) {
2631                     if (s == startpos)
2632                         goto after_try_utf8;
2633                     while (1) {
2634                         if (regtry(reginfo, &s)) {
2635                             goto got_it;
2636                         }
2637                       after_try_utf8:
2638                         if (s > end) {
2639                             goto phooey;
2640                         }
2641                         if (prog->extflags & RXf_USE_INTUIT) {
2642                             s = re_intuit_start(rx, sv, strbeg,
2643                                     s + UTF8SKIP(s), strend, flags, NULL);
2644                             if (!s) {
2645                                 goto phooey;
2646                             }
2647                         }
2648                         else {
2649                             s += UTF8SKIP(s);
2650                         }
2651                     }
2652                 } /* end search for check string in unicode */
2653                 else {
2654                     if (s == startpos) {
2655                         goto after_try_latin;
2656                     }
2657                     while (1) {
2658                         if (regtry(reginfo, &s)) {
2659                             goto got_it;
2660                         }
2661                       after_try_latin:
2662                         if (s > end) {
2663                             goto phooey;
2664                         }
2665                         if (prog->extflags & RXf_USE_INTUIT) {
2666                             s = re_intuit_start(rx, sv, strbeg,
2667                                         s + 1, strend, flags, NULL);
2668                             if (!s) {
2669                                 goto phooey;
2670                             }
2671                         }
2672                         else {
2673                             s++;
2674                         }
2675                     }
2676                 } /* end search for check string in latin*/
2677             } /* end search for check string */
2678             else { /* search for newline */
2679                 if (s > startpos) {
2680                     /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
2681                     s--;
2682                 }
2683                 /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
2684                 while (s <= end) { /* note it could be possible to match at the end of the string */
2685                     if (*s++ == '\n') { /* don't need PL_utf8skip here */
2686                         if (regtry(reginfo, &s))
2687                             goto got_it;
2688                     }
2689                 }
2690             } /* end search for newline */
2691         } /* end anchored/multiline check string search */
2692         goto phooey;
2693     } else if (prog->intflags & PREGf_ANCH_GPOS)
2694     {
2695         /* PREGf_ANCH_GPOS should never be true if PREGf_GPOS_SEEN is not true */
2696         assert(prog->intflags & PREGf_GPOS_SEEN);
2697         /* For anchored \G, the only position it can match from is
2698          * (ganch-gofs); we already set startpos to this above; if intuit
2699          * moved us on from there, we can't possibly succeed */
2700         assert(startpos == reginfo->ganch - prog->gofs);
2701         if (s == startpos && regtry(reginfo, &s))
2702             goto got_it;
2703         goto phooey;
2704     }
2705
2706     /* Messy cases:  unanchored match. */
2707     if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2708         /* we have /x+whatever/ */
2709         /* it must be a one character string (XXXX Except is_utf8_pat?) */
2710         char ch;
2711 #ifdef DEBUGGING
2712         int did_match = 0;
2713 #endif
2714         if (utf8_target) {
2715             if (! prog->anchored_utf8) {
2716                 to_utf8_substr(prog);
2717             }
2718             ch = SvPVX_const(prog->anchored_utf8)[0];
2719             REXEC_FBC_SCAN(
2720                 if (*s == ch) {
2721                     DEBUG_EXECUTE_r( did_match = 1 );
2722                     if (regtry(reginfo, &s)) goto got_it;
2723                     s += UTF8SKIP(s);
2724                     while (s < strend && *s == ch)
2725                         s += UTF8SKIP(s);
2726                 }
2727             );
2728
2729         }
2730         else {
2731             if (! prog->anchored_substr) {
2732                 if (! to_byte_substr(prog)) {
2733                     NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2734                 }
2735             }
2736             ch = SvPVX_const(prog->anchored_substr)[0];
2737             REXEC_FBC_SCAN(
2738                 if (*s == ch) {
2739                     DEBUG_EXECUTE_r( did_match = 1 );
2740                     if (regtry(reginfo, &s)) goto got_it;
2741                     s++;
2742                     while (s < strend && *s == ch)
2743                         s++;
2744                 }
2745             );
2746         }
2747         DEBUG_EXECUTE_r(if (!did_match)
2748                 PerlIO_printf(Perl_debug_log,
2749                                   "Did not find anchored character...\n")
2750                );
2751     }
2752     else if (prog->anchored_substr != NULL
2753               || prog->anchored_utf8 != NULL
2754               || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2755                   && prog->float_max_offset < strend - s)) {
2756         SV *must;
2757         SSize_t back_max;
2758         SSize_t back_min;
2759         char *last;
2760         char *last1;            /* Last position checked before */
2761 #ifdef DEBUGGING
2762         int did_match = 0;
2763 #endif
2764         if (prog->anchored_substr || prog->anchored_utf8) {
2765             if (utf8_target) {
2766                 if (! prog->anchored_utf8) {
2767                     to_utf8_substr(prog);
2768                 }
2769                 must = prog->anchored_utf8;
2770             }
2771             else {
2772                 if (! prog->anchored_substr) {
2773                     if (! to_byte_substr(prog)) {
2774                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2775                     }
2776                 }
2777                 must = prog->anchored_substr;
2778             }
2779             back_max = back_min = prog->anchored_offset;
2780         } else {
2781             if (utf8_target) {
2782                 if (! prog->float_utf8) {
2783                     to_utf8_substr(prog);
2784                 }
2785                 must = prog->float_utf8;
2786             }
2787             else {
2788                 if (! prog->float_substr) {
2789                     if (! to_byte_substr(prog)) {
2790                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2791                     }
2792                 }
2793                 must = prog->float_substr;
2794             }
2795             back_max = prog->float_max_offset;
2796             back_min = prog->float_min_offset;
2797         }
2798             
2799         if (back_min<0) {
2800             last = strend;
2801         } else {
2802             last = HOP3c(strend,        /* Cannot start after this */
2803                   -(SSize_t)(CHR_SVLEN(must)
2804                          - (SvTAIL(must) != 0) + back_min), strbeg);
2805         }
2806         if (s > reginfo->strbeg)
2807             last1 = HOPc(s, -1);
2808         else
2809             last1 = s - 1;      /* bogus */
2810
2811         /* XXXX check_substr already used to find "s", can optimize if
2812            check_substr==must. */
2813         dontbother = 0;
2814         strend = HOPc(strend, -dontbother);
2815         while ( (s <= last) &&
2816                 (s = fbm_instr((unsigned char*)HOP4c(s, back_min, strbeg,  strend),
2817                                   (unsigned char*)strend, must,
2818                                   multiline ? FBMrf_MULTILINE : 0)) ) {
2819             DEBUG_EXECUTE_r( did_match = 1 );
2820             if (HOPc(s, -back_max) > last1) {
2821                 last1 = HOPc(s, -back_min);
2822                 s = HOPc(s, -back_max);
2823             }
2824             else {
2825                 char * const t = (last1 >= reginfo->strbeg)
2826                                     ? HOPc(last1, 1) : last1 + 1;
2827
2828                 last1 = HOPc(s, -back_min);
2829                 s = t;
2830             }
2831             if (utf8_target) {
2832                 while (s <= last1) {
2833                     if (regtry(reginfo, &s))
2834                         goto got_it;
2835                     if (s >= last1) {
2836                         s++; /* to break out of outer loop */
2837                         break;
2838                     }
2839                     s += UTF8SKIP(s);
2840                 }
2841             }
2842             else {
2843                 while (s <= last1) {
2844                     if (regtry(reginfo, &s))
2845                         goto got_it;
2846                     s++;
2847                 }
2848             }
2849         }
2850         DEBUG_EXECUTE_r(if (!did_match) {
2851             RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
2852                 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2853             PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2854                               ((must == prog->anchored_substr || must == prog->anchored_utf8)
2855                                ? "anchored" : "floating"),
2856                 quoted, RE_SV_TAIL(must));
2857         });                 
2858         goto phooey;
2859     }
2860     else if ( (c = progi->regstclass) ) {
2861         if (minlen) {
2862             const OPCODE op = OP(progi->regstclass);
2863             /* don't bother with what can't match */
2864             if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2865                 strend = HOPc(strend, -(minlen - 1));
2866         }
2867         DEBUG_EXECUTE_r({
2868             SV * const prop = sv_newmortal();
2869             regprop(prog, prop, c, reginfo);
2870             {
2871                 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
2872                     s,strend-s,60);
2873                 PerlIO_printf(Perl_debug_log,
2874                     "Matching stclass %.*s against %s (%d bytes)\n",
2875                     (int)SvCUR(prop), SvPVX_const(prop),
2876                      quoted, (int)(strend - s));
2877             }
2878         });
2879         if (find_byclass(prog, c, s, strend, reginfo))
2880             goto got_it;
2881         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2882     }
2883     else {
2884         dontbother = 0;
2885         if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2886             /* Trim the end. */
2887             char *last= NULL;
2888             SV* float_real;
2889             STRLEN len;
2890             const char *little;
2891
2892             if (utf8_target) {
2893                 if (! prog->float_utf8) {
2894                     to_utf8_substr(prog);
2895                 }
2896                 float_real = prog->float_utf8;
2897             }
2898             else {
2899                 if (! prog->float_substr) {
2900                     if (! to_byte_substr(prog)) {
2901                         NON_UTF8_TARGET_BUT_UTF8_REQUIRED(phooey);
2902                     }
2903                 }
2904                 float_real = prog->float_substr;
2905             }
2906
2907             little = SvPV_const(float_real, len);
2908             if (SvTAIL(float_real)) {
2909                     /* This means that float_real contains an artificial \n on
2910                      * the end due to the presence of something like this:
2911                      * /foo$/ where we can match both "foo" and "foo\n" at the
2912                      * end of the string.  So we have to compare the end of the
2913                      * string first against the float_real without the \n and
2914                      * then against the full float_real with the string.  We
2915                      * have to watch out for cases where the string might be
2916                      * smaller than the float_real or the float_real without
2917                      * the \n. */
2918                     char *checkpos= strend - len;
2919                     DEBUG_OPTIMISE_r(
2920                         PerlIO_printf(Perl_debug_log,
2921                             "%sChecking for float_real.%s\n",
2922                             PL_colors[4], PL_colors[5]));
2923                     if (checkpos + 1 < strbeg) {
2924                         /* can't match, even if we remove the trailing \n
2925                          * string is too short to match */
2926                         DEBUG_EXECUTE_r(
2927                             PerlIO_printf(Perl_debug_log,
2928                                 "%sString shorter than required trailing substring, cannot match.%s\n",
2929                                 PL_colors[4], PL_colors[5]));
2930                         goto phooey;
2931                     } else if (memEQ(checkpos + 1, little, len - 1)) {
2932                         /* can match, the end of the string matches without the
2933                          * "\n" */
2934                         last = checkpos + 1;
2935                     } else if (checkpos < strbeg) {
2936                         /* cant match, string is too short when the "\n" is
2937                          * included */
2938                         DEBUG_EXECUTE_r(
2939                             PerlIO_printf(Perl_debug_log,
2940                                 "%sString does not contain required trailing substring, cannot match.%s\n",
2941                                 PL_colors[4], PL_colors[5]));
2942                         goto phooey;
2943                     } else if (!multiline) {
2944                         /* non multiline match, so compare with the "\n" at the
2945                          * end of the string */
2946                         if (memEQ(checkpos, little, len)) {
2947                             last= checkpos;
2948                         } else {
2949                             DEBUG_EXECUTE_r(
2950                                 PerlIO_printf(Perl_debug_log,
2951                                     "%sString does not contain required trailing substring, cannot match.%s\n",
2952                                     PL_colors[4], PL_colors[5]));
2953                             goto phooey;
2954                         }
2955                     } else {
2956                         /* multiline match, so we have to search for a place
2957                          * where the full string is located */
2958                         goto find_last;
2959                     }
2960             } else {
2961                   find_last:
2962                     if (len)
2963                         last = rninstr(s, strend, little, little + len);
2964                     else
2965                         last = strend;  /* matching "$" */
2966             }
2967             if (!last) {
2968                 /* at one point this block contained a comment which was
2969                  * probably incorrect, which said that this was a "should not
2970                  * happen" case.  Even if it was true when it was written I am
2971                  * pretty sure it is not anymore, so I have removed the comment
2972                  * and replaced it with this one. Yves */
2973                 DEBUG_EXECUTE_r(
2974                     PerlIO_printf(Perl_debug_log,
2975                         "String does not contain required substring, cannot match.\n"
2976                     ));
2977                 goto phooey;
2978             }
2979             dontbother = strend - last + prog->float_min_offset;
2980         }
2981         if (minlen && (dontbother < minlen))
2982             dontbother = minlen - 1;
2983         strend -= dontbother;              /* this one's always in bytes! */
2984         /* We don't know much -- general case. */
2985         if (utf8_target) {
2986             for (;;) {
2987                 if (regtry(reginfo, &s))
2988                     goto got_it;
2989                 if (s >= strend)
2990                     break;
2991                 s += UTF8SKIP(s);
2992             };
2993         }
2994         else {
2995             do {
2996                 if (regtry(reginfo, &s))
2997                     goto got_it;
2998             } while (s++ < strend);
2999         }
3000     }
3001
3002     /* Failure. */
3003     goto phooey;
3004
3005 got_it:
3006     /* s/// doesn't like it if $& is earlier than where we asked it to
3007      * start searching (which can happen on something like /.\G/) */
3008     if (       (flags & REXEC_FAIL_ON_UNDERFLOW)
3009             && (prog->offs[0].start < stringarg - strbeg))
3010     {
3011         /* this should only be possible under \G */
3012         assert(prog->intflags & PREGf_GPOS_SEEN);
3013         DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
3014             "matched, but failing for REXEC_FAIL_ON_UNDERFLOW\n"));
3015         goto phooey;
3016     }
3017
3018     DEBUG_BUFFERS_r(
3019         if (swap)
3020             PerlIO_printf(Perl_debug_log,
3021                 "rex=0x%"UVxf" freeing offs: 0x%"UVxf"\n",
3022                 PTR2UV(prog),
3023                 PTR2UV(swap)
3024             );
3025     );
3026     Safefree(swap);
3027
3028     /* clean up; this will trigger destructors that will free all slabs
3029      * above the current one, and cleanup the regmatch_info_aux
3030      * and regmatch_info_aux_eval sructs */
3031
3032     LEAVE_SCOPE(oldsave);
3033
3034     if (RXp_PAREN_NAMES(prog)) 
3035         (void)hv_iterinit(RXp_PAREN_NAMES(prog));
3036
3037     RX_MATCH_UTF8_set(rx, utf8_target);
3038
3039     /* make sure $`, $&, $', and $digit will work later */
3040     if ( !(flags & REXEC_NOT_FIRST) )
3041         S_reg_set_capture_string(aTHX_ rx,
3042                                     strbeg, reginfo->strend,
3043                                     sv, flags, utf8_target);
3044
3045     return 1;
3046
3047 phooey:
3048     DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
3049                           PL_colors[4], PL_colors[5]));
3050
3051     /* clean up; this will trigger destructors that will free all slabs
3052      * above the current one, and cleanup the regmatch_info_aux
3053      * and regmatch_info_aux_eval sructs */
3054
3055     LEAVE_SCOPE(oldsave);
3056
3057     if (swap) {
3058         /* we failed :-( roll it back */
3059         DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
3060             "rex=0x%"UVxf" rolling back offs: freeing=0x%"UVxf" restoring=0x%"UVxf"\n",
3061             PTR2UV(prog),
3062             PTR2UV(prog->offs),
3063             PTR2UV(swap)
3064         ));
3065         Safefree(prog->offs);
3066         prog->offs = swap;
3067     }
3068     return 0;
3069 }
3070
3071
3072 /* Set which rex is pointed to by PL_reg_curpm, handling ref counting.
3073  * Do inc before dec, in case old and new rex are the same */
3074 #define SET_reg_curpm(Re2)                          \
3075     if (reginfo->info_aux_eval) {                   \
3076         (void)ReREFCNT_inc(Re2);                    \
3077         ReREFCNT_dec(PM_GETRE(PL_reg_curpm));       \
3078         PM_SETRE((PL_reg_curpm), (Re2));            \
3079     }
3080
3081
3082 /*
3083  - regtry - try match at specific point
3084  */
3085 STATIC I32                      /* 0 failure, 1 success */
3086 S_regtry(pTHX_ regmatch_info *reginfo, char **startposp)
3087 {
3088     dVAR;
3089     CHECKPOINT lastcp;
3090     REGEXP *const rx = reginfo->prog;
3091     regexp *const prog = ReANY(rx);
3092     SSize_t result;
3093     RXi_GET_DECL(prog,progi);
3094     GET_RE_DEBUG_FLAGS_DECL;
3095
3096     PERL_ARGS_ASSERT_REGTRY;
3097
3098     reginfo->cutpoint=NULL;
3099
3100     prog->offs[0].start = *startposp - reginfo->strbeg;
3101     prog->lastparen = 0;
3102     prog->lastcloseparen = 0;
3103
3104     /* XXXX What this code is doing here?!!!  There should be no need
3105        to do this again and again, prog->lastparen should take care of
3106        this!  --ilya*/
3107
3108     /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
3109      * Actually, the code in regcppop() (which Ilya may be meaning by
3110      * prog->lastparen), is not needed at all by the test suite
3111      * (op/regexp, op/pat, op/split), but that code is needed otherwise
3112      * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
3113      * Meanwhile, this code *is* needed for the
3114      * above-mentioned test suite tests to succeed.  The common theme
3115      * on those tests seems to be returning null fields from matches.
3116      * --jhi updated by dapm */
3117 #if 1
3118     if (prog->nparens) {
3119         regexp_paren_pair *pp = prog->offs;
3120         I32 i;
3121         for (i = prog->nparens; i > (I32)prog->lastparen; i--) {
3122             ++pp;
3123             pp->start = -1;
3124             pp->end = -1;
3125         }
3126     }
3127 #endif
3128     REGCP_SET(lastcp);
3129     result = regmatch(reginfo, *startposp, progi->program + 1);
3130     if (result != -1) {
3131         prog->offs[0].end = result;
3132         return 1;
3133     }
3134     if (reginfo->cutpoint)
3135         *startposp= reginfo->cutpoint;
3136     REGCP_UNWIND(lastcp);
3137     return 0;
3138 }
3139
3140
3141 #define sayYES goto yes
3142 #define sayNO goto no
3143 #define sayNO_SILENT goto no_silent
3144
3145 /* we dont use STMT_START/END here because it leads to 
3146    "unreachable code" warnings, which are bogus, but distracting. */
3147 #define CACHEsayNO \
3148     if (ST.cache_mask) \
3149        reginfo->info_aux->poscache[ST.cache_offset] |= ST.cache_mask; \
3150     sayNO
3151
3152 /* this is used to determine how far from the left messages like
3153    'failed...' are printed. It should be set such that messages 
3154    are inline with the regop output that created them.
3155 */
3156 #define REPORT_CODE_OFF 32
3157
3158
3159 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
3160 #define CHRTEST_VOID   -1000 /* the c1/c2 "next char" test should be skipped */
3161 #define CHRTEST_NOT_A_CP_1 -999
3162 #define CHRTEST_NOT_A_CP_2 -998
3163
3164 /* grab a new slab and return the first slot in it */
3165
3166 STATIC regmatch_state *
3167 S_push_slab(pTHX)
3168 {
3169 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3170     dMY_CXT;
3171 #endif
3172     regmatch_slab *s = PL_regmatch_slab->next;
3173     if (!s) {
3174         Newx(s, 1, regmatch_slab);
3175         s->prev = PL_regmatch_slab;
3176         s->next = NULL;
3177         PL_regmatch_slab->next = s;
3178     }
3179     PL_regmatch_slab = s;
3180     return SLAB_FIRST(s);
3181 }
3182
3183
3184 /* push a new state then goto it */
3185
3186 #define PUSH_STATE_GOTO(state, node, input) \
3187     pushinput = input; \
3188     scan = node; \
3189     st->resume_state = state; \
3190     goto push_state;
3191
3192 /* push a new state with success backtracking, then goto it */
3193
3194 #define PUSH_YES_STATE_GOTO(state, node, input) \
3195     pushinput = input; \
3196     scan = node; \
3197     st->resume_state = state; \
3198     goto push_yes_state;
3199
3200
3201
3202
3203 /*
3204
3205 regmatch() - main matching routine
3206
3207 This is basically one big switch statement in a loop. We execute an op,
3208 set 'next' to point the next op, and continue. If we come to a point which
3209 we may need to backtrack to on failure such as (A|B|C), we push a
3210 backtrack state onto the backtrack stack. On failure, we pop the top
3211 state, and re-enter the loop at the state indicated. If there are no more
3212 states to pop, we return failure.
3213
3214 Sometimes we also need to backtrack on success; for example /A+/, where
3215 after successfully matching one A, we need to go back and try to
3216 match another one; similarly for lookahead assertions: if the assertion
3217 completes successfully, we backtrack to the state just before the assertion
3218 and then carry on.  In these cases, the pushed state is marked as
3219 'backtrack on success too'. This marking is in fact done by a chain of
3220 pointers, each pointing to the previous 'yes' state. On success, we pop to
3221 the nearest yes state, discarding any intermediate failure-only states.
3222 Sometimes a yes state is pushed just to force some cleanup code to be
3223 called at the end of a successful match or submatch; e.g. (??{$re}) uses
3224 it to free the inner regex.
3225
3226 Note that failure backtracking rewinds the cursor position, while
3227 success backtracking leaves it alone.
3228
3229 A pattern is complete when the END op is executed, while a subpattern
3230 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
3231 ops trigger the "pop to last yes state if any, otherwise return true"
3232 behaviour.
3233
3234 A common convention in this function is to use A and B to refer to the two
3235 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
3236 the subpattern to be matched possibly multiple times, while B is the entire
3237 rest of the pattern. Variable and state names reflect this convention.
3238
3239 The states in the main switch are the union of ops and failure/success of
3240 substates associated with with that op.  For example, IFMATCH is the op
3241 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
3242 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
3243 successfully matched A and IFMATCH_A_fail is a state saying that we have
3244 just failed to match A. Resume states always come in pairs. The backtrack
3245 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
3246 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
3247 on success or failure.
3248
3249 The struct that holds a backtracking state is actually a big union, with
3250 one variant for each major type of op. The variable st points to the
3251 top-most backtrack struct. To make the code clearer, within each
3252 block of code we #define ST to alias the relevant union.
3253
3254 Here's a concrete example of a (vastly oversimplified) IFMATCH
3255 implementation:
3256
3257     switch (state) {
3258     ....
3259
3260 #define ST st->u.ifmatch
3261
3262     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3263         ST.foo = ...; // some state we wish to save
3264         ...
3265         // push a yes backtrack state with a resume value of
3266         // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
3267         // first node of A:
3268         PUSH_YES_STATE_GOTO(IFMATCH_A, A, newinput);
3269         // NOTREACHED
3270
3271     case IFMATCH_A: // we have successfully executed A; now continue with B
3272         next = B;
3273         bar = ST.foo; // do something with the preserved value
3274         break;
3275
3276     case IFMATCH_A_fail: // A failed, so the assertion failed
3277         ...;   // do some housekeeping, then ...
3278         sayNO; // propagate the failure
3279
3280 #undef ST
3281
3282     ...
3283     }
3284
3285 For any old-timers reading this who are familiar with the old recursive
3286 approach, the code above is equivalent to:
3287
3288     case IFMATCH: // we are executing the IFMATCH op, (?=A)B
3289     {
3290         int foo = ...
3291         ...
3292         if (regmatch(A)) {
3293             next = B;
3294             bar = foo;
3295             break;
3296         }
3297         ...;   // do some housekeeping, then ...
3298         sayNO; // propagate the failure
3299     }
3300
3301 The topmost backtrack state, pointed to by st, is usually free. If you
3302 want to claim it, populate any ST.foo fields in it with values you wish to
3303 save, then do one of
3304
3305         PUSH_STATE_GOTO(resume_state, node, newinput);
3306         PUSH_YES_STATE_GOTO(resume_state, node, newinput);
3307
3308 which sets that backtrack state's resume value to 'resume_state', pushes a
3309 new free entry to the top of the backtrack stack, then goes to 'node'.
3310 On backtracking, the free slot is popped, and the saved state becomes the
3311 new free state. An ST.foo field in this new top state can be temporarily
3312 accessed to retrieve values, but once the main loop is re-entered, it
3313 becomes available for reuse.
3314
3315 Note that the depth of the backtrack stack constantly increases during the
3316 left-to-right execution of the pattern, rather than going up and down with
3317 the pattern nesting. For example the stack is at its maximum at Z at the
3318 end of the pattern, rather than at X in the following:
3319
3320     /(((X)+)+)+....(Y)+....Z/
3321
3322 The only exceptions to this are lookahead/behind assertions and the cut,
3323 (?>A), which pop all the backtrack states associated with A before
3324 continuing.
3325  
3326 Backtrack state structs are allocated in slabs of about 4K in size.
3327 PL_regmatch_state and st always point to the currently active state,
3328 and PL_regmatch_slab points to the slab currently containing
3329 PL_regmatch_state.  The first time regmatch() is called, the first slab is
3330 allocated, and is never freed until interpreter destruction. When the slab
3331 is full, a new one is allocated and chained to the end. At exit from
3332 regmatch(), slabs allocated since entry are freed.
3333
3334 */
3335  
3336
3337 #define DEBUG_STATE_pp(pp)                                  \
3338     DEBUG_STATE_r({                                         \
3339         DUMP_EXEC_POS(locinput, scan, utf8_target);         \
3340         PerlIO_printf(Perl_debug_log,                       \
3341             "    %*s"pp" %s%s%s%s%s\n",                     \
3342             depth*2, "",                                    \
3343             PL_reg_name[st->resume_state],                  \
3344             ((st==yes_state||st==mark_state) ? "[" : ""),   \
3345             ((st==yes_state) ? "Y" : ""),                   \
3346             ((st==mark_state) ? "M" : ""),                  \
3347             ((st==yes_state||st==mark_state) ? "]" : "")    \
3348         );                                                  \
3349     });
3350
3351
3352 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
3353
3354 #ifdef DEBUGGING
3355
3356 STATIC void
3357 S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
3358     const char *start, const char *end, const char *blurb)
3359 {
3360     const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
3361
3362     PERL_ARGS_ASSERT_DEBUG_START_MATCH;
3363
3364     if (!PL_colorset)   
3365             reginitcolors();    
3366     {
3367         RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0), 
3368             RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);   
3369         
3370         RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
3371             start, end - start, 60); 
3372         
3373         PerlIO_printf(Perl_debug_log, 
3374             "%s%s REx%s %s against %s\n", 
3375                        PL_colors[4], blurb, PL_colors[5], s0, s1); 
3376         
3377         if (utf8_target||utf8_pat)
3378             PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
3379                 utf8_pat ? "pattern" : "",
3380                 utf8_pat && utf8_target ? " and " : "",
3381                 utf8_target ? "string" : ""
3382             ); 
3383     }
3384 }
3385
3386 STATIC void
3387 S_dump_exec_pos(pTHX_ const char *locinput, 
3388                       const regnode *scan, 
3389                       const char *loc_regeol, 
3390                       const char *loc_bostr, 
3391                       const char *loc_reg_starttry,
3392                       const bool utf8_target)
3393 {
3394     const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
3395     const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
3396     int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
3397     /* The part of the string before starttry has one color
3398        (pref0_len chars), between starttry and current
3399        position another one (pref_len - pref0_len chars),
3400        after the current position the third one.
3401        We assume that pref0_len <= pref_len, otherwise we
3402        decrease pref0_len.  */
3403     int pref_len = (locinput - loc_bostr) > (5 + taill) - l
3404         ? (5 + taill) - l : locinput - loc_bostr;
3405     int pref0_len;
3406
3407     PERL_ARGS_ASSERT_DUMP_EXEC_POS;
3408
3409     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
3410         pref_len++;
3411     pref0_len = pref_len  - (locinput - loc_reg_starttry);
3412     if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
3413         l = ( loc_regeol - locinput > (5 + taill) - pref_len
3414               ? (5 + taill) - pref_len : loc_regeol - locinput);
3415     while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
3416         l--;
3417     if (pref0_len < 0)
3418         pref0_len = 0;
3419     if (pref0_len > pref_len)
3420         pref0_len = pref_len;
3421     {
3422         const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
3423
3424         RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
3425             (locinput - pref_len),pref0_len, 60, 4, 5);
3426         
3427         RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3428                     (locinput - pref_len + pref0_len),
3429                     pref_len - pref0_len, 60, 2, 3);
3430         
3431         RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
3432                     locinput, loc_regeol - locinput, 10, 0, 1);
3433
3434         const STRLEN tlen=len0+len1+len2;
3435         PerlIO_printf(Perl_debug_log,
3436                     "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
3437                     (IV)(locinput - loc_bostr),
3438                     len0, s0,
3439                     len1, s1,
3440                     (docolor ? "" : "> <"),
3441                     len2, s2,
3442                     (int)(tlen > 19 ? 0 :  19 - tlen),
3443                     "");
3444     }
3445 }
3446
3447 #endif
3448
3449 /* reg_check_named_buff_matched()
3450  * Checks to see if a named buffer has matched. The data array of 
3451  * buffer numbers corresponding to the buffer is expected to reside
3452  * in the regexp->data->data array in the slot stored in the ARG() of
3453  * node involved. Note that this routine doesn't actually care about the
3454  * name, that information is not preserved from compilation to execution.
3455  * Returns the index of the leftmost defined buffer with the given name
3456  * or 0 if non of the buffers matched.
3457  */
3458 STATIC I32
3459 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
3460 {
3461     I32 n;
3462     RXi_GET_DECL(rex,rexi);
3463     SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
3464     I32 *nums=(I32*)SvPVX(sv_dat);
3465
3466     PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3467
3468     for ( n=0; n<SvIVX(sv_dat); n++ ) {
3469         if ((I32)rex->lastparen >= nums[n] &&
3470             rex->offs[nums[n]].end != -1)
3471         {
3472             return nums[n];
3473         }
3474     }
3475     return 0;
3476 }
3477
3478
3479 static bool
3480 S_setup_EXACTISH_ST_c1_c2(pTHX_ const regnode * const text_node, int *c1p,
3481         U8* c1_utf8, int *c2p, U8* c2_utf8, regmatch_info *reginfo)
3482 {
3483     /* This function determines if there are one or two characters that match
3484      * the first character of the passed-in EXACTish node <text_node>, and if
3485      * so, returns them in the passed-in pointers.
3486      *
3487      * If it determines that no possible character in the target string can
3488      * match, it returns FALSE; otherwise TRUE.  (The FALSE situation occurs if
3489      * the first character in <text_node> requires UTF-8 to represent, and the
3490      * target string isn't in UTF-8.)
3491      *
3492      * If there are more than two characters that could match the beginning of
3493      * <text_node>, or if more context is required to determine a match or not,
3494      * it sets both *<c1p> and *<c2p> to CHRTEST_VOID.
3495      *
3496      * The motiviation behind this function is to allow the caller to set up
3497      * tight loops for matching.  If <text_node> is of type EXACT, there is
3498      * only one possible character that can match its first character, and so
3499      * the situation is quite simple.  But things get much more complicated if
3500      * folding is involved.  It may be that the first character of an EXACTFish
3501      * node doesn't participate in any possible fold, e.g., punctuation, so it
3502      * can be matched only by itself.  The vast majority of characters that are
3503      * in folds match just two things, their lower and upper-case equivalents.
3504      * But not all are like that; some have multiple possible matches, or match
3505      * sequences of more than one character.  This function sorts all that out.
3506      *
3507      * Consider the patterns A*B or A*?B where A and B are arbitrary.  In a
3508      * loop of trying to match A*, we know we can't exit where the thing
3509      * following it isn't a B.  And something can't be a B unless it is the
3510      * beginning of B.  By putting a quick test for that beginning in a tight
3511      * loop, we can rule out things that can't possibly be B without having to
3512      * break out of the loop, thus avoiding work.  Similarly, if A is a single
3513      * character, we can make a tight loop matching A*, using the outputs of
3514      * this function.
3515      *
3516      * If the target string to match isn't in UTF-8, and there aren't
3517      * complications which require CHRTEST_VOID, *<c1p> and *<c2p> are set to
3518      * the one or two possible octets (which are characters in this situation)
3519      * that can match.  In all cases, if there is only one character that can
3520      * match, *<c1p> and *<c2p> will be identical.
3521      *
3522      * If the target string is in UTF-8, the buffers pointed to by <c1_utf8>
3523      * and <c2_utf8> will contain the one or two UTF-8 sequences of bytes that
3524      * can match the beginning of <text_node>.  They should be declared with at
3525      * least length UTF8_MAXBYTES+1.  (If the target string isn't in UTF-8, it is
3526      * undefined what these contain.)  If one or both of the buffers are
3527      * invariant under UTF-8, *<c1p>, and *<c2p> will also be set to the
3528      * corresponding invariant.  If variant, the corresponding *<c1p> and/or
3529      * *<c2p> will be set to a negative number(s) that shouldn't match any code
3530      * point (unless inappropriately coerced to unsigned).   *<c1p> will equal
3531      * *<c2p> if and only if <c1_utf8> and <c2_utf8> are the same. */
3532
3533     const bool utf8_target = reginfo->is_utf8_target;
3534
3535     UV c1 = CHRTEST_NOT_A_CP_1;
3536     UV c2 = CHRTEST_NOT_A_CP_2;
3537     bool use_chrtest_void = FALSE;
3538     const bool is_utf8_pat = reginfo->is_utf8_pat;
3539
3540     /* Used when we have both utf8 input and utf8 output, to avoid converting
3541      * to/from code points */
3542     bool utf8_has_been_setup = FALSE;
3543
3544     dVAR;
3545
3546     U8 *pat = (U8*)STRING(text_node);
3547     U8 folded[UTF8_MAX_FOLD_CHAR_EXPAND * UTF8_MAXBYTES_CASE + 1] = { '\0' };
3548
3549     if (OP(text_node) == EXACT) {
3550
3551         /* In an exact node, only one thing can be matched, that first
3552          * character.  If both the pat and the target are UTF-8, we can just
3553          * copy the input to the output, avoiding finding the code point of
3554          * that character */
3555         if (!is_utf8_pat) {
3556             c2 = c1 = *pat;
3557         }
3558         else if (utf8_target) {
3559             Copy(pat, c1_utf8, UTF8SKIP(pat), U8);
3560             Copy(pat, c2_utf8, UTF8SKIP(pat), U8);
3561             utf8_has_been_setup = TRUE;
3562         }
3563         else {
3564             c2 = c1 = valid_utf8_to_uvchr(pat, NULL);
3565         }
3566     }
3567     else { /* an EXACTFish node */
3568         U8 *pat_end = pat + STR_LEN(text_node);
3569
3570         /* An EXACTFL node has at least some characters unfolded, because what
3571          * they match is not known until now.  So, now is the time to fold
3572          * the first few of them, as many as are needed to determine 'c1' and
3573          * 'c2' later in the routine.  If the pattern isn't UTF-8, we only need
3574          * to fold if in a UTF-8 locale, and then only the Sharp S; everything
3575          * else is 1-1 and isn't assumed to be folded.  In a UTF-8 pattern, we
3576          * need to fold as many characters as a single character can fold to,
3577          * so that later we can check if the first ones are such a multi-char
3578          * fold.  But, in such a pattern only locale-problematic characters
3579          * aren't folded, so we can skip this completely if the first character
3580          * in the node isn't one of the tricky ones */
3581         if (OP(text_node) == EXACTFL) {
3582
3583             if (! is_utf8_pat) {
3584                 if (IN_UTF8_CTYPE_LOCALE && *pat == LATIN_SMALL_LETTER_SHARP_S)
3585                 {
3586                     folded[0] = folded[1] = 's';
3587                     pat = folded;
3588                     pat_end = folded + 2;
3589                 }
3590             }
3591             else if (is_PROBLEMATIC_LOCALE_FOLDEDS_START_utf8(pat)) {
3592                 U8 *s = pat;
3593                 U8 *d = folded;
3594                 int i;
3595
3596                 for (i = 0; i < UTF8_MAX_FOLD_CHAR_EXPAND && s < pat_end; i++) {
3597                     if (isASCII(*s)) {
3598                         *(d++) = (U8) toFOLD_LC(*s);
3599                         s++;
3600                     }
3601                     else {
3602                         STRLEN len;
3603                         _to_utf8_fold_flags(s,
3604                                             d,
3605                                             &len,
3606                                             FOLD_FLAGS_FULL | FOLD_FLAGS_LOCALE);
3607                         d += len;
3608                         s += UTF8SKIP(s);
3609                     }
3610                 }
3611
3612                 pat = folded;
3613                 pat_end = d;
3614             }
3615         }
3616
3617         if ((is_utf8_pat && is_MULTI_CHAR_FOLD_utf8(pat))
3618              || (!is_utf8_pat && is_MULTI_CHAR_FOLD_latin1(pat)))
3619         {
3620             /* Multi-character folds require more context to sort out.  Also
3621              * PL_utf8_foldclosures used below doesn't handle them, so have to
3622              * be handled outside this routine */
3623             use_chrtest_void = TRUE;
3624         }
3625         else { /* an EXACTFish node which doesn't begin with a multi-char fold */
3626             c1 = is_utf8_pat ? valid_utf8_to_uvchr(pat, NULL) : *pat;
3627             if (c1 > 256) {
3628                 /* Load the folds hash, if not already done */
3629                 SV** listp;
3630                 if (! PL_utf8_foldclosures) {
3631                     if (! PL_utf8_tofold) {
3632                         U8 dummy[UTF8_MAXBYTES_CASE+1];
3633
3634                         /* Force loading this by folding an above-Latin1 char */
3635                         to_utf8_fold((U8*) HYPHEN_UTF8, dummy, NULL);
3636                         assert(PL_utf8_tofold); /* Verify that worked */
3637                     }
3638                     PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
3639                 }
3640
3641                 /* The fold closures data structure is a hash with the keys
3642                  * being the UTF-8 of every character that is folded to, like
3643                  * 'k', and the values each an array of all code points that
3644                  * fold to its key.  e.g. [ 'k', 'K', KELVIN_SIGN ].
3645                  * Multi-character folds are not included */
3646                 if ((! (listp = hv_fetch(PL_utf8_foldclosures,
3647                                         (char *) pat,
3648                                         UTF8SKIP(pat),
3649                                         FALSE))))
3650                 {
3651                     /* Not found in the hash, therefore there are no folds
3652                     * containing it, so there is only a single character that
3653                     * could match */
3654                     c2 = c1;
3655                 }
3656                 else {  /* Does participate in folds */
3657                     AV* list = (AV*) *listp;
3658                     if (av_tindex(list) != 1) {
3659
3660                         /* If there aren't exactly two folds to this, it is
3661                          * outside the scope of this function */
3662                         use_chrtest_void = TRUE;
3663                     }
3664                     else {  /* There are two.  Get them */
3665                         SV** c_p = av_fetch(list, 0, FALSE);
3666                         if (c_p == NULL) {
3667                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
3668                         }
3669                         c1 = SvUV(*c_p);
3670
3671                         c_p = av_fetch(list, 1, FALSE);
3672                         if (c_p == NULL) {
3673                             Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
3674                         }
3675                         c2 = SvUV(*c_p);
3676
3677                         /* Folds that cross the 255/256 boundary are forbidden
3678                          * if EXACTFL (and isnt a UTF8 locale), or EXACTFA and
3679                          * one is ASCIII.  Since the pattern character is above
3680                          * 256, and its only other match is below 256, the only
3681                          * legal match will be to itself.  We have thrown away
3682                          * the original, so have to compute which is the one
3683                          * above 255 */
3684                         if ((c1 < 256) != (c2 < 256)) {
3685                             if ((OP(text_node) == EXACTFL
3686                                  && ! IN_UTF8_CTYPE_LOCALE)
3687                                 || ((OP(text_node) == EXACTFA
3688                                     || OP(text_node) == EXACTFA_NO_TRIE)
3689                                     && (isASCII(c1) || isASCII(c2))))
3690                             {
3691                                 if (c1 < 256) {
3692                                     c1 = c2;
3693                                 }
3694                                 else {
3695                                     c2 = c1;
3696                                 }
3697                             }
3698                         }
3699                     }
3700                 }
3701             }
3702             else /* Here, c1 is < 255 */
3703                 if (utf8_target
3704                     && HAS_NONLATIN1_FOLD_CLOSURE(c1)
3705                     && ( ! (OP(text_node) == EXACTFL && ! IN_UTF8_CTYPE_LOCALE))
3706                     && ((OP(text_node) != EXACTFA
3707                         && OP(text_node) != EXACTFA_NO_TRIE)
3708                         || ! isASCII(c1)))
3709             {
3710                 /* Here, there could be something above Latin1 in the target
3711                  * which folds to this character in the pattern.  All such
3712                  * cases except LATIN SMALL LETTER Y WITH DIAERESIS have more
3713                  * than two characters involved in their folds, so are outside
3714                  * the scope of this function */
3715                 if (UNLIKELY(c1 == LATIN_SMALL_LETTER_Y_WITH_DIAERESIS)) {
3716                     c2 = LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS;
3717                 }
3718                 else {
3719                     use_chrtest_void = TRUE;
3720                 }
3721             }
3722             else { /* Here nothing above Latin1 can fold to the pattern
3723                       character */
3724                 switch (OP(text_node)) {
3725
3726                     case EXACTFL:   /* /l rules */
3727                         c2 = PL_fold_locale[c1];
3728                         break;
3729
3730                     case EXACTF:   /* This node only generated for non-utf8
3731                                     patterns */
3732                         assert(! is_utf8_pat);
3733                         if (! utf8_target) {    /* /d rules */
3734                             c2 = PL_fold[c1];
3735                             break;
3736                         }
3737                         /* FALLTHROUGH */
3738                         /* /u rules for all these.  This happens to work for
3739                         * EXACTFA as nothing in Latin1 folds to ASCII */
3740                     case EXACTFA_NO_TRIE:   /* This node only generated for
3741                                             non-utf8 patterns */
3742                         assert(! is_utf8_pat);
3743                         /* FALL THROUGH */
3744                     case EXACTFA:
3745                     case EXACTFU_SS:
3746                     case EXACTFU:
3747                         c2 = PL_fold_latin1[c1];
3748                         break;
3749
3750                     default:
3751                         Perl_croak(aTHX_ "panic: Unexpected op %u", OP(text_node));
3752                         assert(0); /* NOTREACHED */
3753                 }
3754             }
3755         }
3756     }
3757
3758     /* Here have figured things out.  Set up the returns */
3759     if (use_chrtest_void) {
3760         *c2p = *c1p = CHRTEST_VOID;
3761     }
3762     else if (utf8_target) {
3763         if (! utf8_has_been_setup) {    /* Don't have the utf8; must get it */
3764             uvchr_to_utf8(c1_utf8, c1);
3765             uvchr_to_utf8(c2_utf8, c2);
3766         }
3767
3768         /* Invariants are stored in both the utf8 and byte outputs; Use
3769          * negative numbers otherwise for the byte ones.  Make sure that the
3770          * byte ones are the same iff the utf8 ones are the same */
3771         *c1p = (UTF8_IS_INVARIANT(*c1_utf8)) ? *c1_utf8 : CHRTEST_NOT_A_CP_1;
3772         *c2p = (UTF8_IS_INVARIANT(*c2_utf8))
3773                 ? *c2_utf8
3774                 : (c1 == c2)
3775                   ? CHRTEST_NOT_A_CP_1
3776                   : CHRTEST_NOT_A_CP_2;
3777     }
3778     else if (c1 > 255) {
3779        if (c2 > 255) {  /* both possibilities are above what a non-utf8 string
3780                            can represent */
3781            return FALSE;
3782        }
3783
3784        *c1p = *c2p = c2;    /* c2 is the only representable value */
3785     }
3786     else {  /* c1 is representable; see about c2 */
3787        *c1p = c1;
3788        *c2p = (c2 < 256) ? c2 : c1;
3789     }
3790
3791     return TRUE;
3792 }
3793
3794 /* returns -1 on failure, $+[0] on success */
3795 STATIC SSize_t
3796 S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
3797 {
3798 #if PERL_VERSION < 9 && !defined(PERL_CORE)
3799     dMY_CXT;
3800 #endif
3801     dVAR;
3802     const bool utf8_target = reginfo->is_utf8_target;
3803     const U32 uniflags = UTF8_ALLOW_DEFAULT;
3804     REGEXP *rex_sv = reginfo->prog;
3805     regexp *rex = ReANY(rex_sv);
3806     RXi_GET_DECL(rex,rexi);
3807     /* the current state. This is a cached copy of PL_regmatch_state */
3808     regmatch_state *st;
3809     /* cache heavy used fields of st in registers */
3810     regnode *scan;
3811     regnode *next;
3812     U32 n = 0;  /* general value; init to avoid compiler warning */
3813     SSize_t ln = 0; /* len or last;  init to avoid compiler warning */
3814     char *locinput = startpos;
3815     char *pushinput; /* where to continue after a PUSH */
3816     I32 nextchr;   /* is always set to UCHARAT(locinput) */
3817
3818     bool result = 0;        /* return value of S_regmatch */
3819     int depth = 0;          /* depth of backtrack stack */
3820     U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
3821     const U32 max_nochange_depth =
3822         (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
3823         3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
3824     regmatch_state *yes_state = NULL; /* state to pop to on success of
3825                                                             subpattern */
3826     /* mark_state piggy backs on the yes_state logic so that when we unwind 
3827        the stack on success we can update the mark_state as we go */
3828     regmatch_state *mark_state = NULL; /* last mark state we have seen */
3829     regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
3830     struct regmatch_state  *cur_curlyx = NULL; /* most recent curlyx */
3831     U32 state_num;
3832     bool no_final = 0;      /* prevent failure from backtracking? */
3833     bool do_cutgroup = 0;   /* no_final only until next branch/trie entry */
3834     char *startpoint = locinput;
3835     SV *popmark = NULL;     /* are we looking for a mark? */
3836     SV *sv_commit = NULL;   /* last mark name seen in failure */
3837     SV *sv_yes_mark = NULL; /* last mark name we have seen 
3838                                during a successful match */
3839     U32 lastopen = 0;       /* last open we saw */
3840     bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;   
3841     SV* const oreplsv = GvSVn(PL_replgv);
3842     /* these three flags are set by various ops to signal information to
3843      * the very next op. They have a useful lifetime of exactly one loop
3844      * iteration, and are not preserved or restored by state pushes/pops
3845      */
3846     bool sw = 0;            /* the condition value in (?(cond)a|b) */
3847     bool minmod = 0;        /* the next "{n,m}" is a "{n,m}?" */
3848     int logical = 0;        /* the following EVAL is:
3849                                 0: (?{...})
3850                                 1: (?(?{...})X|Y)
3851                                 2: (??{...})
3852                                or the following IFMATCH/UNLESSM is:
3853                                 false: plain (?=foo)
3854                                 true:  used as a condition: (?(?=foo))
3855                             */
3856     PAD* last_pad = NULL;
3857     dMULTICALL;
3858     I32 gimme = G_SCALAR;
3859     CV *caller_cv = NULL;       /* who called us */
3860     CV *last_pushed_cv = NULL;  /* most recently called (?{}) CV */
3861     CHECKPOINT runops_cp;       /* savestack position before executing EVAL */
3862     U32 maxopenparen = 0;       /* max '(' index seen so far */
3863     int to_complement;  /* Invert the result? */
3864     _char_class_number classnum;
3865     bool is_utf8_pat = reginfo->is_utf8_pat;
3866
3867 #ifdef DEBUGGING
3868     GET_RE_DEBUG_FLAGS_DECL;
3869 #endif
3870
3871     /* protect against undef(*^R) */
3872     SAVEFREESV(SvREFCNT_inc_simple_NN(oreplsv));
3873
3874     /* shut up 'may be used uninitialized' compiler warnings for dMULTICALL */
3875     multicall_oldcatch = 0;
3876     multicall_cv = NULL;
3877     cx = NULL;
3878     PERL_UNUSED_VAR(multicall_cop);
3879     PERL_UNUSED_VAR(newsp);
3880
3881
3882     PERL_ARGS_ASSERT_REGMATCH;
3883
3884     DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
3885             PerlIO_printf(Perl_debug_log,"regmatch start\n");
3886     }));
3887
3888     st = PL_regmatch_state;
3889
3890     /* Note that nextchr is a byte even in UTF */
3891     SET_nextchr;
3892     scan = prog;
3893     while (scan != NULL) {
3894
3895         DEBUG_EXECUTE_r( {
3896             SV * const prop = sv_newmortal();
3897             regnode *rnext=regnext(scan);
3898             DUMP_EXEC_POS( locinput, scan, utf8_target );
3899             regprop(rex, prop, scan, reginfo);
3900             
3901             PerlIO_printf(Perl_debug_log,
3902                     "%3"IVdf":%*s%s(%"IVdf")\n",
3903                     (IV)(scan - rexi->program), depth*2, "",
3904                     SvPVX_const(prop),
3905                     (PL_regkind[OP(scan)] == END || !rnext) ? 
3906                         0 : (IV)(rnext - rexi->program));
3907         });
3908
3909         next = scan + NEXT_OFF(scan);
3910         if (next == scan)
3911             next = NULL;
3912         state_num = OP(scan);
3913
3914       reenter_switch:
3915         to_complement = 0;
3916
3917         SET_nextchr;
3918         assert(nextchr < 256 && (nextchr >= 0 || nextchr == NEXTCHR_EOS));
3919
3920         switch (state_num) {
3921         case BOL: /*  /^../  */
3922             if (locinput == reginfo->strbeg)
3923                 break;
3924             sayNO;
3925
3926         case MBOL: /*  /^../m  */
3927             if (locinput == reginfo->strbeg ||
3928                 (!NEXTCHR_IS_EOS && locinput[-1] == '\n'))
3929             {
3930                 break;
3931             }
3932             sayNO;
3933
3934         case SBOL: /*  /^../s  */
3935             if (locinput == reginfo->strbeg)
3936                 break;
3937             sayNO;
3938
3939         case GPOS: /*  \G  */
3940             if (locinput == reginfo->ganch)
3941                 break;
3942