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