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