This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Migrate t/op/{fork,runlevel,tie}.t to use run_multiple_progs().
[perl5.git] / regexec.c
CommitLineData
a0d0e21e
LW
1/* regexec.c
2 */
3
4/*
4ac71550
TC
5 * One Ring to rule them all, One Ring to find them
6 &
7 * [p.v of _The Lord of the Rings_, opening poem]
8 * [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
9 * [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
a0d0e21e
LW
10 */
11
61296642
DM
12/* This file contains functions for executing a regular expression. See
13 * also regcomp.c which funnily enough, contains functions for compiling
166f8a29 14 * a regular expression.
e4a054ea
DM
15 *
16 * This file is also copied at build time to ext/re/re_exec.c, where
17 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
18 * This causes the main functions to be compiled under new names and with
19 * debugging support added, which makes "use re 'debug'" work.
166f8a29
DM
20 */
21
a687059c
LW
22/* NOTE: this is derived from Henry Spencer's regexp code, and should not
23 * confused with the original package (see point 3 below). Thanks, Henry!
24 */
25
26/* Additional note: this code is very heavily munged from Henry's version
27 * in places. In some spots I've traded clarity for efficiency, so don't
28 * blame Henry for some of the lack of readability.
29 */
30
e50aee73
AD
31/* The names of the functions have been changed from regcomp and
32 * regexec to pregcomp and pregexec in order to avoid conflicts
33 * with the POSIX routines of the same names.
34*/
35
b9d5759e 36#ifdef PERL_EXT_RE_BUILD
54df2634 37#include "re_top.h"
9041c2e3 38#endif
56953603 39
a687059c 40/*
e50aee73 41 * pregcomp and pregexec -- regsub and regerror are not used in perl
a687059c
LW
42 *
43 * Copyright (c) 1986 by University of Toronto.
44 * Written by Henry Spencer. Not derived from licensed software.
45 *
46 * Permission is granted to anyone to use this software for any
47 * purpose on any computer system, and to redistribute it freely,
48 * subject to the following restrictions:
49 *
50 * 1. The author is not responsible for the consequences of use of
51 * this software, no matter how awful, even if they arise
52 * from defects in it.
53 *
54 * 2. The origin of this software must not be misrepresented, either
55 * by explicit claim or by omission.
56 *
57 * 3. Altered versions must be plainly marked as such, and must not
58 * be misrepresented as being the original software.
59 *
60 **** Alterations to Henry's code are...
61 ****
4bb101f2 62 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
1129b882
NC
63 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
64 **** by Larry Wall and others
a687059c 65 ****
9ef589d8
LW
66 **** You may distribute under the terms of either the GNU General Public
67 **** License or the Artistic License, as specified in the README file.
a687059c
LW
68 *
69 * Beware that some of this code is subtly aware of the way operator
70 * precedence is structured in regular expressions. Serious changes in
71 * regular-expression syntax might require a total rethink.
72 */
73#include "EXTERN.h"
864dbfa3 74#define PERL_IN_REGEXEC_C
a687059c 75#include "perl.h"
0f5d15d6 76
54df2634
NC
77#ifdef PERL_IN_XSUB_RE
78# include "re_comp.h"
79#else
80# include "regcomp.h"
81#endif
a687059c 82
ef07e810 83#define RF_tainted 1 /* tainted information used? e.g. locale */
c277df42 84#define RF_warned 2 /* warned about big count? */
faec1544 85
ab3bbdeb 86#define RF_utf8 8 /* Pattern contains multibyte chars? */
a0ed51b3 87
f2ed9b32 88#define UTF_PATTERN ((PL_reg_flags & RF_utf8) != 0)
ce862d02
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
7e2509c1
KW
97/* Valid for non-utf8 strings, non-ANYOFV nodes only: avoids the reginclass
98 * call if there are no complications: i.e., if everything matchable is
99 * straight forward in the bitmap */
af364d03
KW
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 )
2f7f8cb1 321#define IS_TEXTF(rn) ( (OP(rn)==EXACTFU || OP(rn)==EXACTFA || 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 )
2f7f8cb1 327#define IS_TEXTFU(rn) ( OP(rn)==EXACTFU || OP(rn) == EXACTFA)
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.
af944926 1079 This leaves EXACTF-ish 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
4cadc6a9
YO
1243#define REXEC_FBC_EXACTISH_SCAN(CoNd) \
1244STMT_START { \
1245 while (s <= e) { \
1246 if ( (CoNd) \
fac1af77 1247 && (ln == 1 || folder(s, pat_string, ln)) \
9a5a5549 1248 && (!reginfo || regtry(reginfo, &s)) ) \
4cadc6a9
YO
1249 goto got_it; \
1250 s++; \
1251 } \
1252} STMT_END
1253
1254#define REXEC_FBC_UTF8_SCAN(CoDe) \
1255STMT_START { \
1256 while (s + (uskip = UTF8SKIP(s)) <= strend) { \
1257 CoDe \
1258 s += uskip; \
1259 } \
1260} STMT_END
1261
1262#define REXEC_FBC_SCAN(CoDe) \
1263STMT_START { \
1264 while (s < strend) { \
1265 CoDe \
1266 s++; \
1267 } \
1268} STMT_END
1269
1270#define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \
1271REXEC_FBC_UTF8_SCAN( \
1272 if (CoNd) { \
24b23f37 1273 if (tmp && (!reginfo || regtry(reginfo, &s))) \
4cadc6a9
YO
1274 goto got_it; \
1275 else \
1276 tmp = doevery; \
1277 } \
1278 else \
1279 tmp = 1; \
1280)
1281
1282#define REXEC_FBC_CLASS_SCAN(CoNd) \
1283REXEC_FBC_SCAN( \
1284 if (CoNd) { \
24b23f37 1285 if (tmp && (!reginfo || regtry(reginfo, &s))) \
4cadc6a9
YO
1286 goto got_it; \
1287 else \
1288 tmp = doevery; \
1289 } \
1290 else \
1291 tmp = 1; \
1292)
1293
1294#define REXEC_FBC_TRYIT \
24b23f37 1295if ((!reginfo || regtry(reginfo, &s))) \
4cadc6a9
YO
1296 goto got_it
1297
e1d1eefb 1298#define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \
f2ed9b32 1299 if (utf8_target) { \
e1d1eefb
YO
1300 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1301 } \
1302 else { \
1303 REXEC_FBC_CLASS_SCAN(CoNd); \
d981ef24 1304 }
e1d1eefb 1305
4cadc6a9 1306#define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd) \
f2ed9b32 1307 if (utf8_target) { \
4cadc6a9
YO
1308 UtFpReLoAd; \
1309 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1310 } \
1311 else { \
1312 REXEC_FBC_CLASS_SCAN(CoNd); \
d981ef24 1313 }
4cadc6a9
YO
1314
1315#define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd) \
1316 PL_reg_flags |= RF_tainted; \
f2ed9b32 1317 if (utf8_target) { \
4cadc6a9
YO
1318 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1319 } \
1320 else { \
1321 REXEC_FBC_CLASS_SCAN(CoNd); \
d981ef24 1322 }
4cadc6a9 1323
786e8c11
YO
1324#define DUMP_EXEC_POS(li,s,doutf8) \
1325 dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1326
cfaf538b
KW
1327
1328#define UTF8_NOLOAD(TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
1329 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n'; \
1330 tmp = TEST_NON_UTF8(tmp); \
1331 REXEC_FBC_UTF8_SCAN( \
1332 if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1333 tmp = !tmp; \
1334 IF_SUCCESS; \
1335 } \
1336 else { \
1337 IF_FAIL; \
1338 } \
1339 ); \
1340
1341#define UTF8_LOAD(TeSt1_UtF8, TeSt2_UtF8, IF_SUCCESS, IF_FAIL) \
1342 if (s == PL_bostr) { \
1343 tmp = '\n'; \
1344 } \
1345 else { \
1346 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr); \
1347 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT); \
1348 } \
1349 tmp = TeSt1_UtF8; \
1350 LOAD_UTF8_CHARCLASS_ALNUM(); \
1351 REXEC_FBC_UTF8_SCAN( \
1352 if (tmp == ! (TeSt2_UtF8)) { \
1353 tmp = !tmp; \
1354 IF_SUCCESS; \
1355 } \
1356 else { \
1357 IF_FAIL; \
1358 } \
1359 ); \
1360
63ac0dad
KW
1361/* The only difference between the BOUND and NBOUND cases is that
1362 * REXEC_FBC_TRYIT is called when matched in BOUND, and when non-matched in
1363 * NBOUND. This is accomplished by passing it in either the if or else clause,
1364 * with the other one being empty */
1365#define FBC_BOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1dcf4a1b 1366 FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
cfaf538b
KW
1367
1368#define FBC_BOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1dcf4a1b 1369 FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER), TEST_NON_UTF8, REXEC_FBC_TRYIT, PLACEHOLDER)
63ac0dad
KW
1370
1371#define FBC_NBOUND(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1dcf4a1b 1372 FBC_BOUND_COMMON(UTF8_LOAD(TEST1_UTF8, TEST2_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
cfaf538b
KW
1373
1374#define FBC_NBOUND_NOLOAD(TEST_NON_UTF8, TEST1_UTF8, TEST2_UTF8) \
1dcf4a1b 1375 FBC_BOUND_COMMON(UTF8_NOLOAD(TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT), TEST_NON_UTF8, PLACEHOLDER, REXEC_FBC_TRYIT)
cfaf538b 1376
63ac0dad
KW
1377
1378/* Common to the BOUND and NBOUND cases. Unfortunately the UTF8 tests need to
1379 * be passed in completely with the variable name being tested, which isn't
1380 * such a clean interface, but this is easier to read than it was before. We
1381 * are looking for the boundary (or non-boundary between a word and non-word
1382 * character. The utf8 and non-utf8 cases have the same logic, but the details
1383 * must be different. Find the "wordness" of the character just prior to this
1384 * one, and compare it with the wordness of this one. If they differ, we have
1385 * a boundary. At the beginning of the string, pretend that the previous
1386 * character was a new-line */
cfaf538b 1387#define FBC_BOUND_COMMON(UTF8_CODE, TEST_NON_UTF8, IF_SUCCESS, IF_FAIL) \
63ac0dad 1388 if (utf8_target) { \
cfaf538b 1389 UTF8_CODE \
63ac0dad
KW
1390 } \
1391 else { /* Not utf8 */ \
1392 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n'; \
1393 tmp = TEST_NON_UTF8(tmp); \
1394 REXEC_FBC_SCAN( \
1395 if (tmp == ! TEST_NON_UTF8((U8) *s)) { \
1396 tmp = !tmp; \
1397 IF_SUCCESS; \
1398 } \
1399 else { \
1400 IF_FAIL; \
1401 } \
1402 ); \
1403 } \
1404 if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s))) \
1405 goto got_it;
1406
786e8c11
YO
1407/* We know what class REx starts with. Try to find this position... */
1408/* if reginfo is NULL, its a dryrun */
1409/* annoyingly all the vars in this routine have different names from their counterparts
1410 in regmatch. /grrr */
1411
3c3eec57 1412STATIC char *
07be1b83 1413S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
24b23f37 1414 const char *strend, regmatch_info *reginfo)
a687059c 1415{
27da23d5 1416 dVAR;
bbe252da 1417 const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
fac1af77
KW
1418 char *pat_string; /* The pattern's exactish string */
1419 char *pat_end; /* ptr to end char of pat_string */
1420 re_fold_t folder; /* Function for computing non-utf8 folds */
1421 const U8 *fold_array; /* array for folding ords < 256 */
d8093b23 1422 STRLEN ln;
5dab1207 1423 STRLEN lnc;
078c425b 1424 register STRLEN uskip;
fac1af77
KW
1425 U8 c1;
1426 U8 c2;
6eb5f6b9
JH
1427 char *e;
1428 register I32 tmp = 1; /* Scratch variable? */
f2ed9b32 1429 register const bool utf8_target = PL_reg_match_utf8;
453bfd44 1430 UV utf8_fold_flags = 0;
f8fc2ecf 1431 RXi_GET_DECL(prog,progi);
7918f24d
NC
1432
1433 PERL_ARGS_ASSERT_FIND_BYCLASS;
f8fc2ecf 1434
6eb5f6b9
JH
1435 /* We know what class it must start with. */
1436 switch (OP(c)) {
f56b6394 1437 case ANYOFV:
6eb5f6b9 1438 case ANYOF:
f56b6394 1439 if (utf8_target || OP(c) == ANYOFV) {
b1e3e569
KW
1440 STRLEN inclasslen = strend - s;
1441 REXEC_FBC_UTF8_CLASS_SCAN(
1442 reginclass(prog, c, (U8*)s, &inclasslen, utf8_target));
388cc4de
HS
1443 }
1444 else {
1445 while (s < strend) {
1446 STRLEN skip = 1;
1447
32fc9b6a 1448 if (REGINCLASS(prog, c, (U8*)s) ||
388cc4de
HS
1449 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1450 /* The assignment of 2 is intentional:
1451 * for the folded sharp s, the skip is 2. */
1452 (skip = SHARP_S_SKIP))) {
24b23f37 1453 if (tmp && (!reginfo || regtry(reginfo, &s)))
388cc4de
HS
1454 goto got_it;
1455 else
1456 tmp = doevery;
1457 }
1458 else
1459 tmp = 1;
1460 s += skip;
1461 }
a0d0e21e 1462 }
6eb5f6b9 1463 break;
f33976b4 1464 case CANY:
4cadc6a9 1465 REXEC_FBC_SCAN(
24b23f37 1466 if (tmp && (!reginfo || regtry(reginfo, &s)))
f33976b4
DB
1467 goto got_it;
1468 else
1469 tmp = doevery;
4cadc6a9 1470 );
f33976b4 1471 break;
2f7f8cb1
KW
1472
1473 case EXACTFA:
1474 if (UTF_PATTERN || utf8_target) {
1475 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
1476 goto do_exactf_utf8;
1477 }
1478 fold_array = PL_fold_latin1; /* Latin1 folds are not affected by */
1479 folder = foldEQ_latin1; /* /a, except the sharp s one which */
1480 goto do_exactf_non_utf8; /* isn't dealt with by these */
1481
9a5a5549 1482 case EXACTFU:
fac1af77
KW
1483 if (UTF_PATTERN || utf8_target) {
1484 utf8_fold_flags = 0;
1485 goto do_exactf_utf8;
1486 }
1487 fold_array = PL_fold_latin1;
1488 folder = foldEQ_latin1;
1489 /* XXX This uses the full utf8 fold because if the pattern contains
1490 * 'ss' it could match LATIN_SMALL_LETTER SHARP_S in the string.
1491 * There could be a new node type, say EXACTFU_SS, which is
1492 * generated by regcomp only if there is an 'ss', and then every
1493 * other case could goto do_exactf_non_utf8;*/
1494 goto do_exactf_utf8;
1495
6eb5f6b9 1496 case EXACTF:
fac1af77
KW
1497 if (UTF_PATTERN || utf8_target) {
1498 utf8_fold_flags = 0;
1499 goto do_exactf_utf8;
1500 }
1501 fold_array = PL_fold;
1502 folder = foldEQ;
1503 goto do_exactf_non_utf8;
1504
1505 case EXACTFL:
1506 if (UTF_PATTERN || utf8_target) {
17580e7a 1507 utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
fac1af77
KW
1508 goto do_exactf_utf8;
1509 }
1510 fold_array = PL_fold_locale;
1511 folder = foldEQ_locale;
1512
1513 /* FALL THROUGH */
1514
1515 do_exactf_non_utf8: /* Neither pattern nor string are UTF8 */
1516
1517 /* The idea in the non-utf8 EXACTF* cases is to first find the
1518 * first character of the EXACTF* node and then, if necessary,
1519 * case-insensitively compare the full text of the node. c1 is the
1520 * first character. c2 is its fold. This logic will not work for
1521 * Unicode semantics and the german sharp ss, which hence should
1522 * not be compiled into a node that gets here. */
1523 pat_string = STRING(c);
1524 ln = STR_LEN(c); /* length to match in octets/bytes */
1525
1526 e = HOP3c(strend, -((I32)ln), s);
1527
1528 if (!reginfo && e < s) {
1529 e = s; /* Due to minlen logic of intuit() */
1530 }
1531
1532 c1 = *pat_string;
1533 c2 = fold_array[c1];
1534 if (c1 == c2) { /* If char and fold are the same */
1535 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1536 }
1537 else {
1538 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1539 }
1540 break;
1541
1542 do_exactf_utf8:
1543
1544 /* If one of the operands is in utf8, we can't use the simpler
1545 * folding above, due to the fact that many different characters
1546 * can have the same fold, or portion of a fold, or different-
1547 * length fold */
1548 pat_string = STRING(c);
1549 ln = STR_LEN(c); /* length to match in octets/bytes */
1550 pat_end = pat_string + ln;
1551 lnc = (UTF_PATTERN) /* length to match in characters */
1552 ? utf8_length((U8 *) pat_string, (U8 *) pat_end)
1553 : ln;
1554
1555 e = HOP3c(strend, -((I32)lnc), s);
1556
1557 if (!reginfo && e < s) {
1558 e = s; /* Due to minlen logic of intuit() */
1559 }
1560
1561 while (s <= e) {
1562 char *my_strend= (char *)strend;
1563 if (foldEQ_utf8_flags(s, &my_strend, 0, utf8_target,
1564 pat_string, NULL, ln, cBOOL(UTF_PATTERN), utf8_fold_flags)
1565 && (!reginfo || regtry(reginfo, &s)) )
1566 {
1567 goto got_it;
1568 }
1569 s += UTF8SKIP(s);
1570 }
1571 break;
bbce6d69 1572 case BOUNDL:
3280af22 1573 PL_reg_flags |= RF_tainted;
63ac0dad
KW
1574 FBC_BOUND(isALNUM_LC,
1575 isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
1576 isALNUM_LC_utf8((U8*)s));
a0ed51b3 1577 break;
bbce6d69 1578 case NBOUNDL:
3280af22 1579 PL_reg_flags |= RF_tainted;
63ac0dad
KW
1580 FBC_NBOUND(isALNUM_LC,
1581 isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp)),
1582 isALNUM_LC_utf8((U8*)s));
1583 break;
1584 case BOUND:
1585 FBC_BOUND(isWORDCHAR,
1586 isALNUM_uni(tmp),
1587 cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1588 break;
cfaf538b
KW
1589 case BOUNDA:
1590 FBC_BOUND_NOLOAD(isWORDCHAR_A,
1591 isWORDCHAR_A(tmp),
1592 isWORDCHAR_A((U8*)s));
1593 break;
a0d0e21e 1594 case NBOUND:
63ac0dad
KW
1595 FBC_NBOUND(isWORDCHAR,
1596 isALNUM_uni(tmp),
1597 cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1598 break;
cfaf538b
KW
1599 case NBOUNDA:
1600 FBC_NBOUND_NOLOAD(isWORDCHAR_A,
1601 isWORDCHAR_A(tmp),
1602 isWORDCHAR_A((U8*)s));
1603 break;
63ac0dad
KW
1604 case BOUNDU:
1605 FBC_BOUND(isWORDCHAR_L1,
1606 isALNUM_uni(tmp),
1607 cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
1608 break;
1609 case NBOUNDU:
1610 FBC_NBOUND(isWORDCHAR_L1,
1611 isALNUM_uni(tmp),
1612 cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, utf8_target)));
a0ed51b3 1613 break;
bbce6d69 1614 case ALNUML:
4cadc6a9
YO
1615 REXEC_FBC_CSCAN_TAINT(
1616 isALNUM_LC_utf8((U8*)s),
1617 isALNUM_LC(*s)
1618 );
6895a8aa 1619 break;
980866de
KW
1620 case ALNUMU:
1621 REXEC_FBC_CSCAN_PRELOAD(
1622 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1623 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1624 isWORDCHAR_L1((U8) *s)
1625 );
6895a8aa 1626 break;
980866de
KW
1627 case ALNUM:
1628 REXEC_FBC_CSCAN_PRELOAD(
1629 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1630 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1631 isWORDCHAR((U8) *s)
1632 );
6895a8aa 1633 break;
cfaf538b 1634 case ALNUMA:
8e9da4d4
KW
1635 /* Don't need to worry about utf8, as it can match only a single
1636 * byte invariant character */
cfaf538b 1637 REXEC_FBC_CLASS_SCAN( isWORDCHAR_A(*s));
6895a8aa 1638 break;
980866de
KW
1639 case NALNUMU:
1640 REXEC_FBC_CSCAN_PRELOAD(
1641 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1642 swash_fetch(RE_utf8_perl_word,(U8*)s, utf8_target),
1643 ! isWORDCHAR_L1((U8) *s)
1644 );
6895a8aa 1645 break;
a0d0e21e 1646 case NALNUM:
4cadc6a9 1647 REXEC_FBC_CSCAN_PRELOAD(
d1eb3177 1648 LOAD_UTF8_CHARCLASS_PERL_WORD(),
f2ed9b32 1649 !swash_fetch(RE_utf8_perl_word, (U8*)s, utf8_target),
980866de 1650 ! isALNUM(*s)
4cadc6a9 1651 );
6895a8aa 1652 break;
cfaf538b 1653 case NALNUMA:
8e9da4d4
KW
1654 REXEC_FBC_CSCAN(
1655 !isWORDCHAR_A(*s),
1656 !isWORDCHAR_A(*s)
1657 );
1658 break;
bbce6d69 1659 case NALNUML:
4cadc6a9
YO
1660 REXEC_FBC_CSCAN_TAINT(
1661 !isALNUM_LC_utf8((U8*)s),
1662 !isALNUM_LC(*s)
1663 );
6895a8aa 1664 break;
980866de
KW
1665 case SPACEU:
1666 REXEC_FBC_CSCAN_PRELOAD(
1667 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1668 *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target),
1669 isSPACE_L1((U8) *s)
1670 );
6895a8aa 1671 break;
a0d0e21e 1672 case SPACE:
4cadc6a9 1673 REXEC_FBC_CSCAN_PRELOAD(
d1eb3177 1674 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
f2ed9b32 1675 *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target),
980866de 1676 isSPACE((U8) *s)
4cadc6a9 1677 );
6895a8aa 1678 break;
cfaf538b 1679 case SPACEA:
8e9da4d4
KW
1680 /* Don't need to worry about utf8, as it can match only a single
1681 * byte invariant character */
cfaf538b 1682 REXEC_FBC_CLASS_SCAN( isSPACE_A(*s));
6895a8aa 1683 break;
bbce6d69 1684 case SPACEL:
4cadc6a9 1685 REXEC_FBC_CSCAN_TAINT(
6bbba904 1686 isSPACE_LC_utf8((U8*)s),
4cadc6a9
YO
1687 isSPACE_LC(*s)
1688 );
6895a8aa 1689 break;
980866de
KW
1690 case NSPACEU:
1691 REXEC_FBC_CSCAN_PRELOAD(
1692 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1693 !( *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target)),
1694 ! isSPACE_L1((U8) *s)
1695 );
6895a8aa 1696 break;
a0d0e21e 1697 case NSPACE:
4cadc6a9 1698 REXEC_FBC_CSCAN_PRELOAD(
d1eb3177 1699 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
f2ed9b32 1700 !(*s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, utf8_target)),
980866de 1701 ! isSPACE((U8) *s)
4cadc6a9 1702 );
6895a8aa 1703 break;
cfaf538b 1704 case NSPACEA:
8e9da4d4
KW
1705 REXEC_FBC_CSCAN(
1706 !isSPACE_A(*s),
1707 !isSPACE_A(*s)
1708 );
1709 break;
bbce6d69 1710 case NSPACEL:
4cadc6a9 1711 REXEC_FBC_CSCAN_TAINT(
6bbba904 1712 !isSPACE_LC_utf8((U8*)s),
4cadc6a9
YO
1713 !isSPACE_LC(*s)
1714 );
6895a8aa 1715 break;
a0d0e21e 1716 case DIGIT:
4cadc6a9 1717 REXEC_FBC_CSCAN_PRELOAD(
d1eb3177 1718 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
f2ed9b32 1719 swash_fetch(RE_utf8_posix_digit,(U8*)s, utf8_target),
4cadc6a9
YO
1720 isDIGIT(*s)
1721 );
6895a8aa 1722 break;
cfaf538b 1723 case DIGITA:
8e9da4d4
KW
1724 /* Don't need to worry about utf8, as it can match only a single
1725 * byte invariant character */
cfaf538b 1726 REXEC_FBC_CLASS_SCAN( isDIGIT_A(*s));
6895a8aa 1727 break;
b8c5462f 1728 case DIGITL:
4cadc6a9
YO
1729 REXEC_FBC_CSCAN_TAINT(
1730 isDIGIT_LC_utf8((U8*)s),
1731 isDIGIT_LC(*s)
1732 );
6895a8aa 1733 break;
a0d0e21e 1734 case NDIGIT:
4cadc6a9 1735 REXEC_FBC_CSCAN_PRELOAD(
d1eb3177 1736 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
f2ed9b32 1737 !swash_fetch(RE_utf8_posix_digit,(U8*)s, utf8_target),
4cadc6a9
YO
1738 !isDIGIT(*s)
1739 );
6895a8aa 1740 break;
cfaf538b 1741 case NDIGITA:
8e9da4d4
KW
1742 REXEC_FBC_CSCAN(
1743 !isDIGIT_A(*s),
1744 !isDIGIT_A(*s)
1745 );
1746 break;
b8c5462f 1747 case NDIGITL:
4cadc6a9
YO
1748 REXEC_FBC_CSCAN_TAINT(
1749 !isDIGIT_LC_utf8((U8*)s),
1750 !isDIGIT_LC(*s)
1751 );
6895a8aa 1752 break;
e1d1eefb
YO
1753 case LNBREAK:
1754 REXEC_FBC_CSCAN(
1755 is_LNBREAK_utf8(s),
1756 is_LNBREAK_latin1(s)
1757 );
6895a8aa 1758 break;
e1d1eefb
YO
1759 case VERTWS:
1760 REXEC_FBC_CSCAN(
1761 is_VERTWS_utf8(s),
1762 is_VERTWS_latin1(s)
1763 );
6895a8aa 1764 break;
e1d1eefb
YO
1765 case NVERTWS:
1766 REXEC_FBC_CSCAN(
1767 !is_VERTWS_utf8(s),
1768 !is_VERTWS_latin1(s)
1769 );
6895a8aa 1770 break;
e1d1eefb
YO
1771 case HORIZWS:
1772 REXEC_FBC_CSCAN(
1773 is_HORIZWS_utf8(s),
1774 is_HORIZWS_latin1(s)
1775 );
6895a8aa 1776 break;
e1d1eefb
YO
1777 case NHORIZWS:
1778 REXEC_FBC_CSCAN(
1779 !is_HORIZWS_utf8(s),
1780 !is_HORIZWS_latin1(s)
1781 );
6895a8aa 1782 break;
1de06328
YO
1783 case AHOCORASICKC:
1784 case AHOCORASICK:
07be1b83 1785 {
a0a388a1 1786 DECL_TRIE_TYPE(c);
07be1b83
YO
1787 /* what trie are we using right now */
1788 reg_ac_data *aho
f8fc2ecf 1789 = (reg_ac_data*)progi->data->data[ ARG( c ) ];
3251b653
NC
1790 reg_trie_data *trie
1791 = (reg_trie_data*)progi->data->data[ aho->trie ];
85fbaab2 1792 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
07be1b83
YO
1793
1794 const char *last_start = strend - trie->minlen;
6148ee25 1795#ifdef DEBUGGING
07be1b83 1796 const char *real_start = s;
6148ee25 1797#endif
07be1b83 1798 STRLEN maxlen = trie->maxlen;
be8e71aa
YO
1799 SV *sv_points;
1800 U8 **points; /* map of where we were in the input string
786e8c11 1801 when reading a given char. For ASCII this
be8e71aa 1802 is unnecessary overhead as the relationship
38a44b82
NC
1803 is always 1:1, but for Unicode, especially
1804 case folded Unicode this is not true. */
f9e705e8 1805 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
786e8c11
YO
1806 U8 *bitmap=NULL;
1807
07be1b83
YO
1808
1809 GET_RE_DEBUG_FLAGS_DECL;
1810
be8e71aa
YO
1811 /* We can't just allocate points here. We need to wrap it in
1812 * an SV so it gets freed properly if there is a croak while
1813 * running the match */
1814 ENTER;
1815 SAVETMPS;
1816 sv_points=newSV(maxlen * sizeof(U8 *));
1817 SvCUR_set(sv_points,
1818 maxlen * sizeof(U8 *));
1819 SvPOK_on(sv_points);
1820 sv_2mortal(sv_points);
1821 points=(U8**)SvPV_nolen(sv_points );
1de06328
YO
1822 if ( trie_type != trie_utf8_fold
1823 && (trie->bitmap || OP(c)==AHOCORASICKC) )
1824 {
786e8c11
YO
1825 if (trie->bitmap)
1826 bitmap=(U8*)trie->bitmap;
1827 else
1828 bitmap=(U8*)ANYOF_BITMAP(c);
07be1b83 1829 }
786e8c11
YO
1830 /* this is the Aho-Corasick algorithm modified a touch
1831 to include special handling for long "unknown char"
1832 sequences. The basic idea being that we use AC as long
1833 as we are dealing with a possible matching char, when
1834 we encounter an unknown char (and we have not encountered
1835 an accepting state) we scan forward until we find a legal
1836 starting char.
1837 AC matching is basically that of trie matching, except
1838 that when we encounter a failing transition, we fall back
1839 to the current states "fail state", and try the current char
1840 again, a process we repeat until we reach the root state,
1841 state 1, or a legal transition. If we fail on the root state
1842 then we can either terminate if we have reached an accepting
1843 state previously, or restart the entire process from the beginning
1844 if we have not.
1845
1846 */
07be1b83
YO
1847 while (s <= last_start) {
1848 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1849 U8 *uc = (U8*)s;
1850 U16 charid = 0;
1851 U32 base = 1;
1852 U32 state = 1;
1853 UV uvc = 0;
1854 STRLEN len = 0;
1855 STRLEN foldlen = 0;
1856 U8 *uscan = (U8*)NULL;
1857 U8 *leftmost = NULL;
786e8c11
YO
1858#ifdef DEBUGGING
1859 U32 accepted_word= 0;
1860#endif
07be1b83
YO
1861 U32 pointpos = 0;
1862
1863 while ( state && uc <= (U8*)strend ) {
1864 int failed=0;
786e8c11
YO
1865 U32 word = aho->states[ state ].wordnum;
1866
1de06328
YO
1867 if( state==1 ) {
1868 if ( bitmap ) {
1869 DEBUG_TRIE_EXECUTE_r(
1870 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1871 dump_exec_pos( (char *)uc, c, strend, real_start,
f2ed9b32 1872 (char *)uc, utf8_target );
1de06328
YO
1873 PerlIO_printf( Perl_debug_log,
1874 " Scanning for legal start char...\n");
1875 }
d085b490
YO
1876 );
1877 if (utf8_target) {
1878 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1879 uc += UTF8SKIP(uc);
1880 }
1881 } else {
1882 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1883 uc++;
1884 }
1885 }
1de06328 1886 s= (char *)uc;
786e8c11 1887 }
786e8c11
YO
1888 if (uc >(U8*)last_start) break;
1889 }
1890
1891 if ( word ) {
2e64971a 1892 U8 *lpos= points[ (pointpos - trie->wordinfo[word].len) % maxlen ];
786e8c11
YO
1893 if (!leftmost || lpos < leftmost) {
1894 DEBUG_r(accepted_word=word);
07be1b83 1895 leftmost= lpos;
786e8c11 1896 }
07be1b83 1897 if (base==0) break;
786e8c11 1898
07be1b83
YO
1899 }
1900 points[pointpos++ % maxlen]= uc;
55eed653
NC
1901 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1902 uscan, len, uvc, charid, foldlen,
1903 foldbuf, uniflags);
786e8c11
YO
1904 DEBUG_TRIE_EXECUTE_r({
1905 dump_exec_pos( (char *)uc, c, strend, real_start,
f2ed9b32 1906 s, utf8_target );
07be1b83 1907 PerlIO_printf(Perl_debug_log,
786e8c11
YO
1908 " Charid:%3u CP:%4"UVxf" ",
1909 charid, uvc);
1910 });
07be1b83
YO
1911
1912 do {
6148ee25 1913#ifdef DEBUGGING
786e8c11 1914 word = aho->states[ state ].wordnum;
6148ee25 1915#endif
07be1b83
YO
1916 base = aho->states[ state ].trans.base;
1917
786e8c11
YO
1918 DEBUG_TRIE_EXECUTE_r({
1919 if (failed)
1920 dump_exec_pos( (char *)uc, c, strend, real_start,
f2ed9b32 1921 s, utf8_target );
07be1b83 1922 PerlIO_printf( Perl_debug_log,
786e8c11
YO
1923 "%sState: %4"UVxf", word=%"UVxf,
1924 failed ? " Fail transition to " : "",
1925 (UV)state, (UV)word);
1926 });
07be1b83
YO
1927 if ( base ) {
1928 U32 tmp;
6dd2be57 1929 I32 offset;
07be1b83 1930 if (charid &&
6dd2be57
DM
1931 ( ((offset = base + charid
1932 - 1 - trie->uniquecharcount)) >= 0)
1933 && ((U32)offset < trie->lasttrans)
1934 && trie->trans[offset].check == state
1935 && (tmp=trie->trans[offset].next))
07be1b83 1936 {
786e8c11
YO
1937 DEBUG_TRIE_EXECUTE_r(
1938 PerlIO_printf( Perl_debug_log," - legal\n"));
07be1b83
YO
1939 state = tmp;
1940 break;
1941 }
1942 else {
786e8c11
YO
1943 DEBUG_TRIE_EXECUTE_r(
1944 PerlIO_printf( Perl_debug_log," - fail\n"));
1945 failed = 1;
1946 state = aho->fail[state];
07be1b83
YO
1947 }
1948 }
1949 else {
1950 /* we must be accepting here */
786e8c11
YO
1951 DEBUG_TRIE_EXECUTE_r(
1952 PerlIO_printf( Perl_debug_log," - accepting\n"));
1953 failed = 1;
07be1b83
YO
1954 break;
1955 }
1956 } while(state);
786e8c11 1957 uc += len;
07be1b83
YO
1958 if (failed) {
1959 if (leftmost)
1960 break;
786e8c11 1961 if (!state) state = 1;
07be1b83
YO
1962 }
1963 }
1964 if ( aho->states[ state ].wordnum ) {
2e64971a 1965 U8 *lpos = points[ (pointpos - trie->wordinfo[aho->states[ state ].wordnum].len) % maxlen ];
786e8c11
YO
1966 if (!leftmost || lpos < leftmost) {
1967 DEBUG_r(accepted_word=aho->states[ state ].wordnum);
07be1b83 1968 leftmost = lpos;
786e8c11 1969 }
07be1b83 1970 }
07be1b83
YO
1971 if (leftmost) {
1972 s = (char*)leftmost;
786e8c11
YO
1973 DEBUG_TRIE_EXECUTE_r({
1974 PerlIO_printf(
70685ca0
JH
1975 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1976 (UV)accepted_word, (IV)(s - real_start)
786e8c11
YO
1977 );
1978 });
24b23f37 1979 if (!reginfo || regtry(reginfo, &s)) {
be8e71aa
YO
1980 FREETMPS;
1981 LEAVE;
07be1b83 1982 goto got_it;
be8e71aa 1983 }
07be1b83 1984 s = HOPc(s,1);
786e8c11
YO
1985 DEBUG_TRIE_EXECUTE_r({
1986 PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1987 });
07be1b83 1988 } else {
786e8c11
YO
1989 DEBUG_TRIE_EXECUTE_r(
1990 PerlIO_printf( Perl_debug_log,"No match.\n"));
07be1b83
YO
1991 break;
1992 }
1993 }
be8e71aa
YO
1994 FREETMPS;
1995 LEAVE;
07be1b83
YO
1996 }
1997 break;
b3c9acc1 1998 default:
3c3eec57
GS
1999 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
2000 break;
d6a28714 2001 }
6eb5f6b9
JH
2002 return 0;
2003 got_it:
2004 return s;
2005}
2006
fae667d5 2007
6eb5f6b9
JH
2008/*
2009 - regexec_flags - match a regexp against a string
2010 */
2011I32
288b8c02 2012Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
6eb5f6b9
JH
2013 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
2014/* strend: pointer to null at end of string */
2015/* strbeg: real beginning of string */
2016/* minend: end of match must be >=minend after stringarg. */
58e23c8d
YO
2017/* data: May be used for some additional optimizations.
2018 Currently its only used, with a U32 cast, for transmitting
2019 the ganch offset when doing a /g match. This will change */
6eb5f6b9
JH
2020/* nosave: For optimizations. */
2021{
97aff369 2022 dVAR;
288b8c02 2023 struct regexp *const prog = (struct regexp *)SvANY(rx);
24b23f37 2024 /*register*/ char *s;
6eb5f6b9 2025 register regnode *c;
24b23f37 2026 /*register*/ char *startpos = stringarg;
6eb5f6b9
JH
2027 I32 minlen; /* must match at least this many chars */
2028 I32 dontbother = 0; /* how many characters not to try at end */
6eb5f6b9
JH
2029 I32 end_shift = 0; /* Same for the end. */ /* CC */
2030 I32 scream_pos = -1; /* Internal iterator of scream. */
ccac19ea 2031 char *scream_olds = NULL;
f2ed9b32 2032 const bool utf8_target = cBOOL(DO_UTF8(sv));
2757e526 2033 I32 multiline;
f8fc2ecf 2034 RXi_GET_DECL(prog,progi);
3b0527fe 2035 regmatch_info reginfo; /* create some info to pass to regtry etc */
e9105d30 2036 regexp_paren_pair *swap = NULL;
a3621e74
YO
2037 GET_RE_DEBUG_FLAGS_DECL;
2038
7918f24d 2039 PERL_ARGS_ASSERT_REGEXEC_FLAGS;
9d4ba2ae 2040 PERL_UNUSED_ARG(data);
6eb5f6b9
JH
2041
2042 /* Be paranoid... */
2043 if (prog == NULL || startpos == NULL) {
2044 Perl_croak(aTHX_ "NULL regexp parameter");
2045 return 0;
2046 }
2047
bbe252da 2048 multiline = prog->extflags & RXf_PMf_MULTILINE;
288b8c02 2049 reginfo.prog = rx; /* Yes, sorry that this is confusing. */
2757e526 2050
f2ed9b32 2051 RX_MATCH_UTF8_set(rx, utf8_target);
1de06328 2052 DEBUG_EXECUTE_r(
f2ed9b32 2053 debug_start_match(rx, utf8_target, startpos, strend,
1de06328
YO
2054 "Matching");
2055 );
bac06658 2056
6eb5f6b9 2057 minlen = prog->minlen;
1de06328
YO
2058
2059 if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
a3621e74 2060 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
a72c7584
JH
2061 "String too short [regexec_flags]...\n"));
2062 goto phooey;
1aa99e6b 2063 }
6eb5f6b9 2064
1de06328 2065
6eb5f6b9 2066 /* Check validity of program. */
f8fc2ecf 2067 if (UCHARAT(progi->program) != REG_MAGIC) {
6eb5f6b9
JH
2068 Perl_croak(aTHX_ "corrupted regexp program");
2069 }
2070
2071 PL_reg_flags = 0;
2072 PL_reg_eval_set = 0;
2073 PL_reg_maxiter = 0;
2074
3c8556c3 2075 if (RX_UTF8(rx))
6eb5f6b9
JH
2076 PL_reg_flags |= RF_utf8;
2077
2078 /* Mark beginning of line for ^ and lookbehind. */
3b0527fe 2079 reginfo.bol = startpos; /* XXX not used ??? */
6eb5f6b9 2080 PL_bostr = strbeg;
3b0527fe 2081 reginfo.sv = sv;
6eb5f6b9
JH
2082
2083 /* Mark end of line for $ (and such) */
2084 PL_regeol = strend;
2085
2086 /* see how far we have to get to not match where we matched before */
3b0527fe 2087 reginfo.till = startpos+minend;
6eb5f6b9 2088
6eb5f6b9
JH
2089 /* If there is a "must appear" string, look for it. */
2090 s = startpos;
2091
bbe252da 2092 if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
6eb5f6b9 2093 MAGIC *mg;
2c296965 2094 if (flags & REXEC_IGNOREPOS){ /* Means: check only at start */
58e23c8d 2095 reginfo.ganch = startpos + prog->gofs;
2c296965 2096 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
ed549f2e 2097 "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
2c296965 2098 } else if (sv && SvTYPE(sv) >= SVt_PVMG
6eb5f6b9 2099 && SvMAGIC(sv)
14befaf4
DM
2100 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
2101 && mg->mg_len >= 0) {
3b0527fe 2102 reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
2c296965 2103 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
ed549f2e 2104 "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
2c296965 2105
bbe252da 2106 if (prog->extflags & RXf_ANCH_GPOS) {
3b0527fe 2107 if (s > reginfo.ganch)
6eb5f6b9 2108 goto phooey;
58e23c8d 2109 s = reginfo.ganch - prog->gofs;
2c296965 2110 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
ed549f2e 2111 "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
c584a96e
YO
2112 if (s < strbeg)
2113 goto phooey;
6eb5f6b9
JH
2114 }
2115 }
58e23c8d 2116 else if (data) {
70685ca0 2117 reginfo.ganch = strbeg + PTR2UV(data);
2c296965
YO
2118 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2119 "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
2120
2121 } else { /* pos() not defined */
3b0527fe 2122 reginfo.ganch = strbeg;
2c296965
YO
2123 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
2124 "GPOS: reginfo.ganch = strbeg\n"));
2125 }
6eb5f6b9 2126 }
288b8c02 2127 if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
e9105d30
GG
2128 /* We have to be careful. If the previous successful match
2129 was from this regex we don't want a subsequent partially
2130 successful match to clobber the old results.
2131 So when we detect this possibility we add a swap buffer
2132 to the re, and switch the buffer each match. If we fail
2133 we switch it back, otherwise we leave it swapped.
2134 */
2135 swap = prog->offs;
2136 /* do we need a save destructor here for eval dies? */
2137 Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
c74340f9 2138 }
a0714e2c 2139 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
6eb5f6b9
JH
2140 re_scream_pos_data d;
2141
2142 d.scream_olds = &scream_olds;
2143 d.scream_pos = &scream_pos;
288b8c02 2144 s = re_intuit_start(rx, sv, s, strend, flags, &d);
3fa9c3d7 2145 if (!s) {
a3621e74 2146 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
6eb5f6b9 2147 goto phooey; /* not present */
3fa9c3d7 2148 }
6eb5f6b9
JH
2149 }
2150
1de06328 2151
6eb5f6b9
JH
2152
2153 /* Simplest case: anchored match need be tried only once. */
2154 /* [unless only anchor is BOL and multiline is set] */
bbe252da 2155 if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
24b23f37 2156 if (s == startpos && regtry(&reginfo, &startpos))
6eb5f6b9 2157 goto got_it;
bbe252da
YO
2158 else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2159 || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
6eb5f6b9
JH
2160 {
2161 char *end;
2162
2163 if (minlen)
2164 dontbother = minlen - 1;
1aa99e6b 2165 end = HOP3c(strend, -dontbother, strbeg) - 1;
6eb5f6b9 2166 /* for multiline we only have to try after newlines */
33b8afdf 2167 if (prog->check_substr || prog->check_utf8) {
92f3d482
YO
2168 /* because of the goto we can not easily reuse the macros for bifurcating the
2169 unicode/non-unicode match modes here like we do elsewhere - demerphq */
2170 if (utf8_target) {
2171 if (s == startpos)
2172 goto after_try_utf8;
2173 while (1) {
2174 if (regtry(&reginfo, &s)) {
2175 goto got_it;
2176 }
2177 after_try_utf8:
2178 if (s > end) {
2179 goto phooey;
2180 }
2181 if (prog->extflags & RXf_USE_INTUIT) {
2182 s = re_intuit_start(rx, sv, s + UTF8SKIP(s), strend, flags, NULL);
2183 if (!s) {
2184 goto phooey;
2185 }
2186 }
2187 else {
2188 s += UTF8SKIP(s);
2189 }
2190 }
2191 } /* end search for check string in unicode */
2192 else {
2193 if (s == startpos) {
2194 goto after_try_latin;
2195 }
2196 while (1) {
2197 if (regtry(&reginfo, &s)) {
2198 goto got_it;
2199 }
2200 after_try_latin:
2201 if (s > end) {
2202 goto phooey;
2203 }
2204 if (prog->extflags & RXf_USE_INTUIT) {
2205 s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2206 if (!s) {
2207 goto phooey;
2208 }
2209 }
2210 else {
2211 s++;
2212 }
2213 }
2214 } /* end search for check string in latin*/
2215 } /* end search for check string */
2216 else { /* search for newline */
2217 if (s > startpos) {
2218 /*XXX: The s-- is almost definitely wrong here under unicode - demeprhq*/
6eb5f6b9 2219 s--;
92f3d482
YO
2220 }
2221 /* We can use a more efficient search as newlines are the same in unicode as they are in latin */
6eb5f6b9
JH
2222 while (s < end) {
2223 if (*s++ == '\n') { /* don't need PL_utf8skip here */
24b23f37 2224 if (regtry(&reginfo, &s))
6eb5f6b9
JH
2225 goto got_it;
2226 }
92f3d482
YO
2227 }
2228 } /* end search for newline */
2229 } /* end anchored/multiline check string search */
6eb5f6b9 2230 goto phooey;
bbe252da 2231 } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
f9f4320a 2232 {
486ec47a 2233 /* the warning about reginfo.ganch being used without initialization
bbe252da 2234 is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
f9f4320a 2235 and we only enter this block when the same bit is set. */
58e23c8d 2236 char *tmp_s = reginfo.ganch - prog->gofs;
c584a96e
YO
2237
2238 if (tmp_s >= strbeg && regtry(&reginfo, &tmp_s))
6eb5f6b9
JH
2239 goto got_it;
2240 goto phooey;
2241 }
2242
2243 /* Messy cases: unanchored match. */
bbe252da 2244 if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
6eb5f6b9 2245 /* we have /x+whatever/ */
f2ed9b32 2246 /* it must be a one character string (XXXX Except UTF_PATTERN?) */
33b8afdf 2247 char ch;
bf93d4cc
GS
2248#ifdef DEBUGGING
2249 int did_match = 0;
2250#endif
f2ed9b32
KW
2251 if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
2252 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2253 ch = SvPVX_const(utf8_target ? prog->anchored_utf8 : prog->anchored_substr)[0];
bf93d4cc 2254
f2ed9b32 2255 if (utf8_target) {
4cadc6a9 2256 REXEC_FBC_SCAN(
6eb5f6b9 2257 if (*s == ch) {
a3621e74 2258 DEBUG_EXECUTE_r( did_match = 1 );
24b23f37 2259 if (regtry(&reginfo, &s)) goto got_it;
6eb5f6b9
JH
2260 s += UTF8SKIP(s);
2261 while (s < strend && *s == ch)
2262 s += UTF8SKIP(s);
2263 }
4cadc6a9 2264 );
6eb5f6b9
JH
2265 }
2266 else {
4cadc6a9 2267 REXEC_FBC_SCAN(
6eb5f6b9 2268 if (*s == ch) {
a3621e74 2269 DEBUG_EXECUTE_r( did_match = 1 );
24b23f37 2270 if (regtry(&reginfo, &s)) goto got_it;
6eb5f6b9
JH
2271 s++;
2272 while (s < strend && *s == ch)
2273 s++;
2274 }
4cadc6a9 2275 );
6eb5f6b9 2276 }
a3621e74 2277 DEBUG_EXECUTE_r(if (!did_match)
bf93d4cc 2278 PerlIO_printf(Perl_debug_log,
b7953727
JH
2279 "Did not find anchored character...\n")
2280 );
6eb5f6b9 2281 }
a0714e2c
SS
2282 else if (prog->anchored_substr != NULL
2283 || prog->anchored_utf8 != NULL
2284 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
33b8afdf
JH
2285 && prog->float_max_offset < strend - s)) {
2286 SV *must;
2287 I32 back_max;
2288 I32 back_min;
2289 char *last;
6eb5f6b9 2290 char *last1; /* Last position checked before */
bf93d4cc
GS
2291#ifdef DEBUGGING
2292 int did_match = 0;
2293#endif
33b8afdf 2294 if (prog->anchored_substr || prog->anchored_utf8) {
f2ed9b32
KW
2295 if (!(utf8_target ? prog->anchored_utf8 : prog->anchored_substr))
2296 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2297 must = utf8_target ? prog->anchored_utf8 : prog->anchored_substr;
33b8afdf
JH
2298 back_max = back_min = prog->anchored_offset;
2299 } else {
f2ed9b32
KW
2300 if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
2301 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2302 must = utf8_target ? prog->float_utf8 : prog->float_substr;
33b8afdf
JH
2303 back_max = prog->float_max_offset;
2304 back_min = prog->float_min_offset;
2305 }
1de06328
YO
2306
2307
33b8afdf
JH
2308 if (must == &PL_sv_undef)
2309 /* could not downgrade utf8 check substring, so must fail */
2310 goto phooey;
2311
1de06328
YO
2312 if (back_min<0) {
2313 last = strend;
2314 } else {
2315 last = HOP3c(strend, /* Cannot start after this */
2316 -(I32)(CHR_SVLEN(must)
2317 - (SvTAIL(must) != 0) + back_min), strbeg);
2318 }
6eb5f6b9
JH
2319 if (s > PL_bostr)
2320 last1 = HOPc(s, -1);
2321 else
2322 last1 = s - 1; /* bogus */
2323
a0288114 2324 /* XXXX check_substr already used to find "s", can optimize if
6eb5f6b9
JH
2325 check_substr==must. */
2326 scream_pos = -1;
2327 dontbother = end_shift;
2328 strend = HOPc(strend, -dontbother);
2329 while ( (s <= last) &&
9041c2e3 2330 ((flags & REXEC_SCREAM)
1de06328 2331 ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
6eb5f6b9 2332 end_shift, &scream_pos, 0))
1de06328 2333 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
9041c2e3 2334 (unsigned char*)strend, must,
7fba1cd6 2335 multiline ? FBMrf_MULTILINE : 0))) ) {
4addbd3b 2336 /* we may be pointing at the wrong string */
07bc277f 2337 if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
3f7c398e 2338 s = strbeg + (s - SvPVX_const(sv));
a3621e74 2339 DEBUG_EXECUTE_r( did_match = 1 );
6eb5f6b9
JH
2340 if (HOPc(s, -back_max) > last1) {
2341 last1 = HOPc(s, -back_min);
2342 s = HOPc(s, -back_max);
2343 }
2344 else {
52657f30 2345 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
6eb5f6b9
JH
2346
2347 last1 = HOPc(s, -back_min);
52657f30 2348 s = t;
6eb5f6b9 2349 }
f2ed9b32 2350 if (utf8_target) {
6eb5f6b9 2351 while (s <= last1) {
24b23f37 2352 if (regtry(&reginfo, &s))
6eb5f6b9
JH
2353 goto got_it;
2354 s += UTF8SKIP(s);
2355 }
2356 }
2357 else {
2358 while (s <= last1) {
24b23f37 2359 if (regtry(&reginfo, &s))
6eb5f6b9
JH
2360 goto got_it;
2361 s++;
2362 }
2363 }
2364 }
ab3bbdeb 2365 DEBUG_EXECUTE_r(if (!did_match) {
f2ed9b32 2366 RE_PV_QUOTED_DECL(quoted, utf8_target, PERL_DEBUG_PAD_ZERO(0),
ab3bbdeb
YO
2367 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2368 PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
33b8afdf 2369 ((must == prog->anchored_substr || must == prog->anchored_utf8)
bf93d4cc 2370 ? "anchored" : "floating"),
ab3bbdeb
YO
2371 quoted, RE_SV_TAIL(must));
2372 });
6eb5f6b9
JH
2373 goto phooey;
2374 }
f8fc2ecf 2375 else if ( (c = progi->regstclass) ) {
f14c76ed 2376 if (minlen) {
f8fc2ecf 2377 const OPCODE op = OP(progi->regstclass);
66e933ab 2378 /* don't bother with what can't match */
786e8c11 2379 if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
f14c76ed
RGS
2380 strend = HOPc(strend, -(minlen - 1));
2381 }
a3621e74 2382 DEBUG_EXECUTE_r({
be8e71aa 2383 SV * const prop = sv_newmortal();
32fc9b6a 2384 regprop(prog, prop, c);
0df25f3d 2385 {
f2ed9b32 2386 RE_PV_QUOTED_DECL(quoted,utf8_target,PERL_DEBUG_PAD_ZERO(1),
ab3bbdeb 2387 s,strend-s,60);
0df25f3d 2388 PerlIO_printf(Perl_debug_log,
1c8f8eb1 2389 "Matching stclass %.*s against %s (%d bytes)\n",
e4f74956 2390 (int)SvCUR(prop), SvPVX_const(prop),
ab3bbdeb 2391 quoted, (int)(strend - s));
0df25f3d 2392 }
ffc61ed2 2393 });
3b0527fe 2394 if (find_byclass(prog, c, s, strend, &reginfo))
6eb5f6b9 2395 goto got_it;
07be1b83 2396 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
d6a28714
JH
2397 }
2398 else {
2399 dontbother = 0;
a0714e2c 2400 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
33b8afdf 2401 /* Trim the end. */
d6a28714 2402 char *last;
33b8afdf
JH
2403 SV* float_real;
2404
f2ed9b32
KW
2405 if (!(utf8_target ? prog->float_utf8 : prog->float_substr))
2406 utf8_target ? to_utf8_substr(prog) : to_byte_substr(prog);
2407 float_real = utf8_target ? prog->float_utf8 : prog->float_substr;
d6a28714
JH
2408
2409 if (flags & REXEC_SCREAM) {
33b8afdf 2410 last = screaminstr(sv, float_real, s - strbeg,
d6a28714
JH
2411 end_shift, &scream_pos, 1); /* last one */
2412 if (!last)
ffc61ed2 2413 last = scream_olds; /* Only one occurrence. */
4addbd3b 2414 /* we may be pointing at the wrong string */
07bc277f 2415 else if (RXp_MATCH_COPIED(prog))
3f7c398e 2416 s = strbeg + (s - SvPVX_const(sv));
b8c5462f 2417 }
d6a28714
JH
2418 else {
2419 STRLEN len;
cfd0369c 2420 const char * const little = SvPV_const(float_real, len);
d6a28714 2421
33b8afdf 2422 if (SvTAIL(float_real)) {
d6a28714
JH
2423 if (memEQ(strend - len + 1, little, len - 1))
2424 last = strend - len + 1;
7fba1cd6 2425 else if (!multiline)
9041c2e3 2426 last = memEQ(strend - len, little, len)
bd61b366 2427 ? strend - len : NULL;
b8c5462f 2428 else
d6a28714
JH
2429 goto find_last;
2430 } else {
2431 find_last:
9041c2e3 2432 if (len)
d6a28714 2433 last = rninstr(s, strend, little, little + len);
b8c5462f 2434 else
a0288114 2435 last = strend; /* matching "$" */
b8c5462f 2436 }
b8c5462f 2437 }
bf93d4cc 2438 if (last == NULL) {
6bda09f9
YO
2439 DEBUG_EXECUTE_r(
2440 PerlIO_printf(Perl_debug_log,
2441 "%sCan't trim the tail, match fails (should not happen)%s\n",
2442 PL_colors[4], PL_colors[5]));
bf93d4cc
GS
2443 goto phooey; /* Should not happen! */
2444 }
d6a28714
JH
2445 dontbother = strend - last + prog->float_min_offset;
2446 }
2447 if (minlen && (dontbother < minlen))
2448 dontbother = minlen - 1;
2449 strend -= dontbother; /* this one's always in bytes! */
2450 /* We don't know much -- general case. */
f2ed9b32 2451 if (utf8_target) {
d6a28714 2452 for (;;) {
24b23f37 2453 if (regtry(&reginfo, &s))
d6a28714
JH
2454 goto got_it;
2455 if (s >= strend)
2456 break;
b8c5462f 2457 s += UTF8SKIP(s);
d6a28714
JH
2458 };
2459 }
2460 else {
2461 do {
24b23f37 2462 if (regtry(&reginfo, &s))
d6a28714
JH
2463 goto got_it;
2464 } while (s++ < strend);
2465 }
2466 }
2467
2468 /* Failure. */
2469 goto phooey;
2470
2471got_it:
e9105d30 2472 Safefree(swap);
288b8c02 2473 RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
d6a28714 2474
19b95bf0 2475 if (PL_reg_eval_set)
4f639d21 2476 restore_pos(aTHX_ prog);
5daac39c
NC
2477 if (RXp_PAREN_NAMES(prog))
2478 (void)hv_iterinit(RXp_PAREN_NAMES(prog));
d6a28714
JH
2479
2480 /* make sure $`, $&, $', and $digit will work later */
2481 if ( !(flags & REXEC_NOT_FIRST) ) {
288b8c02 2482 RX_MATCH_COPY_FREE(rx);
d6a28714 2483 if (flags & REXEC_COPY_STR) {
be8e71aa 2484 const I32 i = PL_regeol - startpos + (stringarg - strbeg);
f8c7b90f 2485#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2486 if ((SvIsCOW(sv)
2487 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2488 if (DEBUG_C_TEST) {
2489 PerlIO_printf(Perl_debug_log,
2490 "Copy on write: regexp capture, type %d\n",
2491 (int) SvTYPE(sv));
2492 }
2493 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
d5263905 2494 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
ed252734
NC
2495 assert (SvPOKp(prog->saved_copy));
2496 } else
2497#endif
2498 {
288b8c02 2499 RX_MATCH_COPIED_on(rx);
ed252734
NC
2500 s = savepvn(strbeg, i);
2501 prog->subbeg = s;
2502 }
d6a28714 2503 prog->sublen = i;
d6a28714
JH
2504 }
2505 else {
2506 prog->subbeg = strbeg;
2507 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2508 }
2509 }
9041c2e3 2510
d6a28714
JH
2511 return 1;
2512
2513phooey:
a3621e74 2514 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
e4584336 2515 PL_colors[4], PL_colors[5]));
d6a28714 2516 if (PL_reg_eval_set)
4f639d21 2517 restore_pos(aTHX_ prog);
e9105d30 2518 if (swap) {
c74340f9 2519 /* we failed :-( roll it back */
e9105d30
GG
2520 Safefree(prog->offs);
2521 prog->offs = swap;
2522 }
2523
d6a28714
JH
2524 return 0;
2525}
2526
6bda09f9 2527
d6a28714
JH
2528/*
2529 - regtry - try match at specific point
2530 */
2531STATIC I32 /* 0 failure, 1 success */
24b23f37 2532S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
d6a28714 2533{
97aff369 2534 dVAR;
d6a28714 2535 CHECKPOINT lastcp;
288b8c02
NC
2536 REGEXP *const rx = reginfo->prog;
2537 regexp *const prog = (struct regexp *)SvANY(rx);
f8fc2ecf 2538 RXi_GET_DECL(prog,progi);
a3621e74 2539 GET_RE_DEBUG_FLAGS_DECL;
7918f24d
NC
2540
2541 PERL_ARGS_ASSERT_REGTRY;
2542
24b23f37 2543 reginfo->cutpoint=NULL;
d6a28714 2544
bbe252da 2545 if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
d6a28714
JH
2546 MAGIC *mg;
2547
2548 PL_reg_eval_set = RS_init;
a3621e74 2549 DEBUG_EXECUTE_r(DEBUG_s(
b900a521
JH
2550 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2551 (IV)(PL_stack_sp - PL_stack_base));
d6a28714 2552 ));
ea8d6ae1 2553 SAVESTACK_CXPOS();
d6a28714
JH
2554 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2555 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2556 SAVETMPS;
2557 /* Apparently this is not needed, judging by wantarray. */
e8347627 2558 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
d6a28714
JH
2559 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2560
3b0527fe 2561 if (reginfo->sv) {
d6a28714 2562 /* Make $_ available to executed code. */
3b0527fe 2563 if (reginfo->sv != DEFSV) {
59f00321 2564 SAVE_DEFSV;
414bf5ae 2565 DEFSV_set(reginfo->sv);
b8c5462f 2566 }
d6a28714 2567
3b0527fe
DM
2568 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2569 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
d6a28714 2570 /* prepare for quick setting of pos */
d300d9fa 2571#ifdef PERL_OLD_COPY_ON_WRITE
51a9ea20
NC
2572 if (SvIsCOW(reginfo->sv))
2573 sv_force_normal_flags(reginfo->sv, 0);
d300d9fa 2574#endif
3dab1dad 2575 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
d300d9fa 2576 &PL_vtbl_mglob, NULL, 0);
d6a28714 2577 mg->mg_len = -1;
b8c5462f 2578 }
d6a28714
JH
2579 PL_reg_magic = mg;
2580 PL_reg_oldpos = mg->mg_len;
4f639d21 2581 SAVEDESTRUCTOR_X(restore_pos, prog);
d6a28714 2582 }
09687e5a 2583 if (!PL_reg_curpm) {
a02a5408 2584 Newxz(PL_reg_curpm, 1, PMOP);
09687e5a
AB
2585#ifdef USE_ITHREADS
2586 {
14a49a24 2587 SV* const repointer = &PL_sv_undef;
92313705
NC
2588 /* this regexp is also owned by the new PL_reg_curpm, which
2589 will try to free it. */
d2ece331 2590 av_push(PL_regex_padav, repointer);
09687e5a
AB
2591 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2592 PL_regex_pad = AvARRAY(PL_regex_padav);
2593 }
2594#endif
2595 }
86c29d75
NC
2596#ifdef USE_ITHREADS
2597 /* It seems that non-ithreads works both with and without this code.
2598 So for efficiency reasons it seems best not to have the code
2599 compiled when it is not needed. */
92313705
NC
2600 /* This is safe against NULLs: */
2601 ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2602 /* PM_reg_curpm owns a reference to this regexp. */
2603 ReREFCNT_inc(rx);
86c29d75 2604#endif
288b8c02 2605 PM_SETRE(PL_reg_curpm, rx);
d6a28714
JH
2606 PL_reg_oldcurpm = PL_curpm;
2607 PL_curpm = PL_reg_curpm;
07bc277f 2608 if (RXp_MATCH_COPIED(prog)) {
d6a28714
JH
2609 /* Here is a serious problem: we cannot rewrite subbeg,
2610 since it may be needed if this match fails. Thus
2611 $` inside (?{}) could fail... */
2612 PL_reg_oldsaved = prog->subbeg;
2613 PL_reg_oldsavedlen = prog->sublen;
f8c7b90f 2614#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC
2615 PL_nrs = prog->saved_copy;
2616#endif
07bc277f 2617 RXp_MATCH_COPIED_off(prog);
d6a28714
JH
2618 }
2619 else
bd61b366 2620 PL_reg_oldsaved = NULL;
d6a28714
JH
2621 prog->subbeg = PL_bostr;
2622 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2623 }
24b23f37 2624 DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
f0ab9afb 2625 prog->offs[0].start = *startpos - PL_bostr;
24b23f37 2626 PL_reginput = *startpos;
d6a28714 2627 PL_reglastparen = &prog->lastparen;
a01268b5 2628 PL_reglastcloseparen = &prog->lastcloseparen;
d6a28714 2629 prog->lastparen = 0;
03994de8 2630 prog->lastcloseparen = 0;
d6a28714 2631 PL_regsize = 0;
f0ab9afb 2632 PL_regoffs = prog->offs;
d6a28714
JH
2633 if (PL_reg_start_tmpl <= prog->nparens) {
2634 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2635 if(PL_reg_start_tmp)
2636 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2637 else
a02a5408 2638 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
d6a28714
JH
2639 }
2640
2641 /* XXXX What this code is doing here?!!! There should be no need
2642 to do this again and again, PL_reglastparen should take care of
3dd2943c 2643 this! --ilya*/
dafc8851
JH
2644
2645 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2646 * Actually, the code in regcppop() (which Ilya may be meaning by
daf18116 2647 * PL_reglastparen), is not needed at all by the test suite
225593e1
DM
2648 * (op/regexp, op/pat, op/split), but that code is needed otherwise
2649 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2650 * Meanwhile, this code *is* needed for the
daf18116
JH
2651 * above-mentioned test suite tests to succeed. The common theme
2652 * on those tests seems to be returning null fields from matches.
225593e1 2653 * --jhi updated by dapm */
dafc8851 2654#if 1
d6a28714 2655 if (prog->nparens) {
f0ab9afb 2656 regexp_paren_pair *pp = PL_regoffs;
097eb12c 2657 register I32 i;
eb160463 2658 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
f0ab9afb
NC
2659 ++pp;
2660 pp->start = -1;
2661 pp->end = -1;
d6a28714
JH
2662 }
2663 }
dafc8851 2664#endif
02db2b7b 2665 REGCP_SET(lastcp);
f8fc2ecf 2666 if (regmatch(reginfo, progi->program + 1)) {
f0ab9afb 2667 PL_regoffs[0].end = PL_reginput - PL_bostr;
d6a28714
JH
2668 return 1;
2669 }
24b23f37
YO
2670 if (reginfo->cutpoint)
2671 *startpos= reginfo->cutpoint;
02db2b7b 2672 REGCP_UNWIND(lastcp);
d6a28714
JH
2673 return 0;
2674}
2675
02db2b7b 2676
8ba1375e
MJD
2677#define sayYES goto yes
2678#define sayNO goto no
262b90c4 2679#define sayNO_SILENT goto no_silent
8ba1375e 2680
f9f4320a
YO
2681/* we dont use STMT_START/END here because it leads to
2682 "unreachable code" warnings, which are bogus, but distracting. */
2683#define CACHEsayNO \
c476f425
DM
2684 if (ST.cache_mask) \
2685 PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
f9f4320a 2686 sayNO
3298f257 2687
a3621e74 2688/* this is used to determine how far from the left messages like
265c4333
YO
2689 'failed...' are printed. It should be set such that messages
2690 are inline with the regop output that created them.
a3621e74 2691*/
265c4333 2692#define REPORT_CODE_OFF 32
a3621e74
YO
2693
2694
40a82448
DM
2695#define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2696#define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
9e137952 2697
86545054
DM
2698#define SLAB_FIRST(s) (&(s)->states[0])
2699#define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2700
5d9a96ca
DM
2701/* grab a new slab and return the first slot in it */
2702
2703STATIC regmatch_state *
2704S_push_slab(pTHX)
2705{
a35a87e7 2706#if PERL_VERSION < 9 && !defined(PERL_CORE)
54df2634
NC
2707 dMY_CXT;
2708#endif
5d9a96ca
DM
2709 regmatch_slab *s = PL_regmatch_slab->next;
2710 if (!s) {
2711 Newx(s, 1, regmatch_slab);
2712 s->prev = PL_regmatch_slab;
2713 s->next = NULL;
2714 PL_regmatch_slab->next = s;
2715 }
2716 PL_regmatch_slab = s;
86545054 2717 return SLAB_FIRST(s);
5d9a96ca 2718}
5b47454d 2719
95b24440 2720
40a82448
DM
2721/* push a new state then goto it */
2722
2723#define PUSH_STATE_GOTO(state, node) \
2724 scan = node; \
2725 st->resume_state = state; \
2726 goto push_state;
2727
2728/* push a new state with success backtracking, then goto it */
2729
2730#define PUSH_YES_STATE_GOTO(state, node) \
2731 scan = node; \
2732 st->resume_state = state; \
2733 goto push_yes_state;
2734
aa283a38 2735
aa283a38 2736
d6a28714 2737/*
95b24440 2738
bf1f174e
DM
2739regmatch() - main matching routine
2740
2741This is basically one big switch statement in a loop. We execute an op,
2742set 'next' to point the next op, and continue. If we come to a point which
2743we may need to backtrack to on failure such as (A|B|C), we push a
2744backtrack state onto the backtrack stack. On failure, we pop the top
2745state, and re-enter the loop at the state indicated. If there are no more
2746states to pop, we return failure.
2747
2748Sometimes we also need to backtrack on success; for example /A+/, where
2749after successfully matching one A, we need to go back and try to
2750match another one; similarly for lookahead assertions: if the assertion
2751completes successfully, we backtrack to the state just before the assertion
2752and then carry on. In these cases, the pushed state is marked as
2753'backtrack on success too'. This marking is in fact done by a chain of
2754pointers, each pointing to the previous 'yes' state. On success, we pop to
2755the nearest yes state, discarding any intermediate failure-only states.
2756Sometimes a yes state is pushed just to force some cleanup code to be
2757called at the end of a successful match or submatch; e.g. (??{$re}) uses
2758it to free the inner regex.
2759
2760Note that failure backtracking rewinds the cursor position, while
2761success backtracking leaves it alone.
2762
2763A pattern is complete when the END op is executed, while a subpattern
2764such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2765ops trigger the "pop to last yes state if any, otherwise return true"
2766behaviour.
2767
2768A common convention in this function is to use A and B to refer to the two
2769subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2770the subpattern to be matched possibly multiple times, while B is the entire
2771rest of the pattern. Variable and state names reflect this convention.
2772
2773The states in the main switch are the union of ops and failure/success of
2774substates associated with with that op. For example, IFMATCH is the op
2775that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2776'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2777successfully matched A and IFMATCH_A_fail is a state saying that we have
2778just failed to match A. Resume states always come in pairs. The backtrack
2779state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2780at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2781on success or failure.
2782
2783The struct that holds a backtracking state is actually a big union, with
2784one variant for each major type of op. The variable st points to the
2785top-most backtrack struct. To make the code clearer, within each
2786block of code we #define ST to alias the relevant union.
2787
2788Here's a concrete example of a (vastly oversimplified) IFMATCH
2789implementation:
2790
2791 switch (state) {
2792 ....
2793
2794#define ST st->u.ifmatch
2795
2796 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2797 ST.foo = ...; // some state we wish to save
95b24440 2798 ...
bf1f174e
DM
2799 // push a yes backtrack state with a resume value of
2800 // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2801 // first node of A:
2802 PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2803 // NOTREACHED
2804
2805 case IFMATCH_A: // we have successfully executed A; now continue with B
2806 next = B;
2807 bar = ST.foo; // do something with the preserved value
2808 break;
2809
2810 case IFMATCH_A_fail: // A failed, so the assertion failed
2811 ...; // do some housekeeping, then ...
2812 sayNO; // propagate the failure
2813
2814#undef ST
95b24440 2815
bf1f174e
DM
2816 ...
2817 }
95b24440 2818
bf1f174e
DM
2819For any old-timers reading this who are familiar with the old recursive
2820approach, the code above is equivalent to:
95b24440 2821
bf1f174e
DM
2822 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2823 {
2824 int foo = ...
95b24440 2825 ...
bf1f174e
DM
2826 if (regmatch(A)) {
2827 next = B;
2828 bar = foo;
2829 break;
95b24440 2830 }
bf1f174e
DM
2831 ...; // do some housekeeping, then ...
2832 sayNO; // propagate the failure
95b24440 2833 }
bf1f174e
DM
2834
2835The topmost backtrack state, pointed to by st, is usually free. If you
2836want to claim it, populate any ST.foo fields in it with values you wish to
2837save, then do one of
2838
2839 PUSH_STATE_GOTO(resume_state, node);
2840 PUSH_YES_STATE_GOTO(resume_state, node);
2841
2842which sets that backtrack state's resume value to 'resume_state', pushes a
2843new free entry to the top of the backtrack stack, then goes to 'node'.
2844On backtracking, the free slot is popped, and the saved state becomes the
2845new free state. An ST.foo field in this new top state can be temporarily
2846accessed to retrieve values, but once the main loop is re-entered, it
2847becomes available for reuse.
2848
2849Note that the depth of the backtrack stack constantly increases during the
2850left-to-right execution of the pattern, rather than going up and down with
2851the pattern nesting. For example the stack is at its maximum at Z at the
2852end of the pattern, rather than at X in the following:
2853
2854 /(((X)+)+)+....(Y)+....Z/
2855
2856The only exceptions to this are lookahead/behind assertions and the cut,
2857(?>A), which pop all the backtrack states associated with A before
2858continuing.
2859
486ec47a 2860Backtrack state structs are allocated in slabs of about 4K in size.
bf1f174e
DM
2861PL_regmatch_state and st always point to the currently active state,
2862and PL_regmatch_slab points to the slab currently containing
2863PL_regmatch_state. The first time regmatch() is called, the first slab is
2864allocated, and is never freed until interpreter destruction. When the slab
2865is full, a new one is allocated and chained to the end. At exit from
2866regmatch(), slabs allocated since entry are freed.
2867
2868*/
95b24440 2869
40a82448 2870
5bc10b2c 2871#define DEBUG_STATE_pp(pp) \
265c4333 2872 DEBUG_STATE_r({ \
f2ed9b32 2873 DUMP_EXEC_POS(locinput, scan, utf8_target); \
5bc10b2c 2874 PerlIO_printf(Perl_debug_log, \
5d458dd8 2875 " %*s"pp" %s%s%s%s%s\n", \
5bc10b2c 2876 depth*2, "", \
13d6edb4 2877 PL_reg_name[st->resume_state], \
5d458dd8
YO
2878 ((st==yes_state||st==mark_state) ? "[" : ""), \
2879 ((st==yes_state) ? "Y" : ""), \
2880 ((st==mark_state) ? "M" : ""), \
2881 ((st==yes_state||st==mark_state) ? "]" : "") \
2882 ); \
265c4333 2883 });
5bc10b2c 2884
40a82448 2885
3dab1dad 2886#define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
95b24440 2887
3df15adc 2888#ifdef DEBUGGING
5bc10b2c 2889
ab3bbdeb 2890STATIC void
f2ed9b32 2891S_debug_start_match(pTHX_ const REGEXP *prog, const bool utf8_target,
ab3bbdeb
YO
2892 const char *start, const char *end, const char *blurb)
2893{
efd26800 2894 const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
7918f24d
NC
2895
2896 PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2897
ab3bbdeb
YO
2898 if (!PL_colorset)
2899 reginitcolors();
2900 {
2901 RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
d2c6dc5e 2902 RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
ab3bbdeb 2903
f2ed9b32 2904 RE_PV_QUOTED_DECL(s1, utf8_target, PERL_DEBUG_PAD_ZERO(1),
ab3bbdeb
YO
2905 start, end - start, 60);
2906
2907 PerlIO_printf(Perl_debug_log,
2908 "%s%s REx%s %s against %s\n",
2909 PL_colors[4], blurb, PL_colors[5], s0, s1);
2910
f2ed9b32 2911 if (utf8_target||utf8_pat)
1de06328
YO
2912 PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2913 utf8_pat ? "pattern" : "",
f2ed9b32
KW
2914 utf8_pat && utf8_target ? " and " : "",
2915 utf8_target ? "string" : ""
ab3bbdeb
YO
2916 );
2917 }
2918}
3df15adc
YO
2919
2920STATIC void
786e8c11
YO
2921S_dump_exec_pos(pTHX_ const char *locinput,
2922 const regnode *scan,
2923 const char *loc_regeol,
2924 const char *loc_bostr,
2925 const char *loc_reg_starttry,
f2ed9b32 2926 const bool utf8_target)
07be1b83 2927{
786e8c11 2928 const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
07be1b83 2929 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
786e8c11 2930 int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
07be1b83
YO
2931 /* The part of the string before starttry has one color
2932 (pref0_len chars), between starttry and current
2933 position another one (pref_len - pref0_len chars),
2934 after the current position the third one.
2935 We assume that pref0_len <= pref_len, otherwise we
2936 decrease pref0_len. */
786e8c11
YO
2937 int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2938 ? (5 + taill) - l : locinput - loc_bostr;
07be1b83
YO
2939 int pref0_len;
2940
7918f24d
NC
2941 PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2942
f2ed9b32 2943 while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
07be1b83 2944 pref_len++;
786e8c11
YO
2945 pref0_len = pref_len - (locinput - loc_reg_starttry);
2946 if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2947 l = ( loc_regeol - locinput > (5 + taill) - pref_len
2948 ? (5 + taill) - pref_len : loc_regeol - locinput);
f2ed9b32 2949 while (utf8_target && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
07be1b83
YO
2950 l--;
2951 if (pref0_len < 0)
2952 pref0_len = 0;
2953 if (pref0_len > pref_len)
2954 pref0_len = pref_len;
2955 {
f2ed9b32 2956 const int is_uni = (utf8_target && OP(scan) != CANY) ? 1 : 0;
0df25f3d 2957
ab3bbdeb 2958 RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
1de06328 2959 (locinput - pref_len),pref0_len, 60, 4, 5);
0df25f3d 2960
ab3bbdeb 2961 RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3df15adc 2962 (locinput - pref_len + pref0_len),
1de06328 2963 pref_len - pref0_len, 60, 2, 3);
0df25f3d 2964
ab3bbdeb 2965 RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
1de06328 2966 locinput, loc_regeol - locinput, 10, 0, 1);
0df25f3d 2967
1de06328 2968 const STRLEN tlen=len0+len1+len2;
3df15adc 2969 PerlIO_printf(Perl_debug_log,
ab3bbdeb 2970 "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
786e8c11 2971 (IV)(locinput - loc_bostr),
07be1b83 2972 len0, s0,
07be1b83 2973 len1, s1,
07be1b83 2974 (docolor ? "" : "> <"),
07be1b83 2975 len2, s2,
f9f4320a 2976 (int)(tlen > 19 ? 0 : 19 - tlen),
07be1b83
YO
2977 "");
2978 }
2979}
3df15adc 2980
07be1b83
YO
2981#endif
2982
0a4db386
YO
2983/* reg_check_named_buff_matched()
2984 * Checks to see if a named buffer has matched. The data array of
2985 * buffer numbers corresponding to the buffer is expected to reside
2986 * in the regexp->data->data array in the slot stored in the ARG() of
2987 * node involved. Note that this routine doesn't actually care about the
2988 * name, that information is not preserved from compilation to execution.
2989 * Returns the index of the leftmost defined buffer with the given name
2990 * or 0 if non of the buffers matched.
2991 */
2992STATIC I32
7918f24d
NC
2993S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2994{
0a4db386 2995 I32 n;
f8fc2ecf 2996 RXi_GET_DECL(rex,rexi);
ad64d0ec 2997 SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
0a4db386 2998 I32 *nums=(I32*)SvPVX(sv_dat);
7918f24d
NC
2999
3000 PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
3001
0a4db386
YO
3002 for ( n=0; n<SvIVX(sv_dat); n++ ) {
3003 if ((I32)*PL_reglastparen >= nums[n] &&
f0ab9afb 3004 PL_regoffs[nums[n]].end != -1)
0a4db386
YO
3005 {
3006 return nums[n];
3007 }
3008 }
3009 return 0;
3010}
3011
2f554ef7
DM
3012
3013/* free all slabs above current one - called during LEAVE_SCOPE */
3014
3015STATIC void
3016S_clear_backtrack_stack(pTHX_ void *p)
3017{
3018 regmatch_slab *s = PL_regmatch_slab->next;
3019 PERL_UNUSED_ARG(p);
3020
3021 if (!s)
3022 return;
3023 PL_regmatch_slab->next = NULL;
3024 while (s) {
3025 regmatch_slab * const osl = s;
3026 s = s->next;
3027 Safefree(osl);
3028 }
3029}
3030
3031
28d8d7f4
YO
3032#define SETREX(Re1,Re2) \
3033 if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
3034 Re1 = (Re2)
3035
d6a28714 3036STATIC I32 /* 0 failure, 1 success */
24b23f37 3037S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
d6a28714 3038{
a35a87e7 3039#if PERL_VERSION < 9 && !defined(PERL_CORE)
54df2634
NC
3040 dMY_CXT;
3041#endif
27da23d5 3042 dVAR;
f2ed9b32 3043 register const bool utf8_target = PL_reg_match_utf8;
4ad0818d 3044 const U32 uniflags = UTF8_ALLOW_DEFAULT;
288b8c02
NC
3045 REGEXP *rex_sv = reginfo->prog;
3046 regexp *rex = (struct regexp *)SvANY(rex_sv);
f8fc2ecf 3047 RXi_GET_DECL(rex,rexi);
2f554ef7 3048 I32 oldsave;
5d9a96ca
DM
3049 /* the current state. This is a cached copy of PL_regmatch_state */
3050 register regmatch_state *st;
5d9a96ca
DM
3051 /* cache heavy used fields of st in registers */
3052 register regnode *scan;
3053 register regnode *next;
438e9bae 3054 register U32 n = 0; /* general value; init to avoid compiler warning */
24d3c4a9 3055 register I32 ln = 0; /* len or last; init to avoid compiler warning */
5d9a96ca 3056 register char *locinput = PL_reginput;
5d9a96ca 3057 register I32 nextchr; /* is always set to UCHARAT(locinput) */
24d3c4a9 3058
b69b0499 3059 bool result = 0; /* return value of S_regmatch */
24d3c4a9 3060 int depth = 0; /* depth of backtrack stack */
4b196cd4
YO
3061 U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
3062 const U32 max_nochange_depth =
3063 (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
3064 3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
77cb431f
DM
3065 regmatch_state *yes_state = NULL; /* state to pop to on success of
3066 subpattern */
e2e6a0f1
YO
3067 /* mark_state piggy backs on the yes_state logic so that when we unwind
3068 the stack on success we can update the mark_state as we go */
3069 regmatch_state *mark_state = NULL; /* last mark state we have seen */
faec1544 3070 regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
b8591aee 3071 struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
40a82448 3072 U32 state_num;
5d458dd8
YO
3073 bool no_final = 0; /* prevent failure from backtracking? */
3074 bool do_cutgroup = 0; /* no_final only until next branch/trie entry */
e2e6a0f1 3075 char *startpoint = PL_reginput;
5d458dd8
YO
3076 SV *popmark = NULL; /* are we looking for a mark? */
3077 SV *sv_commit = NULL; /* last mark name seen in failure */
3078 SV *sv_yes_mark = NULL; /* last mark name we have seen
486ec47a 3079 during a successful match */
5d458dd8
YO
3080 U32 lastopen = 0; /* last open we saw */
3081 bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
19b95bf0 3082 SV* const oreplsv = GvSV(PL_replgv);
24d3c4a9
DM
3083 /* these three flags are set by various ops to signal information to
3084 * the very next op. They have a useful lifetime of exactly one loop
3085 * iteration, and are not preserved or restored by state pushes/pops
3086 */
3087 bool sw = 0; /* the condition value in (?(cond)a|b) */
3088 bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
3089 int logical = 0; /* the following EVAL is:
3090 0: (?{...})
3091 1: (?(?{...})X|Y)
3092 2: (??{...})
3093 or the following IFMATCH/UNLESSM is:
3094 false: plain (?=foo)
3095 true: used as a condition: (?(?=foo))
3096 */
95b24440 3097#ifdef DEBUGGING
e68ec53f 3098 GET_RE_DEBUG_FLAGS_DECL;
d6a28714
JH
3099#endif
3100
7918f24d
NC
3101 PERL_ARGS_ASSERT_REGMATCH;
3102
3b57cd43 3103 DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
24b23f37 3104 PerlIO_printf(Perl_debug_log,"regmatch start\n");
3b57cd43 3105 }));
5d9a96ca
DM
3106 /* on first ever call to regmatch, allocate first slab */
3107 if (!PL_regmatch_slab) {
3108 Newx(PL_regmatch_slab, 1, regmatch_slab);
3109 PL_regmatch_slab->prev = NULL;
3110 PL_regmatch_slab->next = NULL;
86545054 3111 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
5d9a96ca
DM
3112 }
3113
2f554ef7
DM
3114 oldsave = PL_savestack_ix;
3115 SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
3116 SAVEVPTR(PL_regmatch_slab);
3117 SAVEVPTR(PL_regmatch_state);
5d9a96ca
DM
3118
3119 /* grab next free state slot */
3120 st = ++PL_regmatch_state;
86545054 3121 if (st > SLAB_LAST(PL_regmatch_slab))
5d9a96ca
DM
3122 st = PL_regmatch_state = S_push_slab(aTHX);
3123
d6a28714
JH
3124 /* Note that nextchr is a byte even in UTF */
3125 nextchr = UCHARAT(locinput);
3126 scan = prog;
3127 while (scan != NULL) {
8ba1375e 3128
a3621e74 3129 DEBUG_EXECUTE_r( {
6136c704 3130 SV * const prop = sv_newmortal();
1de06328 3131 regnode *rnext=regnext(scan);
f2ed9b32 3132 DUMP_EXEC_POS( locinput, scan, utf8_target );
32fc9b6a 3133 regprop(rex, prop, scan);
07be1b83
YO
3134
3135 PerlIO_printf(Perl_debug_log,
3136 "%3"IVdf":%*s%s(%"IVdf")\n",
f8fc2ecf 3137 (IV)(scan - rexi->program), depth*2, "",
07be1b83 3138 SvPVX_const(prop),
1de06328 3139 (PL_regkind[OP(scan)] == END || !rnext) ?
f8fc2ecf 3140 0 : (IV)(rnext - rexi->program));
2a782b5b 3141 });
d6a28714
JH
3142
3143 next = scan + NEXT_OFF(scan);
3144 if (next == scan)
3145 next = NULL;
40a82448 3146 state_num = OP(scan);
d6a28714 3147
40a82448 3148 reenter_switch:
34a81e2b
B
3149
3150 assert(PL_reglastparen == &rex->lastparen);
3151 assert(PL_reglastcloseparen == &rex->lastcloseparen);
3152 assert(PL_regoffs == rex->offs);
3153
40a82448 3154 switch (state_num) {
d6a28714 3155 case BOL:
7fba1cd6 3156 if (locinput == PL_bostr)
d6a28714 3157 {
3b0527fe 3158 /* reginfo->till = reginfo->bol; */
b8c5462f
JH
3159 break;
3160 }
d6a28714
JH
3161 sayNO;
3162 case MBOL:
12d33761
HS
3163 if (locinput == PL_bostr ||
3164 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
d6a28714 3165 {
b8c5462f
JH
3166 break;
3167 }
d6a28714
JH
3168 sayNO;
3169 case SBOL:
c2a73568 3170 if (locinput == PL_bostr)
b8c5462f 3171 break;
d6a28714
JH
3172 sayNO;
3173 case GPOS:
3b0527fe 3174 if (locinput == reginfo->ganch)
d6a28714
JH
3175 break;
3176 sayNO;
ee9b8eae
YO
3177
3178 case KEEPS:
3179 /* update the startpoint */
f0ab9afb 3180 st->u.keeper.val = PL_regoffs[0].start;
ee9b8eae 3181 PL_reginput = locinput;
f0ab9afb 3182 PL_regoffs[0].start = locinput - PL_bostr;
ee9b8eae
YO
3183 PUSH_STATE_GOTO(KEEPS_next, next);
3184 /*NOT-REACHED*/
3185 case KEEPS_next_fail:
3186 /* rollback the start point change */
f0ab9afb 3187 PL_regoffs[0].start = st->u.keeper.val;
ee9b8eae
YO
3188 sayNO_SILENT;
3189 /*NOT-REACHED*/
d6a28714 3190 case EOL:
d6a28714
JH
3191 goto seol;
3192 case MEOL:
d6a28714 3193 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
b8c5462f 3194 sayNO;
b8c5462f 3195 break;
d6a28714
JH
3196 case SEOL:
3197 seol:
3198 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
b8c5462f 3199 sayNO;
d6a28714 3200 if (PL_regeol - locinput > 1)
b8c5462f 3201 sayNO;
b8c5462f 3202 break;
d6a28714
JH
3203 case EOS:
3204 if (PL_regeol != locinput)
b8c5462f 3205 sayNO;
d6a28714 3206 break;
ffc61ed2 3207 case SANY:
d6a28714 3208 if (!nextchr && locinput >= PL_regeol)
4633a7c4 3209 sayNO;
f2ed9b32 3210 if (utf8_target) {
f33976b4
DB
3211 locinput += PL_utf8skip[nextchr];
3212 if (locinput > PL_regeol)
3213 sayNO;
3214 nextchr = UCHARAT(locinput);
3215 }
3216 else
3217 nextchr = UCHARAT(++locinput);
3218 break;
3219 case CANY:
3220 if (!nextchr && locinput >= PL_regeol)
3221 sayNO;
b8c5462f 3222 nextchr = UCHARAT(++locinput);
a0d0e21e 3223 break;
ffc61ed2 3224 case REG_ANY:
1aa99e6b
IH
3225 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
3226 sayNO;
f2ed9b32 3227 if (utf8_target) {
b8c5462f 3228 locinput += PL_utf8skip[nextchr];
d6a28714
JH
3229 if (locinput > PL_regeol)
3230 sayNO;
a0ed51b3 3231 nextchr = UCHARAT(locinput);
a0ed51b3 3232 }
1aa99e6b
IH
3233 else
3234 nextchr = UCHARAT(++locinput);
a0ed51b3 3235 break;
166ba7cd
DM
3236
3237#undef ST
3238#define ST st->u.trie
786e8c11
YO
3239 case TRIEC:
3240 /* In this case the charclass data is available inline so
3241 we can fail fast without a lot of extra overhead.
3242 */
f2ed9b32 3243 if (scan->flags == EXACT || !utf8_target) {
786e8c11
YO
3244 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3245 DEBUG_EXECUTE_r(
3246 PerlIO_printf(Perl_debug_log,
3247 "%*s %sfailed to match trie start class...%s\n",
5bc10b2c 3248 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
786e8c11
YO
3249 );
3250 sayNO_SILENT;
3251 /* NOTREACHED */
3252 }
3253 }
3254 /* FALL THROUGH */
5b47454d 3255 case TRIE:
2e64971a
DM
3256 /* the basic plan of execution of the trie is:
3257 * At the beginning, run though all the states, and
3258 * find the longest-matching word. Also remember the position
3259 * of the shortest matching word. For example, this pattern:
3260 * 1 2 3 4 5
3261 * ab|a|x|abcd|abc
3262 * when matched against the string "abcde", will generate
3263 * accept states for all words except 3, with the longest
3264 * matching word being 4, and the shortest being 1 (with
3265 * the position being after char 1 of the string).
3266 *
3267 * Then for each matching word, in word order (i.e. 1,2,4,5),
3268 * we run the remainder of the pattern; on each try setting
3269 * the current position to the character following the word,
3270 * returning to try the next word on failure.
3271 *
3272 * We avoid having to build a list of words at runtime by
3273 * using a compile-time structure, wordinfo[].prev, which
3274 * gives, for each word, the previous accepting word (if any).
3275 * In the case above it would contain the mappings 1->2, 2->0,
3276 * 3->0, 4->5, 5->1. We can use this table to generate, from
3277 * the longest word (4 above), a list of all words, by
3278 * following the list of prev pointers; this gives us the
3279 * unordered list 4,5,1,2. Then given the current word we have
3280 * just tried, we can go through the list and find the
3281 * next-biggest word to try (so if we just failed on word 2,
3282 * the next in the list is 4).
3283 *
3284 * Since at runtime we don't record the matching position in
3285 * the string for each word, we have to work that out for
3286 * each word we're about to process. The wordinfo table holds
3287 * the character length of each word; given that we recorded
3288 * at the start: the position of the shortest word and its
3289 * length in chars, we just need to move the pointer the
3290 * difference between the two char lengths. Depending on
3291 * Unicode status and folding, that's cheap or expensive.
3292 *
3293 * This algorithm is optimised for the case where are only a
3294 * small number of accept states, i.e. 0,1, or maybe 2.
3295 * With lots of accepts states, and having to try all of them,
3296 * it becomes quadratic on number of accept states to find all
3297 * the next words.
3298 */
3299
3dab1dad 3300 {
07be1b83 3301 /* what type of TRIE am I? (utf8 makes this contextual) */
a0a388a1 3302 DECL_TRIE_TYPE(scan);
3dab1dad
YO
3303
3304 /* what trie are we using right now */
be8e71aa 3305 reg_trie_data * const trie
f8fc2ecf 3306 = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
85fbaab2 3307 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3dab1dad 3308 U32 state = trie->startstate;
166ba7cd 3309
3dab1dad
YO
3310 if (trie->bitmap && trie_type != trie_utf8_fold &&
3311 !TRIE_BITMAP_TEST(trie,*locinput)
3312 ) {
3313 if (trie->states[ state ].wordnum) {
3314 DEBUG_EXECUTE_r(
3315 PerlIO_printf(Perl_debug_log,
3316 "%*s %smatched empty string...%s\n",
5bc10b2c 3317 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3dab1dad 3318 );
20dbff7c
YO
3319 if (!trie->jump)
3320 break;
3dab1dad
YO
3321 } else {
3322 DEBUG_EXECUTE_r(
3323 PerlIO_printf(Perl_debug_log,
786e8c11 3324 "%*s %sfailed to match trie start class...%s\n",
5bc10b2c 3325 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3dab1dad
YO
3326 );
3327 sayNO_SILENT;
3328 }
3329 }
166ba7cd 3330
786e8c11
YO
3331 {
3332 U8 *uc = ( U8* )locinput;
3333
3334 STRLEN len = 0;
3335 STRLEN foldlen = 0;
3336 U8 *uscan = (U8*)NULL;
786e8c11 3337 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2e64971a
DM
3338 U32 charcount = 0; /* how many input chars we have matched */
3339 U32 accepted = 0; /* have we seen any accepting states? */
786e8c11 3340
786e8c11
YO
3341 ST.B = next;
3342 ST.jump = trie->jump;
786e8c11 3343 ST.me = scan;
2e64971a
DM
3344 ST.firstpos = NULL;
3345 ST.longfold = FALSE; /* char longer if folded => it's harder */
3346 ST.nextword = 0;
3347
3348 /* fully traverse the TRIE; note the position of the
3349 shortest accept state and the wordnum of the longest
3350 accept state */
07be1b83 3351
a3621e74 3352 while ( state && uc <= (U8*)PL_regeol ) {
786e8c11 3353 U32 base = trie->states[ state ].trans.base;
f9f4320a 3354 UV uvc = 0;
acb909b4 3355 U16 charid = 0;
2e64971a
DM
3356 U16 wordnum;
3357 wordnum = trie->states[ state ].wordnum;
3358
3359 if (wordnum) { /* it's an accept state */
3360 if (!accepted) {
3361 accepted = 1;
3362 /* record first match position */
3363 if (ST.longfold) {
3364 ST.firstpos = (U8*)locinput;
3365 ST.firstchars = 0;
5b47454d 3366 }
2e64971a
DM
3367 else {
3368 ST.firstpos = uc;
3369 ST.firstchars = charcount;
3370 }
3371 }
3372 if (!ST.nextword || wordnum < ST.nextword)
3373 ST.nextword = wordnum;
3374 ST.topword = wordnum;
786e8c11 3375 }
a3621e74 3376
07be1b83 3377 DEBUG_TRIE_EXECUTE_r({
f2ed9b32 3378 DUMP_EXEC_POS( (char *)uc, scan, utf8_target );
a3621e74 3379 PerlIO_printf( Perl_debug_log,
2e64971a 3380 "%*s %sState: %4"UVxf" Accepted: %c ",
5bc10b2c 3381 2+depth * 2, "", PL_colors[4],
2e64971a 3382 (UV)state, (accepted ? 'Y' : 'N'));
07be1b83 3383 });
a3621e74 3384
2e64971a 3385 /* read a char and goto next state */
a3621e74 3386 if ( base ) {
6dd2be57 3387 I32 offset;
55eed653
NC
3388 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3389 uscan, len, uvc, charid, foldlen,
3390 foldbuf, uniflags);
2e64971a
DM
3391 charcount++;
3392 if (foldlen>0)
3393 ST.longfold = TRUE;
5b47454d 3394 if (charid &&
6dd2be57
DM
3395 ( ((offset =
3396 base + charid - 1 - trie->uniquecharcount)) >= 0)
3397
3398 && ((U32)offset < trie->lasttrans)
3399 && trie->trans[offset].check == state)
5b47454d 3400 {
6dd2be57 3401 state = trie->trans[offset].next;
5b47454d
DM
3402 }
3403 else {
3404 state = 0;
3405 }
3406 uc += len;
3407
3408 }
3409 else {
a3621e74
YO
3410 state = 0;
3411 }
3412 DEBUG_TRIE_EXECUTE_r(
e4584336 3413 PerlIO_printf( Perl_debug_log,
786e8c11 3414 "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
e4584336 3415 charid, uvc, (UV)state, PL_colors[5] );
a3621e74
YO
3416 );
3417 }
2e64971a 3418 if (!accepted)
a3621e74 3419 sayNO;
a3621e74 3420
2e64971a
DM
3421 /* calculate total number of accept states */
3422 {
3423 U16 w = ST.topword;
3424 accepted = 0;
3425 while (w) {
3426 w = trie->wordinfo[w].prev;
3427 accepted++;
3428 }
3429 ST.accepted = accepted;
3430 }
3431
166ba7cd
DM
3432 DEBUG_EXECUTE_r(
3433 PerlIO_printf( Perl_debug_log,
3434 "%*s %sgot %"IVdf" possible matches%s\n",
5bc10b2c 3435 REPORT_CODE_OFF + depth * 2, "",
166ba7cd
DM
3436 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3437 );
2e64971a 3438 goto trie_first_try; /* jump into the fail handler */
786e8c11 3439 }}
fae667d5 3440 /* NOTREACHED */
2e64971a
DM
3441
3442 case TRIE_next_fail: /* we failed - try next alternative */
fae667d5
YO
3443 if ( ST.jump) {
3444 REGCP_UNWIND(ST.cp);
3445 for (n = *PL_reglastparen; n > ST.lastparen; n--)
f0ab9afb 3446 PL_regoffs[n].end = -1;
fae667d5
YO
3447 *PL_reglastparen = n;
3448 }
2e64971a
DM
3449 if (!--ST.accepted) {
3450 DEBUG_EXECUTE_r({
3451 PerlIO_printf( Perl_debug_log,
3452 "%*s %sTRIE failed...%s\n",
3453 REPORT_CODE_OFF+depth*2, "",
3454 PL_colors[4],
3455 PL_colors[5] );
3456 });
3457 sayNO_SILENT;
3458 }
3459 {
3460 /* Find next-highest word to process. Note that this code
3461 * is O(N^2) per trie run (O(N) per branch), so keep tight */
d9a396a3
DM
3462 register U16 min = 0;
3463 register U16 word;
2e64971a
DM
3464 register U16 const nextword = ST.nextword;
3465 register reg_trie_wordinfo * const wordinfo
3466 = ((reg_trie_data*)rexi->data->data[ARG(ST.me)])->wordinfo;
3467 for (word=ST.topword; word; word=wordinfo[word].prev) {
3468 if (word > nextword && (!min || word < min))
3469 min = word;
3470 }
3471 ST.nextword = min;
3472 }
3473
fae667d5 3474 trie_first_try:
5d458dd8
YO
3475 if (do_cutgroup) {
3476 do_cutgroup = 0;
3477 no_final = 0;
3478 }
fae667d5
YO
3479
3480 if ( ST.jump) {
3481 ST.lastparen = *PL_reglastparen;
3482 REGCP_SET(ST.cp);
2e64971a 3483 }
a3621e74 3484
2e64971a 3485 /* find start char of end of current word */
166ba7cd 3486 {
2e64971a
DM
3487 U32 chars; /* how many chars to skip */
3488 U8 *uc = ST.firstpos;
3489 reg_trie_data * const trie
3490 = (reg_trie_data*)rexi->data->data[ARG(ST.me)];
3491
3492 assert((trie->wordinfo[ST.nextword].len - trie->prefixlen)
3493 >= ST.firstchars);
3494 chars = (trie->wordinfo[ST.nextword].len - trie->prefixlen)
3495 - ST.firstchars;
3496
3497 if (ST.longfold) {
3498 /* the hard option - fold each char in turn and find
3499 * its folded length (which may be different */
3500 U8 foldbuf[UTF8_MAXBYTES_CASE + 1];
3501 STRLEN foldlen;
3502 STRLEN len;
d9a396a3 3503 UV uvc;
2e64971a
DM
3504 U8 *uscan;
3505
3506 while (chars) {
f2ed9b32 3507 if (utf8_target) {
2e64971a
DM
3508 uvc = utf8n_to_uvuni((U8*)uc, UTF8_MAXLEN, &len,
3509 uniflags);
3510 uc += len;
3511 }
3512 else {
3513 uvc = *uc;
3514 uc++;
3515 }
3516 uvc = to_uni_fold(uvc, foldbuf, &foldlen);
3517 uscan = foldbuf;
3518 while (foldlen) {
3519 if (!--chars)
3520 break;
3521 uvc = utf8n_to_uvuni(uscan, UTF8_MAXLEN, &len,
3522 uniflags);
3523 uscan += len;
3524 foldlen -= len;
3525 }
3526 }
a3621e74 3527 }
2e64971a 3528 else {
f2ed9b32 3529 if (utf8_target)
2e64971a
DM
3530 while (chars--)
3531 uc += UTF8SKIP(uc);
3532 else
3533 uc += chars;
3534 }
3535 PL_reginput = (char *)uc;
3536 }
166ba7cd 3537
2e64971a
DM
3538 scan = (ST.jump && ST.jump[ST.nextword])
3539 ? ST.me + ST.jump[ST.nextword]
3540 : ST.B;
166ba7cd 3541
2e64971a
DM
3542 DEBUG_EXECUTE_r({
3543 PerlIO_printf( Perl_debug_log,
3544 "%*s %sTRIE matched word #%d, continuing%s\n",
3545 REPORT_CODE_OFF+depth*2, "",
3546 PL_colors[4],
3547 ST.nextword,
3548 PL_colors[5]
3549 );
3550 });
3551
3552 if (ST.accepted > 1 || has_cutgroup) {
3553 PUSH_STATE_GOTO(TRIE_next, scan);
3554 /* NOTREACHED */
166ba7cd 3555 }
2e64971a
DM
3556 /* only one choice left - just continue */
3557 DEBUG_EXECUTE_r({
3558 AV *const trie_words
3559 = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3560 SV ** const tmp = av_fetch( trie_words,
3561 ST.nextword-1, 0 );
3562 SV *sv= tmp ? sv_newmortal() : NULL;
3563
3564 PerlIO_printf( Perl_debug_log,
3565 "%*s %sonly one match left, short-circuiting: #%d <%s>%s\n",
3566 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3567 ST.nextword,
3568 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3569 PL_colors[0], PL_colors[1],
c89df6cf 3570 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)|PERL_PV_ESCAPE_NONASCII
2e64971a
DM
3571 )
3572 : "not compiled under -Dr",
3573 PL_colors[5] );
3574 });
3575
3576 locinput = PL_reginput;
3577 nextchr = UCHARAT(locinput);
3578 continue; /* execute rest of RE */
166ba7cd 3579 /* NOTREACHED */
166ba7cd
DM
3580#undef ST
3581
95b24440
DM
3582 case EXACT: {
3583 char *s = STRING(scan);
24d3c4a9 3584 ln = STR_LEN(scan);
f2ed9b32 3585 if (utf8_target != UTF_PATTERN) {
bc517b45 3586 /* The target and the pattern have differing utf8ness. */
1aa99e6b 3587 char *l = locinput;
24d3c4a9 3588 const char * const e = s + ln;
a72c7584 3589
f2ed9b32 3590 if (utf8_target) {
5ff6fc6d 3591 /* The target is utf8, the pattern is not utf8. */
1aa99e6b 3592 while (s < e) {
a3b680e6 3593 STRLEN ulen;
1aa99e6b 3594 if (l >= PL_regeol)
5ff6fc6d
JH
3595 sayNO;
3596 if (NATIVE_TO_UNI(*(U8*)s) !=
89ebb4a3 3597 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
041457d9 3598 uniflags))
5ff6fc6d 3599 sayNO;
bc517b45 3600 l += ulen;
5ff6fc6d 3601 s ++;
1aa99e6b 3602 }
5ff6fc6d
JH
3603 }
3604 else {
3605 /* The target is not utf8, the pattern is utf8. */
1aa99e6b 3606 while (s < e) {
a3b680e6 3607 STRLEN ulen;
1aa99e6b
IH
3608 if (l >= PL_regeol)
3609 sayNO;
5ff6fc6d 3610 if (NATIVE_TO_UNI(*((U8*)l)) !=
89ebb4a3 3611 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
041457d9 3612 uniflags))
1aa99e6b 3613 sayNO;
bc517b45 3614 s += ulen;
a72c7584 3615 l ++;
1aa99e6b 3616 }
5ff6fc6d 3617 }
1aa99e6b
IH
3618 locinput = l;
3619 nextchr = UCHARAT(locinput);
3620 break;
3621 }
bc517b45 3622 /* The target and the pattern have the same utf8ness. */
d6a28714
JH
3623 /* Inline the first character, for speed. */
3624 if (UCHARAT(s) != nextchr)
3625 sayNO;
24d3c4a9 3626 if (PL_regeol - locinput < ln)
d6a28714 3627 sayNO;
24d3c4a9 3628 if (ln > 1 && memNE(s, locinput, ln))
d6a28714 3629 sayNO;
24d3c4a9 3630 locinput += ln;
d6a28714
JH
3631 nextchr = UCHARAT(locinput);
3632 break;
95b24440 3633 }
9a5a5549 3634 case EXACTFL: {
a932d541 3635 re_fold_t folder;
9a5a5549
KW
3636 const U8 * fold_array;
3637 const char * s;
d513472c 3638 U32 fold_utf8_flags;
9a5a5549 3639
b8c5462f 3640 PL_reg_flags |= RF_tainted;
9a5a5549
KW
3641 folder = foldEQ_locale;
3642 fold_array = PL_fold_locale;
17580e7a 3643 fold_utf8_flags = FOLDEQ_UTF8_LOCALE;
9a5a5549
KW
3644 goto do_exactf;
3645
3646 case EXACTFU:
3647 folder = foldEQ_latin1;
3648 fold_array = PL_fold_latin1;
d513472c 3649 fold_utf8_flags = 0;
9a5a5549
KW
3650 goto do_exactf;
3651
2f7f8cb1
KW
3652 case EXACTFA:
3653 folder = foldEQ_latin1;
3654 fold_array = PL_fold_latin1;
57014d77 3655 fold_utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
2f7f8cb1
KW
3656 goto do_exactf;
3657
9a5a5549
KW
3658 case EXACTF:
3659 folder = foldEQ;
3660 fold_array = PL_fold;
d513472c 3661 fold_utf8_flags = 0;
9a5a5549
KW
3662
3663 do_exactf:
3664 s = STRING(scan);
24d3c4a9 3665 ln = STR_LEN(scan);
d6a28714 3666
f2ed9b32 3667 if (utf8_target || UTF_PATTERN) {
d07ddd77 3668 /* Either target or the pattern are utf8. */
be8e71aa 3669 const char * const l = locinput;
d07ddd77 3670 char *e = PL_regeol;
bc517b45 3671
d513472c
KW
3672 if (! foldEQ_utf8_flags(s, 0, ln, cBOOL(UTF_PATTERN),
3673 l, &e, 0, utf8_target, fold_utf8_flags)) {
5486206c
JH
3674 /* One more case for the sharp s:
3675 * pack("U0U*", 0xDF) =~ /ss/i,
3676 * the 0xC3 0x9F are the UTF-8
3677 * byte sequence for the U+00DF. */
e1d1eefb 3678
f2ed9b32 3679 if (!(utf8_target &&
e1d1eefb 3680 toLOWER(s[0]) == 's' &&
24d3c4a9 3681 ln >= 2 &&
5486206c
JH
3682 toLOWER(s[1]) == 's' &&
3683 (U8)l[0] == 0xC3 &&
3684 e - l >= 2 &&
3685 (U8)l[1] == 0x9F))
3686 sayNO;
3687 }
d07ddd77
JH
3688 locinput = e;
3689 nextchr = UCHARAT(locinput);
3690 break;
a0ed51b3 3691 }
d6a28714 3692
0a138b74 3693 /* Neither the target nor the pattern are utf8 */
d6a28714 3694 if (UCHARAT(s) != nextchr &&
9a5a5549
KW
3695 UCHARAT(s) != fold_array[nextchr])
3696 {
a0ed51b3 3697 sayNO;
9a5a5549 3698 }
24d3c4a9 3699 if (PL_regeol - locinput < ln)
b8c5462f 3700 sayNO;
9a5a5549 3701 if (ln > 1 && ! folder(s, locinput, ln))
4633a7c4 3702 sayNO;
24d3c4a9 3703 locinput += ln;
d6a28714 3704 nextchr = UCHARAT(locinput);
a0d0e21e 3705 break;
9a5a5549 3706 }
63ac0dad
KW
3707
3708 /* XXX Could improve efficiency by separating these all out using a
3709 * macro or in-line function. At that point regcomp.c would no longer
3710 * have to set the FLAGS fields of these */
b2680017
YO
3711 case BOUNDL:
3712 case NBOUNDL:
3713 PL_reg_flags |= RF_tainted;
3714 /* FALL THROUGH */
3715 case BOUND:
63ac0dad 3716 case BOUNDU:
cfaf538b 3717 case BOUNDA:
b2680017 3718 case NBOUND:
63ac0dad 3719 case NBOUNDU:
cfaf538b 3720 case NBOUNDA:
b2680017 3721 /* was last char in word? */
cfaf538b 3722 if (utf8_target && FLAGS(scan) != REGEX_ASCII_RESTRICTED_CHARSET) {
b2680017
YO
3723 if (locinput == PL_bostr)
3724 ln = '\n';
3725 else {
3726 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3727
3728 ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3729 }
63ac0dad 3730 if (FLAGS(scan) != REGEX_LOCALE_CHARSET) {
b2680017
YO
3731 ln = isALNUM_uni(ln);
3732 LOAD_UTF8_CHARCLASS_ALNUM();
f2ed9b32 3733 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, utf8_target);
b2680017
YO
3734 }
3735 else {
3736 ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3737 n = isALNUM_LC_utf8((U8*)locinput);
3738 }
3739 }
3740 else {
cfaf538b
KW
3741
3742 /* Here the string isn't utf8, or is utf8 and only ascii
3743 * characters are to match \w. In the latter case looking at
3744 * the byte just prior to the current one may be just the final
3745 * byte of a multi-byte character. This is ok. There are two
3746 * cases:
3747 * 1) it is a single byte character, and then the test is doing
3748 * just what it's supposed to.
3749 * 2) it is a multi-byte character, in which case the final
3750 * byte is never mistakable for ASCII, and so the test
3751 * will say it is not a word character, which is the
3752 * correct answer. */
b2680017
YO
3753 ln = (locinput != PL_bostr) ?
3754 UCHARAT(locinput - 1) : '\n';
63ac0dad
KW
3755 switch (FLAGS(scan)) {
3756 case REGEX_UNICODE_CHARSET:
3757 ln = isWORDCHAR_L1(ln);
3758 n = isWORDCHAR_L1(nextchr);
3759 break;
3760 case REGEX_LOCALE_CHARSET:
3761 ln = isALNUM_LC(ln);
3762 n = isALNUM_LC(nextchr);
3763 break;
3764 case REGEX_DEPENDS_CHARSET:
3765 ln = isALNUM(ln);
3766 n = isALNUM(nextchr);
3767 break;
cfaf538b
KW
3768 case REGEX_ASCII_RESTRICTED_CHARSET:
3769 ln = isWORDCHAR_A(ln);
3770 n = isWORDCHAR_A(nextchr);
3771 break;
63ac0dad
KW
3772 default:
3773 Perl_croak(aTHX_ "panic: Unexpected FLAGS %u in op %u", FLAGS(scan), OP(scan));
3774 break;
b2680017
YO
3775 }
3776 }
63ac0dad
KW
3777 /* Note requires that all BOUNDs be lower than all NBOUNDs in
3778 * regcomp.sym */
3779 if (((!ln) == (!n)) == (OP(scan) < NBOUND))
b2680017
YO
3780 sayNO;
3781 break;
f56b6394 3782 case ANYOFV:
d6a28714 3783 case ANYOF:
f56b6394 3784 if (utf8_target || state_num == ANYOFV) {
9e55ce06 3785 STRLEN inclasslen = PL_regeol - locinput;
20ed0b26
KW
3786 if (locinput >= PL_regeol)
3787 sayNO;
9e55ce06 3788
f2ed9b32 3789 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, utf8_target))
09b08e9b 3790 sayNO;
b32d7d3e 3791 locinput += inclasslen;
b8c5462f 3792 nextchr = UCHARAT(locinput);
e0f9d4a8 3793 break;
ffc61ed2
JH
3794 }
3795 else {
3796 if (nextchr < 0)
3797 nextchr = UCHARAT(locinput);
ffc61ed2
JH
3798 if (!nextchr && locinput >= PL_regeol)
3799 sayNO;
20ed0b26 3800 if (!REGINCLASS(rex, scan, (U8*)locinput))
09b08e9b 3801 sayNO;
ffc61ed2 3802 nextchr = UCHARAT(++locinput);
e0f9d4a8
JH
3803 break;
3804 }
b8c5462f 3805 break;
20d0b1e9 3806 /* Special char classes - The defines start on line 129 or so */
ee9a90b8
KW
3807 CCC_TRY_U(ALNUM, NALNUM, isWORDCHAR,
3808 ALNUML, NALNUML, isALNUM_LC, isALNUM_LC_utf8,
3809 ALNUMU, NALNUMU, isWORDCHAR_L1,
cfaf538b 3810 ALNUMA, NALNUMA, isWORDCHAR_A,
ee9a90b8
KW
3811 perl_word, "a");
3812
3813 CCC_TRY_U(SPACE, NSPACE, isSPACE,
3814 SPACEL, NSPACEL, isSPACE_LC, isSPACE_LC_utf8,
3815 SPACEU, NSPACEU, isSPACE_L1,
cfaf538b 3816 SPACEA, NSPACEA, isSPACE_A,
ee9a90b8
KW
3817 perl_space, " ");
3818
3819 CCC_TRY(DIGIT, NDIGIT, isDIGIT,
3820 DIGITL, NDIGITL, isDIGIT_LC, isDIGIT_LC_utf8,
cfaf538b 3821 DIGITA, NDIGITA, isDIGIT_A,
ee9a90b8 3822 posix_digit, "0");
20d0b1e9 3823
37e2e78e
KW
3824 case CLUMP: /* Match \X: logical Unicode character. This is defined as
3825 a Unicode extended Grapheme Cluster */
3826 /* From http://www.unicode.org/reports/tr29 (5.2 version). An
3827 extended Grapheme Cluster is:
3828
3829 CR LF
3830 | Prepend* Begin Extend*
3831 | .
3832
3833 Begin is (Hangul-syllable | ! Control)
3834 Extend is (Grapheme_Extend | Spacing_Mark)
3835 Control is [ GCB_Control CR LF ]
3836
3837 The discussion below shows how the code for CLUMP is derived
3838 from this regex. Note that most of these concepts are from
3839 property values of the Grapheme Cluster Boundary (GCB) property.
3840 No code point can have multiple property values for a given
3841 property. Thus a code point in Prepend can't be in Control, but
3842 it must be in !Control. This is why Control above includes
3843 GCB_Control plus CR plus LF. The latter two are used in the GCB
3844 property separately, and so can't be in GCB_Control, even though
3845 they logically are controls. Control is not the same as gc=cc,
3846 but includes format and other characters as well.
3847
3848 The Unicode definition of Hangul-syllable is:
3849 L+
3850 | (L* ( ( V | LV ) V* | LVT ) T*)
3851 | T+
3852 )
3853 Each of these is a value for the GCB property, and hence must be
3854 disjoint, so the order they are tested is immaterial, so the
3855 above can safely be changed to
3856 T+
3857 | L+
3858 | (L* ( LVT | ( V | LV ) V*) T*)
3859
3860 The last two terms can be combined like this:
3861 L* ( L
3862 | (( LVT | ( V | LV ) V*) T*))
3863
3864 And refactored into this:
3865 L* (L | LVT T* | V V* T* | LV V* T*)
3866
3867 That means that if we have seen any L's at all we can quit
3868 there, but if the next character is a LVT, a V or and LV we
3869 should keep going.
3870
3871 There is a subtlety with Prepend* which showed up in testing.
3872 Note that the Begin, and only the Begin is required in:
3873 | Prepend* Begin Extend*
3874 Also, Begin contains '! Control'. A Prepend must be a '!
3875 Control', which means it must be a Begin. What it comes down to
3876 is that if we match Prepend* and then find no suitable Begin
3877 afterwards, that if we backtrack the last Prepend, that one will
3878 be a suitable Begin.
3879 */
3880
b7c83a7e 3881 if (locinput >= PL_regeol)
a0ed51b3 3882 sayNO;
f2ed9b32 3883 if (! utf8_target) {
37e2e78e
KW
3884
3885 /* Match either CR LF or '.', as all the other possibilities
3886 * require utf8 */
3887 locinput++; /* Match the . or CR */
3888 if (nextchr == '\r'
3889 && locinput < PL_regeol
3890 && UCHARAT(locinput) == '\n') locinput++;
3891 }
3892 else {
3893
3894 /* Utf8: See if is ( CR LF ); already know that locinput <
3895 * PL_regeol, so locinput+1 is in bounds */
3896 if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
3897 locinput += 2;
3898 }
3899 else {
3900 /* In case have to backtrack to beginning, then match '.' */
3901 char *starting = locinput;
3902
3903 /* In case have to backtrack the last prepend */
3904 char *previous_prepend = 0;
3905
3906 LOAD_UTF8_CHARCLASS_GCB();
3907
3908 /* Match (prepend)* */
3909 while (locinput < PL_regeol
3910 && swash_fetch(PL_utf8_X_prepend,
f2ed9b32 3911 (U8*)locinput, utf8_target))
37e2e78e
KW
3912 {
3913 previous_prepend = locinput;
3914 locinput += UTF8SKIP(locinput);
3915 }
3916
3917 /* As noted above, if we matched a prepend character, but
3918 * the next thing won't match, back off the last prepend we
3919 * matched, as it is guaranteed to match the begin */
3920 if (previous_prepend
3921 && (locinput >= PL_regeol
3922 || ! swash_fetch(PL_utf8_X_begin,
f2ed9b32 3923 (U8*)locinput, utf8_target)))
37e2e78e
KW
3924 {
3925 locinput = previous_prepend;
3926 }
3927
3928 /* Note that here we know PL_regeol > locinput, as we
3929 * tested that upon input to this switch case, and if we
3930 * moved locinput forward, we tested the result just above
3931 * and it either passed, or we backed off so that it will
3932 * now pass */
f2ed9b32 3933 if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, utf8_target)) {
37e2e78e
KW
3934
3935 /* Here did not match the required 'Begin' in the
3936 * second term. So just match the very first
3937 * character, the '.' of the final term of the regex */
3938 locinput = starting + UTF8SKIP(starting);
3939 } else {
3940
3941 /* Here is the beginning of a character that can have
3942 * an extender. It is either a hangul syllable, or a
3943 * non-control */
3944 if (swash_fetch(PL_utf8_X_non_hangul,
f2ed9b32 3945 (U8*)locinput, utf8_target))
37e2e78e
KW
3946 {
3947
3948 /* Here not a Hangul syllable, must be a
3949 * ('! * Control') */
3950 locinput += UTF8SKIP(locinput);
3951 } else {
3952
3953 /* Here is a Hangul syllable. It can be composed
3954 * of several individual characters. One
3955 * possibility is T+ */
3956 if (swash_fetch(PL_utf8_X_T,
f2ed9b32 3957 (U8*)locinput, utf8_target))
37e2e78e
KW
3958 {
3959 while (locinput < PL_regeol
3960 && swash_fetch(PL_utf8_X_T,
f2ed9b32 3961 (U8*)locinput, utf8_target))
37e2e78e
KW
3962 {
3963 locinput += UTF8SKIP(locinput);
3964 }
3965 } else {
3966
3967 /* Here, not T+, but is a Hangul. That means
3968 * it is one of the others: L, LV, LVT or V,
3969 * and matches:
3970 * L* (L | LVT T* | V V* T* | LV V* T*) */
3971
3972 /* Match L* */
3973 while (locinput < PL_regeol
3974 && swash_fetch(PL_utf8_X_L,
f2ed9b32 3975 (U8*)locinput, utf8_target))
37e2e78e
KW
3976 {
3977 locinput += UTF8SKIP(locinput);
3978 }
3979
3980 /* Here, have exhausted L*. If the next
3981 * character is not an LV, LVT nor V, it means
3982 * we had to have at least one L, so matches L+
3983 * in the original equation, we have a complete
3984 * hangul syllable. Are done. */
3985
3986 if (locinput < PL_regeol
3987 && swash_fetch(PL_utf8_X_LV_LVT_V,
f2ed9b32 3988 (U8*)locinput, utf8_target))
37e2e78e
KW
3989 {
3990
3991 /* Otherwise keep going. Must be LV, LVT
3992 * or V. See if LVT */
3993 if (swash_fetch(PL_utf8_X_LVT,
f2ed9b32 3994 (U8*)locinput, utf8_target))
37e2e78e
KW
3995 {
3996 locinput += UTF8SKIP(locinput);
3997 } else {
3998
3999 /* Must be V or LV. Take it, then
4000 * match V* */
4001 locinput += UTF8SKIP(locinput);
4002 while (locinput < PL_regeol
4003 && swash_fetch(PL_utf8_X_V,
f2ed9b32 4004 (U8*)locinput, utf8_target))
37e2e78e
KW
4005 {
4006 locinput += UTF8SKIP(locinput);
4007 }
4008 }
4009
4010 /* And any of LV, LVT, or V can be followed
4011 * by T* */
4012 while (locinput < PL_regeol
4013 && swash_fetch(PL_utf8_X_T,
4014 (U8*)locinput,
f2ed9b32 4015 utf8_target))
37e2e78e
KW
4016 {
4017 locinput += UTF8SKIP(locinput);
4018 }
4019 }
4020 }
4021 }
4022
4023 /* Match any extender */
4024 while (locinput < PL_regeol
4025 && swash_fetch(PL_utf8_X_extend,
f2ed9b32 4026 (U8*)locinput, utf8_target))
37e2e78e
KW
4027 {
4028 locinput += UTF8SKIP(locinput);
4029 }
4030 }
4031 }
4032 if (locinput > PL_regeol) sayNO;
4033 }
a0ed51b3
LW
4034 nextchr = UCHARAT(locinput);
4035 break;
81714fb9
YO
4036
4037 case NREFFL:
d7ef4b73
KW
4038 { /* The capture buffer cases. The ones beginning with N for the
4039 named buffers just convert to the equivalent numbered and
4040 pretend they were called as the corresponding numbered buffer
4041 op. */
26ecd678
TC
4042 /* don't initialize these in the declaration, it makes C++
4043 unhappy */
81714fb9 4044 char *s;
ff1157ca 4045 char type;
8368298a
TC
4046 re_fold_t folder;
4047 const U8 *fold_array;
26ecd678 4048 UV utf8_fold_flags;
8368298a 4049
81714fb9 4050 PL_reg_flags |= RF_tainted;
d7ef4b73
KW
4051 folder = foldEQ_locale;
4052 fold_array = PL_fold_locale;
4053 type = REFFL;
17580e7a 4054 utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
d7ef4b73
KW
4055 goto do_nref;
4056
2f7f8cb1
KW
4057 case NREFFA:
4058 folder = foldEQ_latin1;
4059 fold_array = PL_fold_latin1;
4060 type = REFFA;
4061 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4062 goto do_nref;
4063
d7ef4b73
KW
4064 case NREFFU:
4065 folder = foldEQ_latin1;
4066 fold_array = PL_fold_latin1;
4067 type = REFFU;
d513472c 4068 utf8_fold_flags = 0;
d7ef4b73
KW
4069 goto do_nref;
4070
81714fb9 4071 case NREFF:
d7ef4b73
KW
4072 folder = foldEQ;
4073 fold_array = PL_fold;
4074 type = REFF;
d513472c 4075 utf8_fold_flags = 0;
d7ef4b73
KW
4076 goto do_nref;
4077
4078 case NREF:
4079 type = REF;
83d7b90b
KW
4080 folder = NULL;
4081 fold_array = NULL;
d513472c 4082 utf8_fold_flags = 0;
d7ef4b73
KW
4083 do_nref:
4084
4085 /* For the named back references, find the corresponding buffer
4086 * number */
0a4db386
YO
4087 n = reg_check_named_buff_matched(rex,scan);
4088
d7ef4b73 4089 if ( ! n ) {
81714fb9 4090 sayNO;
d7ef4b73
KW
4091 }
4092 goto do_nref_ref_common;
4093
c8756f30 4094 case REFFL:
3280af22 4095 PL_reg_flags |= RF_tainted;
d7ef4b73
KW
4096 folder = foldEQ_locale;
4097 fold_array = PL_fold_locale;
17580e7a 4098 utf8_fold_flags = FOLDEQ_UTF8_LOCALE;
d7ef4b73
KW
4099 goto do_ref;
4100
2f7f8cb1
KW
4101 case REFFA:
4102 folder = foldEQ_latin1;
4103 fold_array = PL_fold_latin1;
4104 utf8_fold_flags = FOLDEQ_UTF8_NOMIX_ASCII;
4105 goto do_ref;
4106
d7ef4b73
KW
4107 case REFFU:
4108 folder = foldEQ_latin1;
4109 fold_array = PL_fold_latin1;
d513472c 4110 utf8_fold_flags = 0;
d7ef4b73
KW
4111 goto do_ref;
4112
4113 case REFF:
4114 folder = foldEQ;
4115 fold_array = PL_fold;
d513472c 4116 utf8_fold_flags = 0;
83d7b90b 4117 goto do_ref;
d7ef4b73 4118
c277df42 4119 case REF:
83d7b90b
KW
4120 folder = NULL;
4121 fold_array = NULL;
d513472c 4122 utf8_fold_flags = 0;
83d7b90b 4123
d7ef4b73 4124 do_ref:
81714fb9 4125 type = OP(scan);
d7ef4b73
KW
4126 n = ARG(scan); /* which paren pair */
4127
4128 do_nref_ref_common:
f0ab9afb 4129 ln = PL_regoffs[n].start;
2c2d71f5 4130 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3b6647e0 4131 if (*PL_reglastparen < n || ln == -1)
af3f8c16 4132 sayNO; /* Do not match unless seen CLOSEn. */
f0ab9afb 4133 if (ln == PL_regoffs[n].end)
a0d0e21e 4134 break;
a0ed51b3 4135
24d3c4a9 4136 s = PL_bostr + ln;
d7ef4b73 4137 if (type != REF /* REF can do byte comparison */
2f65c56d 4138 && (utf8_target || type == REFFU))
d7ef4b73
KW
4139 { /* XXX handle REFFL better */
4140 char * limit = PL_regeol;
4141
4142 /* This call case insensitively compares the entire buffer
4143 * at s, with the current input starting at locinput, but
4144 * not going off the end given by PL_regeol, and returns in
4145 * limit upon success, how much of the current input was
4146 * matched */
d513472c
KW
4147 if (! foldEQ_utf8_flags(s, NULL, PL_regoffs[n].end - ln, utf8_target,
4148 locinput, &limit, 0, utf8_target, utf8_fold_flags))
d7ef4b73
KW
4149 {
4150 sayNO;
a0ed51b3 4151 }
d7ef4b73 4152 locinput = limit;
a0ed51b3
LW
4153 nextchr = UCHARAT(locinput);
4154 break;
4155 }
4156
d7ef4b73 4157 /* Not utf8: Inline the first character, for speed. */
76e3520e 4158 if (UCHARAT(s) != nextchr &&
81714fb9 4159 (type == REF ||
d7ef4b73 4160 UCHARAT(s) != fold_array[nextchr]))
4633a7c4 4161 sayNO;
f0ab9afb 4162 ln = PL_regoffs[n].end - ln;
24d3c4a9 4163 if (locinput + ln > PL_regeol)
4633a7c4 4164 sayNO;
81714fb9 4165 if (ln > 1 && (type == REF
24d3c4a9 4166 ? memNE(s, locinput, ln)
d7ef4b73 4167 : ! folder(s, locinput, ln)))
4633a7c4 4168 sayNO;
24d3c4a9 4169 locinput += ln;
76e3520e 4170 nextchr = UCHARAT(locinput);
a0d0e21e 4171 break;
81714fb9 4172 }
a0d0e21e 4173 case NOTHING:
c277df42 4174 case TAIL:
a0d0e21e
LW
4175 break;
4176 case BACK:
4177 break;
40a82448
DM
4178
4179#undef ST
4180#define ST st->u.eval
c277df42 4181 {
c277df42 4182 SV *ret;
d2f13c59 4183 REGEXP *re_sv;
6bda09f9 4184 regexp *re;
f8fc2ecf 4185 regexp_internal *rei;
1a147d38
YO
4186 regnode *startpoint;
4187
4188 case GOSTART:
e7707071
YO
4189 case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */
4190 if (cur_eval && cur_eval->locinput==locinput) {
24b23f37 4191 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
1a147d38 4192 Perl_croak(aTHX_ "Infinite recursion in regex");
4b196cd4 4193 if ( ++nochange_depth > max_nochange_depth )
1a147d38
YO
4194 Perl_croak(aTHX_
4195 "Pattern subroutine nesting without pos change"
4196 " exceeded limit in regex");
6bda09f9
YO
4197 } else {
4198 nochange_depth = 0;
1a147d38 4199 }
288b8c02 4200 re_sv = rex_sv;
6bda09f9 4201 re = rex;
f8fc2ecf 4202 rei = rexi;
288b8c02 4203 (void)ReREFCNT_inc(rex_sv);
1a147d38 4204 if (OP(scan)==GOSUB) {
6bda09f9
YO
4205 startpoint = scan + ARG2L(scan);
4206 ST.close_paren = ARG(scan);
4207 } else {
f8fc2ecf 4208 startpoint = rei->program+1;
6bda09f9
YO
4209 ST.close_paren = 0;
4210 }
4211 goto eval_recurse_doit;
4212 /* NOTREACHED */
4213 case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
4214 if (cur_eval && cur_eval->locinput==locinput) {
4b196cd4 4215 if ( ++nochange_depth > max_nochange_depth )
1a147d38 4216 Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
6bda09f9
YO
4217 } else {
4218 nochange_depth = 0;
4219 }
8e5e9ebe 4220 {
4aabdb9b
DM
4221 /* execute the code in the {...} */
4222 dSP;
6136c704 4223 SV ** const before = SP;
4aabdb9b
DM
4224 OP_4tree * const oop = PL_op;
4225 COP * const ocurcop = PL_curcop;
4226 PAD *old_comppad;
d80618d2 4227 char *saved_regeol = PL_regeol;
91332126
FR
4228 struct re_save_state saved_state;
4229
6562f1c4 4230 /* To not corrupt the existing regex state while executing the
b7f4cd04
FR
4231 * eval we would normally put it on the save stack, like with
4232 * save_re_context. However, re-evals have a weird scoping so we
4233 * can't just add ENTER/LEAVE here. With that, things like
4234 *
4235 * (?{$a=2})(a(?{local$a=$a+1}))*aak*c(?{$b=$a})
4236 *
4237 * would break, as they expect the localisation to be unwound
4238 * only when the re-engine backtracks through the bit that
4239 * localised it.
4240 *
4241 * What we do instead is just saving the state in a local c
4242 * variable.
4243 */
91332126
FR
4244 Copy(&PL_reg_state, &saved_state, 1, struct re_save_state);
4245
4aabdb9b 4246 n = ARG(scan);
f8fc2ecf 4247 PL_op = (OP_4tree*)rexi->data->data[n];
24b23f37
YO
4248 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
4249 " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
f8fc2ecf 4250 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
f0ab9afb 4251 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
4aabdb9b 4252
2bf803e2
YO
4253 if (sv_yes_mark) {
4254 SV *sv_mrk = get_sv("REGMARK", 1);
4255 sv_setsv(sv_mrk, sv_yes_mark);
4256 }
4257
8e5e9ebe
RGS
4258 CALLRUNOPS(aTHX); /* Scalar context. */
4259 SPAGAIN;
4260 if (SP == before)
075aa684 4261 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
8e5e9ebe
RGS
4262 else {
4263 ret = POPs;
4264 PUTBACK;
4265 }
4aabdb9b 4266
91332126
FR
4267 Copy(&saved_state, &PL_reg_state, 1, struct re_save_state);
4268
4aabdb9b
DM
4269 PL_op = oop;
4270 PAD_RESTORE_LOCAL(old_comppad);
4271 PL_curcop = ocurcop;
d80618d2 4272 PL_regeol = saved_regeol;
24d3c4a9 4273 if (!logical) {
4aabdb9b
DM
4274 /* /(?{...})/ */
4275 sv_setsv(save_scalar(PL_replgv), ret);
4aabdb9b
DM
4276 break;
4277 }
8e5e9ebe 4278 }
24d3c4a9
DM
4279 if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
4280 logical = 0;
4aabdb9b 4281 {
4f639d21
DM
4282 /* extract RE object from returned value; compiling if
4283 * necessary */
6136c704 4284 MAGIC *mg = NULL;
288b8c02 4285 REGEXP *rx = NULL;
5c35adbb
NC
4286
4287 if (SvROK(ret)) {
288b8c02 4288 SV *const sv = SvRV(ret);
5c35adbb
NC
4289
4290 if (SvTYPE(sv) == SVt_REGEXP) {
d2f13c59 4291 rx = (REGEXP*) sv;
5c35adbb
NC
4292 } else if (SvSMAGICAL(sv)) {
4293 mg = mg_find(sv, PERL_MAGIC_qr);
4294 assert(mg);
4295 }
4296 } else if (SvTYPE(ret) == SVt_REGEXP) {
d2f13c59 4297 rx = (REGEXP*) ret;
5c35adbb 4298 } else if (SvSMAGICAL(ret)) {
124ee91a
NC
4299 if (SvGMAGICAL(ret)) {
4300 /* I don't believe that there is ever qr magic
4301 here. */
4302 assert(!mg_find(ret, PERL_MAGIC_qr));
faf82a0b 4303 sv_unmagic(ret, PERL_MAGIC_qr);
124ee91a
NC
4304 }
4305 else {
faf82a0b 4306 mg = mg_find(ret, PERL_MAGIC_qr);
124ee91a
NC
4307 /* testing suggests mg only ends up non-NULL for
4308 scalars who were upgraded and compiled in the
4309 else block below. In turn, this is only
4310 triggered in the "postponed utf8 string" tests
4311 in t/op/pat.t */
4312 }
0f5d15d6 4313 }
faf82a0b 4314
0f5d15d6 4315 if (mg) {
d2f13c59 4316 rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
e2560c33 4317 assert(rx);
0f5d15d6 4318 }
288b8c02 4319 if (rx) {
f0826785 4320 rx = reg_temp_copy(NULL, rx);
288b8c02 4321 }
0f5d15d6 4322 else {
c737faaf 4323 U32 pm_flags = 0;
a3b680e6 4324 const I32 osize = PL_regsize;
0f5d15d6 4325
b9ad30b4
NC
4326 if (DO_UTF8(ret)) {
4327 assert (SvUTF8(ret));
4328 } else if (SvUTF8(ret)) {
4329 /* Not doing UTF-8, despite what the SV says. Is
4330 this only if we're trapped in use 'bytes'? */
4331 /* Make a copy of the octet sequence, but without
4332 the flag on, as the compiler now honours the
4333 SvUTF8 flag on ret. */
4334 STRLEN len;
4335 const char *const p = SvPV(ret, len);
4336 ret = newSVpvn_flags(p, len, SVs_TEMP);
4337 }
288b8c02 4338 rx = CALLREGCOMP(ret, pm_flags);
9041c2e3 4339 if (!(SvFLAGS(ret)
faf82a0b 4340 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3ce3ed55 4341 | SVs_GMG))) {
a2794585
NC
4342 /* This isn't a first class regexp. Instead, it's
4343 caching a regexp onto an existing, Perl visible
4344 scalar. */
ad64d0ec 4345 sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
3ce3ed55 4346 }
0f5d15d6 4347 PL_regsize = osize;
0f5d15d6 4348 }
288b8c02
NC
4349 re_sv = rx;
4350 re = (struct regexp *)SvANY(rx);
4aabdb9b 4351 }
07bc277f 4352 RXp_MATCH_COPIED_off(re);
28d8d7f4
YO
4353 re->subbeg = rex->subbeg;
4354 re->sublen = rex->sublen;
f8fc2ecf 4355 rei = RXi_GET(re);
6bda09f9 4356 DEBUG_EXECUTE_r(
f2ed9b32 4357 debug_start_match(re_sv, utf8_target, locinput, PL_regeol,
6bda09f9
YO
4358 "Matching embedded");
4359 );
f8fc2ecf 4360 startpoint = rei->program + 1;
1a147d38 4361 ST.close_paren = 0; /* only used for GOSUB */
6bda09f9
YO
4362 /* borrowed from regtry */
4363 if (PL_reg_start_tmpl <= re->nparens) {
4364 PL_reg_start_tmpl = re->nparens*3/2 + 3;
4365 if(PL_reg_start_tmp)
4366 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4367 else
4368 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
dd5def09 4369 }
aa283a38 4370
1a147d38 4371 eval_recurse_doit: /* Share code with GOSUB below this line */
aa283a38 4372 /* run the pattern returned from (??{...}) */
40a82448
DM
4373 ST.cp = regcppush(0); /* Save *all* the positions. */
4374 REGCP_SET(ST.lastcp);
6bda09f9 4375
f0ab9afb 4376 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
6bda09f9 4377
0357f1fd
ML
4378 /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
4379 PL_reglastparen = &re->lastparen;
4380 PL_reglastcloseparen = &re->lastcloseparen;
4381 re->lastparen = 0;
4382 re->lastcloseparen = 0;
4383
4aabdb9b 4384 PL_reginput = locinput;
ae0beba1 4385 PL_regsize = 0;
4aabdb9b
DM
4386
4387 /* XXXX This is too dramatic a measure... */
4388 PL_reg_maxiter = 0;
4389
faec1544 4390 ST.toggle_reg_flags = PL_reg_flags;
3c8556c3 4391 if (RX_UTF8(re_sv))
faec1544
DM
4392 PL_reg_flags |= RF_utf8;
4393 else
4394 PL_reg_flags &= ~RF_utf8;
4395 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
4396
288b8c02 4397 ST.prev_rex = rex_sv;
faec1544 4398 ST.prev_curlyx = cur_curlyx;
288b8c02
NC
4399 SETREX(rex_sv,re_sv);
4400 rex = re;
f8fc2ecf 4401 rexi = rei;
faec1544 4402 cur_curlyx = NULL;
40a82448 4403 ST.B = next;
faec1544
DM
4404 ST.prev_eval = cur_eval;
4405 cur_eval = st;
faec1544 4406 /* now continue from first node in postoned RE */
6bda09f9 4407 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
4aabdb9b 4408 /* NOTREACHED */
a0ed51b3 4409 }
24d3c4a9 4410 /* logical is 1, /(?(?{...})X|Y)/ */
f2338a2e 4411 sw = cBOOL(SvTRUE(ret));
24d3c4a9 4412 logical = 0;
c277df42
IZ
4413 break;
4414 }
40a82448 4415
faec1544
DM
4416 case EVAL_AB: /* cleanup after a successful (??{A})B */
4417 /* note: this is called twice; first after popping B, then A */
4418 PL_reg_flags ^= ST.toggle_reg_flags;
288b8c02
NC
4419 ReREFCNT_dec(rex_sv);
4420 SETREX(rex_sv,ST.prev_rex);
4421 rex = (struct regexp *)SvANY(rex_sv);
f8fc2ecf 4422 rexi = RXi_GET(rex);
faec1544
DM
4423 regcpblow(ST.cp);
4424 cur_eval = ST.prev_eval;
4425 cur_curlyx = ST.prev_curlyx;
34a81e2b
B
4426
4427 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
0357f1fd
ML
4428 PL_reglastparen = &rex->lastparen;
4429 PL_reglastcloseparen = &rex->lastcloseparen;
34a81e2b
B
4430 /* also update PL_regoffs */
4431 PL_regoffs = rex->offs;
0357f1fd 4432
40a82448
DM
4433 /* XXXX This is too dramatic a measure... */
4434 PL_reg_maxiter = 0;
e7707071 4435 if ( nochange_depth )
4b196cd4 4436 nochange_depth--;
262b90c4 4437 sayYES;
40a82448 4438
40a82448 4439
faec1544
DM
4440 case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
4441 /* note: this is called twice; first after popping B, then A */
4442 PL_reg_flags ^= ST.toggle_reg_flags;
288b8c02
NC
4443 ReREFCNT_dec(rex_sv);
4444 SETREX(rex_sv,ST.prev_rex);
4445 rex = (struct regexp *)SvANY(rex_sv);
f8fc2ecf 4446 rexi = RXi_GET(rex);
34a81e2b 4447 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
0357f1fd
ML
4448 PL_reglastparen = &rex->lastparen;
4449 PL_reglastcloseparen = &rex->lastcloseparen;
4450
40a82448
DM
4451 PL_reginput = locinput;
4452 REGCP_UNWIND(ST.lastcp);
4453 regcppop(rex);
faec1544
DM
4454 cur_eval = ST.prev_eval;
4455 cur_curlyx = ST.prev_curlyx;
4456 /* XXXX This is too dramatic a measure... */
4457 PL_reg_maxiter = 0;
e7707071 4458 if ( nochange_depth )
4b196cd4 4459 nochange_depth--;
40a82448 4460 sayNO_SILENT;
40a82448
DM
4461#undef ST
4462
a0d0e21e 4463 case OPEN:
c277df42 4464 n = ARG(scan); /* which paren pair */
3280af22
NIS
4465 PL_reg_start_tmp[n] = locinput;
4466 if (n > PL_regsize)
4467 PL_regsize = n;
e2e6a0f1 4468 lastopen = n;
a0d0e21e
LW
4469 break;
4470 case CLOSE:
c277df42 4471 n = ARG(scan); /* which paren pair */
f0ab9afb
NC
4472 PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
4473 PL_regoffs[n].end = locinput - PL_bostr;
7f69552c
YO
4474 /*if (n > PL_regsize)
4475 PL_regsize = n;*/
3b6647e0 4476 if (n > *PL_reglastparen)
3280af22 4477 *PL_reglastparen = n;
a01268b5 4478 *PL_reglastcloseparen = n;
3b6647e0 4479 if (cur_eval && cur_eval->u.eval.close_paren == n) {
6bda09f9
YO
4480 goto fake_end;
4481 }
a0d0e21e 4482 break;
e2e6a0f1
YO
4483 case ACCEPT:
4484 if (ARG(scan)){
4485 regnode *cursor;
4486 for (cursor=scan;
4487 cursor && OP(cursor)!=END;
4488 cursor=regnext(cursor))
4489 {
4490 if ( OP(cursor)==CLOSE ){
4491 n = ARG(cursor);
4492 if ( n <= lastopen ) {
f0ab9afb
NC
4493 PL_regoffs[n].start
4494 = PL_reg_start_tmp[n] - PL_bostr;
4495 PL_regoffs[n].end = locinput - PL_bostr;
e2e6a0f1
YO
4496 /*if (n > PL_regsize)
4497 PL_regsize = n;*/
3b6647e0 4498 if (n > *PL_reglastparen)
e2e6a0f1
YO
4499 *PL_reglastparen = n;
4500 *PL_reglastcloseparen = n;
3b6647e0
RB
4501 if ( n == ARG(scan) || (cur_eval &&
4502 cur_eval->u.eval.close_paren == n))
e2e6a0f1
YO
4503 break;
4504 }
4505 }
4506 }
4507 }
4508 goto fake_end;
4509 /*NOTREACHED*/
c277df42
IZ
4510 case GROUPP:
4511 n = ARG(scan); /* which paren pair */
f2338a2e 4512 sw = cBOOL(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
c277df42 4513 break;
0a4db386
YO
4514 case NGROUPP:
4515 /* reg_check_named_buff_matched returns 0 for no match */
f2338a2e 4516 sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
0a4db386 4517 break;
1a147d38 4518 case INSUBP:
0a4db386 4519 n = ARG(scan);
3b6647e0 4520 sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
0a4db386
YO
4521 break;
4522 case DEFINEP:
4523 sw = 0;
4524 break;
c277df42 4525 case IFTHEN:
2c2d71f5 4526 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
24d3c4a9 4527 if (sw)
c277df42
IZ
4528 next = NEXTOPER(NEXTOPER(scan));
4529 else {
4530 next = scan + ARG(scan);
4531 if (OP(next) == IFTHEN) /* Fake one. */
4532 next = NEXTOPER(NEXTOPER(next));
4533 }
4534 break;
4535 case LOGICAL:
24d3c4a9 4536 logical = scan->flags;
c277df42 4537 break;
c476f425 4538
2ab05381 4539/*******************************************************************
2ab05381 4540
c476f425
DM
4541The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
4542pattern, where A and B are subpatterns. (For simple A, CURLYM or
4543STAR/PLUS/CURLY/CURLYN are used instead.)
2ab05381 4544
c476f425 4545A*B is compiled as <CURLYX><A><WHILEM><B>
2ab05381 4546
c476f425
DM
4547On entry to the subpattern, CURLYX is called. This pushes a CURLYX
4548state, which contains the current count, initialised to -1. It also sets
4549cur_curlyx to point to this state, with any previous value saved in the
4550state block.
2ab05381 4551
c476f425
DM
4552CURLYX then jumps straight to the WHILEM op, rather than executing A,
4553since the pattern may possibly match zero times (i.e. it's a while {} loop
4554rather than a do {} while loop).
2ab05381 4555
c476f425
DM
4556Each entry to WHILEM represents a successful match of A. The count in the
4557CURLYX block is incremented, another WHILEM state is pushed, and execution
4558passes to A or B depending on greediness and the current count.
2ab05381 4559
c476f425
DM
4560For example, if matching against the string a1a2a3b (where the aN are
4561substrings that match /A/), then the match progresses as follows: (the
4562pushed states are interspersed with the bits of strings matched so far):
2ab05381 4563
c476f425
DM
4564 <CURLYX cnt=-1>
4565 <CURLYX cnt=0><WHILEM>
4566 <CURLYX cnt=1><WHILEM> a1 <WHILEM>
4567 <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
4568 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
4569 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
2ab05381 4570
c476f425
DM
4571(Contrast this with something like CURLYM, which maintains only a single
4572backtrack state:
2ab05381 4573
c476f425
DM
4574 <CURLYM cnt=0> a1
4575 a1 <CURLYM cnt=1> a2
4576 a1 a2 <CURLYM cnt=2> a3
4577 a1 a2 a3 <CURLYM cnt=3> b
4578)
2ab05381 4579
c476f425
DM
4580Each WHILEM state block marks a point to backtrack to upon partial failure
4581of A or B, and also contains some minor state data related to that
4582iteration. The CURLYX block, pointed to by cur_curlyx, contains the
4583overall state, such as the count, and pointers to the A and B ops.
2ab05381 4584
c476f425
DM
4585This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
4586must always point to the *current* CURLYX block, the rules are:
2ab05381 4587
c476f425
DM
4588When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
4589and set cur_curlyx to point the new block.
2ab05381 4590
c476f425
DM
4591When popping the CURLYX block after a successful or unsuccessful match,
4592restore the previous cur_curlyx.
2ab05381 4593
c476f425
DM
4594When WHILEM is about to execute B, save the current cur_curlyx, and set it
4595to the outer one saved in the CURLYX block.
2ab05381 4596
c476f425
DM
4597When popping the WHILEM block after a successful or unsuccessful B match,
4598restore the previous cur_curlyx.
2ab05381 4599
c476f425
DM
4600Here's an example for the pattern (AI* BI)*BO
4601I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
2ab05381 4602
c476f425
DM
4603cur_
4604curlyx backtrack stack
4605------ ---------------
4606NULL
4607CO <CO prev=NULL> <WO>
4608CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4609CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4610NULL <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
2ab05381 4611
c476f425
DM
4612At this point the pattern succeeds, and we work back down the stack to
4613clean up, restoring as we go:
95b24440 4614
c476f425
DM
4615CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4616CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4617CO <CO prev=NULL> <WO>
4618NULL
a0374537 4619
c476f425
DM
4620*******************************************************************/
4621
4622#define ST st->u.curlyx
4623
4624 case CURLYX: /* start of /A*B/ (for complex A) */
4625 {
4626 /* No need to save/restore up to this paren */
4627 I32 parenfloor = scan->flags;
4628
4629 assert(next); /* keep Coverity happy */
4630 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4631 next += ARG(next);
4632
4633 /* XXXX Probably it is better to teach regpush to support
4634 parenfloor > PL_regsize... */
4635 if (parenfloor > (I32)*PL_reglastparen)
4636 parenfloor = *PL_reglastparen; /* Pessimization... */
4637
4638 ST.prev_curlyx= cur_curlyx;
4639 cur_curlyx = st;
4640 ST.cp = PL_savestack_ix;
4641
4642 /* these fields contain the state of the current curly.
4643 * they are accessed by subsequent WHILEMs */
4644 ST.parenfloor = parenfloor;
d02d6d97 4645 ST.me = scan;
c476f425 4646 ST.B = next;
24d3c4a9
DM
4647 ST.minmod = minmod;
4648 minmod = 0;
c476f425
DM
4649 ST.count = -1; /* this will be updated by WHILEM */
4650 ST.lastloc = NULL; /* this will be updated by WHILEM */
4651
4652 PL_reginput = locinput;
4653 PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
5f66b61c 4654 /* NOTREACHED */
c476f425 4655 }
a0d0e21e 4656
c476f425 4657 case CURLYX_end: /* just finished matching all of A*B */
c476f425
DM
4658 cur_curlyx = ST.prev_curlyx;
4659 sayYES;
4660 /* NOTREACHED */
a0d0e21e 4661
c476f425
DM
4662 case CURLYX_end_fail: /* just failed to match all of A*B */
4663 regcpblow(ST.cp);
4664 cur_curlyx = ST.prev_curlyx;
4665 sayNO;
4666 /* NOTREACHED */
4633a7c4 4667
a0d0e21e 4668
c476f425
DM
4669#undef ST
4670#define ST st->u.whilem
4671
4672 case WHILEM: /* just matched an A in /A*B/ (for complex A) */
4673 {
4674 /* see the discussion above about CURLYX/WHILEM */
c476f425 4675 I32 n;
d02d6d97
DM
4676 int min = ARG1(cur_curlyx->u.curlyx.me);
4677 int max = ARG2(cur_curlyx->u.curlyx.me);
4678 regnode *A = NEXTOPER(cur_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS;
4679
c476f425
DM
4680 assert(cur_curlyx); /* keep Coverity happy */
4681 n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4682 ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4683 ST.cache_offset = 0;
4684 ST.cache_mask = 0;
4685
4686 PL_reginput = locinput;
4687
4688 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
d02d6d97
DM
4689 "%*s whilem: matched %ld out of %d..%d\n",
4690 REPORT_CODE_OFF+depth*2, "", (long)n, min, max)
c476f425 4691 );
a0d0e21e 4692
c476f425 4693 /* First just match a string of min A's. */
a0d0e21e 4694
d02d6d97 4695 if (n < min) {
c476f425 4696 cur_curlyx->u.curlyx.lastloc = locinput;
d02d6d97 4697 PUSH_STATE_GOTO(WHILEM_A_pre, A);
c476f425
DM
4698 /* NOTREACHED */
4699 }
4700
4701 /* If degenerate A matches "", assume A done. */
4702
4703 if (locinput == cur_curlyx->u.curlyx.lastloc) {
4704 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4705 "%*s whilem: empty match detected, trying continuation...\n",
4706 REPORT_CODE_OFF+depth*2, "")
4707 );
4708 goto do_whilem_B_max;
4709 }
4710
4711 /* super-linear cache processing */
4712
4713 if (scan->flags) {
a0d0e21e 4714
2c2d71f5 4715 if (!PL_reg_maxiter) {
c476f425
DM
4716 /* start the countdown: Postpone detection until we
4717 * know the match is not *that* much linear. */
2c2d71f5 4718 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
66bf836d
DM
4719 /* possible overflow for long strings and many CURLYX's */
4720 if (PL_reg_maxiter < 0)
4721 PL_reg_maxiter = I32_MAX;
2c2d71f5
JH
4722 PL_reg_leftiter = PL_reg_maxiter;
4723 }
c476f425 4724
2c2d71f5 4725 if (PL_reg_leftiter-- == 0) {
c476f425 4726 /* initialise cache */
3298f257 4727 const I32 size = (PL_reg_maxiter + 7)/8;
2c2d71f5 4728 if (PL_reg_poscache) {
eb160463 4729 if ((I32)PL_reg_poscache_size < size) {
2c2d71f5
JH
4730 Renew(PL_reg_poscache, size, char);
4731 PL_reg_poscache_size = size;
4732 }
4733 Zero(PL_reg_poscache, size, char);
4734 }
4735 else {
4736 PL_reg_poscache_size = size;
a02a5408 4737 Newxz(PL_reg_poscache, size, char);
2c2d71f5 4738 }
c476f425
DM
4739 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4740 "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4741 PL_colors[4], PL_colors[5])
4742 );
2c2d71f5 4743 }
c476f425 4744
2c2d71f5 4745 if (PL_reg_leftiter < 0) {
c476f425
DM
4746 /* have we already failed at this position? */
4747 I32 offset, mask;
4748 offset = (scan->flags & 0xf) - 1
4749 + (locinput - PL_bostr) * (scan->flags>>4);
4750 mask = 1 << (offset % 8);
4751 offset /= 8;
4752 if (PL_reg_poscache[offset] & mask) {
4753 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4754 "%*s whilem: (cache) already tried at this position...\n",
4755 REPORT_CODE_OFF+depth*2, "")
2c2d71f5 4756 );
3298f257 4757 sayNO; /* cache records failure */
2c2d71f5 4758 }
c476f425
DM
4759 ST.cache_offset = offset;
4760 ST.cache_mask = mask;
2c2d71f5 4761 }
c476f425 4762 }
2c2d71f5 4763
c476f425 4764 /* Prefer B over A for minimal matching. */
a687059c 4765
c476f425
DM
4766 if (cur_curlyx->u.curlyx.minmod) {
4767 ST.save_curlyx = cur_curlyx;
4768 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4769 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4770 REGCP_SET(ST.lastcp);
4771 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4772 /* NOTREACHED */
4773 }
a0d0e21e 4774
c476f425
DM
4775 /* Prefer A over B for maximal matching. */
4776
d02d6d97 4777 if (n < max) { /* More greed allowed? */
c476f425
DM
4778 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4779 cur_curlyx->u.curlyx.lastloc = locinput;
4780 REGCP_SET(ST.lastcp);
d02d6d97 4781 PUSH_STATE_GOTO(WHILEM_A_max, A);
c476f425
DM
4782 /* NOTREACHED */
4783 }
4784 goto do_whilem_B_max;
4785 }
4786 /* NOTREACHED */
4787
4788 case WHILEM_B_min: /* just matched B in a minimal match */
4789 case WHILEM_B_max: /* just matched B in a maximal match */
4790 cur_curlyx = ST.save_curlyx;
4791 sayYES;
4792 /* NOTREACHED */
4793
4794 case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4795 cur_curlyx = ST.save_curlyx;
4796 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4797 cur_curlyx->u.curlyx.count--;
4798 CACHEsayNO;
4799 /* NOTREACHED */
4800
4801 case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4802 REGCP_UNWIND(ST.lastcp);
4803 regcppop(rex);
4804 /* FALL THROUGH */
4805 case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4806 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4807 cur_curlyx->u.curlyx.count--;
4808 CACHEsayNO;
4809 /* NOTREACHED */
4810
4811 case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4812 REGCP_UNWIND(ST.lastcp);
4813 regcppop(rex); /* Restore some previous $<digit>s? */
4814 PL_reginput = locinput;
4815 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4816 "%*s whilem: failed, trying continuation...\n",
4817 REPORT_CODE_OFF+depth*2, "")
4818 );
4819 do_whilem_B_max:
4820 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4821 && ckWARN(WARN_REGEXP)
4822 && !(PL_reg_flags & RF_warned))
4823 {
4824 PL_reg_flags |= RF_warned;
4825 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4826 "Complex regular subexpression recursion",
4827 REG_INFTY - 1);
4828 }
4829
4830 /* now try B */
4831 ST.save_curlyx = cur_curlyx;
4832 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4833 PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4834 /* NOTREACHED */
4835
4836 case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4837 cur_curlyx = ST.save_curlyx;
4838 REGCP_UNWIND(ST.lastcp);
4839 regcppop(rex);
4840
d02d6d97 4841 if (cur_curlyx->u.curlyx.count >= /*max*/ARG2(cur_curlyx->u.curlyx.me)) {
c476f425
DM
4842 /* Maximum greed exceeded */
4843 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4844 && ckWARN(WARN_REGEXP)
4845 && !(PL_reg_flags & RF_warned))
4846 {
3280af22 4847 PL_reg_flags |= RF_warned;
c476f425
DM
4848 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4849 "%s limit (%d) exceeded",
4850 "Complex regular subexpression recursion",
4851 REG_INFTY - 1);
a0d0e21e 4852 }
c476f425 4853 cur_curlyx->u.curlyx.count--;
3ab3c9b4 4854 CACHEsayNO;
a0d0e21e 4855 }
c476f425
DM
4856
4857 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4858 "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4859 );
4860 /* Try grabbing another A and see if it helps. */
4861 PL_reginput = locinput;
4862 cur_curlyx->u.curlyx.lastloc = locinput;
4863 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4864 REGCP_SET(ST.lastcp);
d02d6d97
DM
4865 PUSH_STATE_GOTO(WHILEM_A_min,
4866 /*A*/ NEXTOPER(ST.save_curlyx->u.curlyx.me) + EXTRA_STEP_2ARGS);
5f66b61c 4867 /* NOTREACHED */
40a82448
DM
4868
4869#undef ST
4870#define ST st->u.branch
4871
4872 case BRANCHJ: /* /(...|A|...)/ with long next pointer */
c277df42
IZ
4873 next = scan + ARG(scan);
4874 if (next == scan)
4875 next = NULL;
40a82448
DM
4876 scan = NEXTOPER(scan);
4877 /* FALL THROUGH */
c277df42 4878
40a82448
DM
4879 case BRANCH: /* /(...|A|...)/ */
4880 scan = NEXTOPER(scan); /* scan now points to inner node */
40a82448
DM
4881 ST.lastparen = *PL_reglastparen;
4882 ST.next_branch = next;
4883 REGCP_SET(ST.cp);
4884 PL_reginput = locinput;
02db2b7b 4885
40a82448 4886 /* Now go into the branch */
5d458dd8
YO
4887 if (has_cutgroup) {
4888 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4889 } else {
4890 PUSH_STATE_GOTO(BRANCH_next, scan);
4891 }
40a82448 4892 /* NOTREACHED */
5d458dd8
YO
4893 case CUTGROUP:
4894 PL_reginput = locinput;
4895 sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
ad64d0ec 4896 MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5d458dd8
YO
4897 PUSH_STATE_GOTO(CUTGROUP_next,next);
4898 /* NOTREACHED */
4899 case CUTGROUP_next_fail:
4900 do_cutgroup = 1;
4901 no_final = 1;
4902 if (st->u.mark.mark_name)
4903 sv_commit = st->u.mark.mark_name;
4904 sayNO;
4905 /* NOTREACHED */
4906 case BRANCH_next:
4907 sayYES;
4908 /* NOTREACHED */
40a82448 4909 case BRANCH_next_fail: /* that branch failed; try the next, if any */
5d458dd8
YO
4910 if (do_cutgroup) {
4911 do_cutgroup = 0;
4912 no_final = 0;
4913 }
40a82448
DM
4914 REGCP_UNWIND(ST.cp);
4915 for (n = *PL_reglastparen; n > ST.lastparen; n--)
f0ab9afb 4916 PL_regoffs[n].end = -1;
40a82448 4917 *PL_reglastparen = n;
0a4db386 4918 /*dmq: *PL_reglastcloseparen = n; */
40a82448
DM
4919 scan = ST.next_branch;
4920 /* no more branches? */
5d458dd8
YO
4921 if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4922 DEBUG_EXECUTE_r({
4923 PerlIO_printf( Perl_debug_log,
4924 "%*s %sBRANCH failed...%s\n",
4925 REPORT_CODE_OFF+depth*2, "",
4926 PL_colors[4],
4927 PL_colors[5] );
4928 });
4929 sayNO_SILENT;
4930 }
40a82448
DM
4931 continue; /* execute next BRANCH[J] op */
4932 /* NOTREACHED */
4933
a0d0e21e 4934 case MINMOD:
24d3c4a9 4935 minmod = 1;
a0d0e21e 4936 break;
40a82448
DM
4937
4938#undef ST
4939#define ST st->u.curlym
4940
4941 case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4942
4943 /* This is an optimisation of CURLYX that enables us to push
84d2fa14 4944 * only a single backtracking state, no matter how many matches
40a82448
DM
4945 * there are in {m,n}. It relies on the pattern being constant
4946 * length, with no parens to influence future backrefs
4947 */
4948
4949 ST.me = scan;
dc45a647 4950 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
40a82448
DM
4951
4952 /* if paren positive, emulate an OPEN/CLOSE around A */
4953 if (ST.me->flags) {
3b6647e0 4954 U32 paren = ST.me->flags;
40a82448
DM
4955 if (paren > PL_regsize)
4956 PL_regsize = paren;
3b6647e0 4957 if (paren > *PL_reglastparen)
40a82448 4958 *PL_reglastparen = paren;
c277df42 4959 scan += NEXT_OFF(scan); /* Skip former OPEN. */
6407bf3b 4960 }
40a82448
DM
4961 ST.A = scan;
4962 ST.B = next;
4963 ST.alen = 0;
4964 ST.count = 0;
24d3c4a9
DM
4965 ST.minmod = minmod;
4966 minmod = 0;
40a82448
DM
4967 ST.c1 = CHRTEST_UNINIT;
4968 REGCP_SET(ST.cp);
6407bf3b 4969
40a82448
DM
4970 if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4971 goto curlym_do_B;
4972
4973 curlym_do_A: /* execute the A in /A{m,n}B/ */
6407bf3b 4974 PL_reginput = locinput;
40a82448
DM
4975 PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4976 /* NOTREACHED */
5f80c4cf 4977
40a82448
DM
4978 case CURLYM_A: /* we've just matched an A */
4979 locinput = st->locinput;
4980 nextchr = UCHARAT(locinput);
4981
4982 ST.count++;
4983 /* after first match, determine A's length: u.curlym.alen */
4984 if (ST.count == 1) {
4985 if (PL_reg_match_utf8) {
4986 char *s = locinput;
4987 while (s < PL_reginput) {
4988 ST.alen++;
4989 s += UTF8SKIP(s);
4990 }
4991 }
4992 else {
4993 ST.alen = PL_reginput - locinput;
4994 }
4995 if (ST.alen == 0)
4996 ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4997 }
0cadcf80
DM
4998 DEBUG_EXECUTE_r(
4999 PerlIO_printf(Perl_debug_log,
40a82448 5000 "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
5bc10b2c 5001 (int)(REPORT_CODE_OFF+(depth*2)), "",
40a82448 5002 (IV) ST.count, (IV)ST.alen)
0cadcf80
DM
5003 );
5004
40a82448 5005 locinput = PL_reginput;
0a4db386
YO
5006
5007 if (cur_eval && cur_eval->u.eval.close_paren &&
24b23f37 5008 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
0a4db386
YO
5009 goto fake_end;
5010
c966426a
DM
5011 {
5012 I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
5013 if ( max == REG_INFTY || ST.count < max )
5014 goto curlym_do_A; /* try to match another A */
5015 }
40a82448 5016 goto curlym_do_B; /* try to match B */
5f80c4cf 5017
40a82448
DM
5018 case CURLYM_A_fail: /* just failed to match an A */
5019 REGCP_UNWIND(ST.cp);
0a4db386
YO
5020
5021 if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
5022 || (cur_eval && cur_eval->u.eval.close_paren &&
24b23f37 5023 cur_eval->u.eval.close_paren == (U32)ST.me->flags))
40a82448 5024 sayNO;
0cadcf80 5025
40a82448
DM
5026 curlym_do_B: /* execute the B in /A{m,n}B/ */
5027 PL_reginput = locinput;
5028 if (ST.c1 == CHRTEST_UNINIT) {
5029 /* calculate c1 and c2 for possible match of 1st char
5030 * following curly */
5031 ST.c1 = ST.c2 = CHRTEST_VOID;
5032 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
5033 regnode *text_node = ST.B;
5034 if (! HAS_TEXT(text_node))
5035 FIND_NEXT_IMPT(text_node);
ee9b8eae
YO
5036 /* this used to be
5037
5038 (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
5039
5040 But the former is redundant in light of the latter.
5041
5042 if this changes back then the macro for
5043 IS_TEXT and friends need to change.
5044 */
5045 if (PL_regkind[OP(text_node)] == EXACT)
40a82448 5046 {
ee9b8eae 5047
40a82448 5048 ST.c1 = (U8)*STRING(text_node);
9a5a5549
KW
5049 switch (OP(text_node)) {
5050 case EXACTF: ST.c2 = PL_fold[ST.c1]; break;
2f7f8cb1 5051 case EXACTFA:
9a5a5549
KW
5052 case EXACTFU: ST.c2 = PL_fold_latin1[ST.c1]; break;
5053 case EXACTFL: ST.c2 = PL_fold_locale[ST.c1]; break;
5054 default: ST.c2 = ST.c1;
5055 }
c277df42 5056 }
c277df42 5057 }
40a82448
DM
5058 }
5059
5060 DEBUG_EXECUTE_r(
5061 PerlIO_printf(Perl_debug_log,
5062 "%*s CURLYM trying tail with matches=%"IVdf"...\n",
5bc10b2c 5063 (int)(REPORT_CODE_OFF+(depth*2)),
40a82448
DM
5064 "", (IV)ST.count)
5065 );
5066 if (ST.c1 != CHRTEST_VOID
5067 && UCHARAT(PL_reginput) != ST.c1
5068 && UCHARAT(PL_reginput) != ST.c2)
5069 {
5070 /* simulate B failing */
3e901dc0
YO
5071 DEBUG_OPTIMISE_r(
5072 PerlIO_printf(Perl_debug_log,
5073 "%*s CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
5074 (int)(REPORT_CODE_OFF+(depth*2)),"",
5075 (IV)ST.c1,(IV)ST.c2
5076 ));
40a82448
DM
5077 state_num = CURLYM_B_fail;
5078 goto reenter_switch;
5079 }
5080
5081 if (ST.me->flags) {
5082 /* mark current A as captured */
5083 I32 paren = ST.me->flags;
5084 if (ST.count) {
f0ab9afb 5085 PL_regoffs[paren].start
40a82448 5086 = HOPc(PL_reginput, -ST.alen) - PL_bostr;
f0ab9afb 5087 PL_regoffs[paren].end = PL_reginput - PL_bostr;
0a4db386 5088 /*dmq: *PL_reglastcloseparen = paren; */
c277df42 5089 }
40a82448 5090 else
f0ab9afb 5091 PL_regoffs[paren].end = -1;
0a4db386 5092 if (cur_eval && cur_eval->u.eval.close_paren &&
24b23f37 5093 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
0a4db386
YO
5094 {
5095 if (ST.count)
5096 goto fake_end;
5097 else
5098 sayNO;
5099 }
c277df42 5100 }
0a4db386 5101
40a82448 5102 PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
5f66b61c 5103 /* NOTREACHED */
40a82448
DM
5104
5105 case CURLYM_B_fail: /* just failed to match a B */
5106 REGCP_UNWIND(ST.cp);
5107 if (ST.minmod) {
84d2fa14
HS
5108 I32 max = ARG2(ST.me);
5109 if (max != REG_INFTY && ST.count == max)
40a82448
DM
5110 sayNO;
5111 goto curlym_do_A; /* try to match a further A */
5112 }
5113 /* backtrack one A */
5114 if (ST.count == ARG1(ST.me) /* min */)
5115 sayNO;
5116 ST.count--;
5117 locinput = HOPc(locinput, -ST.alen);
5118 goto curlym_do_B; /* try to match B */
5119
c255a977
DM
5120#undef ST
5121#define ST st->u.curly
40a82448 5122
c255a977
DM
5123#define CURLY_SETPAREN(paren, success) \
5124 if (paren) { \
5125 if (success) { \
f0ab9afb
NC
5126 PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
5127 PL_regoffs[paren].end = locinput - PL_bostr; \
0a4db386 5128 *PL_reglastcloseparen = paren; \
c255a977
DM
5129 } \
5130 else \
f0ab9afb 5131 PL_regoffs[paren].end = -1; \
c255a977
DM
5132 }
5133
5134 case STAR: /* /A*B/ where A is width 1 */
5135 ST.paren = 0;
5136 ST.min = 0;
5137 ST.max = REG_INFTY;
a0d0e21e
LW
5138 scan = NEXTOPER(scan);
5139 goto repeat;
c255a977
DM
5140 case PLUS: /* /A+B/ where A is width 1 */
5141 ST.paren = 0;
5142 ST.min = 1;
5143 ST.max = REG_INFTY;
c277df42 5144 scan = NEXTOPER(scan);
c255a977
DM
5145 goto repeat;
5146 case CURLYN: /* /(A){m,n}B/ where A is width 1 */
5147 ST.paren = scan->flags; /* Which paren to set */
5148 if (ST.paren > PL_regsize)
5149 PL_regsize = ST.paren;
3b6647e0 5150 if (ST.paren > *PL_reglastparen)
c255a977
DM
5151 *PL_reglastparen = ST.paren;
5152 ST.min = ARG1(scan); /* min to match */
5153 ST.max = ARG2(scan); /* max to match */
0a4db386 5154 if (cur_eval && cur_eval->u.eval.close_paren &&
86413ec0 5155 cur_eval->u.eval.close_paren == (U32)ST.paren) {
0a4db386
YO
5156 ST.min=1;
5157 ST.max=1;
5158 }
c255a977
DM
5159 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
5160 goto repeat;
5161 case CURLY: /* /A{m,n}B/ where A is width 1 */
5162 ST.paren = 0;
5163 ST.min = ARG1(scan); /* min to match */
5164 ST.max = ARG2(scan); /* max to match */
5165 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
c277df42 5166 repeat:
a0d0e21e
LW
5167 /*
5168 * Lookahead to avoid useless match attempts
5169 * when we know what character comes next.
c255a977 5170 *
5f80c4cf
JP
5171 * Used to only do .*x and .*?x, but now it allows
5172 * for )'s, ('s and (?{ ... })'s to be in the way
5173 * of the quantifier and the EXACT-like node. -- japhy
5174 */
5175
c255a977
DM
5176 if (ST.min > ST.max) /* XXX make this a compile-time check? */
5177 sayNO;
cca55fe3 5178 if (HAS_TEXT(next) || JUMPABLE(next)) {
5f80c4cf
JP
5179 U8 *s;
5180 regnode *text_node = next;
5181
3dab1dad
YO
5182 if (! HAS_TEXT(text_node))
5183 FIND_NEXT_IMPT(text_node);
5f80c4cf 5184
9e137952 5185 if (! HAS_TEXT(text_node))
c255a977 5186 ST.c1 = ST.c2 = CHRTEST_VOID;
5f80c4cf 5187 else {
ee9b8eae 5188 if ( PL_regkind[OP(text_node)] != EXACT ) {
c255a977 5189 ST.c1 = ST.c2 = CHRTEST_VOID;
44a68960 5190 goto assume_ok_easy;
cca55fe3 5191 }
be8e71aa
YO
5192 else
5193 s = (U8*)STRING(text_node);
ee9b8eae
YO
5194
5195 /* Currently we only get here when
5196
5197 PL_rekind[OP(text_node)] == EXACT
5198
5199 if this changes back then the macro for IS_TEXT and
5200 friends need to change. */
f2ed9b32 5201 if (!UTF_PATTERN) {
9a5a5549
KW
5202 ST.c1 = *s;
5203 switch (OP(text_node)) {
5204 case EXACTF: ST.c2 = PL_fold[ST.c1]; break;
2f7f8cb1 5205 case EXACTFA:
9a5a5549
KW
5206 case EXACTFU: ST.c2 = PL_fold_latin1[ST.c1]; break;
5207 case EXACTFL: ST.c2 = PL_fold_locale[ST.c1]; break;
5208 default: ST.c2 = ST.c1; break;
5209 }
1aa99e6b 5210 }
f2ed9b32 5211 else { /* UTF_PATTERN */
9a5a5549 5212 if (IS_TEXTFU(text_node) || IS_TEXTF(text_node)) {
a2a2844f 5213 STRLEN ulen1, ulen2;
89ebb4a3
JH
5214 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
5215 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
a2a2844f
JH
5216
5217 to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
5218 to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
e294cc5d
JH
5219#ifdef EBCDIC
5220 ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
5221 ckWARN(WARN_UTF8) ?
5222 0 : UTF8_ALLOW_ANY);
5223 ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
5224 ckWARN(WARN_UTF8) ?
5225 0 : UTF8_ALLOW_ANY);
5226#else
c255a977 5227 ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
e294cc5d 5228 uniflags);
c255a977 5229 ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
e294cc5d
JH
5230 uniflags);
5231#endif
5f80c4cf
JP
5232 }
5233 else {
c255a977 5234 ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
041457d9 5235 uniflags);
5f80c4cf 5236 }
1aa99e6b
IH
5237 }
5238 }
bbce6d69 5239 }
a0d0e21e 5240 else
c255a977 5241 ST.c1 = ST.c2 = CHRTEST_VOID;
cca55fe3 5242 assume_ok_easy:
c255a977
DM
5243
5244 ST.A = scan;
5245 ST.B = next;
3280af22 5246 PL_reginput = locinput;
24d3c4a9
DM
5247 if (minmod) {
5248 minmod = 0;
e2e6a0f1 5249 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4633a7c4 5250 sayNO;
c255a977 5251 ST.count = ST.min;
a0ed51b3 5252 locinput = PL_reginput;
c255a977
DM
5253 REGCP_SET(ST.cp);
5254 if (ST.c1 == CHRTEST_VOID)
5255 goto curly_try_B_min;
5256
5257 ST.oldloc = locinput;
5258
5259 /* set ST.maxpos to the furthest point along the
5260 * string that could possibly match */
5261 if (ST.max == REG_INFTY) {
5262 ST.maxpos = PL_regeol - 1;
f2ed9b32 5263 if (utf8_target)
c255a977
DM
5264 while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
5265 ST.maxpos--;
5266 }
f2ed9b32 5267 else if (utf8_target) {
c255a977
DM
5268 int m = ST.max - ST.min;
5269 for (ST.maxpos = locinput;
5270 m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
5271 ST.maxpos += UTF8SKIP(ST.maxpos);
5272 }
5273 else {
5274 ST.maxpos = locinput + ST.max - ST.min;
5275 if (ST.maxpos >= PL_regeol)
5276 ST.maxpos = PL_regeol - 1;
5277 }
5278 goto curly_try_B_min_known;
5279
5280 }
5281 else {
e2e6a0f1 5282 ST.count = regrepeat(rex, ST.A, ST.max, depth);
c255a977
DM
5283 locinput = PL_reginput;
5284 if (ST.count < ST.min)
5285 sayNO;
5286 if ((ST.count > ST.min)
5287 && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
5288 {
5289 /* A{m,n} must come at the end of the string, there's
5290 * no point in backing off ... */
5291 ST.min = ST.count;
5292 /* ...except that $ and \Z can match before *and* after
5293 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
5294 We may back off by one in this case. */
5295 if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
5296 ST.min--;
5297 }
5298 REGCP_SET(ST.cp);
5299 goto curly_try_B_max;
5300 }
5301 /* NOTREACHED */
5302
5303
5304 case CURLY_B_min_known_fail:
5305 /* failed to find B in a non-greedy match where c1,c2 valid */
5306 if (ST.paren && ST.count)
f0ab9afb 5307 PL_regoffs[ST.paren].end = -1;
c255a977
DM
5308
5309 PL_reginput = locinput; /* Could be reset... */
5310 REGCP_UNWIND(ST.cp);
5311 /* Couldn't or didn't -- move forward. */
5312 ST.oldloc = locinput;
f2ed9b32 5313 if (utf8_target)
c255a977
DM
5314 locinput += UTF8SKIP(locinput);
5315 else
5316 locinput++;
5317 ST.count++;
5318 curly_try_B_min_known:
5319 /* find the next place where 'B' could work, then call B */
5320 {
5321 int n;
f2ed9b32 5322 if (utf8_target) {
c255a977
DM
5323 n = (ST.oldloc == locinput) ? 0 : 1;
5324 if (ST.c1 == ST.c2) {
5325 STRLEN len;
5326 /* set n to utf8_distance(oldloc, locinput) */
5327 while (locinput <= ST.maxpos &&
5328 utf8n_to_uvchr((U8*)locinput,
5329 UTF8_MAXBYTES, &len,
5330 uniflags) != (UV)ST.c1) {
5331 locinput += len;
5332 n++;
5333 }
1aa99e6b
IH
5334 }
5335 else {
c255a977
DM
5336 /* set n to utf8_distance(oldloc, locinput) */
5337 while (locinput <= ST.maxpos) {
5338 STRLEN len;
5339 const UV c = utf8n_to_uvchr((U8*)locinput,
5340 UTF8_MAXBYTES, &len,
5341 uniflags);
5342 if (c == (UV)ST.c1 || c == (UV)ST.c2)
5343 break;
5344 locinput += len;
5345 n++;
1aa99e6b 5346 }
0fe9bf95
IZ
5347 }
5348 }
c255a977
DM
5349 else {
5350 if (ST.c1 == ST.c2) {
5351 while (locinput <= ST.maxpos &&
5352 UCHARAT(locinput) != ST.c1)
5353 locinput++;
bbce6d69 5354 }
c255a977
DM
5355 else {
5356 while (locinput <= ST.maxpos
5357 && UCHARAT(locinput) != ST.c1
5358 && UCHARAT(locinput) != ST.c2)
5359 locinput++;
a0ed51b3 5360 }
c255a977
DM
5361 n = locinput - ST.oldloc;
5362 }
5363 if (locinput > ST.maxpos)
5364 sayNO;
5365 /* PL_reginput == oldloc now */
5366 if (n) {
5367 ST.count += n;
e2e6a0f1 5368 if (regrepeat(rex, ST.A, n, depth) < n)
4633a7c4 5369 sayNO;
a0d0e21e 5370 }
c255a977
DM
5371 PL_reginput = locinput;
5372 CURLY_SETPAREN(ST.paren, ST.count);
0a4db386 5373 if (cur_eval && cur_eval->u.eval.close_paren &&
86413ec0 5374 cur_eval->u.eval.close_paren == (U32)ST.paren) {
0a4db386
YO
5375 goto fake_end;
5376 }
c255a977 5377 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
a0d0e21e 5378 }
c255a977
DM
5379 /* NOTREACHED */
5380
5381
5382 case CURLY_B_min_fail:
5383 /* failed to find B in a non-greedy match where c1,c2 invalid */
5384 if (ST.paren && ST.count)
f0ab9afb 5385 PL_regoffs[ST.paren].end = -1;
c255a977
DM
5386
5387 REGCP_UNWIND(ST.cp);
5388 /* failed -- move forward one */
5389 PL_reginput = locinput;
e2e6a0f1 5390 if (regrepeat(rex, ST.A, 1, depth)) {
c255a977 5391 ST.count++;
a0ed51b3 5392 locinput = PL_reginput;
c255a977
DM
5393 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
5394 ST.count > 0)) /* count overflow ? */
15272685 5395 {
c255a977
DM
5396 curly_try_B_min:
5397 CURLY_SETPAREN(ST.paren, ST.count);
0a4db386 5398 if (cur_eval && cur_eval->u.eval.close_paren &&
86413ec0 5399 cur_eval->u.eval.close_paren == (U32)ST.paren) {
0a4db386
YO
5400 goto fake_end;
5401 }
c255a977 5402 PUSH_STATE_GOTO(CURLY_B_min, ST.B);
a0d0e21e
LW
5403 }
5404 }
4633a7c4 5405 sayNO;
c255a977
DM
5406 /* NOTREACHED */
5407
5408
5409 curly_try_B_max:
5410 /* a successful greedy match: now try to match B */
40d049e4 5411 if (cur_eval && cur_eval->u.eval.close_paren &&
86413ec0 5412 cur_eval->u.eval.close_paren == (U32)ST.paren) {
40d049e4
YO
5413 goto fake_end;
5414 }
c255a977
DM
5415 {
5416 UV c = 0;
5417 if (ST.c1 != CHRTEST_VOID)
f2ed9b32 5418 c = utf8_target ? utf8n_to_uvchr((U8*)PL_reginput,
c255a977 5419 UTF8_MAXBYTES, 0, uniflags)
466787eb 5420 : (UV) UCHARAT(PL_reginput);
c255a977
DM
5421 /* If it could work, try it. */
5422 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
5423 CURLY_SETPAREN(ST.paren, ST.count);
5424 PUSH_STATE_GOTO(CURLY_B_max, ST.B);
5425 /* NOTREACHED */
5426 }
5427 }
5428 /* FALL THROUGH */
5429 case CURLY_B_max_fail:
5430 /* failed to find B in a greedy match */
5431 if (ST.paren && ST.count)
f0ab9afb 5432 PL_regoffs[ST.paren].end = -1;
c255a977
DM
5433
5434 REGCP_UNWIND(ST.cp);
5435 /* back up. */
5436 if (--ST.count < ST.min)
5437 sayNO;
5438 PL_reginput = locinput = HOPc(locinput, -1);
5439 goto curly_try_B_max;
5440
5441#undef ST
5442
a0d0e21e 5443 case END:
6bda09f9 5444 fake_end:
faec1544
DM
5445 if (cur_eval) {
5446 /* we've just finished A in /(??{A})B/; now continue with B */
5447 I32 tmpix;
faec1544
DM
5448 st->u.eval.toggle_reg_flags
5449 = cur_eval->u.eval.toggle_reg_flags;
5450 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
5451
288b8c02
NC
5452 st->u.eval.prev_rex = rex_sv; /* inner */
5453 SETREX(rex_sv,cur_eval->u.eval.prev_rex);
5454 rex = (struct regexp *)SvANY(rex_sv);
f8fc2ecf 5455 rexi = RXi_GET(rex);
faec1544 5456 cur_curlyx = cur_eval->u.eval.prev_curlyx;
288b8c02 5457 ReREFCNT_inc(rex_sv);
faec1544 5458 st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
34a81e2b
B
5459
5460 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
5461 PL_reglastparen = &rex->lastparen;
5462 PL_reglastcloseparen = &rex->lastcloseparen;
5463
faec1544
DM
5464 REGCP_SET(st->u.eval.lastcp);
5465 PL_reginput = locinput;
5466
5467 /* Restore parens of the outer rex without popping the
5468 * savestack */
5469 tmpix = PL_savestack_ix;
5470 PL_savestack_ix = cur_eval->u.eval.lastcp;
5471 regcppop(rex);
5472 PL_savestack_ix = tmpix;
5473
5474 st->u.eval.prev_eval = cur_eval;
5475 cur_eval = cur_eval->u.eval.prev_eval;
5476 DEBUG_EXECUTE_r(
2a49f0f5
JH
5477 PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n",
5478 REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
e7707071
YO
5479 if ( nochange_depth )
5480 nochange_depth--;
5481
5482 PUSH_YES_STATE_GOTO(EVAL_AB,
faec1544
DM
5483 st->u.eval.prev_eval->u.eval.B); /* match B */
5484 }
5485
3b0527fe 5486 if (locinput < reginfo->till) {
a3621e74 5487 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
7821416a
IZ
5488 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
5489 PL_colors[4],
5490 (long)(locinput - PL_reg_starttry),
3b0527fe 5491 (long)(reginfo->till - PL_reg_starttry),
7821416a 5492 PL_colors[5]));
58e23c8d 5493
262b90c4 5494 sayNO_SILENT; /* Cannot match: too short. */
7821416a
IZ
5495 }
5496 PL_reginput = locinput; /* put where regtry can find it */
262b90c4 5497 sayYES; /* Success! */
dad79028
DM
5498
5499 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
5500 DEBUG_EXECUTE_r(
5501 PerlIO_printf(Perl_debug_log,
5502 "%*s %ssubpattern success...%s\n",
5bc10b2c 5503 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
3280af22 5504 PL_reginput = locinput; /* put where regtry can find it */
262b90c4 5505 sayYES; /* Success! */
dad79028 5506
40a82448
DM
5507#undef ST
5508#define ST st->u.ifmatch
5509
5510 case SUSPEND: /* (?>A) */
5511 ST.wanted = 1;
9fe1d20c 5512 PL_reginput = locinput;
9041c2e3 5513 goto do_ifmatch;
dad79028 5514
40a82448
DM
5515 case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
5516 ST.wanted = 0;
dad79028
DM
5517 goto ifmatch_trivial_fail_test;
5518
40a82448
DM
5519 case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
5520 ST.wanted = 1;
dad79028 5521 ifmatch_trivial_fail_test:
a0ed51b3 5522 if (scan->flags) {
52657f30 5523 char * const s = HOPBACKc(locinput, scan->flags);
dad79028
DM
5524 if (!s) {
5525 /* trivial fail */
24d3c4a9
DM
5526 if (logical) {
5527 logical = 0;
f2338a2e 5528 sw = 1 - cBOOL(ST.wanted);
dad79028 5529 }
40a82448 5530 else if (ST.wanted)
dad79028
DM
5531 sayNO;
5532 next = scan + ARG(scan);
5533 if (next == scan)
5534 next = NULL;
5535 break;
5536 }
efb30f32 5537 PL_reginput = s;
a0ed51b3
LW
5538 }
5539 else
5540 PL_reginput = locinput;
5541
c277df42 5542 do_ifmatch:
40a82448 5543 ST.me = scan;
24d3c4a9 5544 ST.logical = logical;
24d786f4
YO
5545 logical = 0; /* XXX: reset state of logical once it has been saved into ST */
5546
40a82448
DM
5547 /* execute body of (?...A) */
5548 PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
5549 /* NOTREACHED */
5550
5551 case IFMATCH_A_fail: /* body of (?...A) failed */
5552 ST.wanted = !ST.wanted;
5553 /* FALL THROUGH */
5554
5555 case IFMATCH_A: /* body of (?...A) succeeded */
24d3c4a9 5556 if (ST.logical) {
f2338a2e 5557 sw = cBOOL(ST.wanted);
40a82448
DM
5558 }
5559 else if (!ST.wanted)
5560 sayNO;
5561
5562 if (OP(ST.me) == SUSPEND)
5563 locinput = PL_reginput;
5564 else {
5565 locinput = PL_reginput = st->locinput;
5566 nextchr = UCHARAT(locinput);
5567 }
5568 scan = ST.me + ARG(ST.me);
5569 if (scan == ST.me)
5570 scan = NULL;
5571 continue; /* execute B */
5572
5573#undef ST
dad79028 5574
c277df42 5575 case LONGJMP:
c277df42
IZ
5576 next = scan + ARG(scan);
5577 if (next == scan)
5578 next = NULL;
a0d0e21e 5579 break;
54612592 5580 case COMMIT:
e2e6a0f1
YO
5581 reginfo->cutpoint = PL_regeol;
5582 /* FALLTHROUGH */
5d458dd8 5583 case PRUNE:
24b23f37 5584 PL_reginput = locinput;
e2e6a0f1 5585 if (!scan->flags)
ad64d0ec 5586 sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
54612592
YO
5587 PUSH_STATE_GOTO(COMMIT_next,next);
5588 /* NOTREACHED */
5589 case COMMIT_next_fail:
5590 no_final = 1;
5591 /* FALLTHROUGH */
7f69552c
YO
5592 case OPFAIL:
5593 sayNO;
e2e6a0f1
YO
5594 /* NOTREACHED */
5595
5596#define ST st->u.mark
5597 case MARKPOINT:
5598 ST.prev_mark = mark_state;
5d458dd8 5599 ST.mark_name = sv_commit = sv_yes_mark
ad64d0ec 5600 = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
e2e6a0f1
YO
5601 mark_state = st;
5602 ST.mark_loc = PL_reginput = locinput;
5603 PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5604 /* NOTREACHED */
5605 case MARKPOINT_next:
5606 mark_state = ST.prev_mark;
5607 sayYES;
5608 /* NOTREACHED */
5609 case MARKPOINT_next_fail:
5d458dd8 5610 if (popmark && sv_eq(ST.mark_name,popmark))
e2e6a0f1
YO
5611 {
5612 if (ST.mark_loc > startpoint)
5613 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5614 popmark = NULL; /* we found our mark */
5615 sv_commit = ST.mark_name;
5616
5617 DEBUG_EXECUTE_r({
5d458dd8 5618 PerlIO_printf(Perl_debug_log,
e2e6a0f1
YO
5619 "%*s %ssetting cutpoint to mark:%"SVf"...%s\n",
5620 REPORT_CODE_OFF+depth*2, "",
be2597df 5621 PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
e2e6a0f1
YO
5622 });
5623 }
5624 mark_state = ST.prev_mark;
5d458dd8
YO
5625 sv_yes_mark = mark_state ?
5626 mark_state->u.mark.mark_name : NULL;
e2e6a0f1
YO
5627 sayNO;
5628 /* NOTREACHED */
5d458dd8
YO
5629 case SKIP:
5630 PL_reginput = locinput;
5631 if (scan->flags) {
2bf803e2 5632 /* (*SKIP) : if we fail we cut here*/
5d458dd8 5633 ST.mark_name = NULL;
e2e6a0f1 5634 ST.mark_loc = locinput;
5d458dd8
YO
5635 PUSH_STATE_GOTO(SKIP_next,next);
5636 } else {
2bf803e2 5637 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5d458dd8
YO
5638 otherwise do nothing. Meaning we need to scan
5639 */
5640 regmatch_state *cur = mark_state;
ad64d0ec 5641 SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5d458dd8
YO
5642
5643 while (cur) {
5644 if ( sv_eq( cur->u.mark.mark_name,
5645 find ) )
5646 {
5647 ST.mark_name = find;
5648 PUSH_STATE_GOTO( SKIP_next, next );
5649 }
5650 cur = cur->u.mark.prev_mark;
5651 }
e2e6a0f1 5652 }
2bf803e2 5653 /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5d458dd8
YO
5654 break;
5655 case SKIP_next_fail:
5656 if (ST.mark_name) {
5657 /* (*CUT:NAME) - Set up to search for the name as we
5658 collapse the stack*/
5659 popmark = ST.mark_name;
5660 } else {
5661 /* (*CUT) - No name, we cut here.*/
e2e6a0f1
YO
5662 if (ST.mark_loc > startpoint)
5663 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5d458dd8
YO
5664 /* but we set sv_commit to latest mark_name if there
5665 is one so they can test to see how things lead to this
5666 cut */
5667 if (mark_state)
5668 sv_commit=mark_state->u.mark.mark_name;
5669 }
e2e6a0f1
YO
5670 no_final = 1;
5671 sayNO;
5672 /* NOTREACHED */
5673#undef ST
32e6a07c
YO
5674 case FOLDCHAR:
5675 n = ARG(scan);
f2ed9b32 5676 if ( n == (U32)what_len_TRICKYFOLD(locinput,utf8_target,ln) ) {
e64b1bd1 5677 locinput += ln;
ced7f090 5678 } else if ( LATIN_SMALL_LETTER_SHARP_S == n && !utf8_target && !UTF_PATTERN ) {
e64b1bd1
YO
5679 sayNO;
5680 } else {
5681 U8 folded[UTF8_MAXBYTES_CASE+1];
5682 STRLEN foldlen;
5683 const char * const l = locinput;
5684 char *e = PL_regeol;
5685 to_uni_fold(n, folded, &foldlen);
5686
4c1b470c 5687 if (! foldEQ_utf8((const char*) folded, 0, foldlen, 1,
f2ed9b32 5688 l, &e, 0, utf8_target)) {
32e6a07c 5689 sayNO;
e64b1bd1
YO
5690 }
5691 locinput = e;
32e6a07c
YO
5692 }
5693 nextchr = UCHARAT(locinput);
5694 break;
e1d1eefb 5695 case LNBREAK:
f2ed9b32 5696 if ((n=is_LNBREAK(locinput,utf8_target))) {
e1d1eefb
YO
5697 locinput += n;
5698 nextchr = UCHARAT(locinput);
5699 } else
5700 sayNO;
5701 break;
5702
5703#define CASE_CLASS(nAmE) \
5704 case nAmE: \
f2ed9b32 5705 if ((n=is_##nAmE(locinput,utf8_target))) { \
e1d1eefb
YO
5706 locinput += n; \
5707 nextchr = UCHARAT(locinput); \
5708 } else \
5709 sayNO; \
5710 break; \
5711 case N##nAmE: \
f2ed9b32 5712 if ((n=is_##nAmE(locinput,utf8_target))) { \
e1d1eefb
YO
5713 sayNO; \
5714 } else { \
5715 locinput += UTF8SKIP(locinput); \
5716 nextchr = UCHARAT(locinput); \
5717 } \
5718 break
5719
5720 CASE_CLASS(VERTWS);
5721 CASE_CLASS(HORIZWS);
5722#undef CASE_CLASS
5723
a0d0e21e 5724 default:
b900a521 5725 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
d7d93a81 5726 PTR2UV(scan), OP(scan));
cea2e8a9 5727 Perl_croak(aTHX_ "regexp memory corruption");
5d458dd8
YO
5728
5729 } /* end switch */
95b24440 5730
5d458dd8
YO
5731 /* switch break jumps here */
5732 scan = next; /* prepare to execute the next op and ... */
5733 continue; /* ... jump back to the top, reusing st */
95b24440
DM
5734 /* NOTREACHED */
5735
40a82448
DM
5736 push_yes_state:
5737 /* push a state that backtracks on success */
5738 st->u.yes.prev_yes_state = yes_state;
5739 yes_state = st;
5740 /* FALL THROUGH */
5741 push_state:
5742 /* push a new regex state, then continue at scan */
5743 {
5744 regmatch_state *newst;
5745
24b23f37
YO
5746 DEBUG_STACK_r({
5747 regmatch_state *cur = st;
5748 regmatch_state *curyes = yes_state;
5749 int curd = depth;
5750 regmatch_slab *slab = PL_regmatch_slab;
5751 for (;curd > -1;cur--,curd--) {
5752 if (cur < SLAB_FIRST(slab)) {
5753 slab = slab->prev;
5754 cur = SLAB_LAST(slab);
5755 }
5756 PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5757 REPORT_CODE_OFF + 2 + depth * 2,"",
13d6edb4 5758 curd, PL_reg_name[cur->resume_state],
24b23f37
YO
5759 (curyes == cur) ? "yes" : ""
5760 );
5761 if (curyes == cur)
5762 curyes = cur->u.yes.prev_yes_state;
5763 }
5764 } else
5765 DEBUG_STATE_pp("push")
5766 );
40a82448 5767 depth++;
40a82448
DM
5768 st->locinput = locinput;
5769 newst = st+1;
5770 if (newst > SLAB_LAST(PL_regmatch_slab))
5771 newst = S_push_slab(aTHX);
5772 PL_regmatch_state = newst;
786e8c11 5773
40a82448
DM
5774 locinput = PL_reginput;
5775 nextchr = UCHARAT(locinput);
5776 st = newst;
5777 continue;
5778 /* NOTREACHED */
5779 }
a0d0e21e 5780 }
a687059c 5781
a0d0e21e
LW
5782 /*
5783 * We get here only if there's trouble -- normally "case END" is
5784 * the terminating point.
5785 */
cea2e8a9 5786 Perl_croak(aTHX_ "corrupted regexp pointers");
a0d0e21e 5787 /*NOTREACHED*/
4633a7c4
LW
5788 sayNO;
5789
262b90c4 5790yes:
77cb431f
DM
5791 if (yes_state) {
5792 /* we have successfully completed a subexpression, but we must now
5793 * pop to the state marked by yes_state and continue from there */
77cb431f 5794 assert(st != yes_state);
5bc10b2c
DM
5795#ifdef DEBUGGING
5796 while (st != yes_state) {
5797 st--;
5798 if (st < SLAB_FIRST(PL_regmatch_slab)) {
5799 PL_regmatch_slab = PL_regmatch_slab->prev;
5800 st = SLAB_LAST(PL_regmatch_slab);
5801 }
e2e6a0f1 5802 DEBUG_STATE_r({
54612592
YO
5803 if (no_final) {
5804 DEBUG_STATE_pp("pop (no final)");
5805 } else {
5806 DEBUG_STATE_pp("pop (yes)");
5807 }
e2e6a0f1 5808 });
5bc10b2c
DM
5809 depth--;
5810 }
5811#else
77cb431f
DM
5812 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5813 || yes_state > SLAB_LAST(PL_regmatch_slab))
5814 {
5815 /* not in this slab, pop slab */
5816 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5817 PL_regmatch_slab = PL_regmatch_slab->prev;
5818 st = SLAB_LAST(PL_regmatch_slab);
5819 }
5820 depth -= (st - yes_state);
5bc10b2c 5821#endif
77cb431f
DM
5822 st = yes_state;
5823 yes_state = st->u.yes.prev_yes_state;
5824 PL_regmatch_state = st;
24b23f37 5825
5d458dd8
YO
5826 if (no_final) {
5827 locinput= st->locinput;
5828 nextchr = UCHARAT(locinput);
5829 }
54612592 5830 state_num = st->resume_state + no_final;
24d3c4a9 5831 goto reenter_switch;
77cb431f
DM
5832 }
5833
a3621e74 5834 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
e4584336 5835 PL_colors[4], PL_colors[5]));
02db2b7b 5836
19b95bf0
DM
5837 if (PL_reg_eval_set) {
5838 /* each successfully executed (?{...}) block does the equivalent of
5839 * local $^R = do {...}
5840 * When popping the save stack, all these locals would be undone;
5841 * bypass this by setting the outermost saved $^R to the latest
5842 * value */
5843 if (oreplsv != GvSV(PL_replgv))
5844 sv_setsv(oreplsv, GvSV(PL_replgv));
5845 }
95b24440 5846 result = 1;
aa283a38 5847 goto final_exit;
4633a7c4
LW
5848
5849no:
a3621e74 5850 DEBUG_EXECUTE_r(
7821416a 5851 PerlIO_printf(Perl_debug_log,
786e8c11 5852 "%*s %sfailed...%s\n",
5bc10b2c 5853 REPORT_CODE_OFF+depth*2, "",
786e8c11 5854 PL_colors[4], PL_colors[5])
7821416a 5855 );
aa283a38 5856
262b90c4 5857no_silent:
54612592
YO
5858 if (no_final) {
5859 if (yes_state) {
5860 goto yes;
5861 } else {
5862 goto final_exit;
5863 }
5864 }
aa283a38
DM
5865 if (depth) {
5866 /* there's a previous state to backtrack to */
40a82448
DM
5867 st--;
5868 if (st < SLAB_FIRST(PL_regmatch_slab)) {
5869 PL_regmatch_slab = PL_regmatch_slab->prev;
5870 st = SLAB_LAST(PL_regmatch_slab);
5871 }
5872 PL_regmatch_state = st;
40a82448
DM
5873 locinput= st->locinput;
5874 nextchr = UCHARAT(locinput);
5875
5bc10b2c
DM
5876 DEBUG_STATE_pp("pop");
5877 depth--;
262b90c4
DM
5878 if (yes_state == st)
5879 yes_state = st->u.yes.prev_yes_state;
5bc10b2c 5880
24d3c4a9
DM
5881 state_num = st->resume_state + 1; /* failure = success + 1 */
5882 goto reenter_switch;
95b24440 5883 }
24d3c4a9 5884 result = 0;
aa283a38 5885
262b90c4 5886 final_exit:
bbe252da 5887 if (rex->intflags & PREGf_VERBARG_SEEN) {
5d458dd8
YO
5888 SV *sv_err = get_sv("REGERROR", 1);
5889 SV *sv_mrk = get_sv("REGMARK", 1);
5890 if (result) {
e2e6a0f1 5891 sv_commit = &PL_sv_no;
5d458dd8
YO
5892 if (!sv_yes_mark)
5893 sv_yes_mark = &PL_sv_yes;
5894 } else {
5895 if (!sv_commit)
5896 sv_commit = &PL_sv_yes;
5897 sv_yes_mark = &PL_sv_no;
5898 }
5899 sv_setsv(sv_err, sv_commit);
5900 sv_setsv(sv_mrk, sv_yes_mark);
e2e6a0f1 5901 }
19b95bf0 5902
2f554ef7
DM
5903 /* clean up; in particular, free all slabs above current one */
5904 LEAVE_SCOPE(oldsave);
5d9a96ca 5905
95b24440 5906 return result;
a687059c
LW
5907}
5908
5909/*
5910 - regrepeat - repeatedly match something simple, report how many
5911 */
5912/*
5913 * [This routine now assumes that it will only match on things of length 1.
5914 * That was true before, but now we assume scan - reginput is the count,
a0ed51b3 5915 * rather than incrementing count on every character. [Er, except utf8.]]
a687059c 5916 */
76e3520e 5917STATIC I32
e2e6a0f1 5918S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
a687059c 5919{
27da23d5 5920 dVAR;
a0d0e21e 5921 register char *scan;
a0d0e21e 5922 register I32 c;
3280af22 5923 register char *loceol = PL_regeol;
a0ed51b3 5924 register I32 hardcount = 0;
f2ed9b32 5925 register bool utf8_target = PL_reg_match_utf8;
d513472c 5926 UV utf8_flags;
4f55667c
SP
5927#ifndef DEBUGGING
5928 PERL_UNUSED_ARG(depth);
5929#endif
a0d0e21e 5930
7918f24d
NC
5931 PERL_ARGS_ASSERT_REGREPEAT;
5932
3280af22 5933 scan = PL_reginput;
faf11cac
HS
5934 if (max == REG_INFTY)
5935 max = I32_MAX;
5936 else if (max < loceol - scan)
7f596f4c 5937 loceol = scan + max;
a0d0e21e 5938 switch (OP(p)) {
22c35a8c 5939 case REG_ANY:
f2ed9b32 5940 if (utf8_target) {
ffc61ed2 5941 loceol = PL_regeol;
1aa99e6b 5942 while (scan < loceol && hardcount < max && *scan != '\n') {
ffc61ed2
JH
5943 scan += UTF8SKIP(scan);
5944 hardcount++;
5945 }
5946 } else {
5947 while (scan < loceol && *scan != '\n')
5948 scan++;
a0ed51b3
LW
5949 }
5950 break;
ffc61ed2 5951 case SANY:
f2ed9b32 5952 if (utf8_target) {
def8e4ea 5953 loceol = PL_regeol;
a0804c9e 5954 while (scan < loceol && hardcount < max) {
def8e4ea
JH
5955 scan += UTF8SKIP(scan);
5956 hardcount++;
5957 }
5958 }
5959 else
5960 scan = loceol;
a0ed51b3 5961 break;
f33976b4
DB
5962 case CANY:
5963 scan = loceol;
5964 break;
59d32103
KW
5965 case EXACT:
5966 /* To get here, EXACTish nodes must have *byte* length == 1. That
5967 * means they match only characters in the string that can be expressed
5968 * as a single byte. For non-utf8 strings, that means a simple match.
5969 * For utf8 strings, the character matched must be an invariant, or
5970 * downgradable to a single byte. The pattern's utf8ness is
5971 * irrelevant, as since it's a single byte, it either isn't utf8, or if
5972 * it is, it's an invariant */
5973
5974 c = (U8)*STRING(p);
5975 assert(! UTF_PATTERN || UNI_IS_INVARIANT(c));
5976
5977 if (! utf8_target || UNI_IS_INVARIANT(c)) {
5978 while (scan < loceol && UCHARAT(scan) == c) {
5979 scan++;
5980 }
5981 }
5982 else {
5983
5984 /* Here, the string is utf8, and the pattern char is different
5985 * in utf8 than not, so can't compare them directly. Outside the
5986 * loop, find find the two utf8 bytes that represent c, and then
5987 * look for those in sequence in the utf8 string */
5988 U8 high = UTF8_TWO_BYTE_HI(c);
5989 U8 low = UTF8_TWO_BYTE_LO(c);
5990 loceol = PL_regeol;
5991
5992 while (hardcount < max
5993 && scan + 1 < loceol
5994 && UCHARAT(scan) == high
5995 && UCHARAT(scan + 1) == low)
5996 {
5997 scan += 2;
5998 hardcount++;
5999 }
6000 }
6001 break;
2f7f8cb1
KW
6002 case EXACTFA:
6003 utf8_flags = FOLDEQ_UTF8_NOMIX_ASCII;
6004 goto do_exactf;
6005
d4e0b827
KW
6006 case EXACTFL:
6007 PL_reg_flags |= RF_tainted;
17580e7a
KW
6008 utf8_flags = FOLDEQ_UTF8_LOCALE;
6009 goto do_exactf;
6010
d4e0b827 6011 case EXACTF:
9a5a5549 6012 case EXACTFU:
d513472c 6013 utf8_flags = 0;
59d32103 6014
2be3e190
KW
6015 /* The comments for the EXACT case above apply as well to these fold
6016 * ones */
634c83a2 6017
2f7f8cb1 6018 do_exactf:
090f7165 6019 c = (U8)*STRING(p);
634c83a2 6020 assert(! UTF_PATTERN || UNI_IS_INVARIANT(c));
d4e0b827 6021
59d32103 6022 if (utf8_target) { /* Use full Unicode fold matching */
59d32103
KW
6023 char *tmpeol = loceol;
6024 while (hardcount < max
d513472c
KW
6025 && foldEQ_utf8_flags(scan, &tmpeol, 0, utf8_target,
6026 STRING(p), NULL, 1, cBOOL(UTF_PATTERN), utf8_flags))
59d32103
KW
6027 {
6028 scan = tmpeol;
6029 tmpeol = loceol;
6030 hardcount++;
6031 }
634c83a2 6032
59d32103
KW
6033 /* XXX Note that the above handles properly the German sharp s in
6034 * the pattern matching ss in the string. But it doesn't handle
6035 * properly cases where the string contains say 'LIGATURE ff' and
6036 * the pattern is 'f+'. This would require, say, a new function or
6037 * revised interface to foldEQ_utf8(), in which the maximum number
6038 * of characters to match could be passed and it would return how
6039 * many actually did. This is just one of many cases where
6040 * multi-char folds don't work properly, and so the fix is being
6041 * deferred */
6042 }
6043 else {
87381386 6044 U8 folded;
59d32103 6045
2be3e190
KW
6046 /* Here, the string isn't utf8 and c is a single byte; and either
6047 * the pattern isn't utf8 or c is an invariant, so its utf8ness
6048 * doesn't affect c. Can just do simple comparisons for exact or
6049 * fold matching. */
d4e0b827 6050 switch (OP(p)) {
87381386 6051 case EXACTF: folded = PL_fold[c]; break;
2f7f8cb1 6052 case EXACTFA:
9a5a5549 6053 case EXACTFU: folded = PL_fold_latin1[c]; break;
87381386
KW
6054 case EXACTFL: folded = PL_fold_locale[c]; break;
6055 default: Perl_croak(aTHX_ "panic: Unexpected op %u", OP(p));
6056 }
6057 while (scan < loceol &&
6058 (UCHARAT(scan) == c || UCHARAT(scan) == folded))
6059 {
6060 scan++;
634c83a2
KW
6061 }
6062 }
bbce6d69 6063 break;
f56b6394 6064 case ANYOFV:
a0d0e21e 6065 case ANYOF:
4e8910e0
KW
6066 if (utf8_target || OP(p) == ANYOFV) {
6067 STRLEN inclasslen;
ffc61ed2 6068 loceol = PL_regeol;
4e8910e0
KW
6069 inclasslen = loceol - scan;
6070 while (hardcount < max
6071 && ((inclasslen = loceol - scan) > 0)
6072 && reginclass(prog, p, (U8*)scan, &inclasslen, utf8_target))
6073 {
6074 scan += inclasslen;
ffc61ed2
JH
6075 hardcount++;
6076 }
6077 } else {
32fc9b6a 6078 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
ffc61ed2
JH
6079 scan++;
6080 }
a0d0e21e 6081 break;
980866de 6082 case ALNUMU:
f2ed9b32 6083 if (utf8_target) {
980866de 6084 utf8_wordchar:
ffc61ed2 6085 loceol = PL_regeol;
1a4fad37 6086 LOAD_UTF8_CHARCLASS_ALNUM();
1aa99e6b 6087 while (hardcount < max && scan < loceol &&
a12cf05f
KW
6088 swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target))
6089 {
ffc61ed2
JH
6090 scan += UTF8SKIP(scan);
6091 hardcount++;
6092 }
980866de 6093 } else {
a12cf05f
KW
6094 while (scan < loceol && isWORDCHAR_L1((U8) *scan)) {
6095 scan++;
6096 }
980866de
KW
6097 }
6098 break;
6099 case ALNUM:
6100 if (utf8_target)
6101 goto utf8_wordchar;
6102 while (scan < loceol && isALNUM((U8) *scan)) {
6103 scan++;
a0ed51b3
LW
6104 }
6105 break;
cfaf538b
KW
6106 case ALNUMA:
6107 while (scan < loceol && isWORDCHAR_A((U8) *scan)) {
6108 scan++;
6109 }
6110 break;
bbce6d69 6111 case ALNUML:
3280af22 6112 PL_reg_flags |= RF_tainted;
f2ed9b32 6113 if (utf8_target) {
ffc61ed2 6114 loceol = PL_regeol;
1aa99e6b
IH
6115 while (hardcount < max && scan < loceol &&
6116 isALNUM_LC_utf8((U8*)scan)) {
ffc61ed2
JH
6117 scan += UTF8SKIP(scan);
6118 hardcount++;
6119 }
6120 } else {
6121 while (scan < loceol && isALNUM_LC(*scan))
6122 scan++;
a0ed51b3
LW
6123 }
6124 break;
980866de 6125 case NALNUMU:
f2ed9b32 6126 if (utf8_target) {
980866de
KW
6127
6128 utf8_Nwordchar:
6129
ffc61ed2 6130 loceol = PL_regeol;
1a4fad37 6131 LOAD_UTF8_CHARCLASS_ALNUM();
1aa99e6b 6132 while (hardcount < max && scan < loceol &&
980866de 6133 ! swash_fetch(PL_utf8_alnum, (U8*)scan, utf8_target))
a12cf05f 6134 {
ffc61ed2
JH
6135 scan += UTF8SKIP(scan);
6136 hardcount++;
6137 }
980866de 6138 } else {
a12cf05f
KW
6139 while (scan < loceol && ! isWORDCHAR_L1((U8) *scan)) {
6140 scan++;
6141 }
980866de
KW
6142 }
6143 break;
6144 case NALNUM:
6145 if (utf8_target)
6146 goto utf8_Nwordchar;
6147 while (scan < loceol && ! isALNUM((U8) *scan)) {
6148 scan++;
a0ed51b3
LW
6149 }
6150 break;
cfaf538b
KW
6151 case NALNUMA:
6152 if (utf8_target) {
6153 while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) {
6154 scan += UTF8SKIP(scan);
6155 }
6156 }
6157 else {
6158 while (scan < loceol && ! isWORDCHAR_A((U8) *scan)) {
6159 scan++;
6160 }
6161 }
6162 break;
bbce6d69 6163 case NALNUML:
3280af22 6164 PL_reg_flags |= RF_tainted;
f2ed9b32 6165 if (utf8_target) {
ffc61ed2 6166 loceol = PL_regeol;
1aa99e6b
IH
6167 while (hardcount < max && scan < loceol &&
6168 !isALNUM_LC_utf8((U8*)scan)) {
ffc61ed2
JH
6169 scan += UTF8SKIP(scan);
6170 hardcount++;
6171 }
6172 } else {
6173 while (scan < loceol && !isALNUM_LC(*scan))
6174 scan++;
a0ed51b3
LW
6175 }
6176 break;
980866de 6177 case SPACEU:
f2ed9b32 6178 if (utf8_target) {
980866de
KW
6179
6180 utf8_space:
6181
ffc61ed2 6182 loceol = PL_regeol;
1a4fad37 6183 LOAD_UTF8_CHARCLASS_SPACE();
1aa99e6b 6184 while (hardcount < max && scan < loceol &&
3568d838 6185 (*scan == ' ' ||
a12cf05f
KW
6186 swash_fetch(PL_utf8_space,(U8*)scan, utf8_target)))
6187 {
ffc61ed2
JH
6188 scan += UTF8SKIP(scan);
6189 hardcount++;
6190 }
980866de
KW
6191 break;
6192 }
6193 else {
a12cf05f
KW
6194 while (scan < loceol && isSPACE_L1((U8) *scan)) {
6195 scan++;
6196 }
980866de
KW
6197 break;
6198 }
6199 case SPACE:
6200 if (utf8_target)
6201 goto utf8_space;
6202
6203 while (scan < loceol && isSPACE((U8) *scan)) {
6204 scan++;
a0ed51b3
LW
6205 }
6206 break;
cfaf538b
KW
6207 case SPACEA:
6208 while (scan < loceol && isSPACE_A((U8) *scan)) {
6209 scan++;
6210 }
6211 break;
bbce6d69 6212 case SPACEL:
3280af22 6213 PL_reg_flags |= RF_tainted;
f2ed9b32 6214 if (utf8_target) {
ffc61ed2 6215 loceol = PL_regeol;
1aa99e6b 6216 while (hardcount < max && scan < loceol &&
6bbba904 6217 isSPACE_LC_utf8((U8*)scan)) {
ffc61ed2
JH
6218 scan += UTF8SKIP(scan);
6219 hardcount++;
6220 }
6221 } else {
6222 while (scan < loceol && isSPACE_LC(*scan))
6223 scan++;
a0ed51b3
LW
6224 }
6225 break;
980866de 6226 case NSPACEU:
f2ed9b32 6227 if (utf8_target) {
980866de
KW
6228
6229 utf8_Nspace:
6230
ffc61ed2 6231 loceol = PL_regeol;
1a4fad37 6232 LOAD_UTF8_CHARCLASS_SPACE();
1aa99e6b 6233 while (hardcount < max && scan < loceol &&
980866de
KW
6234 ! (*scan == ' ' ||
6235 swash_fetch(PL_utf8_space,(U8*)scan, utf8_target)))
a12cf05f 6236 {
ffc61ed2
JH
6237 scan += UTF8SKIP(scan);
6238 hardcount++;
6239 }
980866de
KW
6240 break;
6241 }
6242 else {
a12cf05f
KW
6243 while (scan < loceol && ! isSPACE_L1((U8) *scan)) {
6244 scan++;
6245 }
980866de
KW
6246 }
6247 break;
6248 case NSPACE:
6249 if (utf8_target)
6250 goto utf8_Nspace;
6251
6252 while (scan < loceol && ! isSPACE((U8) *scan)) {
6253 scan++;
a0ed51b3 6254 }
0008a298 6255 break;
cfaf538b
KW
6256 case NSPACEA:
6257 if (utf8_target) {
6258 while (scan < loceol && ! isSPACE_A((U8) *scan)) {
6259 scan += UTF8SKIP(scan);
6260 }
6261 }
6262 else {
6263 while (scan < loceol && ! isSPACE_A((U8) *scan)) {
6264 scan++;
6265 }
6266 }
6267 break;
bbce6d69 6268 case NSPACEL:
3280af22 6269 PL_reg_flags |= RF_tainted;
f2ed9b32 6270 if (utf8_target) {
ffc61ed2 6271 loceol = PL_regeol;
1aa99e6b 6272 while (hardcount < max && scan < loceol &&
6bbba904 6273 !isSPACE_LC_utf8((U8*)scan)) {
ffc61ed2
JH
6274 scan += UTF8SKIP(scan);
6275 hardcount++;
6276 }
6277 } else {
6278 while (scan < loceol && !isSPACE_LC(*scan))
6279 scan++;
a0ed51b3
LW
6280 }
6281 break;
a0d0e21e 6282 case DIGIT:
f2ed9b32 6283 if (utf8_target) {
ffc61ed2 6284 loceol = PL_regeol;
1a4fad37 6285 LOAD_UTF8_CHARCLASS_DIGIT();
1aa99e6b 6286 while (hardcount < max && scan < loceol &&
f2ed9b32 6287 swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
ffc61ed2
JH
6288 scan += UTF8SKIP(scan);
6289 hardcount++;
6290 }
6291 } else {
6292 while (scan < loceol && isDIGIT(*scan))
6293 scan++;
a0ed51b3
LW
6294 }
6295 break;
cfaf538b
KW
6296 case DIGITA:
6297 while (scan < loceol && isDIGIT_A((U8) *scan)) {
6298 scan++;
6299 }
6300 break;
b77393f6
KW
6301 case DIGITL:
6302 PL_reg_flags |= RF_tainted;
6303 if (utf8_target) {
6304 loceol = PL_regeol;
6305 while (hardcount < max && scan < loceol &&
6306 isDIGIT_LC_utf8((U8*)scan)) {
6307 scan += UTF8SKIP(scan);
6308 hardcount++;
6309 }
6310 } else {
6311 while (scan < loceol && isDIGIT_LC(*scan))
6312 scan++;
6313 }
6314 break;
a0d0e21e 6315 case NDIGIT:
f2ed9b32 6316 if (utf8_target) {
ffc61ed2 6317 loceol = PL_regeol;
1a4fad37 6318 LOAD_UTF8_CHARCLASS_DIGIT();
1aa99e6b 6319 while (hardcount < max && scan < loceol &&
f2ed9b32 6320 !swash_fetch(PL_utf8_digit, (U8*)scan, utf8_target)) {
ffc61ed2
JH
6321 scan += UTF8SKIP(scan);
6322 hardcount++;
6323 }
6324 } else {
6325 while (scan < loceol && !isDIGIT(*scan))
6326 scan++;
a0ed51b3 6327 }
cfaf538b
KW
6328 break;
6329 case NDIGITA:
6330 if (utf8_target) {
6331 while (scan < loceol && ! isDIGIT_A((U8) *scan)) {
6332 scan += UTF8SKIP(scan);
6333 }
6334 }
6335 else {
6336 while (scan < loceol && ! isDIGIT_A((U8) *scan)) {
6337 scan++;
6338 }
6339 }
6340 break;
b77393f6
KW
6341 case NDIGITL:
6342 PL_reg_flags |= RF_tainted;
6343 if (utf8_target) {
6344 loceol = PL_regeol;
6345 while (hardcount < max && scan < loceol &&
6346 !isDIGIT_LC_utf8((U8*)scan)) {
6347 scan += UTF8SKIP(scan);
6348 hardcount++;
6349 }
6350 } else {
6351 while (scan < loceol && !isDIGIT_LC(*scan))
6352 scan++;
6353 }
6354 break;
e1d1eefb 6355 case LNBREAK:
f2ed9b32 6356 if (utf8_target) {
e1d1eefb
YO
6357 loceol = PL_regeol;
6358 while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
6359 scan += c;
6360 hardcount++;
6361 }
6362 } else {
6363 /*
6364 LNBREAK can match two latin chars, which is ok,
6365 because we have a null terminated string, but we
6366 have to use hardcount in this situation
6367 */
6368 while (scan < loceol && (c=is_LNBREAK_latin1(scan))) {
6369 scan+=c;
6370 hardcount++;
6371 }
6372 }
6373 break;
6374 case HORIZWS:
f2ed9b32 6375 if (utf8_target) {
e1d1eefb
YO
6376 loceol = PL_regeol;
6377 while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
6378 scan += c;
6379 hardcount++;
6380 }
6381 } else {
6382 while (scan < loceol && is_HORIZWS_latin1(scan))
6383 scan++;
6384 }
a0ed51b3 6385 break;
e1d1eefb 6386 case NHORIZWS:
f2ed9b32 6387 if (utf8_target) {
e1d1eefb
YO
6388 loceol = PL_regeol;
6389 while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
6390 scan += UTF8SKIP(scan);
6391 hardcount++;
6392 }
6393 } else {
6394 while (scan < loceol && !is_HORIZWS_latin1(scan))
6395 scan++;
6396
6397 }
6398 break;
6399 case VERTWS:
f2ed9b32 6400 if (utf8_target) {
e1d1eefb
YO
6401 loceol = PL_regeol;
6402 while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
6403 scan += c;
6404 hardcount++;
6405 }
6406 } else {
6407 while (scan < loceol && is_VERTWS_latin1(scan))
6408 scan++;
6409
6410 }
6411 break;
6412 case NVERTWS:
f2ed9b32 6413 if (utf8_target) {
e1d1eefb
YO
6414 loceol = PL_regeol;
6415 while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
6416 scan += UTF8SKIP(scan);
6417 hardcount++;
6418 }
6419 } else {
6420 while (scan < loceol && !is_VERTWS_latin1(scan))
6421 scan++;
6422
6423 }
6424 break;
6425
a0d0e21e
LW
6426 default: /* Called on something of 0 width. */
6427 break; /* So match right here or not at all. */
6428 }
a687059c 6429
a0ed51b3
LW
6430 if (hardcount)
6431 c = hardcount;
6432 else
6433 c = scan - PL_reginput;
3280af22 6434 PL_reginput = scan;
a687059c 6435
a3621e74 6436 DEBUG_r({
e68ec53f 6437 GET_RE_DEBUG_FLAGS_DECL;
be8e71aa 6438 DEBUG_EXECUTE_r({
e68ec53f
YO
6439 SV * const prop = sv_newmortal();
6440 regprop(prog, prop, p);
6441 PerlIO_printf(Perl_debug_log,
be8e71aa 6442 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
e2e6a0f1 6443 REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
a3621e74 6444 });
be8e71aa 6445 });
9041c2e3 6446
a0d0e21e 6447 return(c);
a687059c
LW
6448}
6449
c277df42 6450
be8e71aa 6451#if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
c277df42 6452/*
ffc61ed2
JH
6453- regclass_swash - prepare the utf8 swash
6454*/
6455
6456SV *
32fc9b6a 6457Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
ffc61ed2 6458{
97aff369 6459 dVAR;
9e55ce06
JH
6460 SV *sw = NULL;
6461 SV *si = NULL;
6462 SV *alt = NULL;
f8fc2ecf
YO
6463 RXi_GET_DECL(prog,progi);
6464 const struct reg_data * const data = prog ? progi->data : NULL;
ffc61ed2 6465
7918f24d
NC
6466 PERL_ARGS_ASSERT_REGCLASS_SWASH;
6467
4f639d21 6468 if (data && data->count) {
a3b680e6 6469 const U32 n = ARG(node);
ffc61ed2 6470
4f639d21 6471 if (data->what[n] == 's') {
ad64d0ec
NC
6472 SV * const rv = MUTABLE_SV(data->data[n]);
6473 AV * const av = MUTABLE_AV(SvRV(rv));
2d03de9c 6474 SV **const ary = AvARRAY(av);
9e55ce06 6475 SV **a, **b;
9041c2e3 6476
711a919c 6477 /* See the end of regcomp.c:S_regclass() for
9e55ce06
JH
6478 * documentation of these array elements. */
6479
b11f357e 6480 si = *ary;
fe5bfecd
JH
6481 a = SvROK(ary[1]) ? &ary[1] : NULL;
6482 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
b11f357e 6483
ffc61ed2
JH
6484 if (a)
6485 sw = *a;
6486 else if (si && doinit) {
6487 sw = swash_init("utf8", "", si, 1, 0);
6488 (void)av_store(av, 1, sw);
6489 }
9e55ce06
JH
6490 if (b)
6491 alt = *b;
ffc61ed2
JH
6492 }
6493 }
6494
9e55ce06
JH
6495 if (listsvp)
6496 *listsvp = si;
6497 if (altsvp)
6498 *altsvp = alt;
ffc61ed2
JH
6499
6500 return sw;
6501}
76234dfb 6502#endif
ffc61ed2
JH
6503
6504/*
ba7b4546 6505 - reginclass - determine if a character falls into a character class
832705d4 6506
6698fab5
KW
6507 n is the ANYOF regnode
6508 p is the target string
6509 lenp is pointer to the maximum number of bytes of how far to go in p
6510 (This is assumed wthout checking to always be at least the current
6511 character's size)
6512 utf8_target tells whether p is in UTF-8.
832705d4 6513
4b3cda86
KW
6514 Returns true if matched; false otherwise. If lenp is not NULL, on return
6515 from a successful match, the value it points to will be updated to how many
6516 bytes in p were matched. If there was no match, the value is undefined,
6517 possibly changed from the input.
eba1359e 6518
d5788240
KW
6519 Note that this can be a synthetic start class, a combination of various
6520 nodes, so things you think might be mutually exclusive, such as locale,
6521 aren't. It can match both locale and non-locale
6522
bbce6d69 6523 */
6524
76e3520e 6525STATIC bool
f6ad78d8 6526S_reginclass(pTHX_ const regexp * const prog, register const regnode * const n, register const U8* const p, STRLEN* lenp, register const bool utf8_target)
bbce6d69 6527{
27da23d5 6528 dVAR;
a3b680e6 6529 const char flags = ANYOF_FLAGS(n);
bbce6d69 6530 bool match = FALSE;
cc07378b 6531 UV c = *p;
f7ab54c6 6532 STRLEN c_len = 0;
6698fab5 6533 STRLEN maxlen;
1aa99e6b 6534
7918f24d
NC
6535 PERL_ARGS_ASSERT_REGINCLASS;
6536
4b3cda86 6537 /* If c is not already the code point, get it */
f2ed9b32 6538 if (utf8_target && !UTF8_IS_INVARIANT(c)) {
f7ab54c6 6539 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &c_len,
6182169b
KW
6540 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
6541 | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
6542 /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
6543 * UTF8_ALLOW_FFFF */
f7ab54c6 6544 if (c_len == (STRLEN)-1)
e8a70c6f 6545 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
19f67299 6546 }
a5a291f5
KW
6547 else {
6548 c_len = 1;
6549 }
bbce6d69 6550
a5a291f5
KW
6551 /* Use passed in max length, or one character if none passed in or less
6552 * than one character. And assume will match just one character. This is
6553 * overwritten later if matched more. */
4b3cda86 6554 if (lenp) {
a5a291f5
KW
6555 maxlen = (*lenp > c_len) ? *lenp : c_len;
6556 *lenp = c_len;
4b3cda86
KW
6557
6558 }
6559 else {
a5a291f5 6560 maxlen = c_len;
4b3cda86
KW
6561 }
6562
7cdde544
KW
6563 /* If this character is potentially in the bitmap, check it */
6564 if (c < 256) {
ffc61ed2
JH
6565 if (ANYOF_BITMAP_TEST(n, c))
6566 match = TRUE;
11454c59
KW
6567 else if (flags & ANYOF_NON_UTF8_LATIN1_ALL
6568 && ! utf8_target
6569 && ! isASCII(c))
6570 {
6571 match = TRUE;
6572 }
a0ed51b3 6573
78969a98
KW
6574 else if (flags & ANYOF_LOCALE) {
6575 PL_reg_flags |= RF_tainted;
6576
6577 if ((flags & ANYOF_LOC_NONBITMAP_FOLD)
6578 && ANYOF_BITMAP_TEST(n, PL_fold_locale[c]))
6579 {
ffc61ed2 6580 match = TRUE;
78969a98 6581 }
040aea3a
KW
6582 else if (ANYOF_CLASS_TEST_ANY_SET(n) &&
6583 ((ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
6584 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
6585 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
6586 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
6587 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
6588 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
6589 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
6590 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
6591 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
6592 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
6593 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
6594 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
6595 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
6596 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
6597 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
6598 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
6599 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
6600 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
6601 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
6602 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
6603 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
6604 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
6605 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
6606 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
6607 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
6608 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
6609 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
6610 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
6611 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
6612 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
6613 ) /* How's that for a conditional? */
78969a98 6614 ) {
ffc61ed2
JH
6615 match = TRUE;
6616 }
a0ed51b3 6617 }
a0ed51b3
LW
6618 }
6619
7cdde544 6620 /* If the bitmap didn't (or couldn't) match, and something outside the
de87c4fe
KW
6621 * bitmap could match, try that. Locale nodes specifiy completely the
6622 * behavior of code points in the bit map (otherwise, a utf8 target would
6623 * cause them to be treated as Unicode and not locale), except XXX in
6624 * the very unlikely event when this node is a synthetic start class, which
6625 * could be a combination of locale and non-locale nodes */
ef87b810 6626 if (!match) {
10ee90d2
KW
6627 if (utf8_target && (flags & ANYOF_UNICODE_ALL) && c >= 256) {
6628 match = TRUE; /* Everything above 255 matches */
e051a21d 6629 }
10ee90d2 6630 else if ((flags & ANYOF_NONBITMAP_NON_UTF8
de87c4fe
KW
6631 || (utf8_target && flags & ANYOF_UTF8
6632 && (c >=256 || ! (flags & ANYOF_LOCALE)))))
ef87b810 6633 {
7cdde544
KW
6634 AV *av;
6635 SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
6636
6637 if (sw) {
6638 U8 * utf8_p;
6639 if (utf8_target) {
6640 utf8_p = (U8 *) p;
6641 } else {
f56b6394
KW
6642
6643 /* Not utf8. Convert as much of the string as available up
6644 * to the limit of how far the (single) character in the
6645 * pattern can possibly match (no need to go further). If
6646 * the node is a straight ANYOF or not folding, it can't
6647 * match more than one. Otherwise, It can match up to how
6648 * far a single char can fold to. Since not utf8, each
6649 * character is a single byte, so the max it can be in
6650 * bytes is the same as the max it can be in characters */
6651 STRLEN len = (OP(n) == ANYOF
6652 || ! (flags & ANYOF_LOC_NONBITMAP_FOLD))
6653 ? 1
6654 : (maxlen < UTF8_MAX_FOLD_CHAR_EXPAND)
6655 ? maxlen
6656 : UTF8_MAX_FOLD_CHAR_EXPAND;
7cdde544
KW
6657 utf8_p = bytes_to_utf8(p, &len);
6658 }
f56b6394 6659
f7eb7452 6660 if (swash_fetch(sw, utf8_p, TRUE))
7cdde544 6661 match = TRUE;
39065660 6662 else if (flags & ANYOF_LOC_NONBITMAP_FOLD) {
f56b6394
KW
6663
6664 /* Here, we need to test if the fold of the target string
6665 * matches. In the case of a multi-char fold that is
6666 * caught by regcomp.c, it has stored all such folds into
6667 * 'av'; we linearly check to see if any match the target
6668 * string (folded). We know that the originals were each
6669 * one character, but we don't currently know how many
6670 * characters/bytes each folded to, except we do know that
6671 * there are small limits imposed by Unicode. XXX A
6672 * performance enhancement would be to have regcomp.c store
6673 * the max number of chars/bytes that are in an av entry,
f6ed098a
KW
6674 * as, say the 0th element. Even better would be to have a
6675 * hash of the few characters that can start a multi-char
6676 * fold to the max number of chars of those folds.
6677 *
6678 * Further down, if there isn't a
f56b6394
KW
6679 * match in the av, we will check if there is another
6680 * fold-type match. For that, we also need the fold, but
6681 * only the first character. No sense in folding it twice,
6682 * so we do it here, even if there isn't any multi-char
6683 * fold, so we always fold at least the first character.
6684 * If the node is a straight ANYOF node, or there is only
6685 * one character available in the string, or if there isn't
6686 * any av, that's all we have to fold. In the case of a
6687 * multi-char fold, we do have guarantees in Unicode that
6688 * it can only expand up to so many characters and so many
6689 * bytes. We keep track so don't exceed either.
6690 *
6691 * If there is a match, we will need to advance (if lenp is
6692 * specified) the match pointer in the target string. But
6693 * what we are comparing here isn't that string directly,
6694 * but its fold, whose length may differ from the original.
6695 * As we go along in constructing the fold, therefore, we
6696 * create a map so that we know how many bytes in the
6697 * source to advance given that we have matched a certain
6698 * number of bytes in the fold. This map is stored in
6699 * 'map_fold_len_back'. The first character in the fold
6700 * has array element 1 contain the number of bytes in the
6701 * source that folded to it; the 2nd is the cumulative
6702 * number to match it; ... */
6703 U8 map_fold_len_back[UTF8_MAX_FOLD_CHAR_EXPAND] = { 0 };
6704 U8 folded[UTF8_MAXBYTES_CASE+1];
6705 STRLEN foldlen = 0; /* num bytes in fold of 1st char */
6706 STRLEN foldlen_for_av; /* num bytes in fold of all chars */
6707
6708 if (OP(n) == ANYOF || maxlen == 1 || ! lenp || ! av) {
6709
6710 /* Here, only need to fold the first char of the target
6711 * string */
6712 to_utf8_fold(utf8_p, folded, &foldlen);
6713 foldlen_for_av = foldlen;
6714 map_fold_len_back[1] = UTF8SKIP(utf8_p);
6715 }
6716 else {
6717
6718 /* Here, need to fold more than the first char. Do so
6719 * up to the limits */
6720 UV which_char = 0;
6721 U8* source_ptr = utf8_p; /* The source for the fold
6722 is the regex target
6723 string */
6724 U8* folded_ptr = folded;
6725 U8* e = utf8_p + maxlen; /* Can't go beyond last
6726 available byte in the
6727 target string */
6728 while (which_char < UTF8_MAX_FOLD_CHAR_EXPAND
6729 && source_ptr < e)
6730 {
6731
6732 /* Fold the next character */
6733 U8 this_char_folded[UTF8_MAXBYTES_CASE+1];
6734 STRLEN this_char_foldlen;
6735 to_utf8_fold(source_ptr,
6736 this_char_folded,
6737 &this_char_foldlen);
6738
6739 /* Bail if it would exceed the byte limit for
6740 * folding a single char. */
6741 if (this_char_foldlen + folded_ptr - folded >
6742 UTF8_MAXBYTES_CASE)
6743 {
6744 break;
6745 }
6746
6747 /* Save the first character's folded length, in
6748 * case we have to use it later */
6749 if (! foldlen) {
6750 foldlen = this_char_foldlen;
6751 }
6752
6753 /* Here, add the fold of this character */
6754 Copy(this_char_folded,
6755 folded_ptr,
6756 this_char_foldlen,
6757 U8);
6758 which_char++;
6759 map_fold_len_back[which_char] =
6760 map_fold_len_back[which_char - 1]
6761 + UTF8SKIP(source_ptr);
6762 folded_ptr += this_char_foldlen;
6763 source_ptr += UTF8SKIP(source_ptr);
6764 }
6765 *folded_ptr = '\0';
6766 foldlen_for_av = folded_ptr - folded;
6767 }
6768
6769
6770 /* Do the linear search to see if the fold is in the list
6771 * of multi-char folds. (Useless to look if won't be able
6772 * to store that it is a multi-char fold in *lenp) */
6773 if (lenp && av) {
7cdde544
KW
6774 I32 i;
6775 for (i = 0; i <= av_len(av); i++) {
6776 SV* const sv = *av_fetch(av, i, FALSE);
6777 STRLEN len;
6778 const char * const s = SvPV_const(sv, len);
f56b6394
KW
6779 if (len <= foldlen_for_av && memEQ(s,
6780 (char*)folded,
6781 len))
6782 {
6783
6784 /* Advance the target string ptr to account for
6785 * this fold, but have to translate from the
6786 * folded length to the corresponding source
6787 * length. The array is indexed by how many
6788 * characters in the match */
6789 *lenp = map_fold_len_back[
6790 utf8_length(folded, folded + len)];
7cdde544
KW
6791 match = TRUE;
6792 break;
6793 }
6794 }
6795 }
56ca34ca 6796#if 0
4ee329b3 6797 if (!match) { /* See if the folded version matches */
4ee329b3 6798 SV** listp;
e34d62e9 6799
4ee329b3
KW
6800 /* Consider "k" =~ /[K]/i. The line above would have
6801 * just folded the 'k' to itself, and that isn't going
6802 * to match 'K'. So we look through the closure of
6803 * everything that folds to 'k'. That will find the
6804 * 'K'. Initialize the list, if necessary */
6805 if (! PL_utf8_foldclosures) {
6806
6807 /* If the folds haven't been read in, call a fold
6808 * function to force that */
6809 if (! PL_utf8_tofold) {
6810 U8 dummy[UTF8_MAXBYTES+1];
6811 STRLEN dummy_len;
6812 to_utf8_fold((U8*) "A", dummy, &dummy_len);
6813 }
6814 PL_utf8_foldclosures =
6815 _swash_inversion_hash(PL_utf8_tofold);
6816 }
2726813d 6817
4ee329b3
KW
6818 /* The data structure is a hash with the keys every
6819 * character that is folded to, like 'k', and the
6820 * values each an array of everything that folds to its
6821 * key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
6822 if ((listp = hv_fetch(PL_utf8_foldclosures,
6823 (char *) folded, foldlen, FALSE)))
6824 {
6825 AV* list = (AV*) *listp;
6826 IV i;
6827 for (i = 0; i <= av_len(list); i++) {
6828 SV** try_p = av_fetch(list, i, FALSE);
6829 char* try_c;
6830 if (try_p == NULL) {
6831 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
6832 }
486ec47a 6833 /* Don't have to worry about embedded nulls
4ee329b3
KW
6834 * since NULL isn't folded or foldable */
6835 try_c = SvPVX(*try_p);
6836
6837 /* The fold in a few cases of an above Latin1
6838 * char is in the Latin1 range, and hence may
6839 * be in the bitmap */
6840 if (UTF8_IS_INVARIANT(*try_c)
6841 && ANYOF_BITMAP_TEST(n,
6842 UNI_TO_NATIVE(*try_c)))
a9ef5332 6843 {
4ee329b3
KW
6844 match = TRUE;
6845 break;
6846 }
6847 else if
6848 (UTF8_IS_DOWNGRADEABLE_START(*try_c)
6849 && ANYOF_BITMAP_TEST(n, UNI_TO_NATIVE(
1f933721 6850 TWO_BYTE_UTF8_TO_UNI(try_c[0],
4ee329b3
KW
6851 try_c[1]))))
6852 {
6853 /* Since the fold comes from internally
6854 * generated data, we can safely assume it
6855 * is valid utf8 in the test above */
6856 match = TRUE;
6857 break;
f7eb7452 6858 } else if (swash_fetch(sw, (U8*) try_c, TRUE)) {
4ee329b3
KW
6859 match = TRUE;
6860 break;
2726813d 6861 }
4ee329b3
KW
6862 }
6863 }
7cdde544 6864 }
56ca34ca 6865#endif
7cdde544
KW
6866 }
6867
6868 /* If we allocated a string above, free it */
6869 if (! utf8_target) Safefree(utf8_p);
6870 }
6871 }
6872 }
6873
a0ed51b3
LW
6874 return (flags & ANYOF_INVERT) ? !match : match;
6875}
161b471a 6876
dfe13c55 6877STATIC U8 *
0ce71af7 6878S_reghop3(U8 *s, I32 off, const U8* lim)
9041c2e3 6879{
97aff369 6880 dVAR;
7918f24d
NC
6881
6882 PERL_ARGS_ASSERT_REGHOP3;
6883
a0ed51b3 6884 if (off >= 0) {
1aa99e6b 6885 while (off-- && s < lim) {
ffc61ed2 6886 /* XXX could check well-formedness here */
a0ed51b3 6887 s += UTF8SKIP(s);
ffc61ed2 6888 }
a0ed51b3
LW
6889 }
6890 else {
1de06328
YO
6891 while (off++ && s > lim) {
6892 s--;
6893 if (UTF8_IS_CONTINUED(*s)) {
6894 while (s > lim && UTF8_IS_CONTINUATION(*s))
6895 s--;
a0ed51b3 6896 }
1de06328 6897 /* XXX could check well-formedness here */
a0ed51b3
LW
6898 }
6899 }
6900 return s;
6901}
161b471a 6902
f9f4320a
YO
6903#ifdef XXX_dmq
6904/* there are a bunch of places where we use two reghop3's that should
6905 be replaced with this routine. but since thats not done yet
6906 we ifdef it out - dmq
6907*/
dfe13c55 6908STATIC U8 *
1de06328
YO
6909S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
6910{
6911 dVAR;
7918f24d
NC
6912
6913 PERL_ARGS_ASSERT_REGHOP4;
6914
1de06328
YO
6915 if (off >= 0) {
6916 while (off-- && s < rlim) {
6917 /* XXX could check well-formedness here */
6918 s += UTF8SKIP(s);
6919 }
6920 }
6921 else {
6922 while (off++ && s > llim) {
6923 s--;
6924 if (UTF8_IS_CONTINUED(*s)) {
6925 while (s > llim && UTF8_IS_CONTINUATION(*s))
6926 s--;
6927 }
6928 /* XXX could check well-formedness here */
6929 }
6930 }
6931 return s;
6932}
f9f4320a 6933#endif
1de06328
YO
6934
6935STATIC U8 *
0ce71af7 6936S_reghopmaybe3(U8* s, I32 off, const U8* lim)
a0ed51b3 6937{
97aff369 6938 dVAR;
7918f24d
NC
6939
6940 PERL_ARGS_ASSERT_REGHOPMAYBE3;
6941
a0ed51b3 6942 if (off >= 0) {
1aa99e6b 6943 while (off-- && s < lim) {
ffc61ed2 6944 /* XXX could check well-formedness here */
a0ed51b3 6945 s += UTF8SKIP(s);
ffc61ed2 6946 }
a0ed51b3 6947 if (off >= 0)
3dab1dad 6948 return NULL;
a0ed51b3
LW
6949 }
6950 else {
1de06328
YO
6951 while (off++ && s > lim) {
6952 s--;
6953 if (UTF8_IS_CONTINUED(*s)) {
6954 while (s > lim && UTF8_IS_CONTINUATION(*s))
6955 s--;
a0ed51b3 6956 }
1de06328 6957 /* XXX could check well-formedness here */
a0ed51b3
LW
6958 }
6959 if (off <= 0)
3dab1dad 6960 return NULL;
a0ed51b3
LW
6961 }
6962 return s;
6963}
51371543 6964
51371543 6965static void
acfe0abc 6966restore_pos(pTHX_ void *arg)
51371543 6967{
97aff369 6968 dVAR;
097eb12c 6969 regexp * const rex = (regexp *)arg;
51371543
GS
6970 if (PL_reg_eval_set) {
6971 if (PL_reg_oldsaved) {
4f639d21
DM
6972 rex->subbeg = PL_reg_oldsaved;
6973 rex->sublen = PL_reg_oldsavedlen;
f8c7b90f 6974#ifdef PERL_OLD_COPY_ON_WRITE
4f639d21 6975 rex->saved_copy = PL_nrs;
ed252734 6976#endif
07bc277f 6977 RXp_MATCH_COPIED_on(rex);
51371543
GS
6978 }
6979 PL_reg_magic->mg_len = PL_reg_oldpos;
6980 PL_reg_eval_set = 0;
6981 PL_curpm = PL_reg_oldcurpm;
6982 }
6983}
33b8afdf
JH
6984
6985STATIC void
6986S_to_utf8_substr(pTHX_ register regexp *prog)
6987{
a1cac82e 6988 int i = 1;
7918f24d
NC
6989
6990 PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
6991
a1cac82e
NC
6992 do {
6993 if (prog->substrs->data[i].substr
6994 && !prog->substrs->data[i].utf8_substr) {
6995 SV* const sv = newSVsv(prog->substrs->data[i].substr);
6996 prog->substrs->data[i].utf8_substr = sv;
6997 sv_utf8_upgrade(sv);
610460f9
NC
6998 if (SvVALID(prog->substrs->data[i].substr)) {
6999 const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
7000 if (flags & FBMcf_TAIL) {
7001 /* Trim the trailing \n that fbm_compile added last
7002 time. */
7003 SvCUR_set(sv, SvCUR(sv) - 1);
7004 /* Whilst this makes the SV technically "invalid" (as its
7005 buffer is no longer followed by "\0") when fbm_compile()
7006 adds the "\n" back, a "\0" is restored. */
7007 }
7008 fbm_compile(sv, flags);
7009 }
a1cac82e
NC
7010 if (prog->substrs->data[i].substr == prog->check_substr)
7011 prog->check_utf8 = sv;
7012 }
7013 } while (i--);
33b8afdf
JH
7014}
7015
7016STATIC void
7017S_to_byte_substr(pTHX_ register regexp *prog)
7018{
97aff369 7019 dVAR;
a1cac82e 7020 int i = 1;
7918f24d
NC
7021
7022 PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
7023
a1cac82e
NC
7024 do {
7025 if (prog->substrs->data[i].utf8_substr
7026 && !prog->substrs->data[i].substr) {
7027 SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
7028 if (sv_utf8_downgrade(sv, TRUE)) {
610460f9
NC
7029 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
7030 const U8 flags
7031 = BmFLAGS(prog->substrs->data[i].utf8_substr);
7032 if (flags & FBMcf_TAIL) {
7033 /* Trim the trailing \n that fbm_compile added last
7034 time. */
7035 SvCUR_set(sv, SvCUR(sv) - 1);
7036 }
7037 fbm_compile(sv, flags);
7038 }
a1cac82e
NC
7039 } else {
7040 SvREFCNT_dec(sv);
7041 sv = &PL_sv_undef;
7042 }
7043 prog->substrs->data[i].substr = sv;
7044 if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
7045 prog->check_substr = sv;
33b8afdf 7046 }
a1cac82e 7047 } while (i--);
33b8afdf 7048}
66610fdd
RGS
7049
7050/*
7051 * Local variables:
7052 * c-indentation-style: bsd
7053 * c-basic-offset: 4
7054 * indent-tabs-mode: t
7055 * End:
7056 *
37442d52
RGS
7057 * ex: set ts=8 sts=4 sw=4 noet:
7058 */