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