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