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