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