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