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