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