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