source: trunk/essentials/dev-lang/perl/regexec.c@ 3280

Last change on this file since 3280 was 3181, checked in by bird, 19 years ago

perl 5.8.8

File size: 124.5 KB
Line 
1/* regexec.c
2 */
3
4/*
5 * "One Ring to rule them all, One Ring to find them..."
6 */
7
8/* This file contains functions for executing a regular expression. See
9 * also regcomp.c which funnily enough, contains functions for compiling
10 * a regular expression.
11 *
12 * This file is also copied at build time to ext/re/re_exec.c, where
13 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
14 * This causes the main functions to be compiled under new names and with
15 * debugging support added, which makes "use re 'debug'" work.
16
17 */
18
19/* NOTE: this is derived from Henry Spencer's regexp code, and should not
20 * confused with the original package (see point 3 below). Thanks, Henry!
21 */
22
23/* Additional note: this code is very heavily munged from Henry's version
24 * in places. In some spots I've traded clarity for efficiency, so don't
25 * blame Henry for some of the lack of readability.
26 */
27
28/* The names of the functions have been changed from regcomp and
29 * regexec to pregcomp and pregexec in order to avoid conflicts
30 * with the POSIX routines of the same names.
31*/
32
33#ifdef PERL_EXT_RE_BUILD
34/* need to replace pregcomp et al, so enable that */
35# ifndef PERL_IN_XSUB_RE
36# define PERL_IN_XSUB_RE
37# endif
38/* need access to debugger hooks */
39# if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
40# define DEBUGGING
41# endif
42#endif
43
44#ifdef PERL_IN_XSUB_RE
45/* We *really* need to overwrite these symbols: */
46# define Perl_regexec_flags my_regexec
47# define Perl_regdump my_regdump
48# define Perl_regprop my_regprop
49# define Perl_re_intuit_start my_re_intuit_start
50/* *These* symbols are masked to allow static link. */
51# define Perl_pregexec my_pregexec
52# define Perl_reginitcolors my_reginitcolors
53# define Perl_regclass_swash my_regclass_swash
54
55# define PERL_NO_GET_CONTEXT
56#endif
57
58/*
59 * pregcomp and pregexec -- regsub and regerror are not used in perl
60 *
61 * Copyright (c) 1986 by University of Toronto.
62 * Written by Henry Spencer. Not derived from licensed software.
63 *
64 * Permission is granted to anyone to use this software for any
65 * purpose on any computer system, and to redistribute it freely,
66 * subject to the following restrictions:
67 *
68 * 1. The author is not responsible for the consequences of use of
69 * this software, no matter how awful, even if they arise
70 * from defects in it.
71 *
72 * 2. The origin of this software must not be misrepresented, either
73 * by explicit claim or by omission.
74 *
75 * 3. Altered versions must be plainly marked as such, and must not
76 * be misrepresented as being the original software.
77 *
78 **** Alterations to Henry's code are...
79 ****
80 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
81 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
82 ****
83 **** You may distribute under the terms of either the GNU General Public
84 **** License or the Artistic License, as specified in the README file.
85 *
86 * Beware that some of this code is subtly aware of the way operator
87 * precedence is structured in regular expressions. Serious changes in
88 * regular-expression syntax might require a total rethink.
89 */
90#include "EXTERN.h"
91#define PERL_IN_REGEXEC_C
92#include "perl.h"
93
94#include "regcomp.h"
95
96#define RF_tainted 1 /* tainted information used? */
97#define RF_warned 2 /* warned about big count? */
98#define RF_evaled 4 /* Did an EVAL with setting? */
99#define RF_utf8 8 /* String contains multibyte chars? */
100
101#define UTF ((PL_reg_flags & RF_utf8) != 0)
102
103#define RS_init 1 /* eval environment created */
104#define RS_set 2 /* replsv value is set */
105
106#ifndef STATIC
107#define STATIC static
108#endif
109
110#define REGINCLASS(p,c) (ANYOF_FLAGS(p) ? reginclass(p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
111
112/*
113 * Forwards.
114 */
115
116#define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
117#define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
118
119#define reghop_c(pos,off) ((char*)reghop((U8*)pos, off))
120#define reghopmaybe_c(pos,off) ((char*)reghopmaybe((U8*)pos, off))
121#define HOP(pos,off) (PL_reg_match_utf8 ? reghop((U8*)pos, off) : (U8*)(pos + off))
122#define HOPMAYBE(pos,off) (PL_reg_match_utf8 ? reghopmaybe((U8*)pos, off) : (U8*)(pos + off))
123#define HOPc(pos,off) ((char*)HOP(pos,off))
124#define HOPMAYBEc(pos,off) ((char*)HOPMAYBE(pos,off))
125
126#define HOPBACK(pos, off) ( \
127 (PL_reg_match_utf8) \
128 ? reghopmaybe((U8*)pos, -off) \
129 : (pos - off >= PL_bostr) \
130 ? (U8*)(pos - off) \
131 : (U8*)NULL \
132)
133#define HOPBACKc(pos, off) (char*)HOPBACK(pos, off)
134
135#define reghop3_c(pos,off,lim) ((char*)reghop3((U8*)pos, off, (U8*)lim))
136#define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim))
137#define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
138#define HOPMAYBE3(pos,off,lim) (PL_reg_match_utf8 ? reghopmaybe3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
139#define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
140#define HOPMAYBE3c(pos,off,lim) ((char*)HOPMAYBE3(pos,off,lim))
141
142#define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
143 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((U8*)str); assert(ok); LEAVE; } } STMT_END
144#define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
145#define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
146#define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
147#define LOAD_UTF8_CHARCLASS_MARK() LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
148
149/* for use after a quantifier and before an EXACT-like node -- japhy */
150#define JUMPABLE(rn) ( \
151 OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
152 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
153 OP(rn) == PLUS || OP(rn) == MINMOD || \
154 (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \
155)
156
157#define HAS_TEXT(rn) ( \
158 PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \
159)
160
161/*
162 Search for mandatory following text node; for lookahead, the text must
163 follow but for lookbehind (rn->flags != 0) we skip to the next step.
164*/
165#define FIND_NEXT_IMPT(rn) STMT_START { \
166 while (JUMPABLE(rn)) \
167 if (OP(rn) == SUSPEND || PL_regkind[(U8)OP(rn)] == CURLY) \
168 rn = NEXTOPER(NEXTOPER(rn)); \
169 else if (OP(rn) == PLUS) \
170 rn = NEXTOPER(rn); \
171 else if (OP(rn) == IFMATCH) \
172 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
173 else rn += NEXT_OFF(rn); \
174} STMT_END
175
176static void restore_pos(pTHX_ void *arg);
177
178STATIC CHECKPOINT
179S_regcppush(pTHX_ I32 parenfloor)
180{
181 const int retval = PL_savestack_ix;
182#define REGCP_PAREN_ELEMS 4
183 const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
184 int p;
185
186 if (paren_elems_to_push < 0)
187 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
188
189#define REGCP_OTHER_ELEMS 6
190 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
191 for (p = PL_regsize; p > parenfloor; p--) {
192/* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
193 SSPUSHINT(PL_regendp[p]);
194 SSPUSHINT(PL_regstartp[p]);
195 SSPUSHPTR(PL_reg_start_tmp[p]);
196 SSPUSHINT(p);
197 }
198/* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
199 SSPUSHINT(PL_regsize);
200 SSPUSHINT(*PL_reglastparen);
201 SSPUSHINT(*PL_reglastcloseparen);
202 SSPUSHPTR(PL_reginput);
203#define REGCP_FRAME_ELEMS 2
204/* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
205 * are needed for the regexp context stack bookkeeping. */
206 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
207 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
208
209 return retval;
210}
211
212/* These are needed since we do not localize EVAL nodes: */
213# define REGCP_SET(cp) DEBUG_r(PerlIO_printf(Perl_debug_log, \
214 " Setting an EVAL scope, savestack=%"IVdf"\n", \
215 (IV)PL_savestack_ix)); cp = PL_savestack_ix
216
217# define REGCP_UNWIND(cp) DEBUG_r(cp != PL_savestack_ix ? \
218 PerlIO_printf(Perl_debug_log, \
219 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
220 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
221
222STATIC char *
223S_regcppop(pTHX)
224{
225 I32 i;
226 U32 paren = 0;
227 char *input;
228
229 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
230 i = SSPOPINT;
231 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
232 i = SSPOPINT; /* Parentheses elements to pop. */
233 input = (char *) SSPOPPTR;
234 *PL_reglastcloseparen = SSPOPINT;
235 *PL_reglastparen = SSPOPINT;
236 PL_regsize = SSPOPINT;
237
238 /* Now restore the parentheses context. */
239 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
240 i > 0; i -= REGCP_PAREN_ELEMS) {
241 I32 tmps;
242 paren = (U32)SSPOPINT;
243 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
244 PL_regstartp[paren] = SSPOPINT;
245 tmps = SSPOPINT;
246 if (paren <= *PL_reglastparen)
247 PL_regendp[paren] = tmps;
248 DEBUG_r(
249 PerlIO_printf(Perl_debug_log,
250 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
251 (UV)paren, (IV)PL_regstartp[paren],
252 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
253 (IV)PL_regendp[paren],
254 (paren > *PL_reglastparen ? "(no)" : ""));
255 );
256 }
257 DEBUG_r(
258 if ((I32)(*PL_reglastparen + 1) <= PL_regnpar) {
259 PerlIO_printf(Perl_debug_log,
260 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
261 (IV)(*PL_reglastparen + 1), (IV)PL_regnpar);
262 }
263 );
264#if 1
265 /* It would seem that the similar code in regtry()
266 * already takes care of this, and in fact it is in
267 * a better location to since this code can #if 0-ed out
268 * but the code in regtry() is needed or otherwise tests
269 * requiring null fields (pat.t#187 and split.t#{13,14}
270 * (as of patchlevel 7877) will fail. Then again,
271 * this code seems to be necessary or otherwise
272 * building DynaLoader will fail:
273 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
274 * --jhi */
275 for (paren = *PL_reglastparen + 1; (I32)paren <= PL_regnpar; paren++) {
276 if ((I32)paren > PL_regsize)
277 PL_regstartp[paren] = -1;
278 PL_regendp[paren] = -1;
279 }
280#endif
281 return input;
282}
283
284STATIC char *
285S_regcp_set_to(pTHX_ I32 ss)
286{
287 const I32 tmp = PL_savestack_ix;
288
289 PL_savestack_ix = ss;
290 regcppop();
291 PL_savestack_ix = tmp;
292 return Nullch;
293}
294
295typedef struct re_cc_state
296{
297 I32 ss;
298 regnode *node;
299 struct re_cc_state *prev;
300 CURCUR *cc;
301 regexp *re;
302} re_cc_state;
303
304#define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
305
306#define TRYPAREN(paren, n, input) { \
307 if (paren) { \
308 if (n) { \
309 PL_regstartp[paren] = HOPc(input, -1) - PL_bostr; \
310 PL_regendp[paren] = input - PL_bostr; \
311 } \
312 else \
313 PL_regendp[paren] = -1; \
314 } \
315 if (regmatch(next)) \
316 sayYES; \
317 if (paren && n) \
318 PL_regendp[paren] = -1; \
319}
320
321
322/*
323 * pregexec and friends
324 */
325
326/*
327 - pregexec - match a regexp against a string
328 */
329I32
330Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
331 char *strbeg, I32 minend, SV *screamer, U32 nosave)
332/* strend: pointer to null at end of string */
333/* strbeg: real beginning of string */
334/* minend: end of match must be >=minend after stringarg. */
335/* nosave: For optimizations. */
336{
337 return
338 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
339 nosave ? 0 : REXEC_COPY_STR);
340}
341
342STATIC void
343S_cache_re(pTHX_ regexp *prog)
344{
345 PL_regprecomp = prog->precomp; /* Needed for FAIL. */
346#ifdef DEBUGGING
347 PL_regprogram = prog->program;
348#endif
349 PL_regnpar = prog->nparens;
350 PL_regdata = prog->data;
351 PL_reg_re = prog;
352}
353
354/*
355 * Need to implement the following flags for reg_anch:
356 *
357 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
358 * USE_INTUIT_ML
359 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
360 * INTUIT_AUTORITATIVE_ML
361 * INTUIT_ONCE_NOML - Intuit can match in one location only.
362 * INTUIT_ONCE_ML
363 *
364 * Another flag for this function: SECOND_TIME (so that float substrs
365 * with giant delta may be not rechecked).
366 */
367
368/* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
369
370/* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
371 Otherwise, only SvCUR(sv) is used to get strbeg. */
372
373/* XXXX We assume that strpos is strbeg unless sv. */
374
375/* XXXX Some places assume that there is a fixed substring.
376 An update may be needed if optimizer marks as "INTUITable"
377 RExen without fixed substrings. Similarly, it is assumed that
378 lengths of all the strings are no more than minlen, thus they
379 cannot come from lookahead.
380 (Or minlen should take into account lookahead.) */
381
382/* A failure to find a constant substring means that there is no need to make
383 an expensive call to REx engine, thus we celebrate a failure. Similarly,
384 finding a substring too deep into the string means that less calls to
385 regtry() should be needed.
386
387 REx compiler's optimizer found 4 possible hints:
388 a) Anchored substring;
389 b) Fixed substring;
390 c) Whether we are anchored (beginning-of-line or \G);
391 d) First node (of those at offset 0) which may distingush positions;
392 We use a)b)d) and multiline-part of c), and try to find a position in the
393 string which does not contradict any of them.
394 */
395
396/* Most of decisions we do here should have been done at compile time.
397 The nodes of the REx which we used for the search should have been
398 deleted from the finite automaton. */
399
400char *
401Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
402 char *strend, U32 flags, re_scream_pos_data *data)
403{
404 register I32 start_shift = 0;
405 /* Should be nonnegative! */
406 register I32 end_shift = 0;
407 register char *s;
408 register SV *check;
409 char *strbeg;
410 char *t;
411 const int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */
412 I32 ml_anch;
413 register char *other_last = Nullch; /* other substr checked before this */
414 char *check_at = Nullch; /* check substr found at this pos */
415#ifdef DEBUGGING
416 const char * const i_strpos = strpos;
417 SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
418#endif
419 RX_MATCH_UTF8_set(prog,do_utf8);
420
421 if (prog->reganch & ROPT_UTF8) {
422 DEBUG_r(PerlIO_printf(Perl_debug_log,
423 "UTF-8 regex...\n"));
424 PL_reg_flags |= RF_utf8;
425 }
426
427 DEBUG_r({
428 const char *s = PL_reg_match_utf8 ?
429 sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
430 strpos;
431 const int len = PL_reg_match_utf8 ?
432 strlen(s) : strend - strpos;
433 if (!PL_colorset)
434 reginitcolors();
435 if (PL_reg_match_utf8)
436 DEBUG_r(PerlIO_printf(Perl_debug_log,
437 "UTF-8 target...\n"));
438 PerlIO_printf(Perl_debug_log,
439 "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n",
440 PL_colors[4],PL_colors[5],PL_colors[0],
441 prog->precomp,
442 PL_colors[1],
443 (strlen(prog->precomp) > 60 ? "..." : ""),
444 PL_colors[0],
445 (int)(len > 60 ? 60 : len),
446 s, PL_colors[1],
447 (len > 60 ? "..." : "")
448 );
449 });
450
451 /* CHR_DIST() would be more correct here but it makes things slow. */
452 if (prog->minlen > strend - strpos) {
453 DEBUG_r(PerlIO_printf(Perl_debug_log,
454 "String too short... [re_intuit_start]\n"));
455 goto fail;
456 }
457 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
458 PL_regeol = strend;
459 if (do_utf8) {
460 if (!prog->check_utf8 && prog->check_substr)
461 to_utf8_substr(prog);
462 check = prog->check_utf8;
463 } else {
464 if (!prog->check_substr && prog->check_utf8)
465 to_byte_substr(prog);
466 check = prog->check_substr;
467 }
468 if (check == &PL_sv_undef) {
469 DEBUG_r(PerlIO_printf(Perl_debug_log,
470 "Non-utf string cannot match utf check string\n"));
471 goto fail;
472 }
473 if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
474 ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
475 || ( (prog->reganch & ROPT_ANCH_BOL)
476 && !PL_multiline ) ); /* Check after \n? */
477
478 if (!ml_anch) {
479 if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
480 | ROPT_IMPLICIT)) /* not a real BOL */
481 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
482 && sv && !SvROK(sv)
483 && (strpos != strbeg)) {
484 DEBUG_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
485 goto fail;
486 }
487 if (prog->check_offset_min == prog->check_offset_max &&
488 !(prog->reganch & ROPT_CANY_SEEN)) {
489 /* Substring at constant offset from beg-of-str... */
490 I32 slen;
491
492 s = HOP3c(strpos, prog->check_offset_min, strend);
493 if (SvTAIL(check)) {
494 slen = SvCUR(check); /* >= 1 */
495
496 if ( strend - s > slen || strend - s < slen - 1
497 || (strend - s == slen && strend[-1] != '\n')) {
498 DEBUG_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
499 goto fail_finish;
500 }
501 /* Now should match s[0..slen-2] */
502 slen--;
503 if (slen && (*SvPVX_const(check) != *s
504 || (slen > 1
505 && memNE(SvPVX_const(check), s, slen)))) {
506 report_neq:
507 DEBUG_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
508 goto fail_finish;
509 }
510 }
511 else if (*SvPVX_const(check) != *s
512 || ((slen = SvCUR(check)) > 1
513 && memNE(SvPVX_const(check), s, slen)))
514 goto report_neq;
515 check_at = s;
516 goto success_at_start;
517 }
518 }
519 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
520 s = strpos;
521 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
522 end_shift = prog->minlen - start_shift -
523 CHR_SVLEN(check) + (SvTAIL(check) != 0);
524 if (!ml_anch) {
525 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
526 - (SvTAIL(check) != 0);
527 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
528
529 if (end_shift < eshift)
530 end_shift = eshift;
531 }
532 }
533 else { /* Can match at random position */
534 ml_anch = 0;
535 s = strpos;
536 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
537 /* Should be nonnegative! */
538 end_shift = prog->minlen - start_shift -
539 CHR_SVLEN(check) + (SvTAIL(check) != 0);
540 }
541
542#ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
543 if (end_shift < 0)
544 Perl_croak(aTHX_ "panic: end_shift");
545#endif
546
547 restart:
548 /* Find a possible match in the region s..strend by looking for
549 the "check" substring in the region corrected by start/end_shift. */
550 if (flags & REXEC_SCREAM) {
551 I32 p = -1; /* Internal iterator of scream. */
552 I32 * const pp = data ? data->scream_pos : &p;
553
554 if (PL_screamfirst[BmRARE(check)] >= 0
555 || ( BmRARE(check) == '\n'
556 && (BmPREVIOUS(check) == SvCUR(check) - 1)
557 && SvTAIL(check) ))
558 s = screaminstr(sv, check,
559 start_shift + (s - strbeg), end_shift, pp, 0);
560 else
561 goto fail_finish;
562 /* we may be pointing at the wrong string */
563 if (s && RX_MATCH_COPIED(prog))
564 s = strbeg + (s - SvPVX_const(sv));
565 if (data)
566 *data->scream_olds = s;
567 }
568 else if (prog->reganch & ROPT_CANY_SEEN)
569 s = fbm_instr((U8*)(s + start_shift),
570 (U8*)(strend - end_shift),
571 check, PL_multiline ? FBMrf_MULTILINE : 0);
572 else
573 s = fbm_instr(HOP3(s, start_shift, strend),
574 HOP3(strend, -end_shift, strbeg),
575 check, PL_multiline ? FBMrf_MULTILINE : 0);
576
577 /* Update the count-of-usability, remove useless subpatterns,
578 unshift s. */
579
580 /* FIXME - DEBUG_EXECUTE_r if that is merged to maint. */
581 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s",
582 (s ? "Found" : "Did not find"),
583 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
584 PL_colors[0],
585 (int)(SvCUR(check) - (SvTAIL(check)!=0)),
586 SvPVX_const(check),
587 PL_colors[1], (SvTAIL(check) ? "$" : ""),
588 (s ? " at offset " : "...\n") ) );
589
590 if (!s)
591 goto fail_finish;
592
593 check_at = s;
594
595 /* Finish the diagnostic message */
596 DEBUG_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
597
598 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
599 Start with the other substr.
600 XXXX no SCREAM optimization yet - and a very coarse implementation
601 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
602 *always* match. Probably should be marked during compile...
603 Probably it is right to do no SCREAM here...
604 */
605
606 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
607 /* Take into account the "other" substring. */
608 /* XXXX May be hopelessly wrong for UTF... */
609 if (!other_last)
610 other_last = strpos;
611 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
612 do_other_anchored:
613 {
614 char * const last = HOP3c(s, -start_shift, strbeg);
615 char *last1, *last2;
616 char *s1 = s;
617 SV* must;
618
619 t = s - prog->check_offset_max;
620 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
621 && (!do_utf8
622 || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos))
623 && t > strpos)))
624 /* EMPTY */;
625 else
626 t = strpos;
627 t = HOP3c(t, prog->anchored_offset, strend);
628 if (t < other_last) /* These positions already checked */
629 t = other_last;
630 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
631 if (last < last1)
632 last1 = last;
633 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
634 /* On end-of-str: see comment below. */
635 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
636 if (must == &PL_sv_undef) {
637 s = (char*)NULL;
638 DEBUG_r(must = prog->anchored_utf8); /* for debug */
639 }
640 else
641 s = fbm_instr(
642 (unsigned char*)t,
643 HOP3(HOP3(last1, prog->anchored_offset, strend)
644 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
645 must,
646 PL_multiline ? FBMrf_MULTILINE : 0
647 );
648 DEBUG_r(PerlIO_printf(Perl_debug_log,
649 "%s anchored substr \"%s%.*s%s\"%s",
650 (s ? "Found" : "Contradicts"),
651 PL_colors[0],
652 (int)(SvCUR(must)
653 - (SvTAIL(must)!=0)),
654 SvPVX_const(must),
655 PL_colors[1], (SvTAIL(must) ? "$" : "")));
656 if (!s) {
657 if (last1 >= last2) {
658 DEBUG_r(PerlIO_printf(Perl_debug_log,
659 ", giving up...\n"));
660 goto fail_finish;
661 }
662 DEBUG_r(PerlIO_printf(Perl_debug_log,
663 ", trying floating at offset %ld...\n",
664 (long)(HOP3c(s1, 1, strend) - i_strpos)));
665 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
666 s = HOP3c(last, 1, strend);
667 goto restart;
668 }
669 else {
670 DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
671 (long)(s - i_strpos)));
672 t = HOP3c(s, -prog->anchored_offset, strbeg);
673 other_last = HOP3c(s, 1, strend);
674 s = s1;
675 if (t == strpos)
676 goto try_at_start;
677 goto try_at_offset;
678 }
679 }
680 }
681 else { /* Take into account the floating substring. */
682 char *last, *last1;
683 char *s1 = s;
684 SV* must;
685
686 t = HOP3c(s, -start_shift, strbeg);
687 last1 = last =
688 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
689 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
690 last = HOP3c(t, prog->float_max_offset, strend);
691 s = HOP3c(t, prog->float_min_offset, strend);
692 if (s < other_last)
693 s = other_last;
694 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
695 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
696 /* fbm_instr() takes into account exact value of end-of-str
697 if the check is SvTAIL(ed). Since false positives are OK,
698 and end-of-str is not later than strend we are OK. */
699 if (must == &PL_sv_undef) {
700 s = (char*)NULL;
701 DEBUG_r(must = prog->float_utf8); /* for debug message */
702 }
703 else
704 s = fbm_instr((unsigned char*)s,
705 (unsigned char*)last + SvCUR(must)
706 - (SvTAIL(must)!=0),
707 must, PL_multiline ? FBMrf_MULTILINE : 0);
708 /* FIXME - DEBUG_EXECUTE_r if that is merged to maint */
709 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
710 (s ? "Found" : "Contradicts"),
711 PL_colors[0],
712 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
713 SvPVX_const(must),
714 PL_colors[1], (SvTAIL(must) ? "$" : "")));
715 if (!s) {
716 if (last1 == last) {
717 DEBUG_r(PerlIO_printf(Perl_debug_log,
718 ", giving up...\n"));
719 goto fail_finish;
720 }
721 DEBUG_r(PerlIO_printf(Perl_debug_log,
722 ", trying anchored starting at offset %ld...\n",
723 (long)(s1 + 1 - i_strpos)));
724 other_last = last;
725 s = HOP3c(t, 1, strend);
726 goto restart;
727 }
728 else {
729 DEBUG_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
730 (long)(s - i_strpos)));
731 other_last = s; /* Fix this later. --Hugo */
732 s = s1;
733 if (t == strpos)
734 goto try_at_start;
735 goto try_at_offset;
736 }
737 }
738 }
739
740 t = s - prog->check_offset_max;
741 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
742 && (!do_utf8
743 || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos))
744 && t > strpos))) {
745 /* Fixed substring is found far enough so that the match
746 cannot start at strpos. */
747 try_at_offset:
748 if (ml_anch && t[-1] != '\n') {
749 /* Eventually fbm_*() should handle this, but often
750 anchored_offset is not 0, so this check will not be wasted. */
751 /* XXXX In the code below we prefer to look for "^" even in
752 presence of anchored substrings. And we search even
753 beyond the found float position. These pessimizations
754 are historical artefacts only. */
755 find_anchor:
756 while (t < strend - prog->minlen) {
757 if (*t == '\n') {
758 if (t < check_at - prog->check_offset_min) {
759 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
760 /* Since we moved from the found position,
761 we definitely contradict the found anchored
762 substr. Due to the above check we do not
763 contradict "check" substr.
764 Thus we can arrive here only if check substr
765 is float. Redo checking for "other"=="fixed".
766 */
767 strpos = t + 1;
768 DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
769 PL_colors[0],PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
770 goto do_other_anchored;
771 }
772 /* We don't contradict the found floating substring. */
773 /* XXXX Why not check for STCLASS? */
774 s = t + 1;
775 DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
776 PL_colors[0],PL_colors[1], (long)(s - i_strpos)));
777 goto set_useful;
778 }
779 /* Position contradicts check-string */
780 /* XXXX probably better to look for check-string
781 than for "\n", so one should lower the limit for t? */
782 DEBUG_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
783 PL_colors[0],PL_colors[1], (long)(t + 1 - i_strpos)));
784 other_last = strpos = s = t + 1;
785 goto restart;
786 }
787 t++;
788 }
789 DEBUG_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
790 PL_colors[0],PL_colors[1]));
791 goto fail_finish;
792 }
793 else {
794 DEBUG_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
795 PL_colors[0],PL_colors[1]));
796 }
797 s = t;
798 set_useful:
799 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
800 }
801 else {
802 /* The found string does not prohibit matching at strpos,
803 - no optimization of calling REx engine can be performed,
804 unless it was an MBOL and we are not after MBOL,
805 or a future STCLASS check will fail this. */
806 try_at_start:
807 /* Even in this situation we may use MBOL flag if strpos is offset
808 wrt the start of the string. */
809 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
810 && (strpos != strbeg) && strpos[-1] != '\n'
811 /* May be due to an implicit anchor of m{.*foo} */
812 && !(prog->reganch & ROPT_IMPLICIT))
813 {
814 t = strpos;
815 goto find_anchor;
816 }
817 DEBUG_r( if (ml_anch)
818 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
819 (long)(strpos - i_strpos), PL_colors[0],PL_colors[1]);
820 );
821 success_at_start:
822 if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
823 && (do_utf8 ? (
824 prog->check_utf8 /* Could be deleted already */
825 && --BmUSEFUL(prog->check_utf8) < 0
826 && (prog->check_utf8 == prog->float_utf8)
827 ) : (
828 prog->check_substr /* Could be deleted already */
829 && --BmUSEFUL(prog->check_substr) < 0
830 && (prog->check_substr == prog->float_substr)
831 )))
832 {
833 /* If flags & SOMETHING - do not do it many times on the same match */
834 DEBUG_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
835 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
836 if (do_utf8 ? prog->check_substr : prog->check_utf8)
837 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
838 prog->check_substr = prog->check_utf8 = Nullsv; /* disable */
839 prog->float_substr = prog->float_utf8 = Nullsv; /* clear */
840 check = Nullsv; /* abort */
841 s = strpos;
842 /* XXXX This is a remnant of the old implementation. It
843 looks wasteful, since now INTUIT can use many
844 other heuristics. */
845 prog->reganch &= ~RE_USE_INTUIT;
846 }
847 else
848 s = strpos;
849 }
850
851 /* Last resort... */
852 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
853 if (prog->regstclass) {
854 /* minlen == 0 is possible if regstclass is \b or \B,
855 and the fixed substr is ''$.
856 Since minlen is already taken into account, s+1 is before strend;
857 accidentally, minlen >= 1 guaranties no false positives at s + 1
858 even for \b or \B. But (minlen? 1 : 0) below assumes that
859 regstclass does not come from lookahead... */
860 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
861 This leaves EXACTF only, which is dealt with in find_byclass(). */
862 const U8* const str = (U8*)STRING(prog->regstclass);
863 const int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT
864 ? CHR_DIST((U8 *)str+STR_LEN(prog->regstclass),
865 (U8 *)str)
866 : 1);
867 const char * const endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
868 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
869 : (prog->float_substr || prog->float_utf8
870 ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
871 cl_l, strend)
872 : strend);
873
874 t = s;
875 cache_re(prog);
876 s = find_byclass(prog, prog->regstclass, s, endpos, 1);
877 if (!s) {
878#ifdef DEBUGGING
879 const char *what = 0;
880#endif
881 if (endpos == strend) {
882 DEBUG_r( PerlIO_printf(Perl_debug_log,
883 "Could not match STCLASS...\n") );
884 goto fail;
885 }
886 DEBUG_r( PerlIO_printf(Perl_debug_log,
887 "This position contradicts STCLASS...\n") );
888 if ((prog->reganch & ROPT_ANCH) && !ml_anch)
889 goto fail;
890 /* Contradict one of substrings */
891 if (prog->anchored_substr || prog->anchored_utf8) {
892 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
893 DEBUG_r( what = "anchored" );
894 hop_and_restart:
895 s = HOP3c(t, 1, strend);
896 if (s + start_shift + end_shift > strend) {
897 /* XXXX Should be taken into account earlier? */
898 DEBUG_r( PerlIO_printf(Perl_debug_log,
899 "Could not match STCLASS...\n") );
900 goto fail;
901 }
902 if (!check)
903 goto giveup;
904 DEBUG_r( PerlIO_printf(Perl_debug_log,
905 "Looking for %s substr starting at offset %ld...\n",
906 what, (long)(s + start_shift - i_strpos)) );
907 goto restart;
908 }
909 /* Have both, check_string is floating */
910 if (t + start_shift >= check_at) /* Contradicts floating=check */
911 goto retry_floating_check;
912 /* Recheck anchored substring, but not floating... */
913 s = check_at;
914 if (!check)
915 goto giveup;
916 DEBUG_r( PerlIO_printf(Perl_debug_log,
917 "Looking for anchored substr starting at offset %ld...\n",
918 (long)(other_last - i_strpos)) );
919 goto do_other_anchored;
920 }
921 /* Another way we could have checked stclass at the
922 current position only: */
923 if (ml_anch) {
924 s = t = t + 1;
925 if (!check)
926 goto giveup;
927 DEBUG_r( PerlIO_printf(Perl_debug_log,
928 "Looking for /%s^%s/m starting at offset %ld...\n",
929 PL_colors[0],PL_colors[1], (long)(t - i_strpos)) );
930 goto try_at_offset;
931 }
932 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
933 goto fail;
934 /* Check is floating subtring. */
935 retry_floating_check:
936 t = check_at - start_shift;
937 DEBUG_r( what = "floating" );
938 goto hop_and_restart;
939 }
940 if (t != s) {
941 DEBUG_r(PerlIO_printf(Perl_debug_log,
942 "By STCLASS: moving %ld --> %ld\n",
943 (long)(t - i_strpos), (long)(s - i_strpos))
944 );
945 }
946 else {
947 DEBUG_r(PerlIO_printf(Perl_debug_log,
948 "Does not contradict STCLASS...\n");
949 );
950 }
951 }
952 giveup:
953 DEBUG_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
954 PL_colors[4], (check ? "Guessed" : "Giving up"),
955 PL_colors[5], (long)(s - i_strpos)) );
956 return s;
957
958 fail_finish: /* Substring not found */
959 if (prog->check_substr || prog->check_utf8) /* could be removed already */
960 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
961 fail:
962 DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
963 PL_colors[4],PL_colors[5]));
964 return Nullch;
965}
966
967/* We know what class REx starts with. Try to find this position... */
968STATIC char *
969S_find_byclass(pTHX_ regexp * prog, regnode *c, char *s, const char *strend, I32 norun)
970{
971 const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
972 char *m;
973 STRLEN ln;
974 STRLEN lnc;
975 register STRLEN uskip;
976 unsigned int c1;
977 unsigned int c2;
978 char *e;
979 register I32 tmp = 1; /* Scratch variable? */
980 register const bool do_utf8 = PL_reg_match_utf8;
981
982 /* We know what class it must start with. */
983 switch (OP(c)) {
984 case ANYOF:
985 if (do_utf8) {
986 while (s + (uskip = UTF8SKIP(s)) <= strend) {
987 if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
988 !UTF8_IS_INVARIANT((U8)s[0]) ?
989 reginclass(c, (U8*)s, 0, do_utf8) :
990 REGINCLASS(c, (U8*)s)) {
991 if (tmp && (norun || regtry(prog, s)))
992 goto got_it;
993 else
994 tmp = doevery;
995 }
996 else
997 tmp = 1;
998 s += uskip;
999 }
1000 }
1001 else {
1002 while (s < strend) {
1003 STRLEN skip = 1;
1004
1005 if (REGINCLASS(c, (U8*)s) ||
1006 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1007 /* The assignment of 2 is intentional:
1008 * for the folded sharp s, the skip is 2. */
1009 (skip = SHARP_S_SKIP))) {
1010 if (tmp && (norun || regtry(prog, s)))
1011 goto got_it;
1012 else
1013 tmp = doevery;
1014 }
1015 else
1016 tmp = 1;
1017 s += skip;
1018 }
1019 }
1020 break;
1021 case CANY:
1022 while (s < strend) {
1023 if (tmp && (norun || regtry(prog, s)))
1024 goto got_it;
1025 else
1026 tmp = doevery;
1027 s++;
1028 }
1029 break;
1030 case EXACTF:
1031 m = STRING(c);
1032 ln = STR_LEN(c); /* length to match in octets/bytes */
1033 lnc = (I32) ln; /* length to match in characters */
1034 if (UTF) {
1035 STRLEN ulen1, ulen2;
1036 U8 *sm = (U8 *) m;
1037 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1038 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1039 const U32 uniflags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
1040
1041 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1042 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1043
1044 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1045 0, uniflags);
1046 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1047 0, uniflags);
1048 lnc = 0;
1049 while (sm < ((U8 *) m + ln)) {
1050 lnc++;
1051 sm += UTF8SKIP(sm);
1052 }
1053 }
1054 else {
1055 c1 = *(U8*)m;
1056 c2 = PL_fold[c1];
1057 }
1058 goto do_exactf;
1059 case EXACTFL:
1060 m = STRING(c);
1061 ln = STR_LEN(c);
1062 lnc = (I32) ln;
1063 c1 = *(U8*)m;
1064 c2 = PL_fold_locale[c1];
1065 do_exactf:
1066 e = HOP3c(strend, -((I32)lnc), s);
1067
1068 if (norun && e < s)
1069 e = s; /* Due to minlen logic of intuit() */
1070
1071 /* The idea in the EXACTF* cases is to first find the
1072 * first character of the EXACTF* node and then, if
1073 * necessary, case-insensitively compare the full
1074 * text of the node. The c1 and c2 are the first
1075 * characters (though in Unicode it gets a bit
1076 * more complicated because there are more cases
1077 * than just upper and lower: one needs to use
1078 * the so-called folding case for case-insensitive
1079 * matching (called "loose matching" in Unicode).
1080 * ibcmp_utf8() will do just that. */
1081
1082 if (do_utf8) {
1083 UV c, f;
1084 U8 tmpbuf [UTF8_MAXBYTES+1];
1085 STRLEN len, foldlen;
1086 const U32 uniflags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
1087 if (c1 == c2) {
1088 /* Upper and lower of 1st char are equal -
1089 * probably not a "letter". */
1090 while (s <= e) {
1091 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1092 uniflags);
1093 if ( c == c1
1094 && (ln == len ||
1095 ibcmp_utf8(s, (char **)0, 0, do_utf8,
1096 m, (char **)0, ln, (bool)UTF))
1097 && (norun || regtry(prog, s)) )
1098 goto got_it;
1099 else {
1100 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1101 uvchr_to_utf8(tmpbuf, c);
1102 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1103 if ( f != c
1104 && (f == c1 || f == c2)
1105 && (ln == foldlen ||
1106 !ibcmp_utf8((char *) foldbuf,
1107 (char **)0, foldlen, do_utf8,
1108 m,
1109 (char **)0, ln, (bool)UTF))
1110 && (norun || regtry(prog, s)) )
1111 goto got_it;
1112 }
1113 s += len;
1114 }
1115 }
1116 else {
1117 while (s <= e) {
1118 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1119 uniflags);
1120
1121 /* Handle some of the three Greek sigmas cases.
1122 * Note that not all the possible combinations
1123 * are handled here: some of them are handled
1124 * by the standard folding rules, and some of
1125 * them (the character class or ANYOF cases)
1126 * are handled during compiletime in
1127 * regexec.c:S_regclass(). */
1128 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1129 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1130 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1131
1132 if ( (c == c1 || c == c2)
1133 && (ln == len ||
1134 ibcmp_utf8(s, (char **)0, 0, do_utf8,
1135 m, (char **)0, ln, (bool)UTF))
1136 && (norun || regtry(prog, s)) )
1137 goto got_it;
1138 else {
1139 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1140 uvchr_to_utf8(tmpbuf, c);
1141 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1142 if ( f != c
1143 && (f == c1 || f == c2)
1144 && (ln == foldlen ||
1145 !ibcmp_utf8((char *) foldbuf,
1146 (char **)0, foldlen, do_utf8,
1147 m,
1148 (char **)0, ln, (bool)UTF))
1149 && (norun || regtry(prog, s)) )
1150 goto got_it;
1151 }
1152 s += len;
1153 }
1154 }
1155 }
1156 else {
1157 if (c1 == c2)
1158 while (s <= e) {
1159 if ( *(U8*)s == c1
1160 && (ln == 1 || !(OP(c) == EXACTF
1161 ? ibcmp(s, m, ln)
1162 : ibcmp_locale(s, m, ln)))
1163 && (norun || regtry(prog, s)) )
1164 goto got_it;
1165 s++;
1166 }
1167 else
1168 while (s <= e) {
1169 if ( (*(U8*)s == c1 || *(U8*)s == c2)
1170 && (ln == 1 || !(OP(c) == EXACTF
1171 ? ibcmp(s, m, ln)
1172 : ibcmp_locale(s, m, ln)))
1173 && (norun || regtry(prog, s)) )
1174 goto got_it;
1175 s++;
1176 }
1177 }
1178 break;
1179 case BOUNDL:
1180 PL_reg_flags |= RF_tainted;
1181 /* FALL THROUGH */
1182 case BOUND:
1183 if (do_utf8) {
1184 if (s == PL_bostr)
1185 tmp = '\n';
1186 else {
1187 U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1188
1189 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0);
1190 }
1191 tmp = ((OP(c) == BOUND ?
1192 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1193 LOAD_UTF8_CHARCLASS_ALNUM();
1194 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1195 if (tmp == !(OP(c) == BOUND ?
1196 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1197 isALNUM_LC_utf8((U8*)s)))
1198 {
1199 tmp = !tmp;
1200 if ((norun || regtry(prog, s)))
1201 goto got_it;
1202 }
1203 s += uskip;
1204 }
1205 }
1206 else {
1207 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1208 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1209 while (s < strend) {
1210 if (tmp ==
1211 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1212 tmp = !tmp;
1213 if ((norun || regtry(prog, s)))
1214 goto got_it;
1215 }
1216 s++;
1217 }
1218 }
1219 if ((!prog->minlen && tmp) && (norun || regtry(prog, s)))
1220 goto got_it;
1221 break;
1222 case NBOUNDL:
1223 PL_reg_flags |= RF_tainted;
1224 /* FALL THROUGH */
1225 case NBOUND:
1226 if (do_utf8) {
1227 if (s == PL_bostr)
1228 tmp = '\n';
1229 else {
1230 U8 *r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1231
1232 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, 0);
1233 }
1234 tmp = ((OP(c) == NBOUND ?
1235 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1236 LOAD_UTF8_CHARCLASS_ALNUM();
1237 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1238 if (tmp == !(OP(c) == NBOUND ?
1239 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1240 isALNUM_LC_utf8((U8*)s)))
1241 tmp = !tmp;
1242 else if ((norun || regtry(prog, s)))
1243 goto got_it;
1244 s += uskip;
1245 }
1246 }
1247 else {
1248 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1249 tmp = ((OP(c) == NBOUND ?
1250 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1251 while (s < strend) {
1252 if (tmp ==
1253 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1254 tmp = !tmp;
1255 else if ((norun || regtry(prog, s)))
1256 goto got_it;
1257 s++;
1258 }
1259 }
1260 if ((!prog->minlen && !tmp) && (norun || regtry(prog, s)))
1261 goto got_it;
1262 break;
1263 case ALNUM:
1264 if (do_utf8) {
1265 LOAD_UTF8_CHARCLASS_ALNUM();
1266 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1267 if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1268 if (tmp && (norun || regtry(prog, s)))
1269 goto got_it;
1270 else
1271 tmp = doevery;
1272 }
1273 else
1274 tmp = 1;
1275 s += uskip;
1276 }
1277 }
1278 else {
1279 while (s < strend) {
1280 if (isALNUM(*s)) {
1281 if (tmp && (norun || regtry(prog, s)))
1282 goto got_it;
1283 else
1284 tmp = doevery;
1285 }
1286 else
1287 tmp = 1;
1288 s++;
1289 }
1290 }
1291 break;
1292 case ALNUML:
1293 PL_reg_flags |= RF_tainted;
1294 if (do_utf8) {
1295 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1296 if (isALNUM_LC_utf8((U8*)s)) {
1297 if (tmp && (norun || regtry(prog, s)))
1298 goto got_it;
1299 else
1300 tmp = doevery;
1301 }
1302 else
1303 tmp = 1;
1304 s += uskip;
1305 }
1306 }
1307 else {
1308 while (s < strend) {
1309 if (isALNUM_LC(*s)) {
1310 if (tmp && (norun || regtry(prog, s)))
1311 goto got_it;
1312 else
1313 tmp = doevery;
1314 }
1315 else
1316 tmp = 1;
1317 s++;
1318 }
1319 }
1320 break;
1321 case NALNUM:
1322 if (do_utf8) {
1323 LOAD_UTF8_CHARCLASS_ALNUM();
1324 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1325 if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1326 if (tmp && (norun || regtry(prog, s)))
1327 goto got_it;
1328 else
1329 tmp = doevery;
1330 }
1331 else
1332 tmp = 1;
1333 s += uskip;
1334 }
1335 }
1336 else {
1337 while (s < strend) {
1338 if (!isALNUM(*s)) {
1339 if (tmp && (norun || regtry(prog, s)))
1340 goto got_it;
1341 else
1342 tmp = doevery;
1343 }
1344 else
1345 tmp = 1;
1346 s++;
1347 }
1348 }
1349 break;
1350 case NALNUML:
1351 PL_reg_flags |= RF_tainted;
1352 if (do_utf8) {
1353 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1354 if (!isALNUM_LC_utf8((U8*)s)) {
1355 if (tmp && (norun || regtry(prog, s)))
1356 goto got_it;
1357 else
1358 tmp = doevery;
1359 }
1360 else
1361 tmp = 1;
1362 s += uskip;
1363 }
1364 }
1365 else {
1366 while (s < strend) {
1367 if (!isALNUM_LC(*s)) {
1368 if (tmp && (norun || regtry(prog, s)))
1369 goto got_it;
1370 else
1371 tmp = doevery;
1372 }
1373 else
1374 tmp = 1;
1375 s++;
1376 }
1377 }
1378 break;
1379 case SPACE:
1380 if (do_utf8) {
1381 LOAD_UTF8_CHARCLASS_SPACE();
1382 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1383 if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1384 if (tmp && (norun || regtry(prog, s)))
1385 goto got_it;
1386 else
1387 tmp = doevery;
1388 }
1389 else
1390 tmp = 1;
1391 s += uskip;
1392 }
1393 }
1394 else {
1395 while (s < strend) {
1396 if (isSPACE(*s)) {
1397 if (tmp && (norun || regtry(prog, s)))
1398 goto got_it;
1399 else
1400 tmp = doevery;
1401 }
1402 else
1403 tmp = 1;
1404 s++;
1405 }
1406 }
1407 break;
1408 case SPACEL:
1409 PL_reg_flags |= RF_tainted;
1410 if (do_utf8) {
1411 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1412 if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1413 if (tmp && (norun || regtry(prog, s)))
1414 goto got_it;
1415 else
1416 tmp = doevery;
1417 }
1418 else
1419 tmp = 1;
1420 s += uskip;
1421 }
1422 }
1423 else {
1424 while (s < strend) {
1425 if (isSPACE_LC(*s)) {
1426 if (tmp && (norun || regtry(prog, s)))
1427 goto got_it;
1428 else
1429 tmp = doevery;
1430 }
1431 else
1432 tmp = 1;
1433 s++;
1434 }
1435 }
1436 break;
1437 case NSPACE:
1438 if (do_utf8) {
1439 LOAD_UTF8_CHARCLASS_SPACE();
1440 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1441 if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1442 if (tmp && (norun || regtry(prog, s)))
1443 goto got_it;
1444 else
1445 tmp = doevery;
1446 }
1447 else
1448 tmp = 1;
1449 s += uskip;
1450 }
1451 }
1452 else {
1453 while (s < strend) {
1454 if (!isSPACE(*s)) {
1455 if (tmp && (norun || regtry(prog, s)))
1456 goto got_it;
1457 else
1458 tmp = doevery;
1459 }
1460 else
1461 tmp = 1;
1462 s++;
1463 }
1464 }
1465 break;
1466 case NSPACEL:
1467 PL_reg_flags |= RF_tainted;
1468 if (do_utf8) {
1469 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1470 if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1471 if (tmp && (norun || regtry(prog, s)))
1472 goto got_it;
1473 else
1474 tmp = doevery;
1475 }
1476 else
1477 tmp = 1;
1478 s += uskip;
1479 }
1480 }
1481 else {
1482 while (s < strend) {
1483 if (!isSPACE_LC(*s)) {
1484 if (tmp && (norun || regtry(prog, s)))
1485 goto got_it;
1486 else
1487 tmp = doevery;
1488 }
1489 else
1490 tmp = 1;
1491 s++;
1492 }
1493 }
1494 break;
1495 case DIGIT:
1496 if (do_utf8) {
1497 LOAD_UTF8_CHARCLASS_DIGIT();
1498 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1499 if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1500 if (tmp && (norun || regtry(prog, s)))
1501 goto got_it;
1502 else
1503 tmp = doevery;
1504 }
1505 else
1506 tmp = 1;
1507 s += uskip;
1508 }
1509 }
1510 else {
1511 while (s < strend) {
1512 if (isDIGIT(*s)) {
1513 if (tmp && (norun || regtry(prog, s)))
1514 goto got_it;
1515 else
1516 tmp = doevery;
1517 }
1518 else
1519 tmp = 1;
1520 s++;
1521 }
1522 }
1523 break;
1524 case DIGITL:
1525 PL_reg_flags |= RF_tainted;
1526 if (do_utf8) {
1527 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1528 if (isDIGIT_LC_utf8((U8*)s)) {
1529 if (tmp && (norun || regtry(prog, s)))
1530 goto got_it;
1531 else
1532 tmp = doevery;
1533 }
1534 else
1535 tmp = 1;
1536 s += uskip;
1537 }
1538 }
1539 else {
1540 while (s < strend) {
1541 if (isDIGIT_LC(*s)) {
1542 if (tmp && (norun || regtry(prog, s)))
1543 goto got_it;
1544 else
1545 tmp = doevery;
1546 }
1547 else
1548 tmp = 1;
1549 s++;
1550 }
1551 }
1552 break;
1553 case NDIGIT:
1554 if (do_utf8) {
1555 LOAD_UTF8_CHARCLASS_DIGIT();
1556 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1557 if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1558 if (tmp && (norun || regtry(prog, s)))
1559 goto got_it;
1560 else
1561 tmp = doevery;
1562 }
1563 else
1564 tmp = 1;
1565 s += uskip;
1566 }
1567 }
1568 else {
1569 while (s < strend) {
1570 if (!isDIGIT(*s)) {
1571 if (tmp && (norun || regtry(prog, s)))
1572 goto got_it;
1573 else
1574 tmp = doevery;
1575 }
1576 else
1577 tmp = 1;
1578 s++;
1579 }
1580 }
1581 break;
1582 case NDIGITL:
1583 PL_reg_flags |= RF_tainted;
1584 if (do_utf8) {
1585 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1586 if (!isDIGIT_LC_utf8((U8*)s)) {
1587 if (tmp && (norun || regtry(prog, s)))
1588 goto got_it;
1589 else
1590 tmp = doevery;
1591 }
1592 else
1593 tmp = 1;
1594 s += uskip;
1595 }
1596 }
1597 else {
1598 while (s < strend) {
1599 if (!isDIGIT_LC(*s)) {
1600 if (tmp && (norun || regtry(prog, s)))
1601 goto got_it;
1602 else
1603 tmp = doevery;
1604 }
1605 else
1606 tmp = 1;
1607 s++;
1608 }
1609 }
1610 break;
1611 default:
1612 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1613 break;
1614 }
1615 return 0;
1616 got_it:
1617 return s;
1618}
1619
1620/*
1621 - regexec_flags - match a regexp against a string
1622 */
1623I32
1624Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1625 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1626/* strend: pointer to null at end of string */
1627/* strbeg: real beginning of string */
1628/* minend: end of match must be >=minend after stringarg. */
1629/* data: May be used for some additional optimizations. */
1630/* nosave: For optimizations. */
1631{
1632 register char *s;
1633 register regnode *c;
1634 register char *startpos = stringarg;
1635 I32 minlen; /* must match at least this many chars */
1636 I32 dontbother = 0; /* how many characters not to try at end */
1637 I32 end_shift = 0; /* Same for the end. */ /* CC */
1638 I32 scream_pos = -1; /* Internal iterator of scream. */
1639 char *scream_olds;
1640 SV* oreplsv = GvSV(PL_replgv);
1641 const bool do_utf8 = DO_UTF8(sv);
1642#ifdef DEBUGGING
1643 SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
1644 SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
1645#endif
1646 PERL_UNUSED_ARG(data);
1647 RX_MATCH_UTF8_set(prog,do_utf8);
1648
1649 PL_regcc = 0;
1650
1651 cache_re(prog);
1652#ifdef DEBUGGING
1653 PL_regnarrate = DEBUG_r_TEST;
1654#endif
1655
1656 /* Be paranoid... */
1657 if (prog == NULL || startpos == NULL) {
1658 Perl_croak(aTHX_ "NULL regexp parameter");
1659 return 0;
1660 }
1661
1662 minlen = prog->minlen;
1663 if (strend - startpos < minlen) {
1664 DEBUG_r(PerlIO_printf(Perl_debug_log,
1665 "String too short [regexec_flags]...\n"));
1666 goto phooey;
1667 }
1668
1669 /* Check validity of program. */
1670 if (UCHARAT(prog->program) != REG_MAGIC) {
1671 Perl_croak(aTHX_ "corrupted regexp program");
1672 }
1673
1674 PL_reg_flags = 0;
1675 PL_reg_eval_set = 0;
1676 PL_reg_maxiter = 0;
1677
1678 if (prog->reganch & ROPT_UTF8)
1679 PL_reg_flags |= RF_utf8;
1680
1681 /* Mark beginning of line for ^ and lookbehind. */
1682 PL_regbol = startpos;
1683 PL_bostr = strbeg;
1684 PL_reg_sv = sv;
1685
1686 /* Mark end of line for $ (and such) */
1687 PL_regeol = strend;
1688
1689 /* see how far we have to get to not match where we matched before */
1690 PL_regtill = startpos+minend;
1691
1692 /* We start without call_cc context. */
1693 PL_reg_call_cc = 0;
1694
1695 /* If there is a "must appear" string, look for it. */
1696 s = startpos;
1697
1698 if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to have PL_reg_ganch */
1699 MAGIC *mg;
1700
1701 if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
1702 PL_reg_ganch = startpos;
1703 else if (sv && SvTYPE(sv) >= SVt_PVMG
1704 && SvMAGIC(sv)
1705 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1706 && mg->mg_len >= 0) {
1707 PL_reg_ganch = strbeg + mg->mg_len; /* Defined pos() */
1708 if (prog->reganch & ROPT_ANCH_GPOS) {
1709 if (s > PL_reg_ganch)
1710 goto phooey;
1711 s = PL_reg_ganch;
1712 }
1713 }
1714 else /* pos() not defined */
1715 PL_reg_ganch = strbeg;
1716 }
1717
1718 if (!(flags & REXEC_CHECKED) && (prog->check_substr != Nullsv || prog->check_utf8 != Nullsv)) {
1719 re_scream_pos_data d;
1720
1721 d.scream_olds = &scream_olds;
1722 d.scream_pos = &scream_pos;
1723 s = re_intuit_start(prog, sv, s, strend, flags, &d);
1724 if (!s) {
1725 DEBUG_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1726 goto phooey; /* not present */
1727 }
1728 }
1729
1730 DEBUG_r({
1731 const char * const s0 = UTF
1732 ? pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
1733 UNI_DISPLAY_REGEX)
1734 : prog->precomp;
1735 const int len0 = UTF ? SvCUR(dsv0) : prog->prelen;
1736 const char * const s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60,
1737 UNI_DISPLAY_REGEX) : startpos;
1738 const int len1 = do_utf8 ? SvCUR(dsv1) : strend - startpos;
1739 if (!PL_colorset)
1740 reginitcolors();
1741 PerlIO_printf(Perl_debug_log,
1742 "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n",
1743 PL_colors[4],PL_colors[5],PL_colors[0],
1744 len0, len0, s0,
1745 PL_colors[1],
1746 len0 > 60 ? "..." : "",
1747 PL_colors[0],
1748 (int)(len1 > 60 ? 60 : len1),
1749 s1, PL_colors[1],
1750 (len1 > 60 ? "..." : "")
1751 );
1752 });
1753
1754 /* Simplest case: anchored match need be tried only once. */
1755 /* [unless only anchor is BOL and multiline is set] */
1756 if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1757 if (s == startpos && regtry(prog, startpos))
1758 goto got_it;
1759 else if (PL_multiline || (prog->reganch & ROPT_IMPLICIT)
1760 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1761 {
1762 char *end;
1763
1764 if (minlen)
1765 dontbother = minlen - 1;
1766 end = HOP3c(strend, -dontbother, strbeg) - 1;
1767 /* for multiline we only have to try after newlines */
1768 if (prog->check_substr || prog->check_utf8) {
1769 if (s == startpos)
1770 goto after_try;
1771 while (1) {
1772 if (regtry(prog, s))
1773 goto got_it;
1774 after_try:
1775 if (s >= end)
1776 goto phooey;
1777 if (prog->reganch & RE_USE_INTUIT) {
1778 s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1779 if (!s)
1780 goto phooey;
1781 }
1782 else
1783 s++;
1784 }
1785 } else {
1786 if (s > startpos)
1787 s--;
1788 while (s < end) {
1789 if (*s++ == '\n') { /* don't need PL_utf8skip here */
1790 if (regtry(prog, s))
1791 goto got_it;
1792 }
1793 }
1794 }
1795 }
1796 goto phooey;
1797 } else if (prog->reganch & ROPT_ANCH_GPOS) {
1798 if (regtry(prog, PL_reg_ganch))
1799 goto got_it;
1800 goto phooey;
1801 }
1802
1803 /* Messy cases: unanchored match. */
1804 if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1805 /* we have /x+whatever/ */
1806 /* it must be a one character string (XXXX Except UTF?) */
1807 char ch;
1808#ifdef DEBUGGING
1809 int did_match = 0;
1810#endif
1811 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1812 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1813 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1814
1815 if (do_utf8) {
1816 while (s < strend) {
1817 if (*s == ch) {
1818 DEBUG_r( did_match = 1 );
1819 if (regtry(prog, s)) goto got_it;
1820 s += UTF8SKIP(s);
1821 while (s < strend && *s == ch)
1822 s += UTF8SKIP(s);
1823 }
1824 s += UTF8SKIP(s);
1825 }
1826 }
1827 else {
1828 while (s < strend) {
1829 if (*s == ch) {
1830 DEBUG_r( did_match = 1 );
1831 if (regtry(prog, s)) goto got_it;
1832 s++;
1833 while (s < strend && *s == ch)
1834 s++;
1835 }
1836 s++;
1837 }
1838 }
1839 DEBUG_r(if (!did_match)
1840 PerlIO_printf(Perl_debug_log,
1841 "Did not find anchored character...\n")
1842 );
1843 }
1844 else if (prog->anchored_substr != Nullsv
1845 || prog->anchored_utf8 != Nullsv
1846 || ((prog->float_substr != Nullsv || prog->float_utf8 != Nullsv)
1847 && prog->float_max_offset < strend - s)) {
1848 SV *must;
1849 I32 back_max;
1850 I32 back_min;
1851 char *last;
1852 char *last1; /* Last position checked before */
1853#ifdef DEBUGGING
1854 int did_match = 0;
1855#endif
1856 if (prog->anchored_substr || prog->anchored_utf8) {
1857 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1858 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1859 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1860 back_max = back_min = prog->anchored_offset;
1861 } else {
1862 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1863 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1864 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1865 back_max = prog->float_max_offset;
1866 back_min = prog->float_min_offset;
1867 }
1868 if (must == &PL_sv_undef)
1869 /* could not downgrade utf8 check substring, so must fail */
1870 goto phooey;
1871
1872 last = HOP3c(strend, /* Cannot start after this */
1873 -(I32)(CHR_SVLEN(must)
1874 - (SvTAIL(must) != 0) + back_min), strbeg);
1875
1876 if (s > PL_bostr)
1877 last1 = HOPc(s, -1);
1878 else
1879 last1 = s - 1; /* bogus */
1880
1881 /* XXXX check_substr already used to find "s", can optimize if
1882 check_substr==must. */
1883 scream_pos = -1;
1884 dontbother = end_shift;
1885 strend = HOPc(strend, -dontbother);
1886 while ( (s <= last) &&
1887 ((flags & REXEC_SCREAM)
1888 ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
1889 end_shift, &scream_pos, 0))
1890 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
1891 (unsigned char*)strend, must,
1892 PL_multiline ? FBMrf_MULTILINE : 0))) ) {
1893 /* we may be pointing at the wrong string */
1894 if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
1895 s = strbeg + (s - SvPVX_const(sv));
1896 DEBUG_r( did_match = 1 );
1897 if (HOPc(s, -back_max) > last1) {
1898 last1 = HOPc(s, -back_min);
1899 s = HOPc(s, -back_max);
1900 }
1901 else {
1902 char *t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1903
1904 last1 = HOPc(s, -back_min);
1905 s = t;
1906 }
1907 if (do_utf8) {
1908 while (s <= last1) {
1909 if (regtry(prog, s))
1910 goto got_it;
1911 s += UTF8SKIP(s);
1912 }
1913 }
1914 else {
1915 while (s <= last1) {
1916 if (regtry(prog, s))
1917 goto got_it;
1918 s++;
1919 }
1920 }
1921 }
1922 DEBUG_r(if (!did_match)
1923 PerlIO_printf(Perl_debug_log,
1924 "Did not find %s substr \"%s%.*s%s\"%s...\n",
1925 ((must == prog->anchored_substr || must == prog->anchored_utf8)
1926 ? "anchored" : "floating"),
1927 PL_colors[0],
1928 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
1929 SvPVX_const(must),
1930 PL_colors[1], (SvTAIL(must) ? "$" : ""))
1931 );
1932 goto phooey;
1933 }
1934 else if ((c = prog->regstclass)) {
1935 if (minlen) {
1936 I32 op = (U8)OP(prog->regstclass);
1937 /* don't bother with what can't match */
1938 if (PL_regkind[op] != EXACT && op != CANY)
1939 strend = HOPc(strend, -(minlen - 1));
1940 }
1941 DEBUG_r({
1942 SV *prop = sv_newmortal();
1943 const char *s0;
1944 const char *s1;
1945 int len0;
1946 int len1;
1947
1948 regprop(prop, c);
1949 s0 = UTF ?
1950 pv_uni_display(dsv0, (U8*)SvPVX_const(prop), SvCUR(prop), 60,
1951 UNI_DISPLAY_REGEX) :
1952 SvPVX_const(prop);
1953 len0 = UTF ? SvCUR(dsv0) : SvCUR(prop);
1954 s1 = UTF ?
1955 sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
1956 len1 = UTF ? SvCUR(dsv1) : strend - s;
1957 PerlIO_printf(Perl_debug_log,
1958 "Matching stclass \"%*.*s\" against \"%*.*s\"\n",
1959 len0, len0, s0,
1960 len1, len1, s1);
1961 });
1962 if (find_byclass(prog, c, s, strend, 0))
1963 goto got_it;
1964 DEBUG_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
1965 }
1966 else {
1967 dontbother = 0;
1968 if (prog->float_substr != Nullsv || prog->float_utf8 != Nullsv) {
1969 /* Trim the end. */
1970 char *last;
1971 SV* float_real;
1972
1973 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1974 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1975 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
1976
1977 if (flags & REXEC_SCREAM) {
1978 last = screaminstr(sv, float_real, s - strbeg,
1979 end_shift, &scream_pos, 1); /* last one */
1980 if (!last)
1981 last = scream_olds; /* Only one occurrence. */
1982 /* we may be pointing at the wrong string */
1983 else if (RX_MATCH_COPIED(prog))
1984 s = strbeg + (s - SvPVX_const(sv));
1985 }
1986 else {
1987 STRLEN len;
1988 const char * const little = SvPV_const(float_real, len);
1989
1990 if (SvTAIL(float_real)) {
1991 if (memEQ(strend - len + 1, little, len - 1))
1992 last = strend - len + 1;
1993 else if (!PL_multiline)
1994 last = memEQ(strend - len, little, len)
1995 ? strend - len : Nullch;
1996 else
1997 goto find_last;
1998 } else {
1999 find_last:
2000 if (len)
2001 last = rninstr(s, strend, little, little + len);
2002 else
2003 last = strend; /* matching "$" */
2004 }
2005 }
2006 if (last == NULL) {
2007 DEBUG_r(PerlIO_printf(Perl_debug_log,
2008 "%sCan't trim the tail, match fails (should not happen)%s\n",
2009 PL_colors[4],PL_colors[5]));
2010 goto phooey; /* Should not happen! */
2011 }
2012 dontbother = strend - last + prog->float_min_offset;
2013 }
2014 if (minlen && (dontbother < minlen))
2015 dontbother = minlen - 1;
2016 strend -= dontbother; /* this one's always in bytes! */
2017 /* We don't know much -- general case. */
2018 if (do_utf8) {
2019 for (;;) {
2020 if (regtry(prog, s))
2021 goto got_it;
2022 if (s >= strend)
2023 break;
2024 s += UTF8SKIP(s);
2025 };
2026 }
2027 else {
2028 do {
2029 if (regtry(prog, s))
2030 goto got_it;
2031 } while (s++ < strend);
2032 }
2033 }
2034
2035 /* Failure. */
2036 goto phooey;
2037
2038got_it:
2039 RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2040
2041 if (PL_reg_eval_set) {
2042 /* Preserve the current value of $^R */
2043 if (oreplsv != GvSV(PL_replgv))
2044 sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2045 restored, the value remains
2046 the same. */
2047 restore_pos(aTHX_ 0);
2048 }
2049
2050 /* make sure $`, $&, $', and $digit will work later */
2051 if ( !(flags & REXEC_NOT_FIRST) ) {
2052 if (RX_MATCH_COPIED(prog)) {
2053 Safefree(prog->subbeg);
2054 RX_MATCH_COPIED_off(prog);
2055 }
2056 if (flags & REXEC_COPY_STR) {
2057 I32 i = PL_regeol - startpos + (stringarg - strbeg);
2058
2059 s = savepvn(strbeg, i);
2060 prog->subbeg = s;
2061 prog->sublen = i;
2062 RX_MATCH_COPIED_on(prog);
2063 }
2064 else {
2065 prog->subbeg = strbeg;
2066 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2067 }
2068 }
2069
2070 return 1;
2071
2072phooey:
2073 DEBUG_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2074 PL_colors[4],PL_colors[5]));
2075 if (PL_reg_eval_set)
2076 restore_pos(aTHX_ 0);
2077 return 0;
2078}
2079
2080/*
2081 - regtry - try match at specific point
2082 */
2083STATIC I32 /* 0 failure, 1 success */
2084S_regtry(pTHX_ regexp *prog, char *startpos)
2085{
2086 register I32 i;
2087 register I32 *sp;
2088 register I32 *ep;
2089 CHECKPOINT lastcp;
2090
2091#ifdef DEBUGGING
2092 PL_regindent = 0; /* XXXX Not good when matches are reenterable... */
2093#endif
2094 if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2095 MAGIC *mg;
2096
2097 PL_reg_eval_set = RS_init;
2098 DEBUG_r(DEBUG_s(
2099 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2100 (IV)(PL_stack_sp - PL_stack_base));
2101 ));
2102 SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2103 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2104 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2105 SAVETMPS;
2106 /* Apparently this is not needed, judging by wantarray. */
2107 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2108 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2109
2110 if (PL_reg_sv) {
2111 /* Make $_ available to executed code. */
2112 if (PL_reg_sv != DEFSV) {
2113 /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
2114 SAVESPTR(DEFSV);
2115 DEFSV = PL_reg_sv;
2116 }
2117
2118 if (!(SvTYPE(PL_reg_sv) >= SVt_PVMG && SvMAGIC(PL_reg_sv)
2119 && (mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global)))) {
2120 /* prepare for quick setting of pos */
2121 sv_magic(PL_reg_sv, (SV*)0,
2122 PERL_MAGIC_regex_global, Nullch, 0);
2123 mg = mg_find(PL_reg_sv, PERL_MAGIC_regex_global);
2124 mg->mg_len = -1;
2125 }
2126 PL_reg_magic = mg;
2127 PL_reg_oldpos = mg->mg_len;
2128 SAVEDESTRUCTOR_X(restore_pos, 0);
2129 }
2130 if (!PL_reg_curpm) {
2131 Newxz(PL_reg_curpm, 1, PMOP);
2132#ifdef USE_ITHREADS
2133 {
2134 SV* repointer = newSViv(0);
2135 /* so we know which PL_regex_padav element is PL_reg_curpm */
2136 SvFLAGS(repointer) |= SVf_BREAK;
2137 av_push(PL_regex_padav,repointer);
2138 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2139 PL_regex_pad = AvARRAY(PL_regex_padav);
2140 }
2141#endif
2142 }
2143 PM_SETRE(PL_reg_curpm, prog);
2144 PL_reg_oldcurpm = PL_curpm;
2145 PL_curpm = PL_reg_curpm;
2146 if (RX_MATCH_COPIED(prog)) {
2147 /* Here is a serious problem: we cannot rewrite subbeg,
2148 since it may be needed if this match fails. Thus
2149 $` inside (?{}) could fail... */
2150 PL_reg_oldsaved = prog->subbeg;
2151 PL_reg_oldsavedlen = prog->sublen;
2152 RX_MATCH_COPIED_off(prog);
2153 }
2154 else
2155 PL_reg_oldsaved = Nullch;
2156 prog->subbeg = PL_bostr;
2157 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2158 }
2159 prog->startp[0] = startpos - PL_bostr;
2160 PL_reginput = startpos;
2161 PL_regstartp = prog->startp;
2162 PL_regendp = prog->endp;
2163 PL_reglastparen = &prog->lastparen;
2164 PL_reglastcloseparen = &prog->lastcloseparen;
2165 prog->lastparen = 0;
2166 prog->lastcloseparen = 0;
2167 PL_regsize = 0;
2168 DEBUG_r(PL_reg_starttry = startpos);
2169 if (PL_reg_start_tmpl <= prog->nparens) {
2170 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2171 if(PL_reg_start_tmp)
2172 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2173 else
2174 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2175 }
2176
2177 /* XXXX What this code is doing here?!!! There should be no need
2178 to do this again and again, PL_reglastparen should take care of
2179 this! --ilya*/
2180
2181 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2182 * Actually, the code in regcppop() (which Ilya may be meaning by
2183 * PL_reglastparen), is not needed at all by the test suite
2184 * (op/regexp, op/pat, op/split), but that code is needed, oddly
2185 * enough, for building DynaLoader, or otherwise this
2186 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2187 * will happen. Meanwhile, this code *is* needed for the
2188 * above-mentioned test suite tests to succeed. The common theme
2189 * on those tests seems to be returning null fields from matches.
2190 * --jhi */
2191#if 1
2192 sp = prog->startp;
2193 ep = prog->endp;
2194 if (prog->nparens) {
2195 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2196 *++sp = -1;
2197 *++ep = -1;
2198 }
2199 }
2200#endif
2201 REGCP_SET(lastcp);
2202 if (regmatch(prog->program + 1)) {
2203 prog->endp[0] = PL_reginput - PL_bostr;
2204 return 1;
2205 }
2206 REGCP_UNWIND(lastcp);
2207 return 0;
2208}
2209
2210#define RE_UNWIND_BRANCH 1
2211#define RE_UNWIND_BRANCHJ 2
2212
2213union re_unwind_t;
2214
2215typedef struct { /* XX: makes sense to enlarge it... */
2216 I32 type;
2217 I32 prev;
2218 CHECKPOINT lastcp;
2219} re_unwind_generic_t;
2220
2221typedef struct {
2222 I32 type;
2223 I32 prev;
2224 CHECKPOINT lastcp;
2225 I32 lastparen;
2226 regnode *next;
2227 char *locinput;
2228 I32 nextchr;
2229#ifdef DEBUGGING
2230 int regindent;
2231#endif
2232} re_unwind_branch_t;
2233
2234typedef union re_unwind_t {
2235 I32 type;
2236 re_unwind_generic_t generic;
2237 re_unwind_branch_t branch;
2238} re_unwind_t;
2239
2240#define sayYES goto yes
2241#define sayNO goto no
2242#define sayNO_ANYOF goto no_anyof
2243#define sayYES_FINAL goto yes_final
2244#define sayYES_LOUD goto yes_loud
2245#define sayNO_FINAL goto no_final
2246#define sayNO_SILENT goto do_no
2247#define saySAME(x) if (x) goto yes; else goto no
2248
2249#define POSCACHE_SUCCESS 0 /* caching success rather than failure */
2250#define POSCACHE_SEEN 1 /* we know what we're caching */
2251#define POSCACHE_START 2 /* the real cache: this bit maps to pos 0 */
2252#define CACHEsayYES STMT_START { \
2253 if (cache_offset | cache_bit) { \
2254 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) \
2255 PL_reg_poscache[0] |= (1<<POSCACHE_SUCCESS) || (1<<POSCACHE_SEEN); \
2256 else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2257 /* cache records failure, but this is success */ \
2258 DEBUG_r( \
2259 PerlIO_printf(Perl_debug_log, \
2260 "%*s (remove success from failure cache)\n", \
2261 REPORT_CODE_OFF+PL_regindent*2, "") \
2262 ); \
2263 PL_reg_poscache[cache_offset] &= ~(1<<cache_bit); \
2264 } \
2265 } \
2266 sayYES; \
2267} STMT_END
2268#define CACHEsayNO STMT_START { \
2269 if (cache_offset | cache_bit) { \
2270 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) \
2271 PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2272 else if ((PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2273 /* cache records success, but this is failure */ \
2274 DEBUG_r( \
2275 PerlIO_printf(Perl_debug_log, \
2276 "%*s (remove failure from success cache)\n", \
2277 REPORT_CODE_OFF+PL_regindent*2, "") \
2278 ); \
2279 PL_reg_poscache[cache_offset] &= ~(1<<cache_bit); \
2280 } \
2281 } \
2282 sayNO; \
2283} STMT_END
2284
2285#define REPORT_CODE_OFF 24
2286
2287/*
2288 - regmatch - main matching routine
2289 *
2290 * Conceptually the strategy is simple: check to see whether the current
2291 * node matches, call self recursively to see whether the rest matches,
2292 * and then act accordingly. In practice we make some effort to avoid
2293 * recursion, in particular by going through "ordinary" nodes (that don't
2294 * need to know whether the rest of the match failed) by a loop instead of
2295 * by recursion.
2296 */
2297/* [lwall] I've hoisted the register declarations to the outer block in order to
2298 * maybe save a little bit of pushing and popping on the stack. It also takes
2299 * advantage of machines that use a register save mask on subroutine entry.
2300 */
2301STATIC I32 /* 0 failure, 1 success */
2302S_regmatch(pTHX_ regnode *prog)
2303{
2304 register regnode *scan; /* Current node. */
2305 regnode *next; /* Next node. */
2306 regnode *inner; /* Next node in internal branch. */
2307 register I32 nextchr; /* renamed nextchr - nextchar colides with
2308 function of same name */
2309 register I32 n; /* no or next */
2310 register I32 ln = 0; /* len or last */
2311 register char *s = Nullch; /* operand or save */
2312 register char *locinput = PL_reginput;
2313 register I32 c1 = 0, c2 = 0, paren; /* case fold search, parenth */
2314 int minmod = 0, sw = 0, logical = 0;
2315 I32 unwind = 0;
2316#if 0
2317 I32 firstcp = PL_savestack_ix;
2318#endif
2319 register const bool do_utf8 = PL_reg_match_utf8;
2320#ifdef DEBUGGING
2321 SV *dsv0 = PERL_DEBUG_PAD_ZERO(0);
2322 SV *dsv1 = PERL_DEBUG_PAD_ZERO(1);
2323 SV *dsv2 = PERL_DEBUG_PAD_ZERO(2);
2324#endif
2325 U32 uniflags = ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY;
2326
2327#ifdef DEBUGGING
2328 PL_regindent++;
2329#endif
2330
2331 /* Note that nextchr is a byte even in UTF */
2332 nextchr = UCHARAT(locinput);
2333 scan = prog;
2334 while (scan != NULL) {
2335
2336 DEBUG_r( {
2337 SV *prop = sv_newmortal();
2338 const int docolor = *PL_colors[0];
2339 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2340 int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2341 /* The part of the string before starttry has one color
2342 (pref0_len chars), between starttry and current
2343 position another one (pref_len - pref0_len chars),
2344 after the current position the third one.
2345 We assume that pref0_len <= pref_len, otherwise we
2346 decrease pref0_len. */
2347 int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2348 ? (5 + taill) - l : locinput - PL_bostr;
2349 int pref0_len;
2350
2351 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2352 pref_len++;
2353 pref0_len = pref_len - (locinput - PL_reg_starttry);
2354 if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2355 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2356 ? (5 + taill) - pref_len : PL_regeol - locinput);
2357 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2358 l--;
2359 if (pref0_len < 0)
2360 pref0_len = 0;
2361 if (pref0_len > pref_len)
2362 pref0_len = pref_len;
2363 regprop(prop, scan);
2364 {
2365 const char * const s0 =
2366 do_utf8 && OP(scan) != CANY ?
2367 pv_uni_display(dsv0, (U8*)(locinput - pref_len),
2368 pref0_len, 60, UNI_DISPLAY_REGEX) :
2369 locinput - pref_len;
2370 const int len0 = do_utf8 ? strlen(s0) : pref0_len;
2371 const char * const s1 = do_utf8 && OP(scan) != CANY ?
2372 pv_uni_display(dsv1, (U8*)(locinput - pref_len + pref0_len),
2373 pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2374 locinput - pref_len + pref0_len;
2375 const int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
2376 const char * const s2 = do_utf8 && OP(scan) != CANY ?
2377 pv_uni_display(dsv2, (U8*)locinput,
2378 PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2379 locinput;
2380 const int len2 = do_utf8 ? strlen(s2) : l;
2381 PerlIO_printf(Perl_debug_log,
2382 "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2383 (IV)(locinput - PL_bostr),
2384 PL_colors[4],
2385 len0, s0,
2386 PL_colors[5],
2387 PL_colors[2],
2388 len1, s1,
2389 PL_colors[3],
2390 (docolor ? "" : "> <"),
2391 PL_colors[0],
2392 len2, s2,
2393 PL_colors[1],
2394 15 - l - pref_len + 1,
2395 "",
2396 (IV)(scan - PL_regprogram), PL_regindent*2, "",
2397 SvPVX_const(prop));
2398 }
2399 });
2400
2401 next = scan + NEXT_OFF(scan);
2402 if (next == scan)
2403 next = NULL;
2404
2405 switch (OP(scan)) {
2406 case BOL:
2407 if (locinput == PL_bostr || (PL_multiline &&
2408 (nextchr || locinput < PL_regeol) && locinput[-1] == '\n') )
2409 {
2410 /* regtill = regbol; */
2411 break;
2412 }
2413 sayNO;
2414 case MBOL:
2415 if (locinput == PL_bostr ||
2416 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2417 {
2418 break;
2419 }
2420 sayNO;
2421 case SBOL:
2422 if (locinput == PL_bostr)
2423 break;
2424 sayNO;
2425 case GPOS:
2426 if (locinput == PL_reg_ganch)
2427 break;
2428 sayNO;
2429 case EOL:
2430 if (PL_multiline)
2431 goto meol;
2432 else
2433 goto seol;
2434 case MEOL:
2435 meol:
2436 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2437 sayNO;
2438 break;
2439 case SEOL:
2440 seol:
2441 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2442 sayNO;
2443 if (PL_regeol - locinput > 1)
2444 sayNO;
2445 break;
2446 case EOS:
2447 if (PL_regeol != locinput)
2448 sayNO;
2449 break;
2450 case SANY:
2451 if (!nextchr && locinput >= PL_regeol)
2452 sayNO;
2453 if (do_utf8) {
2454 locinput += PL_utf8skip[nextchr];
2455 if (locinput > PL_regeol)
2456 sayNO;
2457 nextchr = UCHARAT(locinput);
2458 }
2459 else
2460 nextchr = UCHARAT(++locinput);
2461 break;
2462 case CANY:
2463 if (!nextchr && locinput >= PL_regeol)
2464 sayNO;
2465 nextchr = UCHARAT(++locinput);
2466 break;
2467 case REG_ANY:
2468 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2469 sayNO;
2470 if (do_utf8) {
2471 locinput += PL_utf8skip[nextchr];
2472 if (locinput > PL_regeol)
2473 sayNO;
2474 nextchr = UCHARAT(locinput);
2475 }
2476 else
2477 nextchr = UCHARAT(++locinput);
2478 break;
2479 case EXACT:
2480 s = STRING(scan);
2481 ln = STR_LEN(scan);
2482 if (do_utf8 != UTF) {
2483 /* The target and the pattern have differing utf8ness. */
2484 char *l = locinput;
2485 const char *e = s + ln;
2486
2487 if (do_utf8) {
2488 /* The target is utf8, the pattern is not utf8. */
2489 while (s < e) {
2490 STRLEN ulen;
2491 if (l >= PL_regeol)
2492 sayNO;
2493 if (NATIVE_TO_UNI(*(U8*)s) !=
2494 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
2495 uniflags))
2496 sayNO;
2497 l += ulen;
2498 s ++;
2499 }
2500 }
2501 else {
2502 /* The target is not utf8, the pattern is utf8. */
2503 while (s < e) {
2504 STRLEN ulen;
2505 if (l >= PL_regeol)
2506 sayNO;
2507 if (NATIVE_TO_UNI(*((U8*)l)) !=
2508 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
2509 uniflags))
2510 sayNO;
2511 s += ulen;
2512 l ++;
2513 }
2514 }
2515 locinput = l;
2516 nextchr = UCHARAT(locinput);
2517 break;
2518 }
2519 /* The target and the pattern have the same utf8ness. */
2520 /* Inline the first character, for speed. */
2521 if (UCHARAT(s) != nextchr)
2522 sayNO;
2523 if (PL_regeol - locinput < ln)
2524 sayNO;
2525 if (ln > 1 && memNE(s, locinput, ln))
2526 sayNO;
2527 locinput += ln;
2528 nextchr = UCHARAT(locinput);
2529 break;
2530 case EXACTFL:
2531 PL_reg_flags |= RF_tainted;
2532 /* FALL THROUGH */
2533 case EXACTF:
2534 s = STRING(scan);
2535 ln = STR_LEN(scan);
2536
2537 if (do_utf8 || UTF) {
2538 /* Either target or the pattern are utf8. */
2539 char *l = locinput;
2540 char *e = PL_regeol;
2541
2542 if (ibcmp_utf8(s, 0, ln, (bool)UTF,
2543 l, &e, 0, do_utf8)) {
2544 /* One more case for the sharp s:
2545 * pack("U0U*", 0xDF) =~ /ss/i,
2546 * the 0xC3 0x9F are the UTF-8
2547 * byte sequence for the U+00DF. */
2548 if (!(do_utf8 &&
2549 toLOWER(s[0]) == 's' &&
2550 ln >= 2 &&
2551 toLOWER(s[1]) == 's' &&
2552 (U8)l[0] == 0xC3 &&
2553 e - l >= 2 &&
2554 (U8)l[1] == 0x9F))
2555 sayNO;
2556 }
2557 locinput = e;
2558 nextchr = UCHARAT(locinput);
2559 break;
2560 }
2561
2562 /* Neither the target and the pattern are utf8. */
2563
2564 /* Inline the first character, for speed. */
2565 if (UCHARAT(s) != nextchr &&
2566 UCHARAT(s) != ((OP(scan) == EXACTF)
2567 ? PL_fold : PL_fold_locale)[nextchr])
2568 sayNO;
2569 if (PL_regeol - locinput < ln)
2570 sayNO;
2571 if (ln > 1 && (OP(scan) == EXACTF
2572 ? ibcmp(s, locinput, ln)
2573 : ibcmp_locale(s, locinput, ln)))
2574 sayNO;
2575 locinput += ln;
2576 nextchr = UCHARAT(locinput);
2577 break;
2578 case ANYOF:
2579 if (do_utf8) {
2580 STRLEN inclasslen = PL_regeol - locinput;
2581
2582 if (!reginclass(scan, (U8*)locinput, &inclasslen, do_utf8))
2583 sayNO_ANYOF;
2584 if (locinput >= PL_regeol)
2585 sayNO;
2586 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
2587 nextchr = UCHARAT(locinput);
2588 break;
2589 }
2590 else {
2591 if (nextchr < 0)
2592 nextchr = UCHARAT(locinput);
2593 if (!REGINCLASS(scan, (U8*)locinput))
2594 sayNO_ANYOF;
2595 if (!nextchr && locinput >= PL_regeol)
2596 sayNO;
2597 nextchr = UCHARAT(++locinput);
2598 break;
2599 }
2600 no_anyof:
2601 /* If we might have the case of the German sharp s
2602 * in a casefolding Unicode character class. */
2603
2604 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
2605 locinput += SHARP_S_SKIP;
2606 nextchr = UCHARAT(locinput);
2607 }
2608 else
2609 sayNO;
2610 break;
2611 case ALNUML:
2612 PL_reg_flags |= RF_tainted;
2613 /* FALL THROUGH */
2614 case ALNUM:
2615 if (!nextchr)
2616 sayNO;
2617 if (do_utf8) {
2618 LOAD_UTF8_CHARCLASS_ALNUM();
2619 if (!(OP(scan) == ALNUM
2620 ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2621 : isALNUM_LC_utf8((U8*)locinput)))
2622 {
2623 sayNO;
2624 }
2625 locinput += PL_utf8skip[nextchr];
2626 nextchr = UCHARAT(locinput);
2627 break;
2628 }
2629 if (!(OP(scan) == ALNUM
2630 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
2631 sayNO;
2632 nextchr = UCHARAT(++locinput);
2633 break;
2634 case NALNUML:
2635 PL_reg_flags |= RF_tainted;
2636 /* FALL THROUGH */
2637 case NALNUM:
2638 if (!nextchr && locinput >= PL_regeol)
2639 sayNO;
2640 if (do_utf8) {
2641 LOAD_UTF8_CHARCLASS_ALNUM();
2642 if (OP(scan) == NALNUM
2643 ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
2644 : isALNUM_LC_utf8((U8*)locinput))
2645 {
2646 sayNO;
2647 }
2648 locinput += PL_utf8skip[nextchr];
2649 nextchr = UCHARAT(locinput);
2650 break;
2651 }
2652 if (OP(scan) == NALNUM
2653 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
2654 sayNO;
2655 nextchr = UCHARAT(++locinput);
2656 break;
2657 case BOUNDL:
2658 case NBOUNDL:
2659 PL_reg_flags |= RF_tainted;
2660 /* FALL THROUGH */
2661 case BOUND:
2662 case NBOUND:
2663 /* was last char in word? */
2664 if (do_utf8) {
2665 if (locinput == PL_bostr)
2666 ln = '\n';
2667 else {
2668 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
2669
2670 ln = utf8n_to_uvchr((U8 *)r, UTF8SKIP(r), 0, 0);
2671 }
2672 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2673 ln = isALNUM_uni(ln);
2674 LOAD_UTF8_CHARCLASS_ALNUM();
2675 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
2676 }
2677 else {
2678 ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
2679 n = isALNUM_LC_utf8((U8*)locinput);
2680 }
2681 }
2682 else {
2683 ln = (locinput != PL_bostr) ?
2684 UCHARAT(locinput - 1) : '\n';
2685 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
2686 ln = isALNUM(ln);
2687 n = isALNUM(nextchr);
2688 }
2689 else {
2690 ln = isALNUM_LC(ln);
2691 n = isALNUM_LC(nextchr);
2692 }
2693 }
2694 if (((!ln) == (!n)) == (OP(scan) == BOUND ||
2695 OP(scan) == BOUNDL))
2696 sayNO;
2697 break;
2698 case SPACEL:
2699 PL_reg_flags |= RF_tainted;
2700 /* FALL THROUGH */
2701 case SPACE:
2702 if (!nextchr)
2703 sayNO;
2704 if (do_utf8) {
2705 if (UTF8_IS_CONTINUED(nextchr)) {
2706 LOAD_UTF8_CHARCLASS_SPACE();
2707 if (!(OP(scan) == SPACE
2708 ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
2709 : isSPACE_LC_utf8((U8*)locinput)))
2710 {
2711 sayNO;
2712 }
2713 locinput += PL_utf8skip[nextchr];
2714 nextchr = UCHARAT(locinput);
2715 break;
2716 }
2717 if (!(OP(scan) == SPACE
2718 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2719 sayNO;
2720 nextchr = UCHARAT(++locinput);
2721 }
2722 else {
2723 if (!(OP(scan) == SPACE
2724 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
2725 sayNO;
2726 nextchr = UCHARAT(++locinput);
2727 }
2728 break;
2729 case NSPACEL:
2730 PL_reg_flags |= RF_tainted;
2731 /* FALL THROUGH */
2732 case NSPACE:
2733 if (!nextchr && locinput >= PL_regeol)
2734 sayNO;