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