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