This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
was RE: Perl_die() / Perl_croak()
[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;
3b6647e0 221 U32 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 */
3b6647e0 275 for (i = *PL_reglastparen + 1; 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)) \
24b23f37 1021 && (!reginfo || regtry(reginfo, &s)) ) \
4cadc6a9
YO		 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)) \
24b23f37 1034 && (!reginfo || regtry(reginfo, &s)) ) \
4cadc6a9
YO		 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))) \
24b23f37 1046 && (!reginfo || regtry(reginfo, &s)) ) \
4cadc6a9
YO		 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) { \
24b23f37 1071 if (tmp && (!reginfo || regtry(reginfo, &s))) \
4cadc6a9
YO		 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) { \
24b23f37 1083 if (tmp && (!reginfo || regtry(reginfo, &s))) \
4cadc6a9
YO		 1084 goto got_it; \
1085 else \
1086 tmp = doevery; \
1087 } \
1088 else \
1089 tmp = 1; \
1090)
1091
1092#define REXEC_FBC_TRYIT \
24b23f37 1093if ((!reginfo || regtry(reginfo, &s))) \
4cadc6a9
YO		 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 1125S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
24b23f37 1126 const char *strend, 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))) {
24b23f37 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(
24b23f37 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 }
24b23f37 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 }
24b23f37 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 });
24b23f37 1601 if (!reginfo || regtry(reginfo, &s)) {
be8e71aa
YO		 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;
24b23f37 1642 /*register*/ char *s;
6eb5f6b9 1643 register regnode *c;
24b23f37 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)) {
24b23f37 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) {
24b23f37 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 */
24b23f37 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. */
24b23f37 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 );
24b23f37 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 );
24b23f37 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) {
24b23f37 1906 if (regtry(&reginfo, &s))
6eb5f6b9
JH		 1907 goto got_it;
1908 s += UTF8SKIP(s);
1909 }
1910 }
1911 else {
1912 while (s <= last1) {
24b23f37 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 (;;) {
24b23f37 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 {
24b23f37 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 */
24b23f37 2085S_regtry(pTHX_ 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;
24b23f37 2093 reginfo->cutpoint=NULL;
d6a28714
JH		 2094
2095 if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2096 MAGIC *mg;
2097
2098 PL_reg_eval_set = RS_init;
a3621e74 2099 DEBUG_EXECUTE_r(DEBUG_s(
b900a521
JH		 2100 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2101 (IV)(PL_stack_sp - PL_stack_base));
d6a28714 2102 ));
ea8d6ae1 2103 SAVESTACK_CXPOS();
d6a28714
JH		 2104 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2105 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2106 SAVETMPS;
2107 /* Apparently this is not needed, judging by wantarray. */
e8347627 2108 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
d6a28714
JH		 2109 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2110
3b0527fe 2111 if (reginfo->sv) {
d6a28714 2112 /* Make $_ available to executed code. */
3b0527fe 2113 if (reginfo->sv != DEFSV) {
59f00321 2114 SAVE_DEFSV;
3b0527fe 2115 DEFSV = reginfo->sv;
b8c5462f 2116 }
d6a28714 2117
3b0527fe
DM		 2118 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2119 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
d6a28714 2120 /* prepare for quick setting of pos */
d300d9fa 2121#ifdef PERL_OLD_COPY_ON_WRITE
51a9ea20
NC		 2122 if (SvIsCOW(reginfo->sv))
2123 sv_force_normal_flags(reginfo->sv, 0);
d300d9fa 2124#endif
3dab1dad 2125 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
d300d9fa 2126 &PL_vtbl_mglob, NULL, 0);
d6a28714 2127 mg->mg_len = -1;
b8c5462f 2128 }
d6a28714
JH		 2129 PL_reg_magic = mg;
2130 PL_reg_oldpos = mg->mg_len;
4f639d21 2131 SAVEDESTRUCTOR_X(restore_pos, prog);
d6a28714 2132 }
09687e5a 2133 if (!PL_reg_curpm) {
a02a5408 2134 Newxz(PL_reg_curpm, 1, PMOP);
09687e5a
AB		 2135#ifdef USE_ITHREADS
2136 {
be8e71aa 2137 SV* const repointer = newSViv(0);
577e12cc 2138 /* so we know which PL_regex_padav element is PL_reg_curpm */
35061a7e 2139 SvFLAGS(repointer) |= SVf_BREAK;
09687e5a
AB		 2140 av_push(PL_regex_padav,repointer);
2141 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2142 PL_regex_pad = AvARRAY(PL_regex_padav);
2143 }
2144#endif
2145 }
aaa362c4 2146 PM_SETRE(PL_reg_curpm, prog);
d6a28714
JH		 2147 PL_reg_oldcurpm = PL_curpm;
2148 PL_curpm = PL_reg_curpm;
2149 if (RX_MATCH_COPIED(prog)) {
2150 /* Here is a serious problem: we cannot rewrite subbeg,
2151 since it may be needed if this match fails. Thus
2152 $` inside (?{}) could fail... */
2153 PL_reg_oldsaved = prog->subbeg;
2154 PL_reg_oldsavedlen = prog->sublen;
f8c7b90f 2155#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2156 PL_nrs = prog->saved_copy;
2157#endif
d6a28714
JH		 2158 RX_MATCH_COPIED_off(prog);
2159 }
2160 else
bd61b366 2161 PL_reg_oldsaved = NULL;
d6a28714
JH		 2162 prog->subbeg = PL_bostr;
2163 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2164 }
24b23f37
YO		 2165 DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2166 prog->startp[0] = *startpos - PL_bostr;
2167 PL_reginput = *startpos;
d6a28714 2168 PL_reglastparen = &prog->lastparen;
a01268b5 2169 PL_reglastcloseparen = &prog->lastcloseparen;
d6a28714 2170 prog->lastparen = 0;
03994de8 2171 prog->lastcloseparen = 0;
d6a28714 2172 PL_regsize = 0;
6bda09f9
YO		 2173 PL_regstartp = prog->startp;
2174 PL_regendp = prog->endp;
d6a28714
JH		 2175 if (PL_reg_start_tmpl <= prog->nparens) {
2176 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2177 if(PL_reg_start_tmp)
2178 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2179 else
a02a5408 2180 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
d6a28714
JH		 2181 }
2182
2183 /* XXXX What this code is doing here?!!! There should be no need
2184 to do this again and again, PL_reglastparen should take care of
3dd2943c 2185 this! --ilya*/
dafc8851
JH		 2186
2187 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2188 * Actually, the code in regcppop() (which Ilya may be meaning by
daf18116
JH		 2189 * PL_reglastparen), is not needed at all by the test suite
2190 * (op/regexp, op/pat, op/split), but that code is needed, oddly
2191 * enough, for building DynaLoader, or otherwise this
2192 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2193 * will happen. Meanwhile, this code *is* needed for the
2194 * above-mentioned test suite tests to succeed. The common theme
2195 * on those tests seems to be returning null fields from matches.
2196 * --jhi */
dafc8851 2197#if 1
d6a28714
JH		 2198 sp = prog->startp;
2199 ep = prog->endp;
2200 if (prog->nparens) {
097eb12c 2201 register I32 i;
eb160463 2202 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
d6a28714
JH		 2203 *++sp = -1;
2204 *++ep = -1;
2205 }
2206 }
dafc8851 2207#endif
02db2b7b 2208 REGCP_SET(lastcp);
3b0527fe 2209 if (regmatch(reginfo, prog->program + 1)) {
d6a28714
JH		 2210 prog->endp[0] = PL_reginput - PL_bostr;
2211 return 1;
2212 }
24b23f37
YO		 2213 if (reginfo->cutpoint)
2214 *startpos= reginfo->cutpoint;
02db2b7b 2215 REGCP_UNWIND(lastcp);
d6a28714
JH		 2216 return 0;
2217}
2218
02db2b7b 2219
8ba1375e
MJD		 2220#define sayYES goto yes
2221#define sayNO goto no
262b90c4 2222#define sayNO_SILENT goto no_silent
8ba1375e 2223
f9f4320a
YO		 2224/* we dont use STMT_START/END here because it leads to
2225 "unreachable code" warnings, which are bogus, but distracting. */
2226#define CACHEsayNO \
c476f425
DM		 2227 if (ST.cache_mask) \
2228 PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
f9f4320a 2229 sayNO
3298f257 2230
a3621e74 2231/* this is used to determine how far from the left messages like
265c4333
YO		 2232 'failed...' are printed. It should be set such that messages
2233 are inline with the regop output that created them.
a3621e74 2234*/
265c4333 2235#define REPORT_CODE_OFF 32
a3621e74
YO		 2236
2237
2238/* Make sure there is a test for this +1 options in re_tests */
2239#define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2240
40a82448
DM		 2241#define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2242#define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
9e137952 2243
86545054
DM		 2244#define SLAB_FIRST(s) (&(s)->states[0])
2245#define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2246
5d9a96ca
DM		 2247/* grab a new slab and return the first slot in it */
2248
2249STATIC regmatch_state *
2250S_push_slab(pTHX)
2251{
54df2634
NC		 2252#if PERL_VERSION < 9
2253 dMY_CXT;
2254#endif
5d9a96ca
DM		 2255 regmatch_slab *s = PL_regmatch_slab->next;
2256 if (!s) {
2257 Newx(s, 1, regmatch_slab);
2258 s->prev = PL_regmatch_slab;
2259 s->next = NULL;
2260 PL_regmatch_slab->next = s;
2261 }
2262 PL_regmatch_slab = s;
86545054 2263 return SLAB_FIRST(s);
5d9a96ca 2264}
5b47454d 2265
95b24440 2266
40a82448
DM		 2267/* push a new state then goto it */
2268
2269#define PUSH_STATE_GOTO(state, node) \
2270 scan = node; \
2271 st->resume_state = state; \
2272 goto push_state;
2273
2274/* push a new state with success backtracking, then goto it */
2275
2276#define PUSH_YES_STATE_GOTO(state, node) \
2277 scan = node; \
2278 st->resume_state = state; \
2279 goto push_yes_state;
2280
aa283a38 2281
aa283a38 2282
d6a28714 2283/*
95b24440 2284
bf1f174e
DM		 2285regmatch() - main matching routine
2286
2287This is basically one big switch statement in a loop. We execute an op,
2288set 'next' to point the next op, and continue. If we come to a point which
2289we may need to backtrack to on failure such as (A|B|C), we push a
2290backtrack state onto the backtrack stack. On failure, we pop the top
2291state, and re-enter the loop at the state indicated. If there are no more
2292states to pop, we return failure.
2293
2294Sometimes we also need to backtrack on success; for example /A+/, where
2295after successfully matching one A, we need to go back and try to
2296match another one; similarly for lookahead assertions: if the assertion
2297completes successfully, we backtrack to the state just before the assertion
2298and then carry on. In these cases, the pushed state is marked as
2299'backtrack on success too'. This marking is in fact done by a chain of
2300pointers, each pointing to the previous 'yes' state. On success, we pop to
2301the nearest yes state, discarding any intermediate failure-only states.
2302Sometimes a yes state is pushed just to force some cleanup code to be
2303called at the end of a successful match or submatch; e.g. (??{$re}) uses
2304it to free the inner regex.
2305
2306Note that failure backtracking rewinds the cursor position, while
2307success backtracking leaves it alone.
2308
2309A pattern is complete when the END op is executed, while a subpattern
2310such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2311ops trigger the "pop to last yes state if any, otherwise return true"
2312behaviour.
2313
2314A common convention in this function is to use A and B to refer to the two
2315subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2316the subpattern to be matched possibly multiple times, while B is the entire
2317rest of the pattern. Variable and state names reflect this convention.
2318
2319The states in the main switch are the union of ops and failure/success of
2320substates associated with with that op. For example, IFMATCH is the op
2321that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2322'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2323successfully matched A and IFMATCH_A_fail is a state saying that we have
2324just failed to match A. Resume states always come in pairs. The backtrack
2325state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2326at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2327on success or failure.
2328
2329The struct that holds a backtracking state is actually a big union, with
2330one variant for each major type of op. The variable st points to the
2331top-most backtrack struct. To make the code clearer, within each
2332block of code we #define ST to alias the relevant union.
2333
2334Here's a concrete example of a (vastly oversimplified) IFMATCH
2335implementation:
2336
2337 switch (state) {
2338 ....
2339
2340#define ST st->u.ifmatch
2341
2342 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2343 ST.foo = ...; // some state we wish to save
95b24440 2344 ...
bf1f174e
DM		 2345 // push a yes backtrack state with a resume value of
2346 // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2347 // first node of A:
2348 PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2349 // NOTREACHED
2350
2351 case IFMATCH_A: // we have successfully executed A; now continue with B
2352 next = B;
2353 bar = ST.foo; // do something with the preserved value
2354 break;
2355
2356 case IFMATCH_A_fail: // A failed, so the assertion failed
2357 ...; // do some housekeeping, then ...
2358 sayNO; // propagate the failure
2359
2360#undef ST
95b24440 2361
bf1f174e
DM		 2362 ...
2363 }
95b24440 2364
bf1f174e
DM		 2365For any old-timers reading this who are familiar with the old recursive
2366approach, the code above is equivalent to:
95b24440 2367
bf1f174e
DM		 2368 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2369 {
2370 int foo = ...
95b24440 2371 ...
bf1f174e
DM		 2372 if (regmatch(A)) {
2373 next = B;
2374 bar = foo;
2375 break;
95b24440 2376 }
bf1f174e
DM		 2377 ...; // do some housekeeping, then ...
2378 sayNO; // propagate the failure
95b24440 2379 }
bf1f174e
DM		 2380
2381The topmost backtrack state, pointed to by st, is usually free. If you
2382want to claim it, populate any ST.foo fields in it with values you wish to
2383save, then do one of
2384
2385 PUSH_STATE_GOTO(resume_state, node);
2386 PUSH_YES_STATE_GOTO(resume_state, node);
2387
2388which sets that backtrack state's resume value to 'resume_state', pushes a
2389new free entry to the top of the backtrack stack, then goes to 'node'.
2390On backtracking, the free slot is popped, and the saved state becomes the
2391new free state. An ST.foo field in this new top state can be temporarily
2392accessed to retrieve values, but once the main loop is re-entered, it
2393becomes available for reuse.
2394
2395Note that the depth of the backtrack stack constantly increases during the
2396left-to-right execution of the pattern, rather than going up and down with
2397the pattern nesting. For example the stack is at its maximum at Z at the
2398end of the pattern, rather than at X in the following:
2399
2400 /(((X)+)+)+....(Y)+....Z/
2401
2402The only exceptions to this are lookahead/behind assertions and the cut,
2403(?>A), which pop all the backtrack states associated with A before
2404continuing.
2405
2406Bascktrack state structs are allocated in slabs of about 4K in size.
2407PL_regmatch_state and st always point to the currently active state,
2408and PL_regmatch_slab points to the slab currently containing
2409PL_regmatch_state. The first time regmatch() is called, the first slab is
2410allocated, and is never freed until interpreter destruction. When the slab
2411is full, a new one is allocated and chained to the end. At exit from
2412regmatch(), slabs allocated since entry are freed.
2413
2414*/
95b24440 2415
40a82448 2416
5bc10b2c 2417#define DEBUG_STATE_pp(pp) \
265c4333 2418 DEBUG_STATE_r({ \
5bc10b2c
DM		 2419 DUMP_EXEC_POS(locinput, scan, do_utf8); \
2420 PerlIO_printf(Perl_debug_log, \
2421 " %*s"pp" %s\n", \
2422 depth*2, "", \
03363afd 2423 reg_name[st->resume_state] ); \
265c4333 2424 });
5bc10b2c 2425
40a82448 2426
3dab1dad 2427#define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
95b24440 2428
3df15adc 2429#ifdef DEBUGGING
5bc10b2c 2430
ab3bbdeb
YO		 2431STATIC void
2432S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
2433 const char *start, const char *end, const char *blurb)
2434{
2435 const bool utf8_pat= prog->reganch & ROPT_UTF8 ? 1 : 0;
2436 if (!PL_colorset)
2437 reginitcolors();
2438 {
2439 RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2440 prog->precomp, prog->prelen, 60);
2441
2442 RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2443 start, end - start, 60);
2444
2445 PerlIO_printf(Perl_debug_log,
2446 "%s%s REx%s %s against %s\n",
2447 PL_colors[4], blurb, PL_colors[5], s0, s1);
2448
2449 if (do_utf8||utf8_pat)
1de06328
YO		 2450 PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2451 utf8_pat ? "pattern" : "",
2452 utf8_pat && do_utf8 ? " and " : "",
2453 do_utf8 ? "string" : ""
ab3bbdeb
YO		 2454 );
2455 }
2456}
3df15adc
YO		 2457
2458STATIC void
786e8c11
YO		 2459S_dump_exec_pos(pTHX_ const char *locinput,
2460 const regnode *scan,
2461 const char *loc_regeol,
2462 const char *loc_bostr,
2463 const char *loc_reg_starttry,
2464 const bool do_utf8)
07be1b83 2465{
786e8c11 2466 const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
07be1b83 2467 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
786e8c11 2468 int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
07be1b83
YO		 2469 /* The part of the string before starttry has one color
2470 (pref0_len chars), between starttry and current
2471 position another one (pref_len - pref0_len chars),
2472 after the current position the third one.
2473 We assume that pref0_len <= pref_len, otherwise we
2474 decrease pref0_len. */
786e8c11
YO		 2475 int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2476 ? (5 + taill) - l : locinput - loc_bostr;
07be1b83
YO		 2477 int pref0_len;
2478
2479 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2480 pref_len++;
786e8c11
YO		 2481 pref0_len = pref_len - (locinput - loc_reg_starttry);
2482 if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2483 l = ( loc_regeol - locinput > (5 + taill) - pref_len
2484 ? (5 + taill) - pref_len : loc_regeol - locinput);
07be1b83
YO		 2485 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2486 l--;
2487 if (pref0_len < 0)
2488 pref0_len = 0;
2489 if (pref0_len > pref_len)
2490 pref0_len = pref_len;
2491 {
3df15adc 2492 const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
0df25f3d 2493
ab3bbdeb 2494 RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
1de06328 2495 (locinput - pref_len),pref0_len, 60, 4, 5);
0df25f3d 2496
ab3bbdeb 2497 RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
3df15adc 2498 (locinput - pref_len + pref0_len),
1de06328 2499 pref_len - pref0_len, 60, 2, 3);
0df25f3d 2500
ab3bbdeb 2501 RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
1de06328 2502 locinput, loc_regeol - locinput, 10, 0, 1);
0df25f3d 2503
1de06328 2504 const STRLEN tlen=len0+len1+len2;
3df15adc 2505 PerlIO_printf(Perl_debug_log,
ab3bbdeb 2506 "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
786e8c11 2507 (IV)(locinput - loc_bostr),
07be1b83 2508 len0, s0,
07be1b83 2509 len1, s1,
07be1b83 2510 (docolor ? "" : "> <"),
07be1b83 2511 len2, s2,
f9f4320a 2512 (int)(tlen > 19 ? 0 : 19 - tlen),
07be1b83
YO		 2513 "");
2514 }
2515}
3df15adc 2516
07be1b83
YO		 2517#endif
2518
0a4db386
YO		 2519/* reg_check_named_buff_matched()
2520 * Checks to see if a named buffer has matched. The data array of
2521 * buffer numbers corresponding to the buffer is expected to reside
2522 * in the regexp->data->data array in the slot stored in the ARG() of
2523 * node involved. Note that this routine doesn't actually care about the
2524 * name, that information is not preserved from compilation to execution.
2525 * Returns the index of the leftmost defined buffer with the given name
2526 * or 0 if non of the buffers matched.
2527 */
2528STATIC I32
2529S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) {
2530 I32 n;
2531 SV *sv_dat=(SV*)rex->data->data[ ARG( scan ) ];
2532 I32 *nums=(I32*)SvPVX(sv_dat);
2533 for ( n=0; n<SvIVX(sv_dat); n++ ) {
2534 if ((I32)*PL_reglastparen >= nums[n] &&
2535 PL_regendp[nums[n]] != -1)
2536 {
2537 return nums[n];
2538 }
2539 }
2540 return 0;
2541}
2542
d6a28714 2543STATIC I32 /* 0 failure, 1 success */
24b23f37 2544S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
d6a28714 2545{
54df2634
NC		 2546#if PERL_VERSION < 9
2547 dMY_CXT;
2548#endif
27da23d5 2549 dVAR;
95b24440 2550 register const bool do_utf8 = PL_reg_match_utf8;
4ad0818d 2551 const U32 uniflags = UTF8_ALLOW_DEFAULT;
95b24440 2552
3b0527fe
DM		 2553 regexp *rex = reginfo->prog;
2554
5d9a96ca
DM		 2555 regmatch_slab *orig_slab;
2556 regmatch_state *orig_state;
a3621e74 2557
5d9a96ca
DM		 2558 /* the current state. This is a cached copy of PL_regmatch_state */
2559 register regmatch_state *st;
95b24440 2560
5d9a96ca
DM		 2561 /* cache heavy used fields of st in registers */
2562 register regnode *scan;
2563 register regnode *next;
438e9bae 2564 register U32 n = 0; /* general value; init to avoid compiler warning */
24d3c4a9 2565 register I32 ln = 0; /* len or last; init to avoid compiler warning */
5d9a96ca 2566 register char *locinput = PL_reginput;
5d9a96ca 2567 register I32 nextchr; /* is always set to UCHARAT(locinput) */
24d3c4a9 2568
b69b0499 2569 bool result = 0; /* return value of S_regmatch */
24d3c4a9 2570 int depth = 0; /* depth of backtrack stack */
1a147d38 2571 int nochange_depth = 0; /* depth of GOSUB recursion with nochange*/
77cb431f
DM		 2572 regmatch_state *yes_state = NULL; /* state to pop to on success of
2573 subpattern */
e2e6a0f1
YO		 2574 /* mark_state piggy backs on the yes_state logic so that when we unwind
2575 the stack on success we can update the mark_state as we go */
2576 regmatch_state *mark_state = NULL; /* last mark state we have seen */
faec1544 2577 regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
b8591aee 2578 struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
40a82448 2579 U32 state_num;
24b23f37 2580 bool no_final = 0;
e2e6a0f1
YO		 2581 char *startpoint = PL_reginput;
2582 SV *popmark = NULL;
2583 SV *sv_commit = NULL;
3b6647e0 2584 unsigned int lastopen = 0;
24d3c4a9
DM		 2585 /* these three flags are set by various ops to signal information to
2586 * the very next op. They have a useful lifetime of exactly one loop
2587 * iteration, and are not preserved or restored by state pushes/pops
2588 */
2589 bool sw = 0; /* the condition value in (?(cond)a|b) */
2590 bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
2591 int logical = 0; /* the following EVAL is:
2592 0: (?{...})
2593 1: (?(?{...})X|Y)
2594 2: (??{...})
2595 or the following IFMATCH/UNLESSM is:
2596 false: plain (?=foo)
2597 true: used as a condition: (?(?=foo))
2598 */
2599
95b24440 2600#ifdef DEBUGGING
e68ec53f 2601 GET_RE_DEBUG_FLAGS_DECL;
d6a28714
JH		 2602#endif
2603
24b23f37
YO		 2604 DEBUG_STACK_r( {
2605 PerlIO_printf(Perl_debug_log,"regmatch start\n");
2606 });
5d9a96ca
DM		 2607 /* on first ever call to regmatch, allocate first slab */
2608 if (!PL_regmatch_slab) {
2609 Newx(PL_regmatch_slab, 1, regmatch_slab);
2610 PL_regmatch_slab->prev = NULL;
2611 PL_regmatch_slab->next = NULL;
86545054 2612 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
5d9a96ca
DM		 2613 }
2614
2615 /* remember current high-water mark for exit */
2616 /* XXX this should be done with SAVE* instead */
2617 orig_slab = PL_regmatch_slab;
2618 orig_state = PL_regmatch_state;
2619
2620 /* grab next free state slot */
2621 st = ++PL_regmatch_state;
86545054 2622 if (st > SLAB_LAST(PL_regmatch_slab))
5d9a96ca
DM		 2623 st = PL_regmatch_state = S_push_slab(aTHX);
2624
d6a28714
JH		 2625 /* Note that nextchr is a byte even in UTF */
2626 nextchr = UCHARAT(locinput);
2627 scan = prog;
2628 while (scan != NULL) {
8ba1375e 2629
a3621e74 2630 DEBUG_EXECUTE_r( {
6136c704 2631 SV * const prop = sv_newmortal();
1de06328 2632 regnode *rnext=regnext(scan);
786e8c11 2633 DUMP_EXEC_POS( locinput, scan, do_utf8 );
32fc9b6a 2634 regprop(rex, prop, scan);
07be1b83
YO		 2635
2636 PerlIO_printf(Perl_debug_log,
2637 "%3"IVdf":%*s%s(%"IVdf")\n",
5bc10b2c 2638 (IV)(scan - rex->program), depth*2, "",
07be1b83 2639 SvPVX_const(prop),
1de06328
YO		 2640 (PL_regkind[OP(scan)] == END || !rnext) ?
2641 0 : (IV)(rnext - rex->program));
2a782b5b 2642 });
d6a28714
JH		 2643
2644 next = scan + NEXT_OFF(scan);
2645 if (next == scan)
2646 next = NULL;
40a82448 2647 state_num = OP(scan);
d6a28714 2648
40a82448
DM		 2649 reenter_switch:
2650 switch (state_num) {
d6a28714 2651 case BOL:
7fba1cd6 2652 if (locinput == PL_bostr)
d6a28714 2653 {
3b0527fe 2654 /* reginfo->till = reginfo->bol; */
b8c5462f
JH		 2655 break;
2656 }
d6a28714
JH		 2657 sayNO;
2658 case MBOL:
12d33761
HS		 2659 if (locinput == PL_bostr ||
2660 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
d6a28714 2661 {
b8c5462f
JH		 2662 break;
2663 }
d6a28714
JH		 2664 sayNO;
2665 case SBOL:
c2a73568 2666 if (locinput == PL_bostr)
b8c5462f 2667 break;
d6a28714
JH		 2668 sayNO;
2669 case GPOS:
3b0527fe 2670 if (locinput == reginfo->ganch)
d6a28714
JH		 2671 break;
2672 sayNO;
2673 case EOL:
d6a28714
JH		 2674 goto seol;
2675 case MEOL:
d6a28714 2676 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
b8c5462f 2677 sayNO;
b8c5462f 2678 break;
d6a28714
JH		 2679 case SEOL:
2680 seol:
2681 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
b8c5462f 2682 sayNO;
d6a28714 2683 if (PL_regeol - locinput > 1)
b8c5462f 2684 sayNO;
b8c5462f 2685 break;
d6a28714
JH		 2686 case EOS:
2687 if (PL_regeol != locinput)
b8c5462f 2688 sayNO;
d6a28714 2689 break;
ffc61ed2 2690 case SANY:
d6a28714 2691 if (!nextchr && locinput >= PL_regeol)
4633a7c4 2692 sayNO;
f33976b4
DB		 2693 if (do_utf8) {
2694 locinput += PL_utf8skip[nextchr];
2695 if (locinput > PL_regeol)
2696 sayNO;
2697 nextchr = UCHARAT(locinput);
2698 }
2699 else
2700 nextchr = UCHARAT(++locinput);
2701 break;
2702 case CANY:
2703 if (!nextchr && locinput >= PL_regeol)
2704 sayNO;
b8c5462f 2705 nextchr = UCHARAT(++locinput);
a0d0e21e 2706 break;
ffc61ed2 2707 case REG_ANY:
1aa99e6b
IH		 2708 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2709 sayNO;
2710 if (do_utf8) {
b8c5462f 2711 locinput += PL_utf8skip[nextchr];
d6a28714
JH		 2712 if (locinput > PL_regeol)
2713 sayNO;
a0ed51b3 2714 nextchr = UCHARAT(locinput);
a0ed51b3 2715 }
1aa99e6b
IH		 2716 else
2717 nextchr = UCHARAT(++locinput);
a0ed51b3 2718 break;
166ba7cd
DM		 2719
2720#undef ST
2721#define ST st->u.trie
786e8c11
YO		 2722 case TRIEC:
2723 /* In this case the charclass data is available inline so
2724 we can fail fast without a lot of extra overhead.
2725 */
2726 if (scan->flags == EXACT || !do_utf8) {
2727 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
2728 DEBUG_EXECUTE_r(
2729 PerlIO_printf(Perl_debug_log,
2730 "%*s %sfailed to match trie start class...%s\n",
5bc10b2c 2731 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
786e8c11
YO		 2732 );
2733 sayNO_SILENT;
2734 /* NOTREACHED */
2735 }
2736 }
2737 /* FALL THROUGH */
5b47454d 2738 case TRIE:
3dab1dad 2739 {
07be1b83 2740 /* what type of TRIE am I? (utf8 makes this contextual) */
3dab1dad
YO		 2741 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2742 trie_type = do_utf8 ?
2743 (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2744 : trie_plain;
2745
2746 /* what trie are we using right now */
be8e71aa 2747 reg_trie_data * const trie
3dab1dad
YO		 2748 = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2749 U32 state = trie->startstate;
166ba7cd 2750
3dab1dad
YO		 2751 if (trie->bitmap && trie_type != trie_utf8_fold &&
2752 !TRIE_BITMAP_TEST(trie,*locinput)
2753 ) {
2754 if (trie->states[ state ].wordnum) {
2755 DEBUG_EXECUTE_r(
2756 PerlIO_printf(Perl_debug_log,
2757 "%*s %smatched empty string...%s\n",
5bc10b2c 2758 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3dab1dad
YO		 2759 );
2760 break;
2761 } else {
2762 DEBUG_EXECUTE_r(
2763 PerlIO_printf(Perl_debug_log,
786e8c11 2764 "%*s %sfailed to match trie start class...%s\n",
5bc10b2c 2765 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3dab1dad
YO		 2766 );
2767 sayNO_SILENT;
2768 }
2769 }
166ba7cd 2770
786e8c11
YO		 2771 {
2772 U8 *uc = ( U8* )locinput;
2773
2774 STRLEN len = 0;
2775 STRLEN foldlen = 0;
2776 U8 *uscan = (U8*)NULL;
2777 STRLEN bufflen=0;
2778 SV *sv_accept_buff = NULL;
2779 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2780
2781 ST.accepted = 0; /* how many accepting states we have seen */
2782 ST.B = next;
2783 ST.jump = trie->jump;
786e8c11 2784 ST.me = scan;
786e8c11 2785
07be1b83
YO		 2786 /*
2787 traverse the TRIE keeping track of all accepting states
2788 we transition through until we get to a failing node.
2789 */
2790
a3621e74 2791 while ( state && uc <= (U8*)PL_regeol ) {
786e8c11 2792 U32 base = trie->states[ state ].trans.base;
f9f4320a 2793 UV uvc = 0;
786e8c11
YO		 2794 U16 charid;
2795 /* We use charid to hold the wordnum as we don't use it
2796 for charid until after we have done the wordnum logic.
2797 We define an alias just so that the wordnum logic reads
2798 more naturally. */
2799
2800#define got_wordnum charid
2801 got_wordnum = trie->states[ state ].wordnum;
2802
2803 if ( got_wordnum ) {
2804 if ( ! ST.accepted ) {
5b47454d
DM		 2805 ENTER;
2806 SAVETMPS;
2807 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2808 sv_accept_buff=newSV(bufflen *
2809 sizeof(reg_trie_accepted) - 1);
786e8c11 2810 SvCUR_set(sv_accept_buff, 0);
5b47454d
DM		 2811 SvPOK_on(sv_accept_buff);
2812 sv_2mortal(sv_accept_buff);
166ba7cd
DM		 2813 SAVETMPS;
2814 ST.accept_buff =
5b47454d
DM		 2815 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2816 }
786e8c11 2817 do {
166ba7cd 2818 if (ST.accepted >= bufflen) {
5b47454d 2819 bufflen *= 2;
166ba7cd 2820 ST.accept_buff =(reg_trie_accepted*)
5b47454d
DM		 2821 SvGROW(sv_accept_buff,
2822 bufflen * sizeof(reg_trie_accepted));
2823 }
2824 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2825 + sizeof(reg_trie_accepted));
a3621e74 2826
786e8c11
YO		 2827
2828 ST.accept_buff[ST.accepted].wordnum = got_wordnum;
2829 ST.accept_buff[ST.accepted].endpos = uc;
2830 ++ST.accepted;
2831 } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
2832 }
2833#undef got_wordnum
a3621e74 2834
07be1b83 2835 DEBUG_TRIE_EXECUTE_r({
786e8c11 2836 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
a3621e74 2837 PerlIO_printf( Perl_debug_log,
786e8c11 2838 "%*s %sState: %4"UVxf" Accepted: %4"UVxf" ",
5bc10b2c 2839 2+depth * 2, "", PL_colors[4],
786e8c11 2840 (UV)state, (UV)ST.accepted );
07be1b83 2841 });
a3621e74
YO		 2842
2843 if ( base ) {
4cadc6a9
YO		 2844 REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
2845 uvc, charid, foldlen, foldbuf, uniflags);
a3621e74 2846
5b47454d
DM		 2847 if (charid &&
2848 (base + charid > trie->uniquecharcount )
2849 && (base + charid - 1 - trie->uniquecharcount
2850 < trie->lasttrans)
2851 && trie->trans[base + charid - 1 -
2852 trie->uniquecharcount].check == state)
2853 {
2854 state = trie->trans[base + charid - 1 -
2855 trie->uniquecharcount ].next;
2856 }
2857 else {
2858 state = 0;
2859 }
2860 uc += len;
2861
2862 }
2863 else {
a3621e74
YO		 2864 state = 0;
2865 }
2866 DEBUG_TRIE_EXECUTE_r(
e4584336 2867 PerlIO_printf( Perl_debug_log,
786e8c11 2868 "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
e4584336 2869 charid, uvc, (UV)state, PL_colors[5] );
a3621e74
YO		 2870 );
2871 }
166ba7cd 2872 if (!ST.accepted )
a3621e74 2873 sayNO;
a3621e74 2874
166ba7cd
DM		 2875 DEBUG_EXECUTE_r(
2876 PerlIO_printf( Perl_debug_log,
2877 "%*s %sgot %"IVdf" possible matches%s\n",
5bc10b2c 2878 REPORT_CODE_OFF + depth * 2, "",
166ba7cd
DM		 2879 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
2880 );
786e8c11 2881 }}
166ba7cd
DM		 2882
2883 /* FALL THROUGH */
2884
2885 case TRIE_next_fail: /* we failed - try next alterative */
2886
2887 if ( ST.accepted == 1 ) {
2888 /* only one choice left - just continue */
2889 DEBUG_EXECUTE_r({
2890 reg_trie_data * const trie
2891 = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2892 SV ** const tmp = RX_DEBUG(reginfo->prog)
2893 ? av_fetch( trie->words, ST.accept_buff[ 0 ].wordnum-1, 0 )
2894 : NULL;
2895 PerlIO_printf( Perl_debug_log,
2896 "%*s %sonly one match left: #%d <%s>%s\n",
5bc10b2c 2897 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
166ba7cd
DM		 2898 ST.accept_buff[ 0 ].wordnum,
2899 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2900 PL_colors[5] );
2901 });
2902 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
2903 /* in this case we free tmps/leave before we call regmatch
2904 as we wont be using accept_buff again. */
2905 FREETMPS;
2906 LEAVE;
2907 locinput = PL_reginput;
2908 nextchr = UCHARAT(locinput);
786e8c11 2909
7f69552c 2910 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
786e8c11
YO		 2911 scan = ST.B;
2912 else
7f69552c 2913 scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
786e8c11 2914
166ba7cd
DM		 2915 continue; /* execute rest of RE */
2916 }
2917
2918 if (!ST.accepted-- ) {
2919 FREETMPS;
2920 LEAVE;
2921 sayNO;
2922 }
2923
a3621e74 2924 /*
166ba7cd
DM		 2925 There are at least two accepting states left. Presumably
2926 the number of accepting states is going to be low,
2927 typically two. So we simply scan through to find the one
2928 with lowest wordnum. Once we find it, we swap the last
2929 state into its place and decrement the size. We then try to
2930 match the rest of the pattern at the point where the word
2931 ends. If we succeed, control just continues along the
2932 regex; if we fail we return here to try the next accepting
2933 state
2934 */
a3621e74 2935
166ba7cd
DM		 2936 {
2937 U32 best = 0;
2938 U32 cur;
2939 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
2940 DEBUG_TRIE_EXECUTE_r(
f2278c82 2941 PerlIO_printf( Perl_debug_log,
166ba7cd 2942 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
5bc10b2c 2943 REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
166ba7cd
DM		 2944 (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
2945 ST.accept_buff[ cur ].wordnum, PL_colors[5] );
2946 );
2947
2948 if (ST.accept_buff[cur].wordnum <
2949 ST.accept_buff[best].wordnum)
2950 best = cur;
a3621e74 2951 }
166ba7cd
DM		 2952
2953 DEBUG_EXECUTE_r({
2954 reg_trie_data * const trie
2955 = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2956 SV ** const tmp = RX_DEBUG(reginfo->prog)
2957 ? av_fetch( trie->words, ST.accept_buff[ best ].wordnum - 1, 0 )
2958 : NULL;
7f69552c 2959 regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
265c4333 2960 ST.B :
7f69552c 2961 ST.me + ST.jump[ST.accept_buff[best].wordnum];
265c4333
YO		 2962 PerlIO_printf( Perl_debug_log,
2963 "%*s %strying alternation #%d <%s> at node #%d %s\n",
5bc10b2c 2964 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
166ba7cd 2965 ST.accept_buff[best].wordnum,
265c4333
YO		 2966 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2967 REG_NODE_NUM(nextop),
166ba7cd
DM		 2968 PL_colors[5] );
2969 });
2970
2971 if ( best<ST.accepted ) {
2972 reg_trie_accepted tmp = ST.accept_buff[ best ];
2973 ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
2974 ST.accept_buff[ ST.accepted ] = tmp;
2975 best = ST.accepted;
a3621e74 2976 }
166ba7cd 2977 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
7f69552c 2978 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
786e8c11
YO		 2979 PUSH_STATE_GOTO(TRIE_next, ST.B);
2980 /* NOTREACHED */
2981 } else {
7f69552c 2982 PUSH_STATE_GOTO(TRIE_next, ST.me + ST.jump[ST.accept_buff[best].wordnum]);
786e8c11
YO		 2983 /* NOTREACHED */
2984 }
2985 /* NOTREACHED */
166ba7cd 2986 }
166ba7cd
DM		 2987 /* NOTREACHED */
2988
2989#undef ST
2990
95b24440
DM		 2991 case EXACT: {
2992 char *s = STRING(scan);
24d3c4a9 2993 ln = STR_LEN(scan);
eb160463 2994 if (do_utf8 != UTF) {
bc517b45 2995 /* The target and the pattern have differing utf8ness. */
1aa99e6b 2996 char *l = locinput;
24d3c4a9 2997 const char * const e = s + ln;
a72c7584 2998
5ff6fc6d
JH		 2999 if (do_utf8) {
3000 /* The target is utf8, the pattern is not utf8. */
1aa99e6b 3001 while (s < e) {
a3b680e6 3002 STRLEN ulen;
1aa99e6b 3003 if (l >= PL_regeol)
5ff6fc6d
JH		 3004 sayNO;
3005 if (NATIVE_TO_UNI(*(U8*)s) !=
89ebb4a3 3006 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
041457d9 3007 uniflags))
5ff6fc6d 3008 sayNO;
bc517b45 3009 l += ulen;
5ff6fc6d 3010 s ++;
1aa99e6b 3011 }
5ff6fc6d
JH		 3012 }
3013 else {
3014 /* The target is not utf8, the pattern is utf8. */
1aa99e6b 3015 while (s < e) {
a3b680e6 3016 STRLEN ulen;
1aa99e6b
IH		 3017 if (l >= PL_regeol)
3018 sayNO;
5ff6fc6d 3019 if (NATIVE_TO_UNI(*((U8*)l)) !=
89ebb4a3 3020 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
041457d9 3021 uniflags))
1aa99e6b 3022 sayNO;
bc517b45 3023 s += ulen;
a72c7584 3024 l ++;
1aa99e6b 3025 }
5ff6fc6d 3026 }
1aa99e6b
IH		 3027 locinput = l;
3028 nextchr = UCHARAT(locinput);
3029 break;
3030 }
bc517b45 3031 /* The target and the pattern have the same utf8ness. */
d6a28714
JH		 3032 /* Inline the first character, for speed. */
3033 if (UCHARAT(s) != nextchr)
3034 sayNO;
24d3c4a9 3035 if (PL_regeol - locinput < ln)
d6a28714 3036 sayNO;
24d3c4a9 3037 if (ln > 1 && memNE(s, locinput, ln))
d6a28714 3038 sayNO;
24d3c4a9 3039 locinput += ln;
d6a28714
JH		 3040 nextchr = UCHARAT(locinput);
3041 break;
95b24440 3042 }
d6a28714 3043 case EXACTFL:
b8c5462f
JH		 3044 PL_reg_flags |= RF_tainted;
3045 /* FALL THROUGH */
95b24440 3046 case EXACTF: {
be8e71aa 3047 char * const s = STRING(scan);
24d3c4a9 3048 ln = STR_LEN(scan);
d6a28714 3049
d07ddd77
JH		 3050 if (do_utf8 || UTF) {
3051 /* Either target or the pattern are utf8. */
be8e71aa 3052 const char * const l = locinput;
d07ddd77 3053 char *e = PL_regeol;
bc517b45 3054
24d3c4a9 3055 if (ibcmp_utf8(s, 0, ln, (bool)UTF,
1feea2c7 3056 l, &e, 0, do_utf8)) {
5486206c
JH		 3057 /* One more case for the sharp s:
3058 * pack("U0U*", 0xDF) =~ /ss/i,
3059 * the 0xC3 0x9F are the UTF-8
3060 * byte sequence for the U+00DF. */
3061 if (!(do_utf8 &&
3062 toLOWER(s[0]) == 's' &&
24d3c4a9 3063 ln >= 2 &&
5486206c
JH		 3064 toLOWER(s[1]) == 's' &&
3065 (U8)l[0] == 0xC3 &&
3066 e - l >= 2 &&
3067 (U8)l[1] == 0x9F))
3068 sayNO;
3069 }
d07ddd77
JH		 3070 locinput = e;
3071 nextchr = UCHARAT(locinput);
3072 break;
a0ed51b3 3073 }
d6a28714 3074
bc517b45
JH		 3075 /* Neither the target and the pattern are utf8. */
3076
d6a28714
JH		 3077 /* Inline the first character, for speed. */
3078 if (UCHARAT(s) != nextchr &&
3079 UCHARAT(s) != ((OP(scan) == EXACTF)
3080 ? PL_fold : PL_fold_locale)[nextchr])
a0ed51b3 3081 sayNO;
24d3c4a9 3082 if (PL_regeol - locinput < ln)
b8c5462f 3083 sayNO;
24d3c4a9
DM		 3084 if (ln > 1 && (OP(scan) == EXACTF
3085 ? ibcmp(s, locinput, ln)
3086 : ibcmp_locale(s, locinput, ln)))
4633a7c4 3087 sayNO;
24d3c4a9 3088 locinput += ln;
d6a28714 3089 nextchr = UCHARAT(locinput);
a0d0e21e 3090 break;
95b24440 3091 }
d6a28714 3092 case ANYOF:
ffc61ed2 3093 if (do_utf8) {
9e55ce06
JH		 3094 STRLEN inclasslen = PL_regeol - locinput;
3095
32fc9b6a 3096 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
262b90c4 3097 goto anyof_fail;
ffc61ed2
JH		 3098 if (locinput >= PL_regeol)
3099 sayNO;
0f0076b4 3100 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
b8c5462f 3101 nextchr = UCHARAT(locinput);
e0f9d4a8 3102 break;
ffc61ed2
JH		 3103 }
3104 else {
3105 if (nextchr < 0)
3106 nextchr = UCHARAT(locinput);
32fc9b6a 3107 if (!REGINCLASS(rex, scan, (U8*)locinput))
262b90c4 3108 goto anyof_fail;
ffc61ed2
JH		 3109 if (!nextchr && locinput >= PL_regeol)
3110 sayNO;
3111 nextchr = UCHARAT(++locinput);
e0f9d4a8
JH		 3112 break;
3113 }
262b90c4 3114 anyof_fail:
e0f9d4a8
JH		 3115 /* If we might have the case of the German sharp s
3116 * in a casefolding Unicode character class. */
3117
ebc501f0
JH		 3118 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3119 locinput += SHARP_S_SKIP;
e0f9d4a8 3120 nextchr = UCHARAT(locinput);
ffc61ed2 3121 }
e0f9d4a8
JH		 3122 else
3123 sayNO;
b8c5462f 3124 break;
d6a28714 3125 case ALNUML:
b8c5462f
JH		 3126 PL_reg_flags |= RF_tainted;
3127 /* FALL THROUGH */
d6a28714 3128 case ALNUM:
b8c5462f 3129 if (!nextchr)
4633a7c4 3130 sayNO;
ffc61ed2 3131 if (do_utf8) {
1a4fad37 3132 LOAD_UTF8_CHARCLASS_ALNUM();
ffc61ed2 3133 if (!(OP(scan) == ALNUM
bb7a0f54 3134 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
d6a28714 3135 : isALNUM_LC_utf8((U8*)locinput)))
b8c5462f
JH		 3136 {
3137 sayNO;
a0ed51b3 3138 }
b8c5462f 3139 locinput += PL_utf8skip[nextchr];
a0ed51b3
LW		 3140 nextchr = UCHARAT(locinput);
3141 break;
3142 }
ffc61ed2 3143 if (!(OP(scan) == ALNUM
d6a28714 3144 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
bbce6d69 3145 sayNO;
b8c5462f 3146 nextchr = UCHARAT(++locinput);
a0d0e21e 3147 break;
d6a28714 3148 case NALNUML:
b8c5462f
JH		 3149 PL_reg_flags |= RF_tainted;
3150 /* FALL THROUGH */
d6a28714
JH		 3151 case NALNUM:
3152 if (!nextchr && locinput >= PL_regeol)
a0ed51b3 3153 sayNO;
ffc61ed2 3154 if (do_utf8) {
1a4fad37 3155 LOAD_UTF8_CHARCLASS_ALNUM();
ffc61ed2 3156 if (OP(scan) == NALNUM
bb7a0f54 3157 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
d6a28714
JH		 3158 : isALNUM_LC_utf8((U8*)locinput))
3159 {
b8c5462f 3160 sayNO;
d6a28714 3161 }
b8c5462f
JH		 3162 locinput += PL_utf8skip[nextchr];
3163 nextchr = UCHARAT(locinput);
3164 break;
3165 }
ffc61ed2 3166 if (OP(scan) == NALNUM
d6a28714 3167 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
b8c5462f 3168 sayNO;
76e3520e 3169 nextchr = UCHARAT(++locinput);
a0d0e21e 3170 break;
d6a28714
JH		 3171 case BOUNDL:
3172 case NBOUNDL:
3280af22 3173 PL_reg_flags |= RF_tainted;
bbce6d69 3174 /* FALL THROUGH */
d6a28714
JH		 3175 case BOUND:
3176 case NBOUND:
3177 /* was last char in word? */
ffc61ed2 3178 if (do_utf8) {
12d33761 3179 if (locinput == PL_bostr)
24d3c4a9 3180 ln = '\n';
ffc61ed2 3181 else {
a3b680e6 3182 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
9041c2e3 3183
24d3c4a9 3184 ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
ffc61ed2
JH		 3185 }
3186 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
24d3c4a9 3187 ln = isALNUM_uni(ln);
1a4fad37 3188 LOAD_UTF8_CHARCLASS_ALNUM();
3568d838 3189 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
ffc61ed2
JH		 3190 }
3191 else {
24d3c4a9 3192 ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
ffc61ed2
JH		 3193 n = isALNUM_LC_utf8((U8*)locinput);
3194 }
a0ed51b3 3195 }
d6a28714 3196 else {
24d3c4a9 3197 ln = (locinput != PL_bostr) ?
12d33761 3198 UCHARAT(locinput - 1) : '\n';
ffc61ed2 3199 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
24d3c4a9 3200 ln = isALNUM(ln);
ffc61ed2
JH		 3201 n = isALNUM(nextchr);
3202 }
3203 else {
24d3c4a9 3204 ln = isALNUM_LC(ln);
ffc61ed2
JH		 3205 n = isALNUM_LC(nextchr);
3206 }
d6a28714 3207 }
24d3c4a9 3208 if (((!ln) == (!n)) == (OP(scan) == BOUND ||
ffc61ed2
JH		 3209 OP(scan) == BOUNDL))
3210 sayNO;
a0ed51b3 3211 break;
d6a28714 3212 case SPACEL:
3280af22 3213 PL_reg_flags |= RF_tainted;
bbce6d69 3214 /* FALL THROUGH */
d6a28714 3215 case SPACE:
9442cb0e 3216 if (!nextchr)
4633a7c4 3217 sayNO;
1aa99e6b 3218 if (do_utf8) {
fd400ab9 3219 if (UTF8_IS_CONTINUED(nextchr)) {
1a4fad37 3220 LOAD_UTF8_CHARCLASS_SPACE();
ffc61ed2 3221 if (!(OP(scan) == SPACE
bb7a0f54 3222 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
ffc61ed2
JH		 3223 : isSPACE_LC_utf8((U8*)locinput)))
3224 {
3225 sayNO;
3226 }
3227 locinput += PL_utf8skip[nextchr];
3228 nextchr = UCHARAT(locinput);
3229 break;
d6a28714 3230 }
ffc61ed2
JH		 3231 if (!(OP(scan) == SPACE
3232 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3233 sayNO;
3234 nextchr = UCHARAT(++locinput);
3235 }
3236 else {
3237 if (!(OP(scan) == SPACE
3238 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3239 sayNO;
3240 nextchr = UCHARAT(++locinput);
a0ed51b3 3241 }
a0ed51b3 3242 break;
d6a28714 3243 case NSPACEL:
3280af22 3244 PL_reg_flags |= RF_tainted;
bbce6d69 3245 /* FALL THROUGH */
d6a28714 3246 case NSPACE:
9442cb0e 3247 if (!nextchr && locinput >= PL_regeol)
b8c5462f 3248 sayNO;
1aa99e6b 3249 if (do_utf8) {
1a4fad37 3250 LOAD_UTF8_CHARCLASS_SPACE();
ffc61ed2 3251 if (OP(scan) == NSPACE
bb7a0f54 3252 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
d6a28714 3253 : isSPACE_LC_utf8((U8*)locinput))
b8c5462f
JH		 3254 {
3255 sayNO;
3256 }
3257 locinput += PL_utf8skip[nextchr];
3258 nextchr = UCHARAT(locinput);
3259 break;
a0ed51b3 3260 }
ffc61ed2 3261 if (OP(scan) == NSPACE
d6a28714 3262 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
4633a7c4 3263 sayNO;
76e3520e 3264 nextchr = UCHARAT(++locinput);
a0d0e21e 3265 break;
d6a28714 3266 case DIGITL:
a0ed51b3
LW		 3267 PL_reg_flags |= RF_tainted;
3268 /* FALL THROUGH */
d6a28714 3269 case DIGIT:
9442cb0e 3270 if (!nextchr)
a0ed51b3 3271 sayNO;
1aa99e6b 3272 if (do_utf8) {
1a4fad37 3273 LOAD_UTF8_CHARCLASS_DIGIT();
ffc61ed2 3274 if (!(OP(scan) == DIGIT
bb7a0f54 3275 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
9442cb0e 3276 : isDIGIT_LC_utf8((U8*)locinput)))
dfe13c55 3277 {
a0ed51b3 3278 sayNO;
dfe13c55 3279 }
6f06b55f 3280 locinput += PL_utf8skip[nextchr];
a0ed51b3
LW		 3281 nextchr = UCHARAT(locinput);
3282 break;
3283 }
ffc61ed2 3284 if (!(OP(scan) == DIGIT
9442cb0e 3285 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
a0ed51b3
LW		 3286 sayNO;
3287 nextchr = UCHARAT(++locinput);
3288 break;
d6a28714 3289 case NDIGITL:
b8c5462f
JH		 3290 PL_reg_flags |= RF_tainted;
3291 /* FALL THROUGH */
d6a28714 3292 case NDIGIT:
9442cb0e 3293 if (!nextchr && locinput >= PL_regeol)
b8c5462f 3294 sayNO;
1aa99e6b 3295 if (do_utf8) {
1a4fad37 3296 LOAD_UTF8_CHARCLASS_DIGIT();
ffc61ed2 3297 if (OP(scan) == NDIGIT
bb7a0f54 3298 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
9442cb0e
GS		 3299 : isDIGIT_LC_utf8((U8*)locinput))
3300 {
a0ed51b3 3301 sayNO;
9442cb0e 3302 }
6f06b55f 3303 locinput += PL_utf8skip[nextchr];
a0ed51b3
LW		 3304 nextchr = UCHARAT(locinput);
3305 break;
3306 }
ffc61ed2 3307 if (OP(scan) == NDIGIT
9442cb0e 3308 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
a0ed51b3
LW		 3309 sayNO;
3310 nextchr = UCHARAT(++locinput);
3311 break;
3312 case CLUMP:
b7c83a7e 3313 if (locinput >= PL_regeol)
a0ed51b3 3314 sayNO;
b7c83a7e 3315 if (do_utf8) {
1a4fad37 3316 LOAD_UTF8_CHARCLASS_MARK();
b7c83a7e
JH		 3317 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3318 sayNO;
3319 locinput += PL_utf8skip[nextchr];
3320 while (locinput < PL_regeol &&
3321 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3322 locinput += UTF8SKIP(locinput);
3323 if (locinput > PL_regeol)
3324 sayNO;
eb08e2da
JH		 3325 }
3326 else
3327 locinput++;
a0ed51b3
LW		 3328 nextchr = UCHARAT(locinput);
3329 break;
81714fb9
YO		 3330
3331 case NREFFL:
3332 {
3333 char *s;
ff1157ca 3334 char type;
81714fb9
YO		 3335 PL_reg_flags |= RF_tainted;
3336 /* FALL THROUGH */
3337 case NREF:
3338 case NREFF:
ff1157ca 3339 type = OP(scan);
0a4db386
YO		 3340 n = reg_check_named_buff_matched(rex,scan);
3341
3342 if ( n ) {
3343 type = REF + ( type - NREF );
3344 goto do_ref;
3345 } else {
81714fb9 3346 sayNO;
0a4db386
YO		 3347 }
3348 /* unreached */
c8756f30 3349 case REFFL:
3280af22 3350 PL_reg_flags |= RF_tainted;
c8756f30 3351 /* FALL THROUGH */
c277df42 3352 case REF:
81714fb9 3353 case REFF:
c277df42 3354 n = ARG(scan); /* which paren pair */
81714fb9
YO		 3355 type = OP(scan);
3356 do_ref:
24d3c4a9 3357 ln = PL_regstartp[n];
2c2d71f5 3358 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3b6647e0 3359 if (*PL_reglastparen < n || ln == -1)
af3f8c16 3360 sayNO; /* Do not match unless seen CLOSEn. */
24d3c4a9 3361 if (ln == PL_regendp[n])
a0d0e21e 3362 break;
a0ed51b3 3363
24d3c4a9 3364 s = PL_bostr + ln;
81714fb9 3365 if (do_utf8 && type != REF) { /* REF can do byte comparison */
a0ed51b3 3366 char *l = locinput;
a3b680e6 3367 const char *e = PL_bostr + PL_regendp[n];
a0ed51b3
LW		 3368 /*
3369 * Note that we can't do the "other character" lookup trick as
3370 * in the 8-bit case (no pun intended) because in Unicode we
3371 * have to map both upper and title case to lower case.
3372 */
81714fb9 3373 if (type == REFF) {
a0ed51b3 3374 while (s < e) {
a3b680e6
AL		 3375 STRLEN ulen1, ulen2;
3376 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3377 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3378
a0ed51b3
LW		 3379 if (l >= PL_regeol)
3380 sayNO;
a2a2844f
JH		 3381 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3382 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
7114a2d2 3383 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
a0ed51b3 3384 sayNO;
a2a2844f
JH		 3385 s += ulen1;
3386 l += ulen2;
a0ed51b3
LW		 3387 }
3388 }
3389 locinput = l;
3390 nextchr = UCHARAT(locinput);
3391 break;
3392 }
3393
a0d0e21e 3394 /* Inline the first character, for speed. */
76e3520e 3395 if (UCHARAT(s) != nextchr &&
81714fb9
YO		 3396 (type == REF ||
3397 (UCHARAT(s) != (type == REFF
3398 ? PL_fold : PL_fold_locale)[nextchr])))
4633a7c4 3399 sayNO;
24d3c4a9
DM		 3400 ln = PL_regendp[n] - ln;
3401 if (locinput + ln > PL_regeol)
4633a7c4 3402 sayNO;
81714fb9 3403 if (ln > 1 && (type == REF
24d3c4a9 3404 ? memNE(s, locinput, ln)
81714fb9 3405 : (type == REFF
24d3c4a9
DM		 3406 ? ibcmp(s, locinput, ln)
3407 : ibcmp_locale(s, locinput, ln))))
4633a7c4 3408 sayNO;
24d3c4a9 3409 locinput += ln;
76e3520e 3410 nextchr = UCHARAT(locinput);
a0d0e21e 3411 break;
81714fb9 3412 }
a0d0e21e 3413 case NOTHING:
c277df42 3414 case TAIL:
a0d0e21e
LW		 3415 break;
3416 case BACK:
3417 break;
40a82448
DM