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