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