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