This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
regexec.c: Add to comment
[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",