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