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