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