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