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
[perl #38906] Regex engine does not release MINMOD
[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.
16
166f8a29
DM		 17 */
18
a687059c
LW		 19/* NOTE: this is derived from Henry Spencer's regexp code, and should not
20 * confused with the original package (see point 3 below). Thanks, Henry!
21 */
22
23/* Additional note: this code is very heavily munged from Henry's version
24 * in places. In some spots I've traded clarity for efficiency, so don't
25 * blame Henry for some of the lack of readability.
26 */
27
e50aee73
AD		 28/* The names of the functions have been changed from regcomp and
29 * regexec to pregcomp and pregexec in order to avoid conflicts
30 * with the POSIX routines of the same names.
31*/
32
b9d5759e
AD		 33#ifdef PERL_EXT_RE_BUILD
34/* need to replace pregcomp et al, so enable that */
35# ifndef PERL_IN_XSUB_RE
36# define PERL_IN_XSUB_RE
37# endif
38/* need access to debugger hooks */
cad2e5aa 39# if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
b9d5759e
AD		 40# define DEBUGGING
41# endif
42#endif
43
44#ifdef PERL_IN_XSUB_RE
d06ea78c 45/* We *really* need to overwrite these symbols: */
56953603
IZ		 46# define Perl_regexec_flags my_regexec
47# define Perl_regdump my_regdump
48# define Perl_regprop my_regprop
cad2e5aa 49# define Perl_re_intuit_start my_re_intuit_start
d06ea78c
GS		 50/* *These* symbols are masked to allow static link. */
51# define Perl_pregexec my_pregexec
9041c2e3 52# define Perl_reginitcolors my_reginitcolors
490a3f88 53# define Perl_regclass_swash my_regclass_swash
c5be433b
GS		 54
55# define PERL_NO_GET_CONTEXT
9041c2e3 56#endif
56953603 57
a687059c 58/*
e50aee73 59 * pregcomp and pregexec -- regsub and regerror are not used in perl
a687059c
LW		 60 *
61 * Copyright (c) 1986 by University of Toronto.
62 * Written by Henry Spencer. Not derived from licensed software.
63 *
64 * Permission is granted to anyone to use this software for any
65 * purpose on any computer system, and to redistribute it freely,
66 * subject to the following restrictions:
67 *
68 * 1. The author is not responsible for the consequences of use of
69 * this software, no matter how awful, even if they arise
70 * from defects in it.
71 *
72 * 2. The origin of this software must not be misrepresented, either
73 * by explicit claim or by omission.
74 *
75 * 3. Altered versions must be plainly marked as such, and must not
76 * be misrepresented as being the original software.
77 *
78 **** Alterations to Henry's code are...
79 ****
4bb101f2 80 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
b94e2f88 81 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
a687059c 82 ****
9ef589d8
LW		 83 **** You may distribute under the terms of either the GNU General Public
84 **** License or the Artistic License, as specified in the README file.
a687059c
LW		 85 *
86 * Beware that some of this code is subtly aware of the way operator
87 * precedence is structured in regular expressions. Serious changes in
88 * regular-expression syntax might require a total rethink.
89 */
90#include "EXTERN.h"
864dbfa3 91#define PERL_IN_REGEXEC_C
a687059c 92#include "perl.h"
0f5d15d6 93
a687059c
LW		 94#include "regcomp.h"
95
c277df42
IZ		 96#define RF_tainted 1 /* tainted information used? */
97#define RF_warned 2 /* warned about big count? */
ce862d02 98#define RF_evaled 4 /* Did an EVAL with setting? */
a0ed51b3
LW		 99#define RF_utf8 8 /* String contains multibyte chars? */
100
eb160463 101#define UTF ((PL_reg_flags & RF_utf8) != 0)
ce862d02
IZ		 102
103#define RS_init 1 /* eval environment created */
104#define RS_set 2 /* replsv value is set */
c277df42 105
a687059c
LW		 106#ifndef STATIC
107#define STATIC static
108#endif
109
ba7b4546 110#define REGINCLASS(p,c) (ANYOF_FLAGS(p) ? reginclass(p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
7d3e948e 111
c277df42
IZ		 112/*
113 * Forwards.
114 */
115
33b8afdf 116#define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
53c4c00c 117#define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
a0ed51b3 118
52657f30
AL		 119#define HOPc(pos,off) ((char *)(PL_reg_match_utf8 \
120 ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
121 : (U8*)(pos + off)))
122#define HOPBACKc(pos, off) ((char*) \
123 ((PL_reg_match_utf8) \
124 ? reghopmaybe3((U8*)pos, -off, ((U8*)(off < 0 ? PL_regeol : PL_bostr))) \
efb30f32
HS		 125 : (pos - off >= PL_bostr) \
126 ? (U8*)(pos - off) \
52657f30 127 : (U8*)NULL) \
efb30f32 128)
efb30f32 129
1aa99e6b 130#define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim))
53c4c00c 131#define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
1aa99e6b 132#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
1aa99e6b 133
1a4fad37
AL		 134#define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
135 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
136#define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
137#define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
138#define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
139#define LOAD_UTF8_CHARCLASS_MARK() LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
51371543 140
5f80c4cf 141/* for use after a quantifier and before an EXACT-like node -- japhy */
e2d8ce26
JP		 142#define JUMPABLE(rn) ( \
143 OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
cca55fe3
JP		 144 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
145 OP(rn) == PLUS || OP(rn) == MINMOD || \
146 (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \
e2d8ce26
JP		 147)
148
cca55fe3
JP		 149#define HAS_TEXT(rn) ( \
150 PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \
151)
e2d8ce26 152
a84d97b6
HS		 153/*
154 Search for mandatory following text node; for lookahead, the text must
155 follow but for lookbehind (rn->flags != 0) we skip to the next step.
156*/
cca55fe3 157#define FIND_NEXT_IMPT(rn) STMT_START { \
e2d8ce26 158 while (JUMPABLE(rn)) \
a84d97b6 159 if (OP(rn) == SUSPEND || PL_regkind[(U8)OP(rn)] == CURLY) \
e2d8ce26 160 rn = NEXTOPER(NEXTOPER(rn)); \
cca55fe3
JP		 161 else if (OP(rn) == PLUS) \
162 rn = NEXTOPER(rn); \
a84d97b6
HS		 163 else if (OP(rn) == IFMATCH) \
164 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
e2d8ce26 165 else rn += NEXT_OFF(rn); \
5f80c4cf 166} STMT_END
74750237 167
acfe0abc 168static void restore_pos(pTHX_ void *arg);
51371543 169
76e3520e 170STATIC CHECKPOINT
cea2e8a9 171S_regcppush(pTHX_ I32 parenfloor)
a0d0e21e 172{
97aff369 173 dVAR;
a3b680e6 174 const int retval = PL_savestack_ix;
b1ce53c5 175#define REGCP_PAREN_ELEMS 4
a3b680e6 176 const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
a0d0e21e
LW		 177 int p;
178
e49a9654
IH		 179 if (paren_elems_to_push < 0)
180 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
181
a01268b5 182#define REGCP_OTHER_ELEMS 6
4b3c1a47 183 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
3280af22 184 for (p = PL_regsize; p > parenfloor; p--) {
b1ce53c5 185/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
cf93c79d
IZ		 186 SSPUSHINT(PL_regendp[p]);
187 SSPUSHINT(PL_regstartp[p]);
3280af22 188 SSPUSHPTR(PL_reg_start_tmp[p]);
a0d0e21e
LW		 189 SSPUSHINT(p);
190 }
b1ce53c5 191/* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
3280af22
NIS		 192 SSPUSHINT(PL_regsize);
193 SSPUSHINT(*PL_reglastparen);
a01268b5 194 SSPUSHINT(*PL_reglastcloseparen);
3280af22 195 SSPUSHPTR(PL_reginput);
41123dfd
JH		 196#define REGCP_FRAME_ELEMS 2
197/* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
198 * are needed for the regexp context stack bookkeeping. */
199 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
b1ce53c5 200 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
41123dfd 201
a0d0e21e
LW		 202 return retval;
203}
204
c277df42 205/* These are needed since we do not localize EVAL nodes: */
a3621e74 206# define REGCP_SET(cp) DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, \
faccc32b 207 " Setting an EVAL scope, savestack=%"IVdf"\n", \
02db2b7b 208 (IV)PL_savestack_ix)); cp = PL_savestack_ix
c3464db5 209
a3621e74 210# define REGCP_UNWIND(cp) DEBUG_EXECUTE_r(cp != PL_savestack_ix ? \
c3464db5 211 PerlIO_printf(Perl_debug_log, \
faccc32b 212 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
02db2b7b 213 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
c277df42 214
76e3520e 215STATIC char *
097eb12c 216S_regcppop(pTHX_ const regexp *rex)
a0d0e21e 217{
97aff369 218 dVAR;
b1ce53c5 219 I32 i;
a0d0e21e 220 char *input;
b1ce53c5 221
a3621e74
YO		 222 GET_RE_DEBUG_FLAGS_DECL;
223
b1ce53c5 224 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
a0d0e21e 225 i = SSPOPINT;
b1ce53c5
JH		 226 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
227 i = SSPOPINT; /* Parentheses elements to pop. */
a0d0e21e 228 input = (char *) SSPOPPTR;
a01268b5 229 *PL_reglastcloseparen = SSPOPINT;
3280af22
NIS		 230 *PL_reglastparen = SSPOPINT;
231 PL_regsize = SSPOPINT;
b1ce53c5
JH		 232
233 /* Now restore the parentheses context. */
41123dfd
JH		 234 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
235 i > 0; i -= REGCP_PAREN_ELEMS) {
1df70142 236 I32 tmps;
097eb12c 237 U32 paren = (U32)SSPOPINT;
3280af22 238 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
cf93c79d
IZ		 239 PL_regstartp[paren] = SSPOPINT;
240 tmps = SSPOPINT;
3280af22
NIS		 241 if (paren <= *PL_reglastparen)
242 PL_regendp[paren] = tmps;
a3621e74 243 DEBUG_EXECUTE_r(
c3464db5 244 PerlIO_printf(Perl_debug_log,
b900a521 245 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
9041c2e3 246 (UV)paren, (IV)PL_regstartp[paren],
b900a521 247 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
9041c2e3 248 (IV)PL_regendp[paren],
3280af22 249 (paren > *PL_reglastparen ? "(no)" : ""));
c277df42 250 );
a0d0e21e 251 }
a3621e74 252 DEBUG_EXECUTE_r(
4f639d21 253 if ((I32)(*PL_reglastparen + 1) <= rex->nparens) {
c3464db5 254 PerlIO_printf(Perl_debug_log,
faccc32b 255 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
4f639d21 256 (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
c277df42
IZ		 257 }
258 );
daf18116 259#if 1
dafc8851
JH		 260 /* It would seem that the similar code in regtry()
261 * already takes care of this, and in fact it is in
262 * a better location to since this code can #if 0-ed out
263 * but the code in regtry() is needed or otherwise tests
264 * requiring null fields (pat.t#187 and split.t#{13,14}
daf18116
JH		 265 * (as of patchlevel 7877) will fail. Then again,
266 * this code seems to be necessary or otherwise
267 * building DynaLoader will fail:
268 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
269 * --jhi */
097eb12c
AL		 270 for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
271 if (i > PL_regsize)
272 PL_regstartp[i] = -1;
273 PL_regendp[i] = -1;
a0d0e21e 274 }
dafc8851 275#endif
a0d0e21e
LW		 276 return input;
277}
278
02db2b7b 279#define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
a0d0e21e 280
95b24440 281#define TRYPAREN(paren, n, input, where) { \
29d1e993
HS		 282 if (paren) { \
283 if (n) { \
284 PL_regstartp[paren] = HOPc(input, -1) - PL_bostr; \
285 PL_regendp[paren] = input - PL_bostr; \
286 } \
287 else \
288 PL_regendp[paren] = -1; \
289 } \
95b24440
DM		 290 REGMATCH(next, where); \
291 if (result) \
29d1e993
HS		 292 sayYES; \
293 if (paren && n) \
294 PL_regendp[paren] = -1; \
295}
296
297
a687059c 298/*
e50aee73 299 * pregexec and friends
a687059c
LW		 300 */
301
302/*
c277df42 303 - pregexec - match a regexp against a string
a687059c 304 */
c277df42 305I32
864dbfa3 306Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
c3464db5 307 char *strbeg, I32 minend, SV *screamer, U32 nosave)
c277df42
IZ		 308/* strend: pointer to null at end of string */
309/* strbeg: real beginning of string */
310/* minend: end of match must be >=minend after stringarg. */
311/* nosave: For optimizations. */
312{
313 return
9041c2e3 314 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
c277df42
IZ		 315 nosave ? 0 : REXEC_COPY_STR);
316}
0f5d15d6 317
22e551b9 318
9041c2e3 319/*
cad2e5aa
JH		 320 * Need to implement the following flags for reg_anch:
321 *
322 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
323 * USE_INTUIT_ML
324 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
325 * INTUIT_AUTORITATIVE_ML
326 * INTUIT_ONCE_NOML - Intuit can match in one location only.
327 * INTUIT_ONCE_ML
328 *
329 * Another flag for this function: SECOND_TIME (so that float substrs
330 * with giant delta may be not rechecked).
331 */
332
333/* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
334
3f7c398e 335/* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
cad2e5aa
JH		 336 Otherwise, only SvCUR(sv) is used to get strbeg. */
337
338/* XXXX We assume that strpos is strbeg unless sv. */
339
6eb5f6b9
JH		 340/* XXXX Some places assume that there is a fixed substring.
341 An update may be needed if optimizer marks as "INTUITable"
342 RExen without fixed substrings. Similarly, it is assumed that
343 lengths of all the strings are no more than minlen, thus they
344 cannot come from lookahead.
345 (Or minlen should take into account lookahead.) */
346
2c2d71f5
JH		 347/* A failure to find a constant substring means that there is no need to make
348 an expensive call to REx engine, thus we celebrate a failure. Similarly,
349 finding a substring too deep into the string means that less calls to
30944b6d
IZ		 350 regtry() should be needed.
351
352 REx compiler's optimizer found 4 possible hints:
353 a) Anchored substring;
354 b) Fixed substring;
355 c) Whether we are anchored (beginning-of-line or \G);
356 d) First node (of those at offset 0) which may distingush positions;
6eb5f6b9 357 We use a)b)d) and multiline-part of c), and try to find a position in the
30944b6d
IZ		 358 string which does not contradict any of them.
359 */
2c2d71f5 360
6eb5f6b9
JH		 361/* Most of decisions we do here should have been done at compile time.
362 The nodes of the REx which we used for the search should have been
363 deleted from the finite automaton. */
364
cad2e5aa
JH		 365char *
366Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
367 char *strend, U32 flags, re_scream_pos_data *data)
368{
97aff369 369 dVAR;
b7953727 370 register I32 start_shift = 0;
cad2e5aa 371 /* Should be nonnegative! */
b7953727 372 register I32 end_shift = 0;
2c2d71f5
JH		 373 register char *s;
374 register SV *check;
a1933d95 375 char *strbeg;
cad2e5aa 376 char *t;
a3b680e6 377 const int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */
cad2e5aa 378 I32 ml_anch;
bd61b366
SS		 379 register char *other_last = NULL; /* other substr checked before this */
380 char *check_at = NULL; /* check substr found at this pos */
1df70142 381 const I32 multiline = prog->reganch & PMf_MULTILINE;
30944b6d 382#ifdef DEBUGGING
890ce7af
AL		 383 const char * const i_strpos = strpos;
384 SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
30944b6d 385#endif
a3621e74
YO		 386
387 GET_RE_DEBUG_FLAGS_DECL;
388
a30b2f1f 389 RX_MATCH_UTF8_set(prog,do_utf8);
cad2e5aa 390
b8d68ded 391 if (prog->reganch & ROPT_UTF8) {
a3621e74 392 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
b8d68ded
JH		 393 "UTF-8 regex...\n"));
394 PL_reg_flags |= RF_utf8;
395 }
396
a3621e74 397 DEBUG_EXECUTE_r({
1df70142 398 const char *s = PL_reg_match_utf8 ?
c728cb41
JH		 399 sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
400 strpos;
1df70142 401 const int len = PL_reg_match_utf8 ?
b8d68ded 402 strlen(s) : strend - strpos;
2a782b5b
JH		 403 if (!PL_colorset)
404 reginitcolors();
b8d68ded 405 if (PL_reg_match_utf8)
a3621e74 406 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
b8d68ded 407 "UTF-8 target...\n"));
2a782b5b 408 PerlIO_printf(Perl_debug_log,
a0288114 409 "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n",
e4584336 410 PL_colors[4], PL_colors[5], PL_colors[0],
2a782b5b
JH		 411 prog->precomp,
412 PL_colors[1],
413 (strlen(prog->precomp) > 60 ? "..." : ""),
414 PL_colors[0],
415 (int)(len > 60 ? 60 : len),
416 s, PL_colors[1],
417 (len > 60 ? "..." : "")
418 );
419 });
cad2e5aa 420
c344f387
JH		 421 /* CHR_DIST() would be more correct here but it makes things slow. */
422 if (prog->minlen > strend - strpos) {
a3621e74 423 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
a72c7584 424 "String too short... [re_intuit_start]\n"));
cad2e5aa 425 goto fail;
2c2d71f5 426 }
a1933d95 427 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
1aa99e6b 428 PL_regeol = strend;
33b8afdf
JH		 429 if (do_utf8) {
430 if (!prog->check_utf8 && prog->check_substr)
431 to_utf8_substr(prog);
432 check = prog->check_utf8;
433 } else {
434 if (!prog->check_substr && prog->check_utf8)
435 to_byte_substr(prog);
436 check = prog->check_substr;
437 }
438 if (check == &PL_sv_undef) {
a3621e74 439 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
33b8afdf
JH		 440 "Non-utf string cannot match utf check string\n"));
441 goto fail;
442 }
2c2d71f5 443 if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
cad2e5aa
JH		 444 ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
445 || ( (prog->reganch & ROPT_ANCH_BOL)
7fba1cd6 446 && !multiline ) ); /* Check after \n? */
cad2e5aa 447
7e25d62c
JH		 448 if (!ml_anch) {
449 if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
450 | ROPT_IMPLICIT)) /* not a real BOL */
3f7c398e 451 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
7e25d62c
JH		 452 && sv && !SvROK(sv)
453 && (strpos != strbeg)) {
a3621e74 454 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
7e25d62c
JH		 455 goto fail;
456 }
457 if (prog->check_offset_min == prog->check_offset_max &&
cce850e4 458 !(prog->reganch & ROPT_CANY_SEEN)) {
2c2d71f5 459 /* Substring at constant offset from beg-of-str... */
cad2e5aa
JH		 460 I32 slen;
461
1aa99e6b 462 s = HOP3c(strpos, prog->check_offset_min, strend);
653099ff
GS		 463 if (SvTAIL(check)) {
464 slen = SvCUR(check); /* >= 1 */
cad2e5aa 465
9041c2e3 466 if ( strend - s > slen || strend - s < slen - 1
2c2d71f5 467 || (strend - s == slen && strend[-1] != '\n')) {
a3621e74 468 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
2c2d71f5 469 goto fail_finish;
cad2e5aa
JH		 470 }
471 /* Now should match s[0..slen-2] */
472 slen--;
3f7c398e 473 if (slen && (*SvPVX_const(check) != *s
cad2e5aa 474 || (slen > 1
3f7c398e 475 && memNE(SvPVX_const(check), s, slen)))) {
2c2d71f5 476 report_neq:
a3621e74 477 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
2c2d71f5
JH		 478 goto fail_finish;
479 }
cad2e5aa 480 }
3f7c398e 481 else if (*SvPVX_const(check) != *s
653099ff 482 || ((slen = SvCUR(check)) > 1
3f7c398e 483 && memNE(SvPVX_const(check), s, slen)))
2c2d71f5 484 goto report_neq;
c315bfe8 485 check_at = s;
2c2d71f5 486 goto success_at_start;
7e25d62c 487 }
cad2e5aa 488 }
2c2d71f5 489 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
cad2e5aa 490 s = strpos;
2c2d71f5 491 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
2c2d71f5 492 end_shift = prog->minlen - start_shift -
653099ff 493 CHR_SVLEN(check) + (SvTAIL(check) != 0);
2c2d71f5 494 if (!ml_anch) {
a3b680e6 495 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
653099ff 496 - (SvTAIL(check) != 0);
a3b680e6 497 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
2c2d71f5
JH		 498
499 if (end_shift < eshift)
500 end_shift = eshift;
501 }
cad2e5aa 502 }
2c2d71f5 503 else { /* Can match at random position */
cad2e5aa
JH		 504 ml_anch = 0;
505 s = strpos;
2c2d71f5
JH		 506 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
507 /* Should be nonnegative! */
508 end_shift = prog->minlen - start_shift -
653099ff 509 CHR_SVLEN(check) + (SvTAIL(check) != 0);
cad2e5aa
JH		 510 }
511
2c2d71f5 512#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
0033605d 513 if (end_shift < 0)
6bbae5e6 514 Perl_croak(aTHX_ "panic: end_shift");
2c2d71f5
JH		 515#endif
516
2c2d71f5
JH		 517 restart:
518 /* Find a possible match in the region s..strend by looking for
519 the "check" substring in the region corrected by start/end_shift. */
cad2e5aa 520 if (flags & REXEC_SCREAM) {
cad2e5aa 521 I32 p = -1; /* Internal iterator of scream. */
a3b680e6 522 I32 * const pp = data ? data->scream_pos : &p;
cad2e5aa 523
2c2d71f5
JH		 524 if (PL_screamfirst[BmRARE(check)] >= 0
525 || ( BmRARE(check) == '\n'
526 && (BmPREVIOUS(check) == SvCUR(check) - 1)
527 && SvTAIL(check) ))
9041c2e3 528 s = screaminstr(sv, check,
2c2d71f5 529 start_shift + (s - strbeg), end_shift, pp, 0);
cad2e5aa 530 else
2c2d71f5 531 goto fail_finish;
4addbd3b
HS		 532 /* we may be pointing at the wrong string */
533 if (s && RX_MATCH_COPIED(prog))
3f7c398e 534 s = strbeg + (s - SvPVX_const(sv));
cad2e5aa
JH		 535 if (data)
536 *data->scream_olds = s;
537 }
f33976b4 538 else if (prog->reganch & ROPT_CANY_SEEN)
3baa4c62
JH		 539 s = fbm_instr((U8*)(s + start_shift),
540 (U8*)(strend - end_shift),
7fba1cd6 541 check, multiline ? FBMrf_MULTILINE : 0);
cad2e5aa 542 else
1aa99e6b
IH		 543 s = fbm_instr(HOP3(s, start_shift, strend),
544 HOP3(strend, -end_shift, strbeg),
7fba1cd6 545 check, multiline ? FBMrf_MULTILINE : 0);
cad2e5aa
JH		 546
547 /* Update the count-of-usability, remove useless subpatterns,
548 unshift s. */
2c2d71f5 549
a0288114 550 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s",
2c2d71f5 551 (s ? "Found" : "Did not find"),
33b8afdf 552 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
2c2d71f5 553 PL_colors[0],
7b0972df 554 (int)(SvCUR(check) - (SvTAIL(check)!=0)),
3f7c398e 555 SvPVX_const(check),
2c2d71f5
JH		 556 PL_colors[1], (SvTAIL(check) ? "$" : ""),
557 (s ? " at offset " : "...\n") ) );
558
559 if (!s)
560 goto fail_finish;
561
6eb5f6b9
JH		 562 check_at = s;
563
2c2d71f5 564 /* Finish the diagnostic message */
a3621e74 565 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
2c2d71f5
JH		 566
567 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
568 Start with the other substr.
569 XXXX no SCREAM optimization yet - and a very coarse implementation
a0288114 570 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
2c2d71f5
JH		 571 *always* match. Probably should be marked during compile...
572 Probably it is right to do no SCREAM here...
573 */
574
33b8afdf 575 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
30944b6d 576 /* Take into account the "other" substring. */
2c2d71f5
JH		 577 /* XXXX May be hopelessly wrong for UTF... */
578 if (!other_last)
6eb5f6b9 579 other_last = strpos;
33b8afdf 580 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
30944b6d
IZ		 581 do_other_anchored:
582 {
890ce7af
AL		 583 char * const last = HOP3c(s, -start_shift, strbeg);
584 char *last1, *last2;
2c2d71f5 585 char *s1 = s;
33b8afdf 586 SV* must;
2c2d71f5 587
2c2d71f5
JH		 588 t = s - prog->check_offset_max;
589 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
1d86a7f9 590 && (!do_utf8
1aa99e6b 591 || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos))
2c2d71f5 592 && t > strpos)))
30944b6d 593 /* EMPTY */;
2c2d71f5
JH		 594 else
595 t = strpos;
1aa99e6b 596 t = HOP3c(t, prog->anchored_offset, strend);
6eb5f6b9
JH		 597 if (t < other_last) /* These positions already checked */
598 t = other_last;
1aa99e6b 599 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
2c2d71f5
JH		 600 if (last < last1)
601 last1 = last;
602 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
603 /* On end-of-str: see comment below. */
33b8afdf
JH		 604 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
605 if (must == &PL_sv_undef) {
606 s = (char*)NULL;
a3621e74 607 DEBUG_EXECUTE_r(must = prog->anchored_utf8); /* for debug */
33b8afdf
JH		 608 }
609 else
610 s = fbm_instr(
611 (unsigned char*)t,
612 HOP3(HOP3(last1, prog->anchored_offset, strend)
613 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
614 must,
7fba1cd6 615 multiline ? FBMrf_MULTILINE : 0
33b8afdf 616 );
a3621e74 617 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
a0288114 618 "%s anchored substr \"%s%.*s%s\"%s",
2c2d71f5
JH		 619 (s ? "Found" : "Contradicts"),
620 PL_colors[0],
33b8afdf
JH		 621 (int)(SvCUR(must)
622 - (SvTAIL(must)!=0)),
3f7c398e 623 SvPVX_const(must),
33b8afdf 624 PL_colors[1], (SvTAIL(must) ? "$" : "")));
2c2d71f5
JH		 625 if (!s) {
626 if (last1 >= last2) {
a3621e74 627 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2c2d71f5
JH		 628 ", giving up...\n"));
629 goto fail_finish;
630 }
a3621e74 631 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2c2d71f5 632 ", trying floating at offset %ld...\n",
1aa99e6b
IH		 633 (long)(HOP3c(s1, 1, strend) - i_strpos)));
634 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
635 s = HOP3c(last, 1, strend);
2c2d71f5
JH		 636 goto restart;
637 }
638 else {
a3621e74 639 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
30944b6d 640 (long)(s - i_strpos)));
1aa99e6b
IH		 641 t = HOP3c(s, -prog->anchored_offset, strbeg);
642 other_last = HOP3c(s, 1, strend);
30944b6d 643 s = s1;
2c2d71f5
JH		 644 if (t == strpos)
645 goto try_at_start;
2c2d71f5
JH		 646 goto try_at_offset;
647 }
30944b6d 648 }
2c2d71f5
JH		 649 }
650 else { /* Take into account the floating substring. */
33b8afdf
JH		 651 char *last, *last1;
652 char *s1 = s;
653 SV* must;
654
655 t = HOP3c(s, -start_shift, strbeg);
656 last1 = last =
657 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
658 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
659 last = HOP3c(t, prog->float_max_offset, strend);
660 s = HOP3c(t, prog->float_min_offset, strend);
661 if (s < other_last)
662 s = other_last;
2c2d71f5 663 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
33b8afdf
JH		 664 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
665 /* fbm_instr() takes into account exact value of end-of-str
666 if the check is SvTAIL(ed). Since false positives are OK,
667 and end-of-str is not later than strend we are OK. */
668 if (must == &PL_sv_undef) {
669 s = (char*)NULL;
a3621e74 670 DEBUG_EXECUTE_r(must = prog->float_utf8); /* for debug message */
33b8afdf
JH		 671 }
672 else
2c2d71f5 673 s = fbm_instr((unsigned char*)s,
33b8afdf
JH		 674 (unsigned char*)last + SvCUR(must)
675 - (SvTAIL(must)!=0),
7fba1cd6 676 must, multiline ? FBMrf_MULTILINE : 0);
a0288114 677 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
33b8afdf
JH		 678 (s ? "Found" : "Contradicts"),
679 PL_colors[0],
680 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
3f7c398e 681 SvPVX_const(must),
33b8afdf
JH		 682 PL_colors[1], (SvTAIL(must) ? "$" : "")));
683 if (!s) {
684 if (last1 == last) {
a3621e74 685 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
33b8afdf
JH		 686 ", giving up...\n"));
687 goto fail_finish;
2c2d71f5 688 }
a3621e74 689 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
33b8afdf
JH		 690 ", trying anchored starting at offset %ld...\n",
691 (long)(s1 + 1 - i_strpos)));
692 other_last = last;
693 s = HOP3c(t, 1, strend);
694 goto restart;
695 }
696 else {
a3621e74 697 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
33b8afdf
JH		 698 (long)(s - i_strpos)));
699 other_last = s; /* Fix this later. --Hugo */
700 s = s1;
701 if (t == strpos)
702 goto try_at_start;
703 goto try_at_offset;
704 }
2c2d71f5 705 }
cad2e5aa 706 }
2c2d71f5
JH		 707
708 t = s - prog->check_offset_max;
2c2d71f5 709 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
1d86a7f9 710 && (!do_utf8
1aa99e6b
IH		 711 || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos))
712 && t > strpos))) {
2c2d71f5
JH		 713 /* Fixed substring is found far enough so that the match
714 cannot start at strpos. */
715 try_at_offset:
cad2e5aa 716 if (ml_anch && t[-1] != '\n') {
30944b6d
IZ		 717 /* Eventually fbm_*() should handle this, but often
718 anchored_offset is not 0, so this check will not be wasted. */
719 /* XXXX In the code below we prefer to look for "^" even in
720 presence of anchored substrings. And we search even
721 beyond the found float position. These pessimizations
722 are historical artefacts only. */
723 find_anchor:
2c2d71f5 724 while (t < strend - prog->minlen) {
cad2e5aa 725 if (*t == '\n') {
4ee3650e 726 if (t < check_at - prog->check_offset_min) {
33b8afdf 727 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
4ee3650e
GS		 728 /* Since we moved from the found position,
729 we definitely contradict the found anchored
30944b6d
IZ		 730 substr. Due to the above check we do not
731 contradict "check" substr.
732 Thus we can arrive here only if check substr
733 is float. Redo checking for "other"=="fixed".
734 */
9041c2e3 735 strpos = t + 1;
a3621e74 736 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
e4584336 737 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
30944b6d
IZ		 738 goto do_other_anchored;
739 }
4ee3650e
GS		 740 /* We don't contradict the found floating substring. */
741 /* XXXX Why not check for STCLASS? */
cad2e5aa 742 s = t + 1;
a3621e74 743 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
e4584336 744 PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
cad2e5aa
JH		 745 goto set_useful;
746 }
4ee3650e
GS		 747 /* Position contradicts check-string */
748 /* XXXX probably better to look for check-string
749 than for "\n", so one should lower the limit for t? */
a3621e74 750 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
e4584336 751 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
0e41cd87 752 other_last = strpos = s = t + 1;
cad2e5aa
JH		 753 goto restart;
754 }
755 t++;
756 }
a3621e74 757 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
e4584336 758 PL_colors[0], PL_colors[1]));
2c2d71f5 759 goto fail_finish;
cad2e5aa 760 }
f5952150 761 else {
a3621e74 762 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
e4584336 763 PL_colors[0], PL_colors[1]));
f5952150 764 }
cad2e5aa
JH		 765 s = t;
766 set_useful:
33b8afdf 767 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
cad2e5aa
JH		 768 }
769 else {
f5952150 770 /* The found string does not prohibit matching at strpos,
2c2d71f5 771 - no optimization of calling REx engine can be performed,
f5952150
GS		 772 unless it was an MBOL and we are not after MBOL,
773 or a future STCLASS check will fail this. */
2c2d71f5
JH		 774 try_at_start:
775 /* Even in this situation we may use MBOL flag if strpos is offset
776 wrt the start of the string. */
05b4157f 777 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
a1933d95 778 && (strpos != strbeg) && strpos[-1] != '\n'
d506a20d
IZ		 779 /* May be due to an implicit anchor of m{.*foo} */
780 && !(prog->reganch & ROPT_IMPLICIT))
781 {
cad2e5aa
JH		 782 t = strpos;
783 goto find_anchor;
784 }
a3621e74 785 DEBUG_EXECUTE_r( if (ml_anch)
f5952150 786 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
e4584336 787 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
30944b6d 788 );
2c2d71f5 789 success_at_start:
30944b6d 790 if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
33b8afdf
JH		 791 && (do_utf8 ? (
792 prog->check_utf8 /* Could be deleted already */
793 && --BmUSEFUL(prog->check_utf8) < 0
794 && (prog->check_utf8 == prog->float_utf8)
795 ) : (
796 prog->check_substr /* Could be deleted already */
797 && --BmUSEFUL(prog->check_substr) < 0
798 && (prog->check_substr == prog->float_substr)
799 )))
66e933ab 800 {
cad2e5aa 801 /* If flags & SOMETHING - do not do it many times on the same match */
a3621e74 802 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
33b8afdf
JH		 803 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
804 if (do_utf8 ? prog->check_substr : prog->check_utf8)
805 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
a0714e2c
SS		 806 prog->check_substr = prog->check_utf8 = NULL; /* disable */
807 prog->float_substr = prog->float_utf8 = NULL; /* clear */
808 check = NULL; /* abort */
cad2e5aa 809 s = strpos;
3cf5c195
IZ		 810 /* XXXX This is a remnant of the old implementation. It
811 looks wasteful, since now INTUIT can use many
6eb5f6b9 812 other heuristics. */
cad2e5aa
JH		 813 prog->reganch &= ~RE_USE_INTUIT;
814 }
815 else
816 s = strpos;
817 }
818
6eb5f6b9
JH		 819 /* Last resort... */
820 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
821 if (prog->regstclass) {
822 /* minlen == 0 is possible if regstclass is \b or \B,
823 and the fixed substr is ''$.
824 Since minlen is already taken into account, s+1 is before strend;
825 accidentally, minlen >= 1 guaranties no false positives at s + 1
826 even for \b or \B. But (minlen? 1 : 0) below assumes that
827 regstclass does not come from lookahead... */
828 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
829 This leaves EXACTF only, which is dealt with in find_byclass(). */
890ce7af 830 const U8* const str = (U8*)STRING(prog->regstclass);
06b5626a 831 const int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT
1aa99e6b 832 ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
66e933ab 833 : 1);
a3b680e6 834 const char * const endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1aa99e6b 835 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
33b8afdf 836 : (prog->float_substr || prog->float_utf8
1aa99e6b
IH		 837 ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
838 cl_l, strend)
839 : strend);
6eb5f6b9
JH		 840
841 t = s;
4f639d21 842 PL_reg_re = prog;
06b5626a 843 s = find_byclass(prog, prog->regstclass, s, endpos, 1);
6eb5f6b9
JH		 844 if (!s) {
845#ifdef DEBUGGING
cbbf8932 846 const char *what = NULL;
6eb5f6b9
JH		 847#endif
848 if (endpos == strend) {
a3621e74 849 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
6eb5f6b9
JH		 850 "Could not match STCLASS...\n") );
851 goto fail;
852 }
a3621e74 853 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
66e933ab 854 "This position contradicts STCLASS...\n") );
653099ff
GS		 855 if ((prog->reganch & ROPT_ANCH) && !ml_anch)
856 goto fail;
6eb5f6b9 857 /* Contradict one of substrings */
33b8afdf
JH		 858 if (prog->anchored_substr || prog->anchored_utf8) {
859 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
a3621e74 860 DEBUG_EXECUTE_r( what = "anchored" );
6eb5f6b9 861 hop_and_restart:
1aa99e6b 862 s = HOP3c(t, 1, strend);
66e933ab
GS		 863 if (s + start_shift + end_shift > strend) {
864 /* XXXX Should be taken into account earlier? */
a3621e74 865 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
66e933ab
GS		 866 "Could not match STCLASS...\n") );
867 goto fail;
868 }
5e39e1e5
HS		 869 if (!check)
870 goto giveup;
a3621e74 871 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
f5952150 872 "Looking for %s substr starting at offset %ld...\n",
6eb5f6b9
JH		 873 what, (long)(s + start_shift - i_strpos)) );
874 goto restart;
875 }
66e933ab 876 /* Have both, check_string is floating */
6eb5f6b9
JH		 877 if (t + start_shift >= check_at) /* Contradicts floating=check */
878 goto retry_floating_check;
879 /* Recheck anchored substring, but not floating... */
9041c2e3 880 s = check_at;
5e39e1e5
HS		 881 if (!check)
882 goto giveup;
a3621e74 883 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
f5952150 884 "Looking for anchored substr starting at offset %ld...\n",
6eb5f6b9
JH		 885 (long)(other_last - i_strpos)) );
886 goto do_other_anchored;
887 }
60e71179
GS		 888 /* Another way we could have checked stclass at the
889 current position only: */
890 if (ml_anch) {
891 s = t = t + 1;
5e39e1e5
HS		 892 if (!check)
893 goto giveup;
a3621e74 894 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
f5952150 895 "Looking for /%s^%s/m starting at offset %ld...\n",
e4584336 896 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
60e71179 897 goto try_at_offset;
66e933ab 898 }
33b8afdf 899 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
60e71179 900 goto fail;
6eb5f6b9
JH		 901 /* Check is floating subtring. */
902 retry_floating_check:
903 t = check_at - start_shift;
a3621e74 904 DEBUG_EXECUTE_r( what = "floating" );
6eb5f6b9
JH		 905 goto hop_and_restart;
906 }
b7953727 907 if (t != s) {
a3621e74 908 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
6eb5f6b9 909 "By STCLASS: moving %ld --> %ld\n",
b7953727
JH		 910 (long)(t - i_strpos), (long)(s - i_strpos))
911 );
912 }
913 else {
a3621e74 914 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
b7953727
JH		 915 "Does not contradict STCLASS...\n");
916 );
917 }
6eb5f6b9 918 }
5e39e1e5 919 giveup:
a3621e74 920 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
5e39e1e5
HS		 921 PL_colors[4], (check ? "Guessed" : "Giving up"),
922 PL_colors[5], (long)(s - i_strpos)) );
cad2e5aa 923 return s;
2c2d71f5
JH		 924
925 fail_finish: /* Substring not found */
33b8afdf
JH		 926 if (prog->check_substr || prog->check_utf8) /* could be removed already */
927 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
cad2e5aa 928 fail:
a3621e74 929 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
e4584336 930 PL_colors[4], PL_colors[5]));
bd61b366 931 return NULL;
cad2e5aa 932}
9661b544 933
6eb5f6b9 934/* We know what class REx starts with. Try to find this position... */
3c3eec57 935STATIC char *
097eb12c 936S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char *strend, I32 norun)
a687059c 937{
27da23d5 938 dVAR;
1df70142 939 const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
6eb5f6b9 940 char *m;
d8093b23 941 STRLEN ln;
5dab1207 942 STRLEN lnc;
078c425b 943 register STRLEN uskip;
d8093b23
G		 944 unsigned int c1;
945 unsigned int c2;
6eb5f6b9
JH		 946 char *e;
947 register I32 tmp = 1; /* Scratch variable? */
a3b680e6 948 register const bool do_utf8 = PL_reg_match_utf8;
cad2e5aa 949
6eb5f6b9
JH		 950 /* We know what class it must start with. */
951 switch (OP(c)) {
6eb5f6b9 952 case ANYOF:
388cc4de 953 if (do_utf8) {
078c425b 954 while (s + (uskip = UTF8SKIP(s)) <= strend) {
388cc4de
HS		 955 if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
956 !UTF8_IS_INVARIANT((U8)s[0]) ?
957 reginclass(c, (U8*)s, 0, do_utf8) :
958 REGINCLASS(c, (U8*)s)) {
959 if (tmp && (norun || regtry(prog, s)))
960 goto got_it;
961 else
962 tmp = doevery;
963 }
964 else
965 tmp = 1;
078c425b 966 s += uskip;
388cc4de
HS		 967 }
968 }
969 else {
970 while (s < strend) {
971 STRLEN skip = 1;
972
973 if (REGINCLASS(c, (U8*)s) ||
974 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
975 /* The assignment of 2 is intentional:
976 * for the folded sharp s, the skip is 2. */
977 (skip = SHARP_S_SKIP))) {
978 if (tmp && (norun || regtry(prog, s)))
979 goto got_it;
980 else
981 tmp = doevery;
982 }
983 else
984 tmp = 1;
985 s += skip;
986 }
a0d0e21e 987 }
6eb5f6b9 988 break;
f33976b4
DB		 989 case CANY:
990 while (s < strend) {
991 if (tmp && (norun || regtry(prog, s)))
992 goto got_it;
993 else
994 tmp = doevery;
995 s++;
996 }
997 break;
6eb5f6b9 998 case EXACTF:
5dab1207
NIS		 999 m = STRING(c);
1000 ln = STR_LEN(c); /* length to match in octets/bytes */
1001 lnc = (I32) ln; /* length to match in characters */
1aa99e6b 1002 if (UTF) {
a2a2844f 1003 STRLEN ulen1, ulen2;
5dab1207 1004 U8 *sm = (U8 *) m;
89ebb4a3
JH		 1005 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1006 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4ad0818d 1007 const U32 uniflags = UTF8_ALLOW_DEFAULT;
a2a2844f
JH		 1008
1009 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1010 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1011
89ebb4a3 1012 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
041457d9 1013 0, uniflags);
89ebb4a3 1014 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
041457d9 1015 0, uniflags);
5dab1207
NIS		 1016 lnc = 0;
1017 while (sm < ((U8 *) m + ln)) {
1018 lnc++;
1019 sm += UTF8SKIP(sm);
1020 }
1aa99e6b
IH		 1021 }
1022 else {
1023 c1 = *(U8*)m;
1024 c2 = PL_fold[c1];
1025 }
6eb5f6b9
JH		 1026 goto do_exactf;
1027 case EXACTFL:
5dab1207
NIS		 1028 m = STRING(c);
1029 ln = STR_LEN(c);
1030 lnc = (I32) ln;
d8093b23 1031 c1 = *(U8*)m;
6eb5f6b9
JH		 1032 c2 = PL_fold_locale[c1];
1033 do_exactf:
db12adc6 1034 e = HOP3c(strend, -((I32)lnc), s);
b3c9acc1 1035
6eb5f6b9
JH		 1036 if (norun && e < s)
1037 e = s; /* Due to minlen logic of intuit() */
1aa99e6b 1038
60a8b682
JH		 1039 /* The idea in the EXACTF* cases is to first find the
1040 * first character of the EXACTF* node and then, if
1041 * necessary, case-insensitively compare the full
1042 * text of the node. The c1 and c2 are the first
1043 * characters (though in Unicode it gets a bit
1044 * more complicated because there are more cases
7f16dd3d
JH		 1045 * than just upper and lower: one needs to use
1046 * the so-called folding case for case-insensitive
1047 * matching (called "loose matching" in Unicode).
1048 * ibcmp_utf8() will do just that. */
60a8b682 1049
1aa99e6b 1050 if (do_utf8) {
575cac57 1051 UV c, f;
89ebb4a3 1052 U8 tmpbuf [UTF8_MAXBYTES+1];
575cac57 1053 STRLEN len, foldlen;
4ad0818d 1054 const U32 uniflags = UTF8_ALLOW_DEFAULT;
09091399 1055 if (c1 == c2) {
5dab1207
NIS		 1056 /* Upper and lower of 1st char are equal -
1057 * probably not a "letter". */
1aa99e6b 1058 while (s <= e) {
89ebb4a3 1059 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
041457d9 1060 uniflags);
80aecb99
JH		 1061 if ( c == c1
1062 && (ln == len ||
66423254 1063 ibcmp_utf8(s, (char **)0, 0, do_utf8,
eb160463 1064 m, (char **)0, ln, (bool)UTF))
55da9344 1065 && (norun || regtry(prog, s)) )
1aa99e6b 1066 goto got_it;
80aecb99 1067 else {
1df70142 1068 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
80aecb99 1069 uvchr_to_utf8(tmpbuf, c);
ac7e0132 1070 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
80aecb99
JH		 1071 if ( f != c
1072 && (f == c1 || f == c2)
1073 && (ln == foldlen ||
66423254
JH		 1074 !ibcmp_utf8((char *) foldbuf,
1075 (char **)0, foldlen, do_utf8,
d07ddd77 1076 m,
eb160463 1077 (char **)0, ln, (bool)UTF))
80aecb99
JH		 1078 && (norun || regtry(prog, s)) )
1079 goto got_it;
1080 }
1aa99e6b
IH		 1081 s += len;
1082 }
09091399
JH		 1083 }
1084 else {
1aa99e6b 1085 while (s <= e) {
89ebb4a3 1086 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
041457d9 1087 uniflags);
80aecb99 1088
60a8b682 1089 /* Handle some of the three Greek sigmas cases.
8c01da3c
JH		 1090 * Note that not all the possible combinations
1091 * are handled here: some of them are handled
1092 * by the standard folding rules, and some of
1093 * them (the character class or ANYOF cases)
1094 * are handled during compiletime in
1095 * regexec.c:S_regclass(). */
880bd946
JH		 1096 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1097 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1098 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
80aecb99
JH		 1099
1100 if ( (c == c1 || c == c2)
1101 && (ln == len ||
66423254 1102 ibcmp_utf8(s, (char **)0, 0, do_utf8,
eb160463 1103 m, (char **)0, ln, (bool)UTF))
55da9344 1104 && (norun || regtry(prog, s)) )
1aa99e6b 1105 goto got_it;
80aecb99 1106 else {
1df70142 1107 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
80aecb99 1108 uvchr_to_utf8(tmpbuf, c);
ac7e0132 1109 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
80aecb99
JH		 1110 if ( f != c
1111 && (f == c1 || f == c2)
1112 && (ln == foldlen ||
a6872d42 1113 !ibcmp_utf8((char *) foldbuf,
66423254 1114 (char **)0, foldlen, do_utf8,
d07ddd77 1115 m,
eb160463 1116 (char **)0, ln, (bool)UTF))
80aecb99
JH		 1117 && (norun || regtry(prog, s)) )
1118 goto got_it;
1119 }
1aa99e6b
IH		 1120 s += len;
1121 }
09091399 1122 }
1aa99e6b
IH		 1123 }
1124 else {
1125 if (c1 == c2)
1126 while (s <= e) {
1127 if ( *(U8*)s == c1
1128 && (ln == 1 || !(OP(c) == EXACTF
1129 ? ibcmp(s, m, ln)
1130 : ibcmp_locale(s, m, ln)))
1131 && (norun || regtry(prog, s)) )
1132 goto got_it;
1133 s++;
1134 }
1135 else
1136 while (s <= e) {
1137 if ( (*(U8*)s == c1 || *(U8*)s == c2)
1138 && (ln == 1 || !(OP(c) == EXACTF
1139 ? ibcmp(s, m, ln)
1140 : ibcmp_locale(s, m, ln)))
1141 && (norun || regtry(prog, s)) )
1142 goto got_it;
1143 s++;
1144 }
b3c9acc1
IZ		 1145 }
1146 break;
bbce6d69 1147 case BOUNDL:
3280af22 1148 PL_reg_flags |= RF_tainted;
bbce6d69 1149 /* FALL THROUGH */
a0d0e21e 1150 case BOUND:
ffc61ed2 1151 if (do_utf8) {
12d33761 1152 if (s == PL_bostr)
ffc61ed2
JH		 1153 tmp = '\n';
1154 else {
6136c704 1155 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
4ad0818d 1156 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
ffc61ed2
JH		 1157 }
1158 tmp = ((OP(c) == BOUND ?
9041c2e3 1159 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1a4fad37 1160 LOAD_UTF8_CHARCLASS_ALNUM();
078c425b 1161 while (s + (uskip = UTF8SKIP(s)) <= strend) {
ffc61ed2 1162 if (tmp == !(OP(c) == BOUND ?
3568d838 1163 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
ffc61ed2
JH		 1164 isALNUM_LC_utf8((U8*)s)))
1165 {
1166 tmp = !tmp;
1167 if ((norun || regtry(prog, s)))
1168 goto got_it;
1169 }
078c425b 1170 s += uskip;
a687059c 1171 }
a0d0e21e 1172 }
667bb95a 1173 else {
12d33761 1174 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
ffc61ed2
JH		 1175 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1176 while (s < strend) {
1177 if (tmp ==
1178 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1179 tmp = !tmp;
1180 if ((norun || regtry(prog, s)))
1181 goto got_it;
1182 }
1183 s++;
a0ed51b3 1184 }
a0ed51b3 1185 }
6eb5f6b9 1186 if ((!prog->minlen && tmp) && (norun || regtry(prog, s)))
a0ed51b3
LW		 1187 goto got_it;
1188 break;
bbce6d69 1189 case NBOUNDL:
3280af22 1190 PL_reg_flags |= RF_tainted;
bbce6d69 1191 /* FALL THROUGH */
a0d0e21e 1192 case NBOUND:
ffc61ed2 1193 if (do_utf8) {
12d33761 1194 if (s == PL_bostr)
ffc61ed2
JH		 1195 tmp = '\n';
1196 else {
6136c704 1197 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
4ad0818d 1198 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
ffc61ed2
JH		 1199 }
1200 tmp = ((OP(c) == NBOUND ?
9041c2e3 1201 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1a4fad37 1202 LOAD_UTF8_CHARCLASS_ALNUM();
078c425b 1203 while (s + (uskip = UTF8SKIP(s)) <= strend) {
ffc61ed2 1204 if (tmp == !(OP(c) == NBOUND ?
3568d838 1205 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
ffc61ed2
JH		 1206 isALNUM_LC_utf8((U8*)s)))
1207 tmp = !tmp;
1208 else if ((norun || regtry(prog, s)))
1209 goto got_it;
078c425b 1210 s += uskip;
ffc61ed2 1211 }
a0d0e21e 1212 }
667bb95a 1213 else {
12d33761 1214 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
ffc61ed2
JH		 1215 tmp = ((OP(c) == NBOUND ?
1216 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1217 while (s < strend) {
1218 if (tmp ==
1219 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1220 tmp = !tmp;
1221 else if ((norun || regtry(prog, s)))
1222 goto got_it;
1223 s++;
1224 }
a0ed51b3 1225 }
6eb5f6b9 1226 if ((!prog->minlen && !tmp) && (norun || regtry(prog, s)))
a0ed51b3
LW		 1227 goto got_it;
1228 break;
a0d0e21e 1229 case ALNUM:
ffc61ed2 1230 if (do_utf8) {
1a4fad37 1231 LOAD_UTF8_CHARCLASS_ALNUM();
078c425b 1232 while (s + (uskip = UTF8SKIP(s)) <= strend) {
3568d838 1233 if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
ffc61ed2
JH		 1234 if (tmp && (norun || regtry(prog, s)))
1235 goto got_it;
1236 else
1237 tmp = doevery;
1238 }
bbce6d69 1239 else
ffc61ed2 1240 tmp = 1;
078c425b 1241 s += uskip;
bbce6d69 1242 }
bbce6d69 1243 }
ffc61ed2
JH		 1244 else {
1245 while (s < strend) {
1246 if (isALNUM(*s)) {
1247 if (tmp && (norun || regtry(prog, s)))
1248 goto got_it;
1249 else
1250 tmp = doevery;
1251 }
a0ed51b3 1252 else
ffc61ed2
JH		 1253 tmp = 1;
1254 s++;
a0ed51b3 1255 }
a0ed51b3
LW		 1256 }
1257 break;
bbce6d69 1258 case ALNUML:
3280af22 1259 PL_reg_flags |= RF_tainted;
ffc61ed2 1260 if (do_utf8) {
078c425b 1261 while (s + (uskip = UTF8SKIP(s)) <= strend) {
ffc61ed2
JH		 1262 if (isALNUM_LC_utf8((U8*)s)) {
1263 if (tmp && (norun || regtry(prog, s)))
1264 goto got_it;
1265 else
1266 tmp = doevery;
1267 }
a687059c 1268 else
ffc61ed2 1269 tmp = 1;
078c425b 1270 s += uskip;
a0d0e21e 1271 }
a0d0e21e 1272 }
ffc61ed2
JH		 1273 else {
1274 while (s < strend) {
1275 if (isALNUM_LC(*s)) {
1276 if (tmp && (norun || regtry(prog, s)))
1277 goto got_it;
1278 else
1279 tmp = doevery;
1280 }
a0ed51b3 1281 else
ffc61ed2
JH		 1282 tmp = 1;
1283 s++;
a0ed51b3 1284 }
a0ed51b3
LW		 1285 }
1286 break;
a0d0e21e 1287 case NALNUM:
ffc61ed2 1288 if (do_utf8) {
1a4fad37 1289 LOAD_UTF8_CHARCLASS_ALNUM();
078c425b 1290 while (s + (uskip = UTF8SKIP(s)) <= strend) {
3568d838 1291 if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
ffc61ed2
JH		 1292 if (tmp && (norun || regtry(prog, s)))
1293 goto got_it;
1294 else
1295 tmp = doevery;
1296 }
bbce6d69 1297 else
ffc61ed2 1298 tmp = 1;
078c425b 1299 s += uskip;
bbce6d69 1300 }
bbce6d69 1301 }
ffc61ed2
JH		 1302 else {
1303 while (s < strend) {
1304 if (!isALNUM(*s)) {
1305 if (tmp && (norun || regtry(prog, s)))
1306 goto got_it;
1307 else
1308 tmp = doevery;
1309 }
a0ed51b3 1310 else
ffc61ed2
JH		 1311 tmp = 1;
1312 s++;
a0ed51b3 1313 }
a0ed51b3
LW		 1314 }
1315 break;
bbce6d69 1316 case NALNUML:
3280af22 1317 PL_reg_flags |= RF_tainted;
ffc61ed2 1318 if (do_utf8) {
078c425b 1319 while (s + (uskip = UTF8SKIP(s)) <= strend) {
ffc61ed2
JH		 1320 if (!isALNUM_LC_utf8((U8*)s)) {
1321 if (tmp && (norun || regtry(prog, s)))
1322 goto got_it;
1323 else
1324 tmp = doevery;
1325 }
a687059c 1326 else
ffc61ed2 1327 tmp = 1;
078c425b 1328 s += uskip;
a687059c 1329 }
a0d0e21e 1330 }
ffc61ed2
JH		 1331 else {
1332 while (s < strend) {
1333 if (!isALNUM_LC(*s)) {
1334 if (tmp && (norun || regtry(prog, s)))
1335 goto got_it;
1336 else
1337 tmp = doevery;
1338 }
a0ed51b3 1339 else
ffc61ed2
JH		 1340 tmp = 1;
1341 s++;
a0ed51b3 1342 }
a0ed51b3
LW		 1343 }
1344 break;
a0d0e21e 1345 case SPACE:
ffc61ed2 1346 if (do_utf8) {
1a4fad37 1347 LOAD_UTF8_CHARCLASS_SPACE();
078c425b 1348 while (s + (uskip = UTF8SKIP(s)) <= strend) {
3568d838 1349 if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
ffc61ed2
JH		 1350 if (tmp && (norun || regtry(prog, s)))
1351 goto got_it;
1352 else
1353 tmp = doevery;
1354 }
a0d0e21e 1355 else
ffc61ed2 1356 tmp = 1;
078c425b 1357 s += uskip;
2304df62 1358 }
a0d0e21e 1359 }
ffc61ed2
JH		 1360 else {
1361 while (s < strend) {
1362 if (isSPACE(*s)) {
1363 if (tmp && (norun || regtry(prog, s)))
1364 goto got_it;
1365 else
1366 tmp = doevery;
1367 }
a0ed51b3 1368 else
ffc61ed2
JH		 1369 tmp = 1;
1370 s++;
a0ed51b3 1371 }
a0ed51b3
LW		 1372 }
1373 break;
bbce6d69 1374 case SPACEL:
3280af22 1375 PL_reg_flags |= RF_tainted;
ffc61ed2 1376 if (do_utf8) {
078c425b 1377 while (s + (uskip = UTF8SKIP(s)) <= strend) {
ffc61ed2
JH		 1378 if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1379 if (tmp && (norun || regtry(prog, s)))
1380 goto got_it;
1381 else
1382 tmp = doevery;
1383 }
bbce6d69 1384 else
ffc61ed2 1385 tmp = 1;
078c425b 1386 s += uskip;
bbce6d69 1387 }
bbce6d69 1388 }
ffc61ed2
JH		 1389 else {
1390 while (s < strend) {
1391 if (isSPACE_LC(*s)) {
1392 if (tmp && (norun || regtry(prog, s)))
1393 goto got_it;
1394 else
1395 tmp = doevery;
1396 }
a0ed51b3 1397 else
ffc61ed2
JH		 1398 tmp = 1;
1399 s++;
a0ed51b3 1400 }
a0ed51b3
LW		 1401 }
1402 break;
a0d0e21e 1403 case NSPACE:
ffc61ed2 1404 if (do_utf8) {
1a4fad37 1405 LOAD_UTF8_CHARCLASS_SPACE();
078c425b 1406 while (s + (uskip = UTF8SKIP(s)) <= strend) {
3568d838 1407 if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
ffc61ed2
JH		 1408 if (tmp && (norun || regtry(prog, s)))
1409 goto got_it;
1410 else
1411 tmp = doevery;
1412 }
a0d0e21e 1413 else
ffc61ed2 1414 tmp = 1;
078c425b 1415 s += uskip;
a687059c 1416 }
a0d0e21e 1417 }
ffc61ed2
JH		 1418 else {
1419 while (s < strend) {
1420 if (!isSPACE(*s)) {
1421 if (tmp && (norun || regtry(prog, s)))
1422 goto got_it;
1423 else
1424 tmp = doevery;
1425 }
a0ed51b3 1426 else
ffc61ed2
JH		 1427 tmp = 1;
1428 s++;
a0ed51b3 1429 }
a0ed51b3
LW		 1430 }
1431 break;
bbce6d69 1432 case NSPACEL:
3280af22 1433 PL_reg_flags |= RF_tainted;
ffc61ed2 1434 if (do_utf8) {
078c425b 1435 while (s + (uskip = UTF8SKIP(s)) <= strend) {
ffc61ed2
JH		 1436 if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1437 if (tmp && (norun || regtry(prog, s)))
1438 goto got_it;
1439 else
1440 tmp = doevery;
1441 }
bbce6d69 1442 else
ffc61ed2 1443 tmp = 1;
078c425b 1444 s += uskip;
bbce6d69 1445 }
bbce6d69 1446 }
ffc61ed2
JH		 1447 else {
1448 while (s < strend) {
1449 if (!isSPACE_LC(*s)) {
1450 if (tmp && (norun || regtry(prog, s)))
1451 goto got_it;
1452 else
1453 tmp = doevery;
1454 }
a0ed51b3 1455 else
ffc61ed2
JH		 1456 tmp = 1;
1457 s++;
a0ed51b3 1458 }
a0ed51b3
LW		 1459 }
1460 break;
a0d0e21e 1461 case DIGIT:
ffc61ed2 1462 if (do_utf8) {
1a4fad37 1463 LOAD_UTF8_CHARCLASS_DIGIT();
078c425b 1464 while (s + (uskip = UTF8SKIP(s)) <= strend) {
3568d838 1465 if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
ffc61ed2
JH		 1466 if (tmp && (norun || regtry(prog, s)))
1467 goto got_it;
1468 else
1469 tmp = doevery;
1470 }
a0d0e21e 1471 else
ffc61ed2 1472 tmp = 1;
078c425b 1473 s += uskip;
2b69d0c2 1474 }
a0d0e21e 1475 }
ffc61ed2
JH		 1476 else {
1477 while (s < strend) {
1478 if (isDIGIT(*s)) {
1479 if (tmp && (norun || regtry(prog, s)))
1480 goto got_it;
1481 else
1482 tmp = doevery;
1483 }
a0ed51b3 1484 else
ffc61ed2
JH		 1485 tmp = 1;
1486 s++;
a0ed51b3 1487 }
a0ed51b3
LW		 1488 }
1489 break;
b8c5462f
JH		 1490 case DIGITL:
1491 PL_reg_flags |= RF_tainted;
ffc61ed2 1492 if (do_utf8) {
078c425b 1493 while (s + (uskip = UTF8SKIP(s)) <= strend) {
ffc61ed2
JH		 1494 if (isDIGIT_LC_utf8((U8*)s)) {
1495 if (tmp && (norun || regtry(prog, s)))
1496 goto got_it;
1497 else
1498 tmp = doevery;
1499 }
b8c5462f 1500 else
ffc61ed2 1501 tmp = 1;
078c425b 1502 s += uskip;
b8c5462f 1503 }
b8c5462f 1504 }
ffc61ed2
JH		 1505 else {
1506 while (s < strend) {
1507 if (isDIGIT_LC(*s)) {
1508 if (tmp && (norun || regtry(prog, s)))
1509 goto got_it;
1510 else
1511 tmp = doevery;
1512 }
b8c5462f 1513 else
ffc61ed2
JH		 1514 tmp = 1;
1515 s++;
b8c5462f 1516 }
b8c5462f
JH		 1517 }
1518 break;
a0d0e21e 1519 case NDIGIT:
ffc61ed2 1520 if (do_utf8) {
1a4fad37 1521 LOAD_UTF8_CHARCLASS_DIGIT();
078c425b 1522 while (s + (uskip = UTF8SKIP(s)) <= strend) {
3568d838 1523 if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
ffc61ed2
JH		 1524 if (tmp && (norun || regtry(prog, s)))
1525 goto got_it;
1526 else
1527 tmp = doevery;
1528 }
a0d0e21e 1529 else
ffc61ed2 1530 tmp = 1;
078c425b 1531 s += uskip;
a687059c 1532 }
a0d0e21e 1533 }
ffc61ed2
JH		 1534 else {
1535 while (s < strend) {
1536 if (!isDIGIT(*s)) {
1537 if (tmp && (norun || regtry(prog, s)))
1538 goto got_it;
1539 else
1540 tmp = doevery;
1541 }
a0ed51b3 1542 else
ffc61ed2
JH		 1543 tmp = 1;
1544 s++;
a0ed51b3 1545 }
a0ed51b3
LW		 1546 }
1547 break;
b8c5462f
JH		 1548 case NDIGITL:
1549 PL_reg_flags |= RF_tainted;
ffc61ed2 1550 if (do_utf8) {
078c425b 1551 while (s + (uskip = UTF8SKIP(s)) <= strend) {
ffc61ed2
JH		 1552 if (!isDIGIT_LC_utf8((U8*)s)) {
1553 if (tmp && (norun || regtry(prog, s)))
1554 goto got_it;
1555 else
1556 tmp = doevery;
1557 }
b8c5462f 1558 else
ffc61ed2 1559 tmp = 1;
078c425b 1560 s += uskip;
b8c5462f 1561 }
a0ed51b3 1562 }
ffc61ed2
JH		 1563 else {
1564 while (s < strend) {
1565 if (!isDIGIT_LC(*s)) {
1566 if (tmp && (norun || regtry(prog, s)))
1567 goto got_it;
1568 else
1569 tmp = doevery;
1570 }
cf93c79d 1571 else
ffc61ed2
JH		 1572 tmp = 1;
1573 s++;
b8c5462f 1574 }
b8c5462f
JH		 1575 }
1576 break;
b3c9acc1 1577 default:
3c3eec57
GS		 1578 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1579 break;
d6a28714 1580 }
6eb5f6b9
JH		 1581 return 0;
1582 got_it:
1583 return s;
1584}
1585
1586/*
1587 - regexec_flags - match a regexp against a string
1588 */
1589I32
1590Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1591 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1592/* strend: pointer to null at end of string */
1593/* strbeg: real beginning of string */
1594/* minend: end of match must be >=minend after stringarg. */
1595/* data: May be used for some additional optimizations. */
1596/* nosave: For optimizations. */
1597{
97aff369 1598 dVAR;
6eb5f6b9
JH		 1599 register char *s;
1600 register regnode *c;
1601 register char *startpos = stringarg;
6eb5f6b9
JH		 1602 I32 minlen; /* must match at least this many chars */
1603 I32 dontbother = 0; /* how many characters not to try at end */
6eb5f6b9
JH		 1604 I32 end_shift = 0; /* Same for the end. */ /* CC */
1605 I32 scream_pos = -1; /* Internal iterator of scream. */
ccac19ea 1606 char *scream_olds = NULL;
6eb5f6b9 1607 SV* oreplsv = GvSV(PL_replgv);
1df70142 1608 const bool do_utf8 = DO_UTF8(sv);
a3b680e6 1609 const I32 multiline = prog->reganch & PMf_MULTILINE;
2a782b5b 1610#ifdef DEBUGGING
6136c704
AL		 1611 SV * const dsv0 = PERL_DEBUG_PAD_ZERO(0);
1612 SV * const dsv1 = PERL_DEBUG_PAD_ZERO(1);
2a782b5b 1613#endif
a3621e74
YO		 1614
1615 GET_RE_DEBUG_FLAGS_DECL;
1616
9d4ba2ae 1617 PERL_UNUSED_ARG(data);
6eb5f6b9
JH		 1618
1619 /* Be paranoid... */
1620 if (prog == NULL || startpos == NULL) {
1621 Perl_croak(aTHX_ "NULL regexp parameter");
1622 return 0;
1623 }
1624
bac06658
JH		 1625 PL_reg_re = prog;
1626#ifdef DEBUGGING
1627 PL_regnarrate = DEBUG_r_TEST;
1628#endif
1629
1630 RX_MATCH_UTF8_set(prog, do_utf8);
1631
6eb5f6b9 1632 minlen = prog->minlen;
61a36c01 1633 if (strend - startpos < minlen) {
a3621e74 1634 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
a72c7584
JH		 1635 "String too short [regexec_flags]...\n"));
1636 goto phooey;
1aa99e6b 1637 }
6eb5f6b9 1638
6eb5f6b9
JH		 1639 /* Check validity of program. */
1640 if (UCHARAT(prog->program) != REG_MAGIC) {
1641 Perl_croak(aTHX_ "corrupted regexp program");
1642 }
1643
1644 PL_reg_flags = 0;
1645 PL_reg_eval_set = 0;
1646 PL_reg_maxiter = 0;
1647
1648 if (prog->reganch & ROPT_UTF8)
1649 PL_reg_flags |= RF_utf8;
1650
1651 /* Mark beginning of line for ^ and lookbehind. */
1652 PL_regbol = startpos;
1653 PL_bostr = strbeg;
1654 PL_reg_sv = sv;
1655
1656 /* Mark end of line for $ (and such) */
1657 PL_regeol = strend;
1658
1659 /* see how far we have to get to not match where we matched before */
1660 PL_regtill = startpos+minend;
1661
6eb5f6b9
JH		 1662 /* If there is a "must appear" string, look for it. */
1663 s = startpos;
1664
1665 if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */
1666 MAGIC *mg;
1667
1668 if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
1669 PL_reg_ganch = startpos;
1670 else if (sv && SvTYPE(sv) >= SVt_PVMG
1671 && SvMAGIC(sv)
14befaf4
DM		 1672 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1673 && mg->mg_len >= 0) {
6eb5f6b9
JH		 1674 PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
1675 if (prog->reganch & ROPT_ANCH_GPOS) {
f33976b4 1676 if (s > PL_reg_ganch)
6eb5f6b9
JH		 1677 goto phooey;
1678 s = PL_reg_ganch;
1679 }
1680 }
1681 else /* pos() not defined */
1682 PL_reg_ganch = strbeg;
1683 }
1684
a0714e2c 1685 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
6eb5f6b9
JH		 1686 re_scream_pos_data d;
1687
1688 d.scream_olds = &scream_olds;
1689 d.scream_pos = &scream_pos;
1690 s = re_intuit_start(prog, sv, s, strend, flags, &d);
3fa9c3d7 1691 if (!s) {
a3621e74 1692 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
6eb5f6b9 1693 goto phooey; /* not present */
3fa9c3d7 1694 }
6eb5f6b9
JH		 1695 }
1696
a3621e74 1697 DEBUG_EXECUTE_r({
1df70142
AL		 1698 const char * const s0 = UTF
1699 ? pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
1700 UNI_DISPLAY_REGEX)
1701 : prog->precomp;
1702 const int len0 = UTF ? SvCUR(dsv0) : prog->prelen;
1703 const char * const s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60,
c728cb41 1704 UNI_DISPLAY_REGEX) : startpos;
1df70142 1705 const int len1 = do_utf8 ? SvCUR(dsv1) : strend - startpos;
2a782b5b
JH		 1706 if (!PL_colorset)
1707 reginitcolors();
1708 PerlIO_printf(Perl_debug_log,
a0288114 1709 "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n",
e4584336 1710 PL_colors[4], PL_colors[5], PL_colors[0],
9e55ce06 1711 len0, len0, s0,
2a782b5b 1712 PL_colors[1],
9e55ce06 1713 len0 > 60 ? "..." : "",
2a782b5b 1714 PL_colors[0],
9e55ce06
JH		 1715 (int)(len1 > 60 ? 60 : len1),
1716 s1, PL_colors[1],
1717 (len1 > 60 ? "..." : "")
2a782b5b
JH		 1718 );
1719 });
6eb5f6b9
JH		 1720
1721 /* Simplest case: anchored match need be tried only once. */
1722 /* [unless only anchor is BOL and multiline is set] */
1723 if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1724 if (s == startpos && regtry(prog, startpos))
1725 goto got_it;
7fba1cd6 1726 else if (multiline || (prog->reganch & ROPT_IMPLICIT)
6eb5f6b9
JH		 1727 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1728 {
1729 char *end;
1730
1731 if (minlen)
1732 dontbother = minlen - 1;
1aa99e6b 1733 end = HOP3c(strend, -dontbother, strbeg) - 1;
6eb5f6b9 1734 /* for multiline we only have to try after newlines */
33b8afdf 1735 if (prog->check_substr || prog->check_utf8) {
6eb5f6b9
JH		 1736 if (s == startpos)
1737 goto after_try;
1738 while (1) {
1739 if (regtry(prog, s))
1740 goto got_it;
1741 after_try:
1742 if (s >= end)
1743 goto phooey;
1744 if (prog->reganch & RE_USE_INTUIT) {
1745 s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1746 if (!s)
1747 goto phooey;
1748 }
1749 else
1750 s++;
1751 }
1752 } else {
1753 if (s > startpos)
1754 s--;
1755 while (s < end) {
1756 if (*s++ == '\n') { /* don't need PL_utf8skip here */
1757 if (regtry(prog, s))
1758 goto got_it;
1759 }
1760 }
1761 }
1762 }
1763 goto phooey;
1764 } else if (prog->reganch & ROPT_ANCH_GPOS) {
1765 if (regtry(prog, PL_reg_ganch))
1766 goto got_it;
1767 goto phooey;
1768 }
1769
1770 /* Messy cases: unanchored match. */
33b8afdf 1771 if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
6eb5f6b9
JH		 1772 /* we have /x+whatever/ */
1773 /* it must be a one character string (XXXX Except UTF?) */
33b8afdf 1774 char ch;
bf93d4cc
GS		 1775#ifdef DEBUGGING
1776 int did_match = 0;
1777#endif
33b8afdf
JH		 1778 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1779 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
3f7c398e 1780 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
bf93d4cc 1781
1aa99e6b 1782 if (do_utf8) {
6eb5f6b9
JH		 1783 while (s < strend) {
1784 if (*s == ch) {
a3621e74 1785 DEBUG_EXECUTE_r( did_match = 1 );
6eb5f6b9
JH		 1786 if (regtry(prog, s)) goto got_it;
1787 s += UTF8SKIP(s);
1788 while (s < strend && *s == ch)
1789 s += UTF8SKIP(s);
1790 }
1791 s += UTF8SKIP(s);
1792 }
1793 }
1794 else {
1795 while (s < strend) {
1796 if (*s == ch) {
a3621e74 1797 DEBUG_EXECUTE_r( did_match = 1 );
6eb5f6b9
JH		 1798 if (regtry(prog, s)) goto got_it;
1799 s++;
1800 while (s < strend && *s == ch)
1801 s++;
1802 }
1803 s++;
1804 }
1805 }
a3621e74 1806 DEBUG_EXECUTE_r(if (!did_match)
bf93d4cc 1807 PerlIO_printf(Perl_debug_log,
b7953727
JH		 1808 "Did not find anchored character...\n")
1809 );
6eb5f6b9 1810 }
a0714e2c
SS		 1811 else if (prog->anchored_substr != NULL
1812 || prog->anchored_utf8 != NULL
1813 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
33b8afdf
JH		 1814 && prog->float_max_offset < strend - s)) {
1815 SV *must;
1816 I32 back_max;
1817 I32 back_min;
1818 char *last;
6eb5f6b9 1819 char *last1; /* Last position checked before */
bf93d4cc
GS		 1820#ifdef DEBUGGING
1821 int did_match = 0;
1822#endif
33b8afdf
JH		 1823 if (prog->anchored_substr || prog->anchored_utf8) {
1824 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1825 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1826 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1827 back_max = back_min = prog->anchored_offset;
1828 } else {
1829 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1830 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1831 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1832 back_max = prog->float_max_offset;
1833 back_min = prog->float_min_offset;
1834 }
1835 if (must == &PL_sv_undef)
1836 /* could not downgrade utf8 check substring, so must fail */
1837 goto phooey;
1838
1839 last = HOP3c(strend, /* Cannot start after this */
1840 -(I32)(CHR_SVLEN(must)
1841 - (SvTAIL(must) != 0) + back_min), strbeg);
6eb5f6b9
JH		 1842
1843 if (s > PL_bostr)
1844 last1 = HOPc(s, -1);
1845 else
1846 last1 = s - 1; /* bogus */
1847
a0288114 1848 /* XXXX check_substr already used to find "s", can optimize if
6eb5f6b9
JH		 1849 check_substr==must. */
1850 scream_pos = -1;
1851 dontbother = end_shift;
1852 strend = HOPc(strend, -dontbother);
1853 while ( (s <= last) &&
9041c2e3 1854 ((flags & REXEC_SCREAM)
1aa99e6b 1855 ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
6eb5f6b9 1856 end_shift, &scream_pos, 0))
1aa99e6b 1857 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
9041c2e3 1858 (unsigned char*)strend, must,
7fba1cd6 1859 multiline ? FBMrf_MULTILINE : 0))) ) {
4addbd3b
HS		 1860 /* we may be pointing at the wrong string */
1861 if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
3f7c398e 1862 s = strbeg + (s - SvPVX_const(sv));
a3621e74 1863 DEBUG_EXECUTE_r( did_match = 1 );
6eb5f6b9
JH		 1864 if (HOPc(s, -back_max) > last1) {
1865 last1 = HOPc(s, -back_min);
1866 s = HOPc(s, -back_max);
1867 }
1868 else {
52657f30 1869 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
6eb5f6b9
JH		 1870
1871 last1 = HOPc(s, -back_min);
52657f30 1872 s = t;
6eb5f6b9 1873 }
1aa99e6b 1874 if (do_utf8) {
6eb5f6b9
JH		 1875 while (s <= last1) {
1876 if (regtry(prog, s))
1877 goto got_it;
1878 s += UTF8SKIP(s);
1879 }
1880 }
1881 else {
1882 while (s <= last1) {
1883 if (regtry(prog, s))
1884 goto got_it;
1885 s++;
1886 }
1887 }
1888 }
a3621e74 1889 DEBUG_EXECUTE_r(if (!did_match)
b7953727 1890 PerlIO_printf(Perl_debug_log,
a0288114 1891 "Did not find %s substr \"%s%.*s%s\"%s...\n",
33b8afdf 1892 ((must == prog->anchored_substr || must == prog->anchored_utf8)
bf93d4cc
GS		 1893 ? "anchored" : "floating"),
1894 PL_colors[0],
1895 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
3f7c398e 1896 SvPVX_const(must),
b7953727
JH		 1897 PL_colors[1], (SvTAIL(must) ? "$" : ""))
1898 );
6eb5f6b9
JH		 1899 goto phooey;
1900 }
155aba94 1901 else if ((c = prog->regstclass)) {
f14c76ed
RGS		 1902 if (minlen) {
1903 I32 op = (U8)OP(prog->regstclass);
66e933ab 1904 /* don't bother with what can't match */
f14c76ed
RGS		 1905 if (PL_regkind[op] != EXACT && op != CANY)
1906 strend = HOPc(strend, -(minlen - 1));
1907 }
a3621e74 1908 DEBUG_EXECUTE_r({
ffc61ed2 1909 SV *prop = sv_newmortal();
cfd0369c
NC		 1910 const char *s0;
1911 const char *s1;
9e55ce06
JH		 1912 int len0;
1913 int len1;
1914
ffc61ed2 1915 regprop(prop, c);
9e55ce06 1916 s0 = UTF ?
3f7c398e 1917 pv_uni_display(dsv0, (U8*)SvPVX_const(prop), SvCUR(prop), 60,
c728cb41 1918 UNI_DISPLAY_REGEX) :
cfd0369c 1919 SvPVX_const(prop);
9e55ce06
JH		 1920 len0 = UTF ? SvCUR(dsv0) : SvCUR(prop);
1921 s1 = UTF ?
c728cb41 1922 sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
9e55ce06
JH		 1923 len1 = UTF ? SvCUR(dsv1) : strend - s;
1924 PerlIO_printf(Perl_debug_log,
a0288114 1925 "Matching stclass \"%*.*s\" against \"%*.*s\"\n",
9e55ce06
JH		 1926 len0, len0, s0,
1927 len1, len1, s1);
ffc61ed2 1928 });
06b5626a 1929 if (find_byclass(prog, c, s, strend, 0))
6eb5f6b9 1930 goto got_it;
a3621e74 1931 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
d6a28714
JH		 1932 }
1933 else {
1934 dontbother = 0;
a0714e2c 1935 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
33b8afdf 1936 /* Trim the end. */
d6a28714 1937 char *last;
33b8afdf
JH		 1938 SV* float_real;
1939
1940 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1941 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1942 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
d6a28714
JH		 1943
1944 if (flags & REXEC_SCREAM) {
33b8afdf 1945 last = screaminstr(sv, float_real, s - strbeg,
d6a28714
JH		 1946 end_shift, &scream_pos, 1); /* last one */
1947 if (!last)
ffc61ed2 1948 last = scream_olds; /* Only one occurrence. */
4addbd3b
HS		 1949 /* we may be pointing at the wrong string */
1950 else if (RX_MATCH_COPIED(prog))
3f7c398e 1951 s = strbeg + (s - SvPVX_const(sv));
b8c5462f 1952 }
d6a28714
JH		 1953 else {
1954 STRLEN len;
cfd0369c 1955 const char * const little = SvPV_const(float_real, len);
d6a28714 1956
33b8afdf 1957 if (SvTAIL(float_real)) {
d6a28714
JH		 1958 if (memEQ(strend - len + 1, little, len - 1))
1959 last = strend - len + 1;
7fba1cd6 1960 else if (!multiline)
9041c2e3 1961 last = memEQ(strend - len, little, len)
bd61b366 1962 ? strend - len : NULL;
b8c5462f 1963 else
d6a28714
JH		 1964 goto find_last;
1965 } else {
1966 find_last:
9041c2e3 1967 if (len)
d6a28714 1968 last = rninstr(s, strend, little, little + len);
b8c5462f 1969 else
a0288114 1970 last = strend; /* matching "$" */
b8c5462f 1971 }
b8c5462f 1972 }
bf93d4cc 1973 if (last == NULL) {
a3621e74 1974 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
bf93d4cc 1975 "%sCan't trim the tail, match fails (should not happen)%s\n",
e4584336 1976 PL_colors[4], PL_colors[5]));
bf93d4cc
GS		 1977 goto phooey; /* Should not happen! */
1978 }
d6a28714
JH		 1979 dontbother = strend - last + prog->float_min_offset;
1980 }
1981 if (minlen && (dontbother < minlen))
1982 dontbother = minlen - 1;
1983 strend -= dontbother; /* this one's always in bytes! */
1984 /* We don't know much -- general case. */
1aa99e6b 1985 if (do_utf8) {
d6a28714
JH		 1986 for (;;) {
1987 if (regtry(prog, s))
1988 goto got_it;
1989 if (s >= strend)
1990 break;
b8c5462f 1991 s += UTF8SKIP(s);
d6a28714
JH		 1992 };
1993 }
1994 else {
1995 do {
1996 if (regtry(prog, s))
1997 goto got_it;
1998 } while (s++ < strend);
1999 }
2000 }
2001
2002 /* Failure. */
2003 goto phooey;
2004
2005got_it:
2006 RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2007
2008 if (PL_reg_eval_set) {
2009 /* Preserve the current value of $^R */
2010 if (oreplsv != GvSV(PL_replgv))
2011 sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2012 restored, the value remains
2013 the same. */
4f639d21 2014 restore_pos(aTHX_ prog);
d6a28714
JH		 2015 }
2016
2017 /* make sure $`, $&, $', and $digit will work later */
2018 if ( !(flags & REXEC_NOT_FIRST) ) {
ed252734 2019 RX_MATCH_COPY_FREE(prog);
d6a28714
JH		 2020 if (flags & REXEC_COPY_STR) {
2021 I32 i = PL_regeol - startpos + (stringarg - strbeg);
f8c7b90f 2022#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2023 if ((SvIsCOW(sv)
2024 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2025 if (DEBUG_C_TEST) {
2026 PerlIO_printf(Perl_debug_log,
2027 "Copy on write: regexp capture, type %d\n",
2028 (int) SvTYPE(sv));
2029 }
2030 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
d5263905 2031 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
ed252734
NC		 2032 assert (SvPOKp(prog->saved_copy));
2033 } else
2034#endif
2035 {
2036 RX_MATCH_COPIED_on(prog);
2037 s = savepvn(strbeg, i);
2038 prog->subbeg = s;
2039 }
d6a28714 2040 prog->sublen = i;
d6a28714
JH		 2041 }
2042 else {
2043 prog->subbeg = strbeg;
2044 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2045 }
2046 }
9041c2e3 2047
d6a28714
JH		 2048 return 1;
2049
2050phooey:
a3621e74 2051 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
e4584336 2052 PL_colors[4], PL_colors[5]));
d6a28714 2053 if (PL_reg_eval_set)
4f639d21 2054 restore_pos(aTHX_ prog);
d6a28714
JH		 2055 return 0;
2056}
2057
2058/*
2059 - regtry - try match at specific point
2060 */
2061STATIC I32 /* 0 failure, 1 success */
2062S_regtry(pTHX_ regexp *prog, char *startpos)
2063{
97aff369 2064 dVAR;
d6a28714
JH		 2065 register I32 *sp;
2066 register I32 *ep;
2067 CHECKPOINT lastcp;
a3621e74 2068 GET_RE_DEBUG_FLAGS_DECL;
d6a28714 2069
02db2b7b
IZ		 2070#ifdef DEBUGGING
2071 PL_regindent = 0; /* XXXX Not good when matches are reenterable... */
2072#endif
d6a28714
JH		 2073 if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2074 MAGIC *mg;
2075
2076 PL_reg_eval_set = RS_init;
a3621e74 2077 DEBUG_EXECUTE_r(DEBUG_s(
b900a521
JH		 2078 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2079 (IV)(PL_stack_sp - PL_stack_base));
d6a28714 2080 ));
e8347627 2081 SAVEI32(cxstack[cxstack_ix].blk_oldsp);
d6a28714
JH		 2082 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2083 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2084 SAVETMPS;
2085 /* Apparently this is not needed, judging by wantarray. */
e8347627 2086 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
d6a28714
JH		 2087 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2088
2089 if (PL_reg_sv) {
2090 /* Make $_ available to executed code. */
2091 if (PL_reg_sv != DEFSV) {
59f00321 2092 SAVE_DEFSV;
d6a28714 2093 DEFSV = PL_reg_sv;
b8c5462f 2094 }
d6a28714 2095
9041c2e3 2096 if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
14befaf4 2097 && (mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global)))) {
d6a28714 2098 /* prepare for quick setting of pos */
d300d9fa
NC		 2099#ifdef PERL_OLD_COPY_ON_WRITE
2100 if (SvIsCOW(sv))
2101 sv_force_normal_flags(sv, 0);
2102#endif
2103 mg = sv_magicext(PL_reg_sv, (SV*)0, PERL_MAGIC_regex_global,
2104 &PL_vtbl_mglob, NULL, 0);
d6a28714 2105 mg->mg_len = -1;
b8c5462f 2106 }
d6a28714
JH		 2107 PL_reg_magic = mg;
2108 PL_reg_oldpos = mg->mg_len;
4f639d21 2109 SAVEDESTRUCTOR_X(restore_pos, prog);
d6a28714 2110 }
09687e5a 2111 if (!PL_reg_curpm) {
a02a5408 2112 Newxz(PL_reg_curpm, 1, PMOP);
09687e5a
AB		 2113#ifdef USE_ITHREADS
2114 {
2115 SV* repointer = newSViv(0);
577e12cc 2116 /* so we know which PL_regex_padav element is PL_reg_curpm */
35061a7e 2117 SvFLAGS(repointer) |= SVf_BREAK;
09687e5a
AB		 2118 av_push(PL_regex_padav,repointer);
2119 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2120 PL_regex_pad = AvARRAY(PL_regex_padav);
2121 }
2122#endif
2123 }
aaa362c4 2124 PM_SETRE(PL_reg_curpm, prog);
d6a28714
JH		 2125 PL_reg_oldcurpm = PL_curpm;
2126 PL_curpm = PL_reg_curpm;
2127 if (RX_MATCH_COPIED(prog)) {
2128 /* Here is a serious problem: we cannot rewrite subbeg,
2129 since it may be needed if this match fails. Thus
2130 $` inside (?{}) could fail... */
2131 PL_reg_oldsaved = prog->subbeg;
2132 PL_reg_oldsavedlen = prog->sublen;
f8c7b90f 2133#ifdef PERL_OLD_COPY_ON_WRITE
ed252734
NC		 2134 PL_nrs = prog->saved_copy;
2135#endif
d6a28714
JH		 2136 RX_MATCH_COPIED_off(prog);
2137 }
2138 else
bd61b366 2139 PL_reg_oldsaved = NULL;
d6a28714
JH		 2140 prog->subbeg = PL_bostr;
2141 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2142 }
973dddac 2143 prog->startp[0] = startpos - PL_bostr;
d6a28714
JH		 2144 PL_reginput = startpos;
2145 PL_regstartp = prog->startp;
2146 PL_regendp = prog->endp;
2147 PL_reglastparen = &prog->lastparen;
a01268b5 2148 PL_reglastcloseparen = &prog->lastcloseparen;
d6a28714 2149 prog->lastparen = 0;
03994de8 2150 prog->lastcloseparen = 0;
d6a28714 2151 PL_regsize = 0;
a3621e74 2152 DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
d6a28714
JH		 2153 if (PL_reg_start_tmpl <= prog->nparens) {
2154 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2155 if(PL_reg_start_tmp)
2156 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2157 else
a02a5408 2158 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
d6a28714
JH		 2159 }
2160
2161 /* XXXX What this code is doing here?!!! There should be no need
2162 to do this again and again, PL_reglastparen should take care of
3dd2943c 2163 this! --ilya*/
dafc8851
JH		 2164
2165 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2166 * Actually, the code in regcppop() (which Ilya may be meaning by
daf18116
JH		 2167 * PL_reglastparen), is not needed at all by the test suite
2168 * (op/regexp, op/pat, op/split), but that code is needed, oddly
2169 * enough, for building DynaLoader, or otherwise this
2170 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2171 * will happen. Meanwhile, this code *is* needed for the
2172 * above-mentioned test suite tests to succeed. The common theme
2173 * on those tests seems to be returning null fields from matches.
2174 * --jhi */
dafc8851 2175#if 1
d6a28714
JH		 2176 sp = prog->startp;
2177 ep = prog->endp;
2178 if (prog->nparens) {
097eb12c 2179 register I32 i;
eb160463 2180 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
d6a28714
JH		 2181 *++sp = -1;
2182 *++ep = -1;
2183 }
2184 }
dafc8851 2185#endif
02db2b7b 2186 REGCP_SET(lastcp);
4f639d21 2187 if (regmatch(prog, prog->program + 1)) {
d6a28714
JH		 2188 prog->endp[0] = PL_reginput - PL_bostr;
2189 return 1;
2190 }
02db2b7b 2191 REGCP_UNWIND(lastcp);
d6a28714
JH		 2192 return 0;
2193}
2194
02db2b7b
IZ		 2195#define RE_UNWIND_BRANCH 1
2196#define RE_UNWIND_BRANCHJ 2
2197
2198union re_unwind_t;
2199
2200typedef struct { /* XX: makes sense to enlarge it... */
2201 I32 type;
2202 I32 prev;
2203 CHECKPOINT lastcp;
2204} re_unwind_generic_t;
2205
2206typedef struct {
2207 I32 type;
2208 I32 prev;
2209 CHECKPOINT lastcp;
2210 I32 lastparen;
2211 regnode *next;
2212 char *locinput;
2213 I32 nextchr;
3a2830be 2214 int minmod;
02db2b7b
IZ		 2215#ifdef DEBUGGING
2216 int regindent;
2217#endif
2218} re_unwind_branch_t;
2219
2220typedef union re_unwind_t {
2221 I32 type;
2222 re_unwind_generic_t generic;
2223 re_unwind_branch_t branch;
2224} re_unwind_t;
2225
8ba1375e
MJD		 2226#define sayYES goto yes
2227#define sayNO goto no
e0f9d4a8 2228#define sayNO_ANYOF goto no_anyof
8ba1375e
MJD		 2229#define sayYES_FINAL goto yes_final
2230#define sayYES_LOUD goto yes_loud
2231#define sayNO_FINAL goto no_final
2232#define sayNO_SILENT goto do_no
2233#define saySAME(x) if (x) goto yes; else goto no
2234
3ab3c9b4
HS		 2235#define POSCACHE_SUCCESS 0 /* caching success rather than failure */
2236#define POSCACHE_SEEN 1 /* we know what we're caching */
2237#define POSCACHE_START 2 /* the real cache: this bit maps to pos 0 */
2238#define CACHEsayYES STMT_START { \
d8319b27 2239 if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
3ab3c9b4
HS		 2240 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) \
2241 PL_reg_poscache[0] |= (1<<POSCACHE_SUCCESS) || (1<<POSCACHE_SEEN); \
2242 else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2243 /* cache records failure, but this is success */ \
2244 DEBUG_r( \
2245 PerlIO_printf(Perl_debug_log, \
2246 "%*s (remove success from failure cache)\n", \
2247 REPORT_CODE_OFF+PL_regindent*2, "") \
2248 ); \
d8319b27 2249 PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
3ab3c9b4
HS		 2250 } \
2251 } \
2252 sayYES; \
2253} STMT_END
2254#define CACHEsayNO STMT_START { \
d8319b27 2255 if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
3ab3c9b4
HS		 2256 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) \
2257 PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2258 else if ((PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2259 /* cache records success, but this is failure */ \
2260 DEBUG_r( \
2261 PerlIO_printf(Perl_debug_log, \
2262 "%*s (remove failure from success cache)\n", \
2263 REPORT_CODE_OFF+PL_regindent*2, "") \
2264 ); \
d8319b27 2265 PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
3ab3c9b4
HS		 2266 } \
2267 } \
2268 sayNO; \
2269} STMT_END
2270
a3621e74
YO		 2271/* this is used to determine how far from the left messages like
2272 'failed...' are printed. Currently 29 makes these messages line
2273 up with the opcode they refer to. Earlier perls used 25 which
2274 left these messages outdented making reviewing a debug output
2275 quite difficult.
2276*/
2277#define REPORT_CODE_OFF 29
2278
2279
2280/* Make sure there is a test for this +1 options in re_tests */
2281#define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2282
5d9a96ca
DM		 2283/* grab a new slab and return the first slot in it */
2284
2285STATIC regmatch_state *
2286S_push_slab(pTHX)
2287{
2288 regmatch_slab *s = PL_regmatch_slab->next;
2289 if (!s) {
2290 Newx(s, 1, regmatch_slab);
2291 s->prev = PL_regmatch_slab;
2292 s->next = NULL;
2293 PL_regmatch_slab->next = s;
2294 }
2295 PL_regmatch_slab = s;
2296 return &s->states[0];
2297}
5b47454d 2298
95b24440
DM		 2299/* simulate a recursive call to regmatch */
2300
2301#define REGMATCH(ns, where) \
5d9a96ca
DM		 2302 st->scan = scan; \
2303 scan = (ns); \
2304 st->resume_state = resume_##where; \
95b24440
DM		 2305 goto start_recurse; \
2306 resume_point_##where:
2307
aa283a38
DM		 2308
2309/* push a new regex state. Set newst to point to it */
2310
2311#define PUSH_STATE(newst, resume) \
2312 depth++; \
2313 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "PUSH STATE(%d)\n", depth)); \
2314 st->scan = scan; \
2315 st->next = next; \
2316 st->n = n; \
2317 st->locinput = locinput; \
2318 st->resume_state = resume; \
2319 newst = st+1; \
2320 if (newst > &(PL_regmatch_slab->states[PERL_REGMATCH_SLAB_SLOTS-1])) \
2321 newst = S_push_slab(aTHX); \
2322 PL_regmatch_state = newst; \
2323 newst->cc = 0; \
2324 newst->minmod = 0; \
2325 newst->sw = 0; \
2326 newst->logical = 0; \
2327 newst->unwind = 0; \
2328 locinput = PL_reginput; \
2329 nextchr = UCHARAT(locinput);
2330
2331#define POP_STATE \
2332 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth)); \
2333 depth--; \
2334 st--; \
2335 if (st < &PL_regmatch_slab->states[0]) { \
2336 PL_regmatch_slab = PL_regmatch_slab->prev; \
2337 st = &PL_regmatch_slab->states[PERL_REGMATCH_SLAB_SLOTS-1]; \
2338 } \
2339 PL_regmatch_state = st; \
2340 scan = st->scan; \
2341 next = st->next; \
2342 n = st->n; \
2343 locinput = st->locinput; \
2344 nextchr = UCHARAT(locinput);
2345
d6a28714
JH		 2346/*
2347 - regmatch - main matching routine
2348 *
2349 * Conceptually the strategy is simple: check to see whether the current
2350 * node matches, call self recursively to see whether the rest matches,
2351 * and then act accordingly. In practice we make some effort to avoid
2352 * recursion, in particular by going through "ordinary" nodes (that don't
2353 * need to know whether the rest of the match failed) by a loop instead of
2354 * by recursion.
2355 */
2356/* [lwall] I've hoisted the register declarations to the outer block in order to
2357 * maybe save a little bit of pushing and popping on the stack. It also takes
2358 * advantage of machines that use a register save mask on subroutine entry.
95b24440
DM		 2359 *
2360 * This function used to be heavily recursive, but since this had the
2361 * effect of blowing the CPU stack on complex regexes, it has been
2362 * restructured to be iterative, and to save state onto the heap rather
2363 * than the stack. Essentially whereever regmatch() used to be called, it
2364 * pushes the current state, notes where to return, then jumps back into
2365 * the main loop.
2366 *
2367 * Originally the structure of this function used to look something like
2368
2369 S_regmatch() {
2370 int a = 1, b = 2;
2371 ...
2372 while (scan != NULL) {
5d9a96ca 2373 a++; // do stuff with a and b
95b24440
DM		 2374 ...
2375 switch (OP(scan)) {
2376 case FOO: {
2377 int local = 3;
2378 ...
2379 if (regmatch(...)) // recurse
2380 goto yes;
2381 }
2382 ...
2383 }
2384 }
2385 yes:
2386 return 1;
2387 }
2388
2389 * Now it looks something like this:
2390
5d9a96ca 2391 typedef struct {
95b24440
DM		 2392 int a, b, local;
2393 int resume_state;
5d9a96ca 2394 } regmatch_state;
95b24440
DM		 2395
2396 S_regmatch() {
5d9a96ca
DM		 2397 regmatch_state *st = new();
2398 int depth=0;
2399 st->a++; // do stuff with a and b
95b24440
DM		 2400 ...
2401 while (scan != NULL) {
2402 ...
2403 switch (OP(scan)) {
2404 case FOO: {
5d9a96ca 2405 st->local = 3;
95b24440 2406 ...
5d9a96ca
DM		 2407 st->scan = scan;
2408 scan = ...;
2409 st->resume_state = resume_FOO;
2410 goto start_recurse; // recurse
95b24440 2411
5d9a96ca
DM		 2412 resume_point_FOO:
2413 if (result)
95b24440
DM		 2414 goto yes;
2415 }
2416 ...
2417 }
5d9a96ca
DM		 2418 start_recurse:
2419 st = new(); push a new state
2420 st->a = 1; st->b = 2;
2421 depth++;
95b24440 2422 }
5d9a96ca 2423 yes:
95b24440 2424 result = 1;
5d9a96ca
DM		 2425 if (depth--) {
2426 st = pop();
95b24440
DM		 2427 switch (resume_state) {
2428 case resume_FOO:
2429 goto resume_point_FOO;
2430 ...
2431 }
2432 }
2433 return result
2434 }
2435
2436 * WARNING: this means that any line in this function that contains a
2437 * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2438 * regmatch() using gotos instead. Thus the values of any local variables
2439 * not saved in the regmatch_state structure will have been lost when
2440 * execution resumes on the next line .
5d9a96ca
DM		 2441 *
2442 * States (ie the st pointer) are allocated in slabs of about 4K in size.
2443 * PL_regmatch_state always points to the currently active state, and
2444 * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2445 * The first time regmatch is called, the first slab is allocated, and is
2446 * never freed until interpreter desctruction. When the slab is full,
2447 * a new one is allocated chained to the end. At exit from regmatch, slabs
2448 * allocated since entry are freed.
d6a28714 2449 */
95b24440
DM		 2450
2451
d6a28714 2452STATIC I32 /* 0 failure, 1 success */
4f639d21 2453S_regmatch(pTHX_ regexp *rex, regnode *prog)
d6a28714 2454{
27da23d5 2455 dVAR;
95b24440 2456 register const bool do_utf8 = PL_reg_match_utf8;
4ad0818d 2457 const U32 uniflags = UTF8_ALLOW_DEFAULT;
95b24440 2458
5d9a96ca
DM		 2459 regmatch_slab *orig_slab;
2460 regmatch_state *orig_state;
a3621e74 2461
5d9a96ca
DM		 2462 /* the current state. This is a cached copy of PL_regmatch_state */
2463 register regmatch_state *st;
95b24440 2464
5d9a96ca
DM		 2465 /* cache heavy used fields of st in registers */
2466 register regnode *scan;
2467 register regnode *next;
2468 register I32 n = 0; /* initialize to shut up compiler warning */
2469 register char *locinput = PL_reginput;
95b24440 2470
5d9a96ca
DM		 2471 /* these variables are NOT saved during a recusive RFEGMATCH: */
2472 register I32 nextchr; /* is always set to UCHARAT(locinput) */
2473 bool result; /* return value of S_regmatch */
2474 regnode *inner; /* Next node in internal branch. */
2475 int depth = 0; /* depth of recursion */
aa283a38
DM		 2476 regmatch_state *newst; /* when pushing a state, this is the new one */
2477 regmatch_state *cur_eval = NULL; /* most recent (??{}) state */
95b24440
DM		 2478
2479#ifdef DEBUGGING
ab74612d 2480 SV *re_debug_flags = NULL;
a3621e74 2481 GET_RE_DEBUG_FLAGS;
d6a28714
JH		 2482 PL_regindent++;
2483#endif
2484
5d9a96ca
DM		 2485 /* on first ever call to regmatch, allocate first slab */
2486 if (!PL_regmatch_slab) {
2487 Newx(PL_regmatch_slab, 1, regmatch_slab);
2488 PL_regmatch_slab->prev = NULL;
2489 PL_regmatch_slab->next = NULL;
2490 PL_regmatch_state = &PL_regmatch_slab->states[0] - 1;
2491 }
2492
2493 /* remember current high-water mark for exit */
2494 /* XXX this should be done with SAVE* instead */
2495 orig_slab = PL_regmatch_slab;
2496 orig_state = PL_regmatch_state;
2497
2498 /* grab next free state slot */
2499 st = ++PL_regmatch_state;
2500 if (st > &(PL_regmatch_slab->states[PERL_REGMATCH_SLAB_SLOTS-1]))
2501 st = PL_regmatch_state = S_push_slab(aTHX);
2502
2503 st->minmod = 0;
2504 st->sw = 0;
2505 st->logical = 0;
2506 st->unwind = 0;
2507 st->cc = NULL;
d6a28714
JH		 2508 /* Note that nextchr is a byte even in UTF */
2509 nextchr = UCHARAT(locinput);
2510 scan = prog;
2511 while (scan != NULL) {
8ba1375e 2512
a3621e74 2513 DEBUG_EXECUTE_r( {
6136c704 2514 SV * const prop = sv_newmortal();
1df70142
AL		 2515 const int docolor = *PL_colors[0];
2516 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
1aa99e6b 2517 int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
d6a28714
JH		 2518 /* The part of the string before starttry has one color
2519 (pref0_len chars), between starttry and current
2520 position another one (pref_len - pref0_len chars),
2521 after the current position the third one.
2522 We assume that pref0_len <= pref_len, otherwise we
2523 decrease pref0_len. */
9041c2e3 2524 int pref_len = (locinput - PL_bostr) > (5 + taill) - l
1aa99e6b
IH		 2525 ? (5 + taill) - l : locinput - PL_bostr;
2526 int pref0_len;
d6a28714 2527
df1ffd02 2528 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
1aa99e6b
IH		 2529 pref_len++;
2530 pref0_len = pref_len - (locinput - PL_reg_starttry);
d6a28714 2531 if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
9041c2e3 2532 l = ( PL_regeol - locinput > (5 + taill) - pref_len
d6a28714 2533 ? (5 + taill) - pref_len : PL_regeol - locinput);
df1ffd02 2534 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
1aa99e6b 2535 l--;
d6a28714
JH		 2536 if (pref0_len < 0)
2537 pref0_len = 0;
2538 if (pref0_len > pref_len)
2539 pref0_len = pref_len;
2540 regprop(prop, scan);
2a782b5b 2541 {
1df70142 2542 const char * const s0 =
f14c76ed 2543 do_utf8 && OP(scan) != CANY ?
95b24440 2544 pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
c728cb41 2545 pref0_len, 60, UNI_DISPLAY_REGEX) :
2a782b5b 2546 locinput - pref_len;
1df70142
AL		 2547 const int len0 = do_utf8 ? strlen(s0) : pref0_len;
2548 const char * const s1 = do_utf8 && OP(scan) != CANY ?
95b24440
DM		 2549 pv_uni_display(PERL_DEBUG_PAD(1),
2550 (U8*)(locinput - pref_len + pref0_len),
c728cb41 2551 pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2a782b5b 2552 locinput - pref_len + pref0_len;
1df70142
AL		 2553 const int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
2554 const char * const s2 = do_utf8 && OP(scan) != CANY ?
95b24440 2555 pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
c728cb41 2556 PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2a782b5b 2557 locinput;
1df70142 2558 const int len2 = do_utf8 ? strlen(s2) : l;
2a782b5b
JH		 2559 PerlIO_printf(Perl_debug_log,
2560 "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2561 (IV)(locinput - PL_bostr),
2562 PL_colors[4],
2563 len0, s0,
2564 PL_colors[5],
2565 PL_colors[2],
2566 len1, s1,
2567 PL_colors[3],
2568 (docolor ? "" : "> <"),
2569 PL_colors[0],
2570 len2, s2,
2571 PL_colors[1],
2572 15 - l - pref_len + 1,
2573 "",
4f639d21 2574 (IV)(scan - rex->program), PL_regindent*2, "",
3f7c398e 2575 SvPVX_const(prop));
2a782b5b
JH		 2576 }
2577 });
d6a28714
JH		 2578
2579 next = scan + NEXT_OFF(scan);
2580 if (next == scan)
2581 next = NULL;
2582
2583 switch (OP(scan)) {
2584 case BOL:
7fba1cd6 2585 if (locinput == PL_bostr)
d6a28714
JH		 2586 {
2587 /* regtill = regbol; */
b8c5462f
JH		 2588 break;
2589 }
d6a28714
JH		 2590 sayNO;
2591 case MBOL:
12d33761
HS		 2592 if (locinput == PL_bostr ||
2593 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
d6a28714 2594 {
b8c5462f
JH		 2595 break;
2596 }
d6a28714
JH		 2597 sayNO;
2598 case SBOL:
c2a73568 2599 if (locinput == PL_bostr)
b8c5462f 2600 break;
d6a28714
JH		 2601 sayNO;
2602 case GPOS:
2603 if (locinput == PL_reg_ganch)
2604 break;
2605 sayNO;
2606 case EOL:
d6a28714
JH		 2607 goto seol;
2608 case MEOL:
d6a28714 2609 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
b8c5462f 2610 sayNO;
b8c5462f 2611 break;
d6a28714
JH		 2612 case SEOL:
2613 seol:
2614 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
b8c5462f 2615 sayNO;
d6a28714 2616 if (PL_regeol - locinput > 1)
b8c5462f 2617 sayNO;
b8c5462f 2618 break;
d6a28714
JH		 2619 case EOS:
2620 if (PL_regeol != locinput)
b8c5462f 2621 sayNO;
d6a28714 2622 break;
ffc61ed2 2623 case SANY:
d6a28714 2624 if (!nextchr && locinput >= PL_regeol)
4633a7c4 2625 sayNO;
f33976b4
DB		 2626 if (do_utf8) {
2627 locinput += PL_utf8skip[nextchr];
2628 if (locinput > PL_regeol)
2629 sayNO;
2630 nextchr = UCHARAT(locinput);
2631 }
2632 else
2633 nextchr = UCHARAT(++locinput);
2634 break;
2635 case CANY:
2636 if (!nextchr && locinput >= PL_regeol)
2637 sayNO;
b8c5462f 2638 nextchr = UCHARAT(++locinput);
a0d0e21e 2639 break;
ffc61ed2 2640 case REG_ANY:
1aa99e6b
IH		 2641 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2642 sayNO;
2643 if (do_utf8) {
b8c5462f 2644 locinput += PL_utf8skip[nextchr];
d6a28714
JH		 2645 if (locinput > PL_regeol)
2646 sayNO;
a0ed51b3 2647 nextchr = UCHARAT(locinput);
a0ed51b3 2648 }
1aa99e6b
IH		 2649 else
2650 nextchr = UCHARAT(++locinput);
a0ed51b3 2651 break;
a3621e74
YO		 2652
2653
2654
2655 /*
2656 traverse the TRIE keeping track of all accepting states
2657 we transition through until we get to a failing node.
2658
a3621e74
YO		 2659
2660 */
5b47454d 2661 case TRIE:
a3621e74
YO		 2662 case TRIEF:
2663 case TRIEFL:
2664 {
a3621e74
YO		 2665 U8 *uc = ( U8* )locinput;
2666 U32 state = 1;
2667 U16 charid = 0;
2668 U32 base = 0;
2669 UV uvc = 0;
2670 STRLEN len = 0;
2671 STRLEN foldlen = 0;
a3621e74
YO		 2672 U8 *uscan = (U8*)NULL;
2673 STRLEN bufflen=0;
95b24440 2674 SV *sv_accept_buff = NULL;
5b47454d
DM		 2675 const enum { trie_plain, trie_utf8, trie_uft8_fold }
2676 trie_type = do_utf8 ?
2677 (OP(scan) == TRIE ? trie_utf8 : trie_uft8_fold)
2678 : trie_plain;
2679
7087a21c
NC		 2680 /* what trie are we using right now */
2681 reg_trie_data *trie
4f639d21 2682 = (reg_trie_data*)PL_reg_re->data->data[ ARG( scan ) ];
d8319b27 2683 st->u.trie.accepted = 0; /* how many accepting states we have seen */
95b24440 2684 result = 0;
a3621e74
YO		 2685
2686 while ( state && uc <= (U8*)PL_regeol ) {
2687
5b47454d 2688 if (trie->states[ state ].wordnum) {
d8319b27 2689 if (!st->u.trie.accepted ) {
5b47454d
DM		 2690 ENTER;
2691 SAVETMPS;
2692 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2693 sv_accept_buff=newSV(bufflen *
2694 sizeof(reg_trie_accepted) - 1);
2695 SvCUR_set(sv_accept_buff,
2696 sizeof(reg_trie_accepted));
2697 SvPOK_on(sv_accept_buff);
2698 sv_2mortal(sv_accept_buff);
d8319b27 2699 st->u.trie.accept_buff =
5b47454d
DM		 2700 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2701 }
2702 else {
d8319b27 2703 if (st->u.trie.accepted >= bufflen) {
5b47454d 2704 bufflen *= 2;
d8319b27 2705 st->u.trie.accept_buff =(reg_trie_accepted*)
5b47454d
DM		 2706 SvGROW(sv_accept_buff,
2707 bufflen * sizeof(reg_trie_accepted));
2708 }
2709 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2710 + sizeof(reg_trie_accepted));
2711 }
d8319b27
DM		 2712 st->u.trie.accept_buff[st->u.trie.accepted].wordnum = trie->states[state].wordnum;
2713 st->u.trie.accept_buff[st->u.trie.accepted].endpos = uc;
2714 ++st->u.trie.accepted;
5b47454d 2715 }
a3621e74
YO		 2716
2717 base = trie->states[ state ].trans.base;
2718
2719 DEBUG_TRIE_EXECUTE_r(
2720 PerlIO_printf( Perl_debug_log,
e4584336 2721 "%*s %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
a3621e74 2722 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
d8319b27 2723 (UV)state, (UV)base, (UV)st->u.trie.accepted );
a3621e74
YO		 2724 );
2725
2726 if ( base ) {
5b47454d
DM		 2727 switch (trie_type) {
2728 case trie_uft8_fold:
a3621e74
YO		 2729 if ( foldlen>0 ) {
2730 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2731 foldlen -= len;
2732 uscan += len;
2733 len=0;
2734 } else {
1df70142 2735 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
a3621e74
YO		 2736 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2737 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2738 foldlen -= UNISKIP( uvc );
2739 uscan = foldbuf + UNISKIP( uvc );
2740 }
5b47454d
DM		 2741 break;
2742 case trie_utf8:
2743 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
2744 &len, uniflags );
2745 break;
2746 case trie_plain:
e4584336 2747 uvc = (UV)*uc;
a3621e74
YO		 2748 len = 1;
2749 }
2750
5b47454d
DM		 2751 if (uvc < 256) {
2752 charid = trie->charmap[ uvc ];
2753 }
2754 else {
2755 charid = 0;
2756 if (trie->widecharmap) {
2757 SV** svpp = (SV**)NULL;
2758 svpp = hv_fetch(trie->widecharmap,
2759 (char*)&uvc, sizeof(UV), 0);
2760 if (svpp)
2761 charid = (U16)SvIV(*svpp);
2762 }
2763 }
a3621e74 2764
5b47454d
DM		 2765 if (charid &&
2766 (base + charid > trie->uniquecharcount )
2767 && (base + charid - 1 - trie->uniquecharcount
2768 < trie->lasttrans)
2769 && trie->trans[base + charid - 1 -
2770 trie->uniquecharcount].check == state)
2771 {
2772 state = trie->trans[base + charid - 1 -
2773 trie->uniquecharcount ].next;
2774 }
2775 else {
2776 state = 0;
2777 }
2778 uc += len;
2779
2780 }
2781 else {
a3621e74
YO		 2782 state = 0;
2783 }
2784 DEBUG_TRIE_EXECUTE_r(
e4584336
RB		 2785 PerlIO_printf( Perl_debug_log,
2786 "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
2787 charid, uvc, (UV)state, PL_colors[5] );
a3621e74
YO		 2788 );
2789 }
d8319b27 2790 if (!st->u.trie.accepted )
a3621e74 2791 sayNO;
a3621e74
YO		 2792
2793 /*
2794 There was at least one accepting state that we
2795 transitioned through. Presumably the number of accepting
2796 states is going to be low, typically one or two. So we
2797 simply scan through to find the one with lowest wordnum.
2798 Once we find it, we swap the last state into its place
2799 and decrement the size. We then try to match the rest of
2800 the pattern at the point where the word ends, if we
2801 succeed then we end the loop, otherwise the loop
2802 eventually terminates once all of the accepting states
2803 have been tried.
2804 */
a3621e74 2805
d8319b27 2806 if ( st->u.trie.accepted == 1 ) {
a3621e74 2807 DEBUG_EXECUTE_r({
097eb12c 2808 SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ 0 ].wordnum-1, 0 );
a3621e74
YO		 2809 PerlIO_printf( Perl_debug_log,
2810 "%*s %sonly one match : #%d <%s>%s\n",
e4584336 2811 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
d8319b27 2812 st->u.trie.accept_buff[ 0 ].wordnum,
cfd0369c 2813 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
a3621e74
YO		 2814 PL_colors[5] );
2815 });
d8319b27 2816 PL_reginput = (char *)st->u.trie.accept_buff[ 0 ].endpos;
a3621e74
YO		 2817 /* in this case we free tmps/leave before we call regmatch
2818 as we wont be using accept_buff again. */
2819 FREETMPS;
2820 LEAVE;
95b24440
DM		 2821 REGMATCH(scan + NEXT_OFF(scan), TRIE1);
2822 /*** all unsaved local vars undefined at this point */
a3621e74
YO		 2823 } else {
2824 DEBUG_EXECUTE_r(
e4584336 2825 PerlIO_printf( Perl_debug_log,"%*s %sgot %"IVdf" possible matches%s\n",
d8319b27 2826 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], (IV)st->u.trie.accepted,
a3621e74
YO		 2827 PL_colors[5] );
2828 );
d8319b27 2829 while ( !result && st->u.trie.accepted-- ) {
a3621e74
YO		 2830 U32 best = 0;
2831 U32 cur;
d8319b27 2832 for( cur = 1 ; cur <= st->u.trie.accepted ; cur++ ) {
e4584336
RB		 2833 DEBUG_TRIE_EXECUTE_r(
2834 PerlIO_printf( Perl_debug_log,
2835 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
2836 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
d8319b27
DM		 2837 (IV)best, st->u.trie.accept_buff[ best ].wordnum, (IV)cur,
2838 st->u.trie.accept_buff[ cur ].wordnum, PL_colors[5] );
e4584336 2839 );
a3621e74 2840
d8319b27
DM		 2841 if (st->u.trie.accept_buff[cur].wordnum <
2842 st->u.trie.accept_buff[best].wordnum)
e822a8b4 2843 best = cur;
a3621e74
YO		 2844 }
2845 DEBUG_EXECUTE_r({
87830502
DM		 2846 reg_trie_data * const trie = (reg_trie_data*)
2847 PL_reg_re->data->data[ARG(scan)];
d8319b27 2848 SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ best ].wordnum - 1, 0 );
a3621e74 2849 PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at 0x%p%s\n",
e4584336 2850 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
d8319b27 2851 st->u.trie.accept_buff[best].wordnum,
cfd0369c 2852 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",scan,
a3621e74
YO		 2853 PL_colors[5] );
2854 });
d8319b27
DM		 2855 if ( best<st->u.trie.accepted ) {
2856 reg_trie_accepted tmp = st->u.trie.accept_buff[ best ];
2857 st->u.trie.accept_buff[ best ] = st->u.trie.accept_buff[ st->u.trie.accepted ];
2858 st->u.trie.accept_buff[ st->u.trie.accepted ] = tmp;
2859 best = st->u.trie.accepted;
a3621e74 2860 }
d8319b27 2861 PL_reginput = (char *)st->u.trie.accept_buff[ best ].endpos;
a3621e74
YO		 2862
2863 /*
2864 as far as I can tell we only need the SAVETMPS/FREETMPS
2865 for re's with EVAL in them but I'm leaving them in for
2866 all until I can be sure.
2867 */
2868 SAVETMPS;
95b24440
DM		 2869 REGMATCH(scan + NEXT_OFF(scan), TRIE2);
2870 /*** all unsaved local vars undefined at this point */
a3621e74
YO		 2871 FREETMPS;
2872 }
2873 FREETMPS;
2874 LEAVE;
2875 }
2876
95b24440 2877 if (result) {
a3621e74
YO		 2878 sayYES;
2879 } else {
2880 sayNO;
2881 }
2882 }
2883 /* unreached codepoint */
95b24440
DM		 2884 case EXACT: {
2885 char *s = STRING(scan);
5d9a96ca 2886 st->ln = STR_LEN(scan);
eb160463 2887 if (do_utf8 != UTF) {
bc517b45 2888 /* The target and the pattern have differing utf8ness. */
1aa99e6b 2889 char *l = locinput;
5d9a96ca 2890 const char *e = s + st->ln;
a72c7584 2891
5ff6fc6d
JH		 2892 if (do_utf8) {
2893 /* The target is utf8, the pattern is not utf8. */
1aa99e6b 2894 while (s < e) {
a3b680e6 2895 STRLEN ulen;
1aa99e6b 2896 if (l >= PL_regeol)
5ff6fc6d
JH		 2897 sayNO;
2898 if (NATIVE_TO_UNI(*(U8*)s) !=
89ebb4a3 2899 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
041457d9 2900 uniflags))
5ff6fc6d 2901 sayNO;
bc517b45 2902 l += ulen;
5ff6fc6d 2903 s ++;
1aa99e6b 2904 }
5ff6fc6d
JH		 2905 }
2906 else {
2907 /* The target is not utf8, the pattern is utf8. */
1aa99e6b 2908 while (s < e) {
a3b680e6 2909 STRLEN ulen;
1aa99e6b
IH		 2910 if (l >= PL_regeol)
2911 sayNO;
5ff6fc6d 2912 if (NATIVE_TO_UNI(*((U8*)l)) !=
89ebb4a3 2913 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
041457d9 2914 uniflags))
1aa99e6b 2915 sayNO;
bc517b45 2916 s += ulen;
a72c7584 2917 l ++;
1aa99e6b 2918 }
5ff6fc6d 2919 }
1aa99e6b
IH		 2920 locinput = l;
2921 nextchr = UCHARAT(locinput);
2922 break;
2923 }
bc517b45 2924 /* The target and the pattern have the same utf8ness. */
d6a28714
JH		 2925 /* Inline the first character, for speed. */
2926 if (UCHARAT(s) != nextchr)
2927 sayNO;
5d9a96ca 2928 if (PL_regeol - locinput < st->ln)
d6a28714 2929 sayNO;
5d9a96ca 2930 if (st->ln > 1 && memNE(s, locinput, st->ln))
d6a28714 2931 sayNO;
5d9a96ca 2932 locinput += st->ln;
d6a28714
JH		 2933 nextchr = UCHARAT(locinput);
2934 break;
95b24440 2935 }
d6a28714 2936 case EXACTFL:
b8c5462f
JH		 2937 PL_reg_flags |= RF_tainted;
2938 /* FALL THROUGH */
95b24440
DM		 2939 case EXACTF: {
2940 char *s = STRING(scan);
5d9a96ca 2941 st->ln = STR_LEN(scan);
d6a28714 2942
d07ddd77
JH		 2943 if (do_utf8 || UTF) {
2944 /* Either target or the pattern are utf8. */
d6a28714 2945 char *l = locinput;
d07ddd77 2946 char *e = PL_regeol;
bc517b45 2947
5d9a96ca 2948 if (ibcmp_utf8(s, 0, st->ln, (bool)UTF,
1feea2c7 2949 l, &e, 0, do_utf8)) {
5486206c
JH		 2950 /* One more case for the sharp s:
2951 * pack("U0U*", 0xDF) =~ /ss/i,
2952 * the 0xC3 0x9F are the UTF-8
2953 * byte sequence for the U+00DF. */
2954 if (!(do_utf8 &&
2955 toLOWER(s[0]) == 's' &&
5d9a96ca 2956 st->ln >= 2 &&
5486206c
JH		 2957 toLOWER(s[1]) == 's' &&
2958 (U8)l[0] == 0xC3 &&
2959 e - l >= 2 &&
2960 (U8)l[1] == 0x9F))
2961 sayNO;
2962 }
d07ddd77
JH		 2963 locinput = e;
2964 nextchr = UCHARAT(locinput);
2965 break;
a0ed51b3 2966 }
d6a28714 2967
bc517b45
JH		 2968 /* Neither the target and the pattern are utf8. */
2969
d6a28714
JH		 2970 /* Inline the first character, for speed. */
2971 if (UCHARAT(s) != nextchr &&
2972 UCHARAT(s) != ((OP(scan) == EXACTF)
2973 ? PL_fold : PL_fold_locale)[nextchr])
a0ed51b3 2974 sayNO;
5d9a96ca 2975 if (PL_regeol - locinput < st->ln)
b8c5462f 2976 sayNO;
5d9a96ca
DM		 2977 if (st->ln > 1 && (OP(scan) == EXACTF
2978 ? ibcmp(s, locinput, st->ln)
2979 : ibcmp_locale(s, locinput, st->ln)))
4633a7c4 2980 sayNO;
5d9a96ca 2981 locinput += st->ln;
d6a28714 2982 nextchr = UCHARAT(locinput);
a0d0e21e 2983 break;
95b24440 2984 }
d6a28714 2985 case ANYOF:
ffc61ed2 2986 if (do_utf8) {
9e55ce06
JH		 2987 STRLEN inclasslen = PL_regeol - locinput;
2988
ba7b4546 2989 if (!reginclass(scan, (U8*)locinput, &inclasslen, do_utf8))
e0f9d4a8 2990 sayNO_ANYOF;
ffc61ed2
JH		 2991 if (locinput >= PL_regeol)
2992 sayNO;
0f0076b4 2993 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
b8c5462f 2994 nextchr = UCHARAT(locinput);
e0f9d4a8 2995 break;
ffc61ed2
JH		 2996 }
2997 else {
2998 if (nextchr < 0)
2999 nextchr = UCHARAT(locinput);
7d3e948e 3000 if (!REGINCLASS(scan, (U8*)locinput))
e0f9d4a8 3001 sayNO_ANYOF;
ffc61ed2
JH		 3002 if (!nextchr && locinput >= PL_regeol)
3003 sayNO;
3004 nextchr = UCHARAT(++locinput);
e0f9d4a8
JH		 3005 break;
3006 }
3007 no_anyof:
3008 /* If we might have the case of the German sharp s
3009 * in a casefolding Unicode character class. */
3010
ebc501f0
JH		 3011 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3012 locinput += SHARP_S_SKIP;
e0f9d4a8 3013 nextchr = UCHARAT(locinput);
ffc61ed2 3014 }
e0f9d4a8
JH		 3015 else
3016 sayNO;
b8c5462f 3017 break;
d6a28714 3018 case ALNUML:
b8c5462f
JH		 3019 PL_reg_flags |= RF_tainted;
3020 /* FALL THROUGH */
d6a28714 3021 case ALNUM:
b8c5462f 3022 if (!nextchr)
4633a7c4 3023 sayNO;
ffc61ed2 3024 if (do_utf8) {
1a4fad37 3025 LOAD_UTF8_CHARCLASS_ALNUM();
ffc61ed2 3026 if (!(OP(scan) == ALNUM
3568d838 3027 ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
d6a28714 3028 : isALNUM_LC_utf8((U8*)locinput)))
b8c5462f
JH		 3029 {
3030 sayNO;
a0ed51b3 3031 }
b8c5462f 3032 locinput += PL_utf8skip[nextchr];
a0ed51b3
LW		 3033 nextchr = UCHARAT(locinput);
3034 break;
3035 }
ffc61ed2 3036 if (!(OP(scan) == ALNUM
d6a28714 3037 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
bbce6d69 3038 sayNO;
b8c5462f 3039 nextchr = UCHARAT(++locinput);
a0d0e21e 3040 break;
d6a28714 3041 case NALNUML:
b8c5462f
JH		 3042 PL_reg_flags |= RF_tainted;
3043 /* FALL THROUGH */
d6a28714
JH		 3044 case NALNUM:
3045 if (!nextchr && locinput >= PL_regeol)
a0ed51b3 3046 sayNO;
ffc61ed2 3047 if (do_utf8) {
1a4fad37 3048 LOAD_UTF8_CHARCLASS_ALNUM();
ffc61ed2 3049 if (OP(scan) == NALNUM
3568d838 3050 ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
d6a28714
JH		 3051 : isALNUM_LC_utf8((U8*)locinput))
3052 {
b8c5462f 3053 sayNO;
d6a28714 3054 }
b8c5462f
JH		 3055 locinput += PL_utf8skip[nextchr];
3056 nextchr = UCHARAT(locinput);
3057 break;
3058 }
ffc61ed2 3059 if (OP(scan) == NALNUM
d6a28714 3060 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
b8c5462f 3061 sayNO;
76e3520e 3062 nextchr = UCHARAT(++locinput);
a0d0e21e 3063 break;
d6a28714
JH		 3064 case BOUNDL:
3065 case NBOUNDL:
3280af22 3066 PL_reg_flags |= RF_tainted;
bbce6d69 3067 /* FALL THROUGH */
d6a28714
JH		 3068 case BOUND:
3069 case NBOUND:
3070 /* was last char in word? */
ffc61ed2 3071 if (do_utf8) {
12d33761 3072 if (locinput == PL_bostr)
5d9a96ca 3073 st->ln = '\n';
ffc61ed2 3074 else {
a3b680e6 3075 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
9041c2e3 3076
4ad0818d 3077 st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
ffc61ed2
JH		 3078 }
3079 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
5d9a96ca 3080 st->ln = isALNUM_uni(st->ln);
1a4fad37 3081 LOAD_UTF8_CHARCLASS_ALNUM();
3568d838 3082 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
ffc61ed2
JH		 3083 }
3084 else {
5d9a96ca 3085 st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
ffc61ed2
JH		 3086 n = isALNUM_LC_utf8((U8*)locinput);
3087 }
a0ed51b3 3088 }
d6a28714 3089 else {
5d9a96ca 3090 st->ln = (locinput != PL_bostr) ?
12d33761 3091 UCHARAT(locinput - 1) : '\n';
ffc61ed2 3092 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
5d9a96ca 3093 st->ln = isALNUM(st->ln);
ffc61ed2
JH		 3094 n = isALNUM(nextchr);
3095 }
3096 else {
5d9a96ca 3097 st->ln = isALNUM_LC(st->ln);
ffc61ed2
JH		 3098 n = isALNUM_LC(nextchr);
3099 }
d6a28714 3100 }
5d9a96ca 3101 if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
ffc61ed2
JH		 3102 OP(scan) == BOUNDL))
3103 sayNO;
a0ed51b3 3104 break;
d6a28714 3105 case SPACEL:
3280af22 3106 PL_reg_flags |= RF_tainted;
bbce6d69 3107 /* FALL THROUGH */
d6a28714 3108 case SPACE:
9442cb0e 3109 if (!nextchr)
4633a7c4 3110 sayNO;
1aa99e6b 3111 if (do_utf8) {
fd400ab9 3112 if (UTF8_IS_CONTINUED(nextchr)) {
1a4fad37 3113 LOAD_UTF8_CHARCLASS_SPACE();
ffc61ed2 3114 if (!(OP(scan) == SPACE
3568d838 3115 ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
ffc61ed2
JH		 3116 : isSPACE_LC_utf8((U8*)locinput)))
3117 {
3118 sayNO;
3119 }
3120 locinput += PL_utf8skip[nextchr];
3121 nextchr = UCHARAT(locinput);
3122 break;
d6a28714 3123 }
ffc61ed2
JH		 3124 if (!(OP(scan) == SPACE
3125 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3126 sayNO;
3127 nextchr = UCHARAT(++locinput);
3128 }
3129 else {
3130 if (!(OP(scan) == SPACE
3131 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3132 sayNO;
3133 nextchr = UCHARAT(++locinput);
a0ed51b3 3134 }
a0ed51b3 3135 break;
d6a28714 3136 case NSPACEL:
3280af22 3137 PL_reg_flags |= RF_tainted;
bbce6d69 3138 /* FALL THROUGH */
d6a28714 3139 case NSPACE:
9442cb0e 3140 if (!nextchr && locinput >= PL_regeol)
b8c5462f 3141 sayNO;
1aa99e6b 3142 if (do_utf8) {
1a4fad37 3143 LOAD_UTF8_CHARCLASS_SPACE();
ffc61ed2 3144 if (OP(scan) == NSPACE
3568d838 3145 ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
d6a28714 3146 : isSPACE_LC_utf8((U8*)locinput))
b8c5462f
JH		 3147 {
3148 sayNO;
3149 }
3150 locinput += PL_utf8skip[nextchr];
3151 nextchr = UCHARAT(locinput);
3152 break;
a0ed51b3 3153 }
ffc61ed2 3154 if (OP(scan) == NSPACE
d6a28714 3155 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
4633a7c4 3156 sayNO;
76e3520e 3157 nextchr = UCHARAT(++locinput);
a0d0e21e 3158 break;
d6a28714 3159 case DIGITL:
a0ed51b3
LW		 3160 PL_reg_flags |= RF_tainted;
3161 /* FALL THROUGH */
d6a28714 3162 case DIGIT:
9442cb0e 3163 if (!nextchr)
a0ed51b3 3164 sayNO;
1aa99e6b 3165 if (do_utf8) {
1a4fad37 3166 LOAD_UTF8_CHARCLASS_DIGIT();
ffc61ed2 3167 if (!(OP(scan) == DIGIT
3568d838 3168 ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
9442cb0e 3169 : isDIGIT_LC_utf8((U8*)locinput)))
dfe13c55 3170 {
a0ed51b3 3171 sayNO;
dfe13c55 3172 }
6f06b55f 3173 locinput += PL_utf8skip[nextchr];
a0ed51b3
LW		 3174 nextchr = UCHARAT(locinput);
3175 break;
3176 }
ffc61ed2 3177 if (!(OP(scan) == DIGIT
9442cb0e 3178 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
a0ed51b3
LW		 3179 sayNO;
3180 nextchr = UCHARAT(++locinput);
3181 break;
d6a28714 3182 case NDIGITL:
b8c5462f
JH		 3183 PL_reg_flags |= RF_tainted;
3184 /* FALL THROUGH */
d6a28714 3185 case NDIGIT:
9442cb0e 3186 if (!nextchr && locinput >= PL_regeol)
b8c5462f 3187 sayNO;
1aa99e6b 3188 if (do_utf8) {
1a4fad37 3189 LOAD_UTF8_CHARCLASS_DIGIT();
ffc61ed2 3190 if (OP(scan) == NDIGIT
3568d838 3191 ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
9442cb0e
GS		 3192 : isDIGIT_LC_utf8((U8*)locinput))
3193 {
a0ed51b3 3194 sayNO;
9442cb0e 3195 }
6f06b55f 3196 locinput += PL_utf8skip[nextchr];
a0ed51b3
LW		 3197 nextchr = UCHARAT(locinput);
3198 break;
3199 }
ffc61ed2 3200 if (OP(scan) == NDIGIT
9442cb0e 3201 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
a0ed51b3
LW		 3202 sayNO;
3203 nextchr = UCHARAT(++locinput);
3204 break;
3205 case CLUMP:
b7c83a7e 3206 if (locinput >= PL_regeol)
a0ed51b3 3207 sayNO;
b7c83a7e 3208 if (do_utf8) {
1a4fad37 3209 LOAD_UTF8_CHARCLASS_MARK();
b7c83a7e
JH		 3210 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3211 sayNO;
3212 locinput += PL_utf8skip[nextchr];
3213 while (locinput < PL_regeol &&
3214 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3215 locinput += UTF8SKIP(locinput);
3216 if (locinput > PL_regeol)
3217 sayNO;
eb08e2da
JH		 3218 }
3219 else
3220 locinput++;
a0ed51b3
LW		 3221 nextchr = UCHARAT(locinput);
3222 break;
c8756f30 3223 case REFFL:
3280af22 3224 PL_reg_flags |= RF_tainted;
c8756f30 3225 /* FALL THROUGH */
c277df42 3226 case REF:
95b24440
DM		 3227 case REFF: {
3228 char *s;
c277df42 3229 n = ARG(scan); /* which paren pair */
5d9a96ca 3230 st->ln = PL_regstartp[n];
2c2d71f5 3231 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
5d9a96ca 3232 if ((I32)*PL_reglastparen < n || st->ln == -1)
af3f8c16 3233 sayNO; /* Do not match unless seen CLOSEn. */
5d9a96ca 3234 if (st->ln == PL_regendp[n])
a0d0e21e 3235 break;
a0ed51b3 3236
5d9a96ca 3237 s = PL_bostr + st->ln;
1aa99e6b 3238 if (do_utf8 && OP(scan) != REF) { /* REF can do byte comparison */
a0ed51b3 3239 char *l = locinput;
a3b680e6 3240 const char *e = PL_bostr + PL_regendp[n];
a0ed51b3
LW		 3241 /*
3242 * Note that we can't do the "other character" lookup trick as
3243 * in the 8-bit case (no pun intended) because in Unicode we
3244 * have to map both upper and title case to lower case.
3245 */
3246 if (OP(scan) == REFF) {
3247 while (s < e) {
a3b680e6
AL		 3248 STRLEN ulen1, ulen2;
3249 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3250 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3251
a0ed51b3
LW		 3252 if (l >= PL_regeol)
3253 sayNO;
a2a2844f
JH		 3254 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3255 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
7114a2d2 3256 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
a0ed51b3 3257 sayNO;
a2a2844f
JH		 3258 s += ulen1;
3259 l += ulen2;
a0ed51b3
LW		 3260 }
3261 }
3262 locinput = l;
3263 nextchr = UCHARAT(locinput);
3264 break;
3265 }
3266
a0d0e21e 3267 /* Inline the first character, for speed. */
76e3520e 3268 if (UCHARAT(s) != nextchr &&
c8756f30
AK		 3269 (OP(scan) == REF ||
3270 (UCHARAT(s) != ((OP(scan) == REFF
22c35a8c 3271 ? PL_fold : PL_fold_locale)[nextchr]))))
4633a7c4 3272 sayNO;
5d9a96ca
DM		 3273 st->ln = PL_regendp[n] - st->ln;
3274 if (locinput + st->ln > PL_regeol)
4633a7c4 3275 sayNO;
5d9a96ca
DM		 3276 if (st->ln > 1 && (OP(scan) == REF
3277 ? memNE(s, locinput, st->ln)
c8756f30 3278 : (OP(scan) == REFF
5d9a96ca
DM		 3279 ? ibcmp(s, locinput, st->ln)
3280 : ibcmp_locale(s, locinput, st->ln))))
4633a7c4 3281 sayNO;
5d9a96ca 3282 locinput += st->ln;
76e3520e 3283 nextchr = UCHARAT(locinput);
a0d0e21e 3284 break;
95b24440 3285 }
a0d0e21e
LW		 3286
3287 case NOTHING:
c277df42 3288 case TAIL:
a0d0e21e
LW		 3289 break;
3290 case BACK:
3291 break;
c277df42
IZ		 3292 case EVAL:
3293 {
c277df42 3294 SV *ret;
8e5e9ebe 3295 {
4aabdb9b
DM		 3296 /* execute the code in the {...} */
3297 dSP;
6136c704 3298 SV ** const before = SP;
4aabdb9b
DM		 3299 OP_4tree * const oop = PL_op;
3300 COP * const ocurcop = PL_curcop;
3301 PAD *old_comppad;
3302 struct regexp * const oreg = PL_reg_re;
3303
3304 n = ARG(scan);
4f639d21 3305 PL_op = (OP_4tree*)PL_reg_re->data->data[n];
4aabdb9b 3306 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
4f639d21 3307 PAD_SAVE_LOCAL(old_comppad, (PAD*)PL_reg_re->data->data[n + 2]);
4aabdb9b
DM		 3308 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3309
8e5e9ebe
RGS		 3310 CALLRUNOPS(aTHX); /* Scalar context. */
3311 SPAGAIN;
3312 if (SP == before)
075aa684 3313 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
8e5e9ebe
RGS		 3314 else {
3315 ret = POPs;
3316 PUTBACK;
3317 }
4aabdb9b
DM		 3318
3319 PL_op = oop;
3320 PAD_RESTORE_LOCAL(old_comppad);
3321 PL_curcop = ocurcop;
87830502 3322 PL_reg_re = oreg;
4aabdb9b
DM		 3323 if (!st->logical) {
3324 /* /(?{...})/ */
3325 sv_setsv(save_scalar(PL_replgv), ret);
4aabdb9b
DM		 3326 break;
3327 }
8e5e9ebe 3328 }
4aabdb9b
DM		 3329 if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3330 regexp *re;
4aabdb9b 3331 {
4f639d21
DM		 3332 /* extract RE object from returned value; compiling if
3333 * necessary */
3334
6136c704 3335 MAGIC *mg = NULL;
4aabdb9b 3336 SV *sv;
faf82a0b
AE		 3337 if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3338 mg = mg_find(sv, PERL_MAGIC_qr);
3339 else if (SvSMAGICAL(ret)) {
3340 if (SvGMAGICAL(ret))
3341 sv_unmagic(ret, PERL_MAGIC_qr);
3342 else
3343 mg = mg_find(ret, PERL_MAGIC_qr);
0f5d15d6 3344 }
faf82a0b 3345
0f5d15d6
IZ		 3346 if (mg) {
3347 re = (regexp *)mg->mg_obj;
df0003d4 3348 (void)ReREFCNT_inc(re);
0f5d15d6
IZ		 3349 }
3350 else {
3351 STRLEN len;
6136c704 3352 const char * const t = SvPV_const(ret, len);
0f5d15d6 3353 PMOP pm;
a3b680e6 3354 const I32 osize = PL_regsize;
0f5d15d6 3355
5fcd1c1b 3356 Zero(&pm, 1, PMOP);
4aabdb9b 3357 if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
83003860 3358 re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
9041c2e3 3359 if (!(SvFLAGS(ret)
faf82a0b
AE		 3360 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3361 | SVs_GMG)))
14befaf4
DM		 3362 sv_magic(ret,(SV*)ReREFCNT_inc(re),
3363 PERL_MAGIC_qr,0,0);
0f5d15d6 3364 PL_regsize = osize;
0f5d15d6 3365 }
4aabdb9b 3366 }
aa283a38
DM		 3367
3368 /* run the pattern returned from (??{...}) */
3369
4aabdb9b
DM		 3370 DEBUG_EXECUTE_r(
3371 PerlIO_printf(Perl_debug_log,
3372 "Entering embedded \"%s%.60s%s%s\"\n",
3373 PL_colors[0],
3374 re->precomp,
3375 PL_colors[1],
3376 (strlen(re->precomp) > 60 ? "..." : ""))
3377 );
2c2d71f5 3378
4aabdb9b
DM		 3379 st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
3380 REGCP_SET(st->u.eval.lastcp);
4aabdb9b
DM		 3381 *PL_reglastparen = 0;
3382 *PL_reglastcloseparen = 0;
4aabdb9b 3383 PL_reginput = locinput;
4aabdb9b
DM		 3384
3385 /* XXXX This is too dramatic a measure... */
3386 PL_reg_maxiter = 0;
3387
5d9a96ca 3388 st->logical = 0;
aa283a38
DM		 3389 st->u.eval.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3390 ((re->reganch & ROPT_UTF8) != 0);
3391 if (st->u.eval.toggleutf) PL_reg_flags ^= RF_utf8;
3392 st->u.eval.prev_rex = rex;
3393 assert(rex == PL_reg_re); /* XXX */
3394 rex = re;
3395 PL_reg_re = rex; /* XXX */
3396
3397 st->u.eval.prev_eval = cur_eval;
3398 st->u.eval.prev_slab = PL_regmatch_slab;
3399 st->u.eval.depth = depth;
3400 cur_eval = st;
3401 PUSH_STATE(newst, resume_EVAL);
3402 st = newst;
3403
3404 /* now continue from first node in postoned RE */
3405 next = re->program + 1;
3406 break;
4aabdb9b 3407 /* NOTREACHED */
a0ed51b3 3408 }
4aabdb9b
DM		 3409 /* /(?(?{...})X|Y)/ */
3410 st->sw = SvTRUE(ret);
3411 st->logical = 0;
c277df42
IZ		 3412 break;
3413 }
a0d0e21e 3414 case OPEN:
c277df42 3415 n = ARG(scan); /* which paren pair */
3280af22
NIS		 3416 PL_reg_start_tmp[n] = locinput;
3417 if (n > PL_regsize)
3418 PL_regsize = n;
a0d0e21e
LW		 3419 break;
3420 case CLOSE:
c277df42 3421 n = ARG(scan); /* which paren pair */
cf93c79d
IZ		 3422 PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3423 PL_regendp[n] = locinput - PL_bostr;
eb160463 3424 if (n > (I32)*PL_reglastparen)
3280af22 3425 *PL_reglastparen = n;
a01268b5 3426 *PL_reglastcloseparen = n;
a0d0e21e 3427 break;
c277df42
IZ		 3428 case GROUPP:
3429 n = ARG(scan); /* which paren pair */
5d9a96ca 3430 st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
c277df42
IZ		 3431 break;
3432 case IFTHEN:
2c2d71f5 3433 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
5d9a96ca 3434 if (st->sw)
c277df42
IZ		 3435 next = NEXTOPER(NEXTOPER(scan));
3436 else {
3437 next = scan + ARG(scan);
3438 if (OP(next) == IFTHEN) /* Fake one. */
3439 next = NEXTOPER(NEXTOPER(next));
3440 }
3441 break;
3442 case LOGICAL:
5d9a96ca 3443 st->logical = scan->flags;
c277df42 3444 break;
2ab05381 3445/*******************************************************************
a0374537
DM		 3446 cc points to the regmatch_state associated with the most recent CURLYX.
3447 This struct contains info about the innermost (...)* loop (an
3448 "infoblock"), and a pointer to the next outer cc.
2ab05381
IZ		 3449
3450 Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3451
95b24440 3452 1) After matching Y, regnode for CURLYX is processed;
2ab05381 3453
a0374537 3454 2) This regnode populates cc, and calls regmatch() recursively
95b24440 3455 with the starting point at WHILEM node;
2ab05381
IZ		 3456