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