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