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