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