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