5 * One Ring to rule them all, One Ring to find them
7 * [p.v of _The Lord of the Rings_, opening poem]
8 * [p.50 of _The Lord of the Rings_, I/iii: "The Shadow of the Past"]
9 * [p.254 of _The Lord of the Rings_, II/ii: "The Council of Elrond"]
12 /* This file contains functions for executing a regular expression. See
13 * also regcomp.c which funnily enough, contains functions for compiling
14 * a regular expression.
16 * This file is also copied at build time to ext/re/re_exec.c, where
17 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
18 * This causes the main functions to be compiled under new names and with
19 * debugging support added, which makes "use re 'debug'" work.
22 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
23 * confused with the original package (see point 3 below). Thanks, Henry!
26 /* Additional note: this code is very heavily munged from Henry's version
27 * in places. In some spots I've traded clarity for efficiency, so don't
28 * blame Henry for some of the lack of readability.
31 /* The names of the functions have been changed from regcomp and
32 * regexec to pregcomp and pregexec in order to avoid conflicts
33 * with the POSIX routines of the same names.
36 #ifdef PERL_EXT_RE_BUILD
41 * pregcomp and pregexec -- regsub and regerror are not used in perl
43 * Copyright (c) 1986 by University of Toronto.
44 * Written by Henry Spencer. Not derived from licensed software.
46 * Permission is granted to anyone to use this software for any
47 * purpose on any computer system, and to redistribute it freely,
48 * subject to the following restrictions:
50 * 1. The author is not responsible for the consequences of use of
51 * this software, no matter how awful, even if they arise
54 * 2. The origin of this software must not be misrepresented, either
55 * by explicit claim or by omission.
57 * 3. Altered versions must be plainly marked as such, and must not
58 * be misrepresented as being the original software.
60 **** Alterations to Henry's code are...
62 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
63 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
64 **** by Larry Wall and others
66 **** You may distribute under the terms of either the GNU General Public
67 **** License or the Artistic License, as specified in the README file.
69 * Beware that some of this code is subtly aware of the way operator
70 * precedence is structured in regular expressions. Serious changes in
71 * regular-expression syntax might require a total rethink.
74 #define PERL_IN_REGEXEC_C
77 #ifdef PERL_IN_XSUB_RE
83 #define RF_tainted 1 /* tainted information used? */
84 #define RF_warned 2 /* warned about big count? */
86 #define RF_utf8 8 /* Pattern contains multibyte chars? */
88 #define UTF ((PL_reg_flags & RF_utf8) != 0)
90 #define RS_init 1 /* eval environment created */
91 #define RS_set 2 /* replsv value is set */
97 #define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
103 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
104 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
106 #define HOPc(pos,off) \
107 (char *)(PL_reg_match_utf8 \
108 ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
110 #define HOPBACKc(pos, off) \
111 (char*)(PL_reg_match_utf8\
112 ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
113 : (pos - off >= PL_bostr) \
117 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
118 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
120 /* these are unrolled below in the CCC_TRY_XXX defined */
121 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
122 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
123 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
124 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
125 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
126 #define LOAD_UTF8_CHARCLASS_MARK() LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
129 #define CCC_TRY_AFF(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC) \
131 PL_reg_flags |= RF_tainted; \
136 if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) { \
137 if (!CAT2(PL_utf8_,CLASS)) { \
141 ok=CAT2(is_utf8_,CLASS)((const U8*)STR); \
145 if (!(OP(scan) == NAME \
146 ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8) \
147 : LCFUNC_utf8((U8*)locinput))) \
151 locinput += PL_utf8skip[nextchr]; \
152 nextchr = UCHARAT(locinput); \
155 if (!(OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr))) \
157 nextchr = UCHARAT(++locinput); \
160 #define CCC_TRY_NEG(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC) \
162 PL_reg_flags |= RF_tainted; \
165 if (!nextchr && locinput >= PL_regeol) \
167 if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) { \
168 if (!CAT2(PL_utf8_,CLASS)) { \
172 ok=CAT2(is_utf8_,CLASS)((const U8*)STR); \
176 if ((OP(scan) == NAME \
177 ? (bool)swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8) \
178 : LCFUNC_utf8((U8*)locinput))) \
182 locinput += PL_utf8skip[nextchr]; \
183 nextchr = UCHARAT(locinput); \
186 if ((OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr))) \
188 nextchr = UCHARAT(++locinput); \
192 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
194 /* for use after a quantifier and before an EXACT-like node -- japhy */
195 /* it would be nice to rework regcomp.sym to generate this stuff. sigh */
196 #define JUMPABLE(rn) ( \
198 (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
200 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
201 OP(rn) == PLUS || OP(rn) == MINMOD || \
202 OP(rn) == KEEPS || (PL_regkind[OP(rn)] == VERB) || \
203 (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
205 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
207 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
210 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
211 we don't need this definition. */
212 #define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF )
213 #define IS_TEXTF(rn) ( OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF )
214 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
217 /* ... so we use this as its faster. */
218 #define IS_TEXT(rn) ( OP(rn)==EXACT )
219 #define IS_TEXTF(rn) ( OP(rn)==EXACTF )
220 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
225 Search for mandatory following text node; for lookahead, the text must
226 follow but for lookbehind (rn->flags != 0) we skip to the next step.
228 #define FIND_NEXT_IMPT(rn) STMT_START { \
229 while (JUMPABLE(rn)) { \
230 const OPCODE type = OP(rn); \
231 if (type == SUSPEND || PL_regkind[type] == CURLY) \
232 rn = NEXTOPER(NEXTOPER(rn)); \
233 else if (type == PLUS) \
235 else if (type == IFMATCH) \
236 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
237 else rn += NEXT_OFF(rn); \
242 static void restore_pos(pTHX_ void *arg);
245 S_regcppush(pTHX_ I32 parenfloor)
248 const int retval = PL_savestack_ix;
249 #define REGCP_PAREN_ELEMS 4
250 const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
252 GET_RE_DEBUG_FLAGS_DECL;
254 if (paren_elems_to_push < 0)
255 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
257 #define REGCP_OTHER_ELEMS 7
258 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
260 for (p = PL_regsize; p > parenfloor; p--) {
261 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
262 SSPUSHINT(PL_regoffs[p].end);
263 SSPUSHINT(PL_regoffs[p].start);
264 SSPUSHPTR(PL_reg_start_tmp[p]);
266 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
267 " saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
268 (UV)p, (IV)PL_regoffs[p].start,
269 (IV)(PL_reg_start_tmp[p] - PL_bostr),
270 (IV)PL_regoffs[p].end
273 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
274 SSPUSHPTR(PL_regoffs);
275 SSPUSHINT(PL_regsize);
276 SSPUSHINT(*PL_reglastparen);
277 SSPUSHINT(*PL_reglastcloseparen);
278 SSPUSHPTR(PL_reginput);
279 #define REGCP_FRAME_ELEMS 2
280 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
281 * are needed for the regexp context stack bookkeeping. */
282 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
283 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
288 /* These are needed since we do not localize EVAL nodes: */
289 #define REGCP_SET(cp) \
291 PerlIO_printf(Perl_debug_log, \
292 " Setting an EVAL scope, savestack=%"IVdf"\n", \
293 (IV)PL_savestack_ix)); \
296 #define REGCP_UNWIND(cp) \
298 if (cp != PL_savestack_ix) \
299 PerlIO_printf(Perl_debug_log, \
300 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
301 (IV)(cp), (IV)PL_savestack_ix)); \
305 S_regcppop(pTHX_ const regexp *rex)
310 GET_RE_DEBUG_FLAGS_DECL;
312 PERL_ARGS_ASSERT_REGCPPOP;
314 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
316 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
317 i = SSPOPINT; /* Parentheses elements to pop. */
318 input = (char *) SSPOPPTR;
319 *PL_reglastcloseparen = SSPOPINT;
320 *PL_reglastparen = SSPOPINT;
321 PL_regsize = SSPOPINT;
322 PL_regoffs=(regexp_paren_pair *) SSPOPPTR;
325 /* Now restore the parentheses context. */
326 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
327 i > 0; i -= REGCP_PAREN_ELEMS) {
329 U32 paren = (U32)SSPOPINT;
330 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
331 PL_regoffs[paren].start = SSPOPINT;
333 if (paren <= *PL_reglastparen)
334 PL_regoffs[paren].end = tmps;
336 PerlIO_printf(Perl_debug_log,
337 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
338 (UV)paren, (IV)PL_regoffs[paren].start,
339 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
340 (IV)PL_regoffs[paren].end,
341 (paren > *PL_reglastparen ? "(no)" : ""));
345 if (*PL_reglastparen + 1 <= rex->nparens) {
346 PerlIO_printf(Perl_debug_log,
347 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
348 (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
352 /* It would seem that the similar code in regtry()
353 * already takes care of this, and in fact it is in
354 * a better location to since this code can #if 0-ed out
355 * but the code in regtry() is needed or otherwise tests
356 * requiring null fields (pat.t#187 and split.t#{13,14}
357 * (as of patchlevel 7877) will fail. Then again,
358 * this code seems to be necessary or otherwise
359 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
360 * --jhi updated by dapm */
361 for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
363 PL_regoffs[i].start = -1;
364 PL_regoffs[i].end = -1;
370 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
373 * pregexec and friends
376 #ifndef PERL_IN_XSUB_RE
378 - pregexec - match a regexp against a string
381 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
382 char *strbeg, I32 minend, SV *screamer, U32 nosave)
383 /* strend: pointer to null at end of string */
384 /* strbeg: real beginning of string */
385 /* minend: end of match must be >=minend after stringarg. */
386 /* nosave: For optimizations. */
388 PERL_ARGS_ASSERT_PREGEXEC;
391 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
392 nosave ? 0 : REXEC_COPY_STR);
397 * Need to implement the following flags for reg_anch:
399 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
401 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
402 * INTUIT_AUTORITATIVE_ML
403 * INTUIT_ONCE_NOML - Intuit can match in one location only.
406 * Another flag for this function: SECOND_TIME (so that float substrs
407 * with giant delta may be not rechecked).
410 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
412 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
413 Otherwise, only SvCUR(sv) is used to get strbeg. */
415 /* XXXX We assume that strpos is strbeg unless sv. */
417 /* XXXX Some places assume that there is a fixed substring.
418 An update may be needed if optimizer marks as "INTUITable"
419 RExen without fixed substrings. Similarly, it is assumed that
420 lengths of all the strings are no more than minlen, thus they
421 cannot come from lookahead.
422 (Or minlen should take into account lookahead.)
423 NOTE: Some of this comment is not correct. minlen does now take account
424 of lookahead/behind. Further research is required. -- demerphq
428 /* A failure to find a constant substring means that there is no need to make
429 an expensive call to REx engine, thus we celebrate a failure. Similarly,
430 finding a substring too deep into the string means that less calls to
431 regtry() should be needed.
433 REx compiler's optimizer found 4 possible hints:
434 a) Anchored substring;
436 c) Whether we are anchored (beginning-of-line or \G);
437 d) First node (of those at offset 0) which may distingush positions;
438 We use a)b)d) and multiline-part of c), and try to find a position in the
439 string which does not contradict any of them.
442 /* Most of decisions we do here should have been done at compile time.
443 The nodes of the REx which we used for the search should have been
444 deleted from the finite automaton. */
447 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
448 char *strend, const U32 flags, re_scream_pos_data *data)
451 struct regexp *const prog = (struct regexp *)SvANY(rx);
452 register I32 start_shift = 0;
453 /* Should be nonnegative! */
454 register I32 end_shift = 0;
459 const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
461 register char *other_last = NULL; /* other substr checked before this */
462 char *check_at = NULL; /* check substr found at this pos */
463 const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
464 RXi_GET_DECL(prog,progi);
466 const char * const i_strpos = strpos;
468 GET_RE_DEBUG_FLAGS_DECL;
470 PERL_ARGS_ASSERT_RE_INTUIT_START;
472 RX_MATCH_UTF8_set(rx,do_utf8);
475 PL_reg_flags |= RF_utf8;
478 debug_start_match(rx, do_utf8, strpos, strend,
479 sv ? "Guessing start of match in sv for"
480 : "Guessing start of match in string for");
483 /* CHR_DIST() would be more correct here but it makes things slow. */
484 if (prog->minlen > strend - strpos) {
485 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
486 "String too short... [re_intuit_start]\n"));
490 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
493 if (!prog->check_utf8 && prog->check_substr)
494 to_utf8_substr(prog);
495 check = prog->check_utf8;
497 if (!prog->check_substr && prog->check_utf8)
498 to_byte_substr(prog);
499 check = prog->check_substr;
501 if (check == &PL_sv_undef) {
502 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
503 "Non-utf8 string cannot match utf8 check string\n"));
506 if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */
507 ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
508 || ( (prog->extflags & RXf_ANCH_BOL)
509 && !multiline ) ); /* Check after \n? */
512 if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
513 && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
514 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
516 && (strpos != strbeg)) {
517 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
520 if (prog->check_offset_min == prog->check_offset_max &&
521 !(prog->extflags & RXf_CANY_SEEN)) {
522 /* Substring at constant offset from beg-of-str... */
525 s = HOP3c(strpos, prog->check_offset_min, strend);
528 slen = SvCUR(check); /* >= 1 */
530 if ( strend - s > slen || strend - s < slen - 1
531 || (strend - s == slen && strend[-1] != '\n')) {
532 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
535 /* Now should match s[0..slen-2] */
537 if (slen && (*SvPVX_const(check) != *s
539 && memNE(SvPVX_const(check), s, slen)))) {
541 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
545 else if (*SvPVX_const(check) != *s
546 || ((slen = SvCUR(check)) > 1
547 && memNE(SvPVX_const(check), s, slen)))
550 goto success_at_start;
553 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
555 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
556 end_shift = prog->check_end_shift;
559 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
560 - (SvTAIL(check) != 0);
561 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
563 if (end_shift < eshift)
567 else { /* Can match at random position */
570 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
571 end_shift = prog->check_end_shift;
573 /* end shift should be non negative here */
576 #ifdef QDEBUGGING /* 7/99: reports of failure (with the older version) */
578 Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
579 (IV)end_shift, RX_PRECOMP(prog));
583 /* Find a possible match in the region s..strend by looking for
584 the "check" substring in the region corrected by start/end_shift. */
587 I32 srch_start_shift = start_shift;
588 I32 srch_end_shift = end_shift;
589 if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
590 srch_end_shift -= ((strbeg - s) - srch_start_shift);
591 srch_start_shift = strbeg - s;
593 DEBUG_OPTIMISE_MORE_r({
594 PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
595 (IV)prog->check_offset_min,
596 (IV)srch_start_shift,
598 (IV)prog->check_end_shift);
601 if (flags & REXEC_SCREAM) {
602 I32 p = -1; /* Internal iterator of scream. */
603 I32 * const pp = data ? data->scream_pos : &p;
605 if (PL_screamfirst[BmRARE(check)] >= 0
606 || ( BmRARE(check) == '\n'
607 && (BmPREVIOUS(check) == SvCUR(check) - 1)
609 s = screaminstr(sv, check,
610 srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
613 /* we may be pointing at the wrong string */
614 if (s && RXp_MATCH_COPIED(prog))
615 s = strbeg + (s - SvPVX_const(sv));
617 *data->scream_olds = s;
622 if (prog->extflags & RXf_CANY_SEEN) {
623 start_point= (U8*)(s + srch_start_shift);
624 end_point= (U8*)(strend - srch_end_shift);
626 start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
627 end_point= HOP3(strend, -srch_end_shift, strbeg);
629 DEBUG_OPTIMISE_MORE_r({
630 PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
631 (int)(end_point - start_point),
632 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
636 s = fbm_instr( start_point, end_point,
637 check, multiline ? FBMrf_MULTILINE : 0);
640 /* Update the count-of-usability, remove useless subpatterns,
644 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
645 SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
646 PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
647 (s ? "Found" : "Did not find"),
648 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)
649 ? "anchored" : "floating"),
652 (s ? " at offset " : "...\n") );
657 /* Finish the diagnostic message */
658 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
660 /* XXX dmq: first branch is for positive lookbehind...
661 Our check string is offset from the beginning of the pattern.
662 So we need to do any stclass tests offset forward from that
671 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
672 Start with the other substr.
673 XXXX no SCREAM optimization yet - and a very coarse implementation
674 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
675 *always* match. Probably should be marked during compile...
676 Probably it is right to do no SCREAM here...
679 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
680 : (prog->float_substr && prog->anchored_substr))
682 /* Take into account the "other" substring. */
683 /* XXXX May be hopelessly wrong for UTF... */
686 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
689 char * const last = HOP3c(s, -start_shift, strbeg);
691 char * const saved_s = s;
694 t = s - prog->check_offset_max;
695 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
697 || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
702 t = HOP3c(t, prog->anchored_offset, strend);
703 if (t < other_last) /* These positions already checked */
705 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
708 /* XXXX It is not documented what units *_offsets are in.
709 We assume bytes, but this is clearly wrong.
710 Meaning this code needs to be carefully reviewed for errors.
714 /* On end-of-str: see comment below. */
715 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
716 if (must == &PL_sv_undef) {
718 DEBUG_r(must = prog->anchored_utf8); /* for debug */
723 HOP3(HOP3(last1, prog->anchored_offset, strend)
724 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
726 multiline ? FBMrf_MULTILINE : 0
729 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
730 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
731 PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
732 (s ? "Found" : "Contradicts"),
733 quoted, RE_SV_TAIL(must));
738 if (last1 >= last2) {
739 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
740 ", giving up...\n"));
743 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
744 ", trying floating at offset %ld...\n",
745 (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
746 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
747 s = HOP3c(last, 1, strend);
751 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
752 (long)(s - i_strpos)));
753 t = HOP3c(s, -prog->anchored_offset, strbeg);
754 other_last = HOP3c(s, 1, strend);
762 else { /* Take into account the floating substring. */
764 char * const saved_s = s;
767 t = HOP3c(s, -start_shift, strbeg);
769 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
770 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
771 last = HOP3c(t, prog->float_max_offset, strend);
772 s = HOP3c(t, prog->float_min_offset, strend);
775 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
776 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
777 /* fbm_instr() takes into account exact value of end-of-str
778 if the check is SvTAIL(ed). Since false positives are OK,
779 and end-of-str is not later than strend we are OK. */
780 if (must == &PL_sv_undef) {
782 DEBUG_r(must = prog->float_utf8); /* for debug message */
785 s = fbm_instr((unsigned char*)s,
786 (unsigned char*)last + SvCUR(must)
788 must, multiline ? FBMrf_MULTILINE : 0);
790 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
791 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
792 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
793 (s ? "Found" : "Contradicts"),
794 quoted, RE_SV_TAIL(must));
798 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
799 ", giving up...\n"));
802 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
803 ", trying anchored starting at offset %ld...\n",
804 (long)(saved_s + 1 - i_strpos)));
806 s = HOP3c(t, 1, strend);
810 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
811 (long)(s - i_strpos)));
812 other_last = s; /* Fix this later. --Hugo */
822 t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
824 DEBUG_OPTIMISE_MORE_r(
825 PerlIO_printf(Perl_debug_log,
826 "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
827 (IV)prog->check_offset_min,
828 (IV)prog->check_offset_max,
836 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
838 || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
841 /* Fixed substring is found far enough so that the match
842 cannot start at strpos. */
844 if (ml_anch && t[-1] != '\n') {
845 /* Eventually fbm_*() should handle this, but often
846 anchored_offset is not 0, so this check will not be wasted. */
847 /* XXXX In the code below we prefer to look for "^" even in
848 presence of anchored substrings. And we search even
849 beyond the found float position. These pessimizations
850 are historical artefacts only. */
852 while (t < strend - prog->minlen) {
854 if (t < check_at - prog->check_offset_min) {
855 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
856 /* Since we moved from the found position,
857 we definitely contradict the found anchored
858 substr. Due to the above check we do not
859 contradict "check" substr.
860 Thus we can arrive here only if check substr
861 is float. Redo checking for "other"=="fixed".
864 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
865 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
866 goto do_other_anchored;
868 /* We don't contradict the found floating substring. */
869 /* XXXX Why not check for STCLASS? */
871 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
872 PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
875 /* Position contradicts check-string */
876 /* XXXX probably better to look for check-string
877 than for "\n", so one should lower the limit for t? */
878 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
879 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
880 other_last = strpos = s = t + 1;
885 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
886 PL_colors[0], PL_colors[1]));
890 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
891 PL_colors[0], PL_colors[1]));
895 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
898 /* The found string does not prohibit matching at strpos,
899 - no optimization of calling REx engine can be performed,
900 unless it was an MBOL and we are not after MBOL,
901 or a future STCLASS check will fail this. */
903 /* Even in this situation we may use MBOL flag if strpos is offset
904 wrt the start of the string. */
905 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
906 && (strpos != strbeg) && strpos[-1] != '\n'
907 /* May be due to an implicit anchor of m{.*foo} */
908 && !(prog->intflags & PREGf_IMPLICIT))
913 DEBUG_EXECUTE_r( if (ml_anch)
914 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
915 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
918 if (!(prog->intflags & PREGf_NAUGHTY) /* XXXX If strpos moved? */
920 prog->check_utf8 /* Could be deleted already */
921 && --BmUSEFUL(prog->check_utf8) < 0
922 && (prog->check_utf8 == prog->float_utf8)
924 prog->check_substr /* Could be deleted already */
925 && --BmUSEFUL(prog->check_substr) < 0
926 && (prog->check_substr == prog->float_substr)
929 /* If flags & SOMETHING - do not do it many times on the same match */
930 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
931 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
932 if (do_utf8 ? prog->check_substr : prog->check_utf8)
933 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
934 prog->check_substr = prog->check_utf8 = NULL; /* disable */
935 prog->float_substr = prog->float_utf8 = NULL; /* clear */
936 check = NULL; /* abort */
938 /* XXXX This is a remnant of the old implementation. It
939 looks wasteful, since now INTUIT can use many
941 prog->extflags &= ~RXf_USE_INTUIT;
948 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
949 /* trie stclasses are too expensive to use here, we are better off to
950 leave it to regmatch itself */
951 if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
952 /* minlen == 0 is possible if regstclass is \b or \B,
953 and the fixed substr is ''$.
954 Since minlen is already taken into account, s+1 is before strend;
955 accidentally, minlen >= 1 guaranties no false positives at s + 1
956 even for \b or \B. But (minlen? 1 : 0) below assumes that
957 regstclass does not come from lookahead... */
958 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
959 This leaves EXACTF only, which is dealt with in find_byclass(). */
960 const U8* const str = (U8*)STRING(progi->regstclass);
961 const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
962 ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
965 if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
966 endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
967 else if (prog->float_substr || prog->float_utf8)
968 endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
972 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
973 (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
976 s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
979 const char *what = NULL;
981 if (endpos == strend) {
982 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
983 "Could not match STCLASS...\n") );
986 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
987 "This position contradicts STCLASS...\n") );
988 if ((prog->extflags & RXf_ANCH) && !ml_anch)
990 /* Contradict one of substrings */
991 if (prog->anchored_substr || prog->anchored_utf8) {
992 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
993 DEBUG_EXECUTE_r( what = "anchored" );
995 s = HOP3c(t, 1, strend);
996 if (s + start_shift + end_shift > strend) {
997 /* XXXX Should be taken into account earlier? */
998 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
999 "Could not match STCLASS...\n") );
1004 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1005 "Looking for %s substr starting at offset %ld...\n",
1006 what, (long)(s + start_shift - i_strpos)) );
1009 /* Have both, check_string is floating */
1010 if (t + start_shift >= check_at) /* Contradicts floating=check */
1011 goto retry_floating_check;
1012 /* Recheck anchored substring, but not floating... */
1016 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1017 "Looking for anchored substr starting at offset %ld...\n",
1018 (long)(other_last - i_strpos)) );
1019 goto do_other_anchored;
1021 /* Another way we could have checked stclass at the
1022 current position only: */
1027 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1028 "Looking for /%s^%s/m starting at offset %ld...\n",
1029 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
1032 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
1034 /* Check is floating subtring. */
1035 retry_floating_check:
1036 t = check_at - start_shift;
1037 DEBUG_EXECUTE_r( what = "floating" );
1038 goto hop_and_restart;
1041 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1042 "By STCLASS: moving %ld --> %ld\n",
1043 (long)(t - i_strpos), (long)(s - i_strpos))
1047 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1048 "Does not contradict STCLASS...\n");
1053 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
1054 PL_colors[4], (check ? "Guessed" : "Giving up"),
1055 PL_colors[5], (long)(s - i_strpos)) );
1058 fail_finish: /* Substring not found */
1059 if (prog->check_substr || prog->check_utf8) /* could be removed already */
1060 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1062 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1063 PL_colors[4], PL_colors[5]));
1067 #define DECL_TRIE_TYPE(scan) \
1068 const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
1069 trie_type = (scan->flags != EXACT) \
1070 ? (do_utf8 ? trie_utf8_fold : (UTF ? trie_latin_utf8_fold : trie_plain)) \
1071 : (do_utf8 ? trie_utf8 : trie_plain)
1073 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, \
1074 uvc, charid, foldlen, foldbuf, uniflags) STMT_START { \
1075 UV uvc_unfolded = 0; \
1076 switch (trie_type) { \
1077 case trie_utf8_fold: \
1078 if ( foldlen>0 ) { \
1079 uvc_unfolded = uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1084 uvc_unfolded = uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1085 uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
1086 foldlen -= UNISKIP( uvc ); \
1087 uscan = foldbuf + UNISKIP( uvc ); \
1090 case trie_latin_utf8_fold: \
1091 if ( foldlen>0 ) { \
1092 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1098 uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen ); \
1099 foldlen -= UNISKIP( uvc ); \
1100 uscan = foldbuf + UNISKIP( uvc ); \
1104 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1112 charid = trie->charmap[ uvc ]; \
1116 if (widecharmap) { \
1117 SV** const svpp = hv_fetch(widecharmap, \
1118 (char*)&uvc, sizeof(UV), 0); \
1120 charid = (U16)SvIV(*svpp); \
1123 if (!charid && trie_type == trie_utf8_fold && !UTF) { \
1124 charid = trie->charmap[uvc_unfolded]; \
1128 #define REXEC_FBC_EXACTISH_CHECK(CoNd) \
1130 char *my_strend= (char *)strend; \
1133 !ibcmp_utf8(s, &my_strend, 0, do_utf8, \
1134 m, NULL, ln, (bool)UTF)) \
1135 && (!reginfo || regtry(reginfo, &s)) ) \
1138 U8 foldbuf[UTF8_MAXBYTES_CASE+1]; \
1139 uvchr_to_utf8(tmpbuf, c); \
1140 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); \
1142 && (f == c1 || f == c2) \
1144 !ibcmp_utf8(s, &my_strend, 0, do_utf8,\
1145 m, NULL, ln, (bool)UTF)) \
1146 && (!reginfo || regtry(reginfo, &s)) ) \
1152 #define REXEC_FBC_EXACTISH_SCAN(CoNd) \
1156 && (ln == 1 || !(OP(c) == EXACTF \
1158 : ibcmp_locale(s, m, ln))) \
1159 && (!reginfo || regtry(reginfo, &s)) ) \
1165 #define REXEC_FBC_UTF8_SCAN(CoDe) \
1167 while (s + (uskip = UTF8SKIP(s)) <= strend) { \
1173 #define REXEC_FBC_SCAN(CoDe) \
1175 while (s < strend) { \
1181 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \
1182 REXEC_FBC_UTF8_SCAN( \
1184 if (tmp && (!reginfo || regtry(reginfo, &s))) \
1193 #define REXEC_FBC_CLASS_SCAN(CoNd) \
1196 if (tmp && (!reginfo || regtry(reginfo, &s))) \
1205 #define REXEC_FBC_TRYIT \
1206 if ((!reginfo || regtry(reginfo, &s))) \
1209 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \
1211 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1214 REXEC_FBC_CLASS_SCAN(CoNd); \
1218 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd) \
1221 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1224 REXEC_FBC_CLASS_SCAN(CoNd); \
1228 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd) \
1229 PL_reg_flags |= RF_tainted; \
1231 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1234 REXEC_FBC_CLASS_SCAN(CoNd); \
1238 #define DUMP_EXEC_POS(li,s,doutf8) \
1239 dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1241 /* We know what class REx starts with. Try to find this position... */
1242 /* if reginfo is NULL, its a dryrun */
1243 /* annoyingly all the vars in this routine have different names from their counterparts
1244 in regmatch. /grrr */
1247 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1248 const char *strend, regmatch_info *reginfo)
1251 const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1255 register STRLEN uskip;
1259 register I32 tmp = 1; /* Scratch variable? */
1260 register const bool do_utf8 = PL_reg_match_utf8;
1261 RXi_GET_DECL(prog,progi);
1263 PERL_ARGS_ASSERT_FIND_BYCLASS;
1265 /* We know what class it must start with. */
1269 REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1270 !UTF8_IS_INVARIANT((U8)s[0]) ?
1271 reginclass(prog, c, (U8*)s, 0, do_utf8) :
1272 REGINCLASS(prog, c, (U8*)s));
1275 while (s < strend) {
1278 if (REGINCLASS(prog, c, (U8*)s) ||
1279 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1280 /* The assignment of 2 is intentional:
1281 * for the folded sharp s, the skip is 2. */
1282 (skip = SHARP_S_SKIP))) {
1283 if (tmp && (!reginfo || regtry(reginfo, &s)))
1296 if (tmp && (!reginfo || regtry(reginfo, &s)))
1304 ln = STR_LEN(c); /* length to match in octets/bytes */
1305 lnc = (I32) ln; /* length to match in characters */
1307 STRLEN ulen1, ulen2;
1309 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1310 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1311 /* used by commented-out code below */
1312 /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1314 /* XXX: Since the node will be case folded at compile
1315 time this logic is a little odd, although im not
1316 sure that its actually wrong. --dmq */
1318 c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1319 c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1321 /* XXX: This is kinda strange. to_utf8_XYZ returns the
1322 codepoint of the first character in the converted
1323 form, yet originally we did the extra step.
1324 No tests fail by commenting this code out however
1325 so Ive left it out. -- dmq.
1327 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1329 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1334 while (sm < ((U8 *) m + ln)) {
1349 c2 = PL_fold_locale[c1];
1351 e = HOP3c(strend, -((I32)lnc), s);
1353 if (!reginfo && e < s)
1354 e = s; /* Due to minlen logic of intuit() */
1356 /* The idea in the EXACTF* cases is to first find the
1357 * first character of the EXACTF* node and then, if
1358 * necessary, case-insensitively compare the full
1359 * text of the node. The c1 and c2 are the first
1360 * characters (though in Unicode it gets a bit
1361 * more complicated because there are more cases
1362 * than just upper and lower: one needs to use
1363 * the so-called folding case for case-insensitive
1364 * matching (called "loose matching" in Unicode).
1365 * ibcmp_utf8() will do just that. */
1367 if (do_utf8 || UTF) {
1369 U8 tmpbuf [UTF8_MAXBYTES+1];
1372 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1374 /* Upper and lower of 1st char are equal -
1375 * probably not a "letter". */
1378 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1383 REXEC_FBC_EXACTISH_CHECK(c == c1);
1389 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1395 /* Handle some of the three Greek sigmas cases.
1396 * Note that not all the possible combinations
1397 * are handled here: some of them are handled
1398 * by the standard folding rules, and some of
1399 * them (the character class or ANYOF cases)
1400 * are handled during compiletime in
1401 * regexec.c:S_regclass(). */
1402 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1403 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1404 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1406 REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1411 /* Neither pattern nor string are UTF8 */
1413 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1415 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1419 PL_reg_flags |= RF_tainted;
1426 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1427 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1429 tmp = ((OP(c) == BOUND ?
1430 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1431 LOAD_UTF8_CHARCLASS_ALNUM();
1432 REXEC_FBC_UTF8_SCAN(
1433 if (tmp == !(OP(c) == BOUND ?
1434 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1435 isALNUM_LC_utf8((U8*)s)))
1443 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1444 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1447 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1453 if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1457 PL_reg_flags |= RF_tainted;
1464 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1465 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1467 tmp = ((OP(c) == NBOUND ?
1468 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1469 LOAD_UTF8_CHARCLASS_ALNUM();
1470 REXEC_FBC_UTF8_SCAN(
1471 if (tmp == !(OP(c) == NBOUND ?
1472 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1473 isALNUM_LC_utf8((U8*)s)))
1475 else REXEC_FBC_TRYIT;
1479 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1480 tmp = ((OP(c) == NBOUND ?
1481 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1484 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1486 else REXEC_FBC_TRYIT;
1489 if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1493 REXEC_FBC_CSCAN_PRELOAD(
1494 LOAD_UTF8_CHARCLASS_ALNUM(),
1495 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1499 REXEC_FBC_CSCAN_TAINT(
1500 isALNUM_LC_utf8((U8*)s),
1504 REXEC_FBC_CSCAN_PRELOAD(
1505 LOAD_UTF8_CHARCLASS_ALNUM(),
1506 !swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1510 REXEC_FBC_CSCAN_TAINT(
1511 !isALNUM_LC_utf8((U8*)s),
1515 REXEC_FBC_CSCAN_PRELOAD(
1516 LOAD_UTF8_CHARCLASS_SPACE(),
1517 *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8),
1521 REXEC_FBC_CSCAN_TAINT(
1522 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1526 REXEC_FBC_CSCAN_PRELOAD(
1527 LOAD_UTF8_CHARCLASS_SPACE(),
1528 !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)),
1532 REXEC_FBC_CSCAN_TAINT(
1533 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1537 REXEC_FBC_CSCAN_PRELOAD(
1538 LOAD_UTF8_CHARCLASS_DIGIT(),
1539 swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1543 REXEC_FBC_CSCAN_TAINT(
1544 isDIGIT_LC_utf8((U8*)s),
1548 REXEC_FBC_CSCAN_PRELOAD(
1549 LOAD_UTF8_CHARCLASS_DIGIT(),
1550 !swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1554 REXEC_FBC_CSCAN_TAINT(
1555 !isDIGIT_LC_utf8((U8*)s),
1561 is_LNBREAK_latin1(s)
1571 !is_VERTWS_latin1(s)
1576 is_HORIZWS_latin1(s)
1580 !is_HORIZWS_utf8(s),
1581 !is_HORIZWS_latin1(s)
1587 /* what trie are we using right now */
1589 = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1591 = (reg_trie_data*)progi->data->data[ aho->trie ];
1592 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1594 const char *last_start = strend - trie->minlen;
1596 const char *real_start = s;
1598 STRLEN maxlen = trie->maxlen;
1600 U8 **points; /* map of where we were in the input string
1601 when reading a given char. For ASCII this
1602 is unnecessary overhead as the relationship
1603 is always 1:1, but for Unicode, especially
1604 case folded Unicode this is not true. */
1605 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1609 GET_RE_DEBUG_FLAGS_DECL;
1611 /* We can't just allocate points here. We need to wrap it in
1612 * an SV so it gets freed properly if there is a croak while
1613 * running the match */
1616 sv_points=newSV(maxlen * sizeof(U8 *));
1617 SvCUR_set(sv_points,
1618 maxlen * sizeof(U8 *));
1619 SvPOK_on(sv_points);
1620 sv_2mortal(sv_points);
1621 points=(U8**)SvPV_nolen(sv_points );
1622 if ( trie_type != trie_utf8_fold
1623 && (trie->bitmap || OP(c)==AHOCORASICKC) )
1626 bitmap=(U8*)trie->bitmap;
1628 bitmap=(U8*)ANYOF_BITMAP(c);
1630 /* this is the Aho-Corasick algorithm modified a touch
1631 to include special handling for long "unknown char"
1632 sequences. The basic idea being that we use AC as long
1633 as we are dealing with a possible matching char, when
1634 we encounter an unknown char (and we have not encountered
1635 an accepting state) we scan forward until we find a legal
1637 AC matching is basically that of trie matching, except
1638 that when we encounter a failing transition, we fall back
1639 to the current states "fail state", and try the current char
1640 again, a process we repeat until we reach the root state,
1641 state 1, or a legal transition. If we fail on the root state
1642 then we can either terminate if we have reached an accepting
1643 state previously, or restart the entire process from the beginning
1647 while (s <= last_start) {
1648 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1656 U8 *uscan = (U8*)NULL;
1657 U8 *leftmost = NULL;
1659 U32 accepted_word= 0;
1663 while ( state && uc <= (U8*)strend ) {
1665 U32 word = aho->states[ state ].wordnum;
1669 DEBUG_TRIE_EXECUTE_r(
1670 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1671 dump_exec_pos( (char *)uc, c, strend, real_start,
1672 (char *)uc, do_utf8 );
1673 PerlIO_printf( Perl_debug_log,
1674 " Scanning for legal start char...\n");
1677 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1682 if (uc >(U8*)last_start) break;
1686 U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1687 if (!leftmost || lpos < leftmost) {
1688 DEBUG_r(accepted_word=word);
1694 points[pointpos++ % maxlen]= uc;
1695 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1696 uscan, len, uvc, charid, foldlen,
1698 DEBUG_TRIE_EXECUTE_r({
1699 dump_exec_pos( (char *)uc, c, strend, real_start,
1701 PerlIO_printf(Perl_debug_log,
1702 " Charid:%3u CP:%4"UVxf" ",
1708 word = aho->states[ state ].wordnum;
1710 base = aho->states[ state ].trans.base;
1712 DEBUG_TRIE_EXECUTE_r({
1714 dump_exec_pos( (char *)uc, c, strend, real_start,
1716 PerlIO_printf( Perl_debug_log,
1717 "%sState: %4"UVxf", word=%"UVxf,
1718 failed ? " Fail transition to " : "",
1719 (UV)state, (UV)word);
1724 (base + charid > trie->uniquecharcount )
1725 && (base + charid - 1 - trie->uniquecharcount
1727 && trie->trans[base + charid - 1 -
1728 trie->uniquecharcount].check == state
1729 && (tmp=trie->trans[base + charid - 1 -
1730 trie->uniquecharcount ].next))
1732 DEBUG_TRIE_EXECUTE_r(
1733 PerlIO_printf( Perl_debug_log," - legal\n"));
1738 DEBUG_TRIE_EXECUTE_r(
1739 PerlIO_printf( Perl_debug_log," - fail\n"));
1741 state = aho->fail[state];
1745 /* we must be accepting here */
1746 DEBUG_TRIE_EXECUTE_r(
1747 PerlIO_printf( Perl_debug_log," - accepting\n"));
1756 if (!state) state = 1;
1759 if ( aho->states[ state ].wordnum ) {
1760 U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1761 if (!leftmost || lpos < leftmost) {
1762 DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1767 s = (char*)leftmost;
1768 DEBUG_TRIE_EXECUTE_r({
1770 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1771 (UV)accepted_word, (IV)(s - real_start)
1774 if (!reginfo || regtry(reginfo, &s)) {
1780 DEBUG_TRIE_EXECUTE_r({
1781 PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1784 DEBUG_TRIE_EXECUTE_r(
1785 PerlIO_printf( Perl_debug_log,"No match.\n"));
1794 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1804 - regexec_flags - match a regexp against a string
1807 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
1808 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1809 /* strend: pointer to null at end of string */
1810 /* strbeg: real beginning of string */
1811 /* minend: end of match must be >=minend after stringarg. */
1812 /* data: May be used for some additional optimizations.
1813 Currently its only used, with a U32 cast, for transmitting
1814 the ganch offset when doing a /g match. This will change */
1815 /* nosave: For optimizations. */
1818 struct regexp *const prog = (struct regexp *)SvANY(rx);
1819 /*register*/ char *s;
1820 register regnode *c;
1821 /*register*/ char *startpos = stringarg;
1822 I32 minlen; /* must match at least this many chars */
1823 I32 dontbother = 0; /* how many characters not to try at end */
1824 I32 end_shift = 0; /* Same for the end. */ /* CC */
1825 I32 scream_pos = -1; /* Internal iterator of scream. */
1826 char *scream_olds = NULL;
1827 const bool do_utf8 = (bool)DO_UTF8(sv);
1829 RXi_GET_DECL(prog,progi);
1830 regmatch_info reginfo; /* create some info to pass to regtry etc */
1831 regexp_paren_pair *swap = NULL;
1832 GET_RE_DEBUG_FLAGS_DECL;
1834 PERL_ARGS_ASSERT_REGEXEC_FLAGS;
1835 PERL_UNUSED_ARG(data);
1837 /* Be paranoid... */
1838 if (prog == NULL || startpos == NULL) {
1839 Perl_croak(aTHX_ "NULL regexp parameter");
1843 multiline = prog->extflags & RXf_PMf_MULTILINE;
1844 reginfo.prog = rx; /* Yes, sorry that this is confusing. */
1846 RX_MATCH_UTF8_set(rx, do_utf8);
1848 debug_start_match(rx, do_utf8, startpos, strend,
1852 minlen = prog->minlen;
1854 if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1855 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1856 "String too short [regexec_flags]...\n"));
1861 /* Check validity of program. */
1862 if (UCHARAT(progi->program) != REG_MAGIC) {
1863 Perl_croak(aTHX_ "corrupted regexp program");
1867 PL_reg_eval_set = 0;
1871 PL_reg_flags |= RF_utf8;
1873 /* Mark beginning of line for ^ and lookbehind. */
1874 reginfo.bol = startpos; /* XXX not used ??? */
1878 /* Mark end of line for $ (and such) */
1881 /* see how far we have to get to not match where we matched before */
1882 reginfo.till = startpos+minend;
1884 /* If there is a "must appear" string, look for it. */
1887 if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
1889 if (flags & REXEC_IGNOREPOS){ /* Means: check only at start */
1890 reginfo.ganch = startpos + prog->gofs;
1891 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1892 "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
1893 } else if (sv && SvTYPE(sv) >= SVt_PVMG
1895 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1896 && mg->mg_len >= 0) {
1897 reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
1898 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1899 "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
1901 if (prog->extflags & RXf_ANCH_GPOS) {
1902 if (s > reginfo.ganch)
1904 s = reginfo.ganch - prog->gofs;
1905 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1906 "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
1912 reginfo.ganch = strbeg + PTR2UV(data);
1913 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1914 "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
1916 } else { /* pos() not defined */
1917 reginfo.ganch = strbeg;
1918 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1919 "GPOS: reginfo.ganch = strbeg\n"));
1922 if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
1923 /* We have to be careful. If the previous successful match
1924 was from this regex we don't want a subsequent partially
1925 successful match to clobber the old results.
1926 So when we detect this possibility we add a swap buffer
1927 to the re, and switch the buffer each match. If we fail
1928 we switch it back, otherwise we leave it swapped.
1931 /* do we need a save destructor here for eval dies? */
1932 Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
1934 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1935 re_scream_pos_data d;
1937 d.scream_olds = &scream_olds;
1938 d.scream_pos = &scream_pos;
1939 s = re_intuit_start(rx, sv, s, strend, flags, &d);
1941 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1942 goto phooey; /* not present */
1948 /* Simplest case: anchored match need be tried only once. */
1949 /* [unless only anchor is BOL and multiline is set] */
1950 if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
1951 if (s == startpos && regtry(®info, &startpos))
1953 else if (multiline || (prog->intflags & PREGf_IMPLICIT)
1954 || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
1959 dontbother = minlen - 1;
1960 end = HOP3c(strend, -dontbother, strbeg) - 1;
1961 /* for multiline we only have to try after newlines */
1962 if (prog->check_substr || prog->check_utf8) {
1966 if (regtry(®info, &s))
1971 if (prog->extflags & RXf_USE_INTUIT) {
1972 s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
1983 if (*s++ == '\n') { /* don't need PL_utf8skip here */
1984 if (regtry(®info, &s))
1991 } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
1993 /* the warning about reginfo.ganch being used without intialization
1994 is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
1995 and we only enter this block when the same bit is set. */
1996 char *tmp_s = reginfo.ganch - prog->gofs;
1998 if (tmp_s >= strbeg && regtry(®info, &tmp_s))
2003 /* Messy cases: unanchored match. */
2004 if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2005 /* we have /x+whatever/ */
2006 /* it must be a one character string (XXXX Except UTF?) */
2011 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2012 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2013 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
2018 DEBUG_EXECUTE_r( did_match = 1 );
2019 if (regtry(®info, &s)) goto got_it;
2021 while (s < strend && *s == ch)
2029 DEBUG_EXECUTE_r( did_match = 1 );
2030 if (regtry(®info, &s)) goto got_it;
2032 while (s < strend && *s == ch)
2037 DEBUG_EXECUTE_r(if (!did_match)
2038 PerlIO_printf(Perl_debug_log,
2039 "Did not find anchored character...\n")
2042 else if (prog->anchored_substr != NULL
2043 || prog->anchored_utf8 != NULL
2044 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2045 && prog->float_max_offset < strend - s)) {
2050 char *last1; /* Last position checked before */
2054 if (prog->anchored_substr || prog->anchored_utf8) {
2055 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2056 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2057 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
2058 back_max = back_min = prog->anchored_offset;
2060 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2061 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2062 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2063 back_max = prog->float_max_offset;
2064 back_min = prog->float_min_offset;
2068 if (must == &PL_sv_undef)
2069 /* could not downgrade utf8 check substring, so must fail */
2075 last = HOP3c(strend, /* Cannot start after this */
2076 -(I32)(CHR_SVLEN(must)
2077 - (SvTAIL(must) != 0) + back_min), strbeg);
2080 last1 = HOPc(s, -1);
2082 last1 = s - 1; /* bogus */
2084 /* XXXX check_substr already used to find "s", can optimize if
2085 check_substr==must. */
2087 dontbother = end_shift;
2088 strend = HOPc(strend, -dontbother);
2089 while ( (s <= last) &&
2090 ((flags & REXEC_SCREAM)
2091 ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2092 end_shift, &scream_pos, 0))
2093 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2094 (unsigned char*)strend, must,
2095 multiline ? FBMrf_MULTILINE : 0))) ) {
2096 /* we may be pointing at the wrong string */
2097 if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2098 s = strbeg + (s - SvPVX_const(sv));
2099 DEBUG_EXECUTE_r( did_match = 1 );
2100 if (HOPc(s, -back_max) > last1) {
2101 last1 = HOPc(s, -back_min);
2102 s = HOPc(s, -back_max);
2105 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2107 last1 = HOPc(s, -back_min);
2111 while (s <= last1) {
2112 if (regtry(®info, &s))
2118 while (s <= last1) {
2119 if (regtry(®info, &s))
2125 DEBUG_EXECUTE_r(if (!did_match) {
2126 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
2127 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2128 PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2129 ((must == prog->anchored_substr || must == prog->anchored_utf8)
2130 ? "anchored" : "floating"),
2131 quoted, RE_SV_TAIL(must));
2135 else if ( (c = progi->regstclass) ) {
2137 const OPCODE op = OP(progi->regstclass);
2138 /* don't bother with what can't match */
2139 if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2140 strend = HOPc(strend, -(minlen - 1));
2143 SV * const prop = sv_newmortal();
2144 regprop(prog, prop, c);
2146 RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
2148 PerlIO_printf(Perl_debug_log,
2149 "Matching stclass %.*s against %s (%d chars)\n",
2150 (int)SvCUR(prop), SvPVX_const(prop),
2151 quoted, (int)(strend - s));
2154 if (find_byclass(prog, c, s, strend, ®info))
2156 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2160 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2165 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2166 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2167 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2169 if (flags & REXEC_SCREAM) {
2170 last = screaminstr(sv, float_real, s - strbeg,
2171 end_shift, &scream_pos, 1); /* last one */
2173 last = scream_olds; /* Only one occurrence. */
2174 /* we may be pointing at the wrong string */
2175 else if (RXp_MATCH_COPIED(prog))
2176 s = strbeg + (s - SvPVX_const(sv));
2180 const char * const little = SvPV_const(float_real, len);
2182 if (SvTAIL(float_real)) {
2183 if (memEQ(strend - len + 1, little, len - 1))
2184 last = strend - len + 1;
2185 else if (!multiline)
2186 last = memEQ(strend - len, little, len)
2187 ? strend - len : NULL;
2193 last = rninstr(s, strend, little, little + len);
2195 last = strend; /* matching "$" */
2200 PerlIO_printf(Perl_debug_log,
2201 "%sCan't trim the tail, match fails (should not happen)%s\n",
2202 PL_colors[4], PL_colors[5]));
2203 goto phooey; /* Should not happen! */
2205 dontbother = strend - last + prog->float_min_offset;
2207 if (minlen && (dontbother < minlen))
2208 dontbother = minlen - 1;
2209 strend -= dontbother; /* this one's always in bytes! */
2210 /* We don't know much -- general case. */
2213 if (regtry(®info, &s))
2222 if (regtry(®info, &s))
2224 } while (s++ < strend);
2233 RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2235 if (PL_reg_eval_set)
2236 restore_pos(aTHX_ prog);
2237 if (RXp_PAREN_NAMES(prog))
2238 (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2240 /* make sure $`, $&, $', and $digit will work later */
2241 if ( !(flags & REXEC_NOT_FIRST) ) {
2242 RX_MATCH_COPY_FREE(rx);
2243 if (flags & REXEC_COPY_STR) {
2244 const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2245 #ifdef PERL_OLD_COPY_ON_WRITE
2247 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2249 PerlIO_printf(Perl_debug_log,
2250 "Copy on write: regexp capture, type %d\n",
2253 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2254 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2255 assert (SvPOKp(prog->saved_copy));
2259 RX_MATCH_COPIED_on(rx);
2260 s = savepvn(strbeg, i);
2266 prog->subbeg = strbeg;
2267 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2274 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2275 PL_colors[4], PL_colors[5]));
2276 if (PL_reg_eval_set)
2277 restore_pos(aTHX_ prog);
2279 /* we failed :-( roll it back */
2280 Safefree(prog->offs);
2289 - regtry - try match at specific point
2291 STATIC I32 /* 0 failure, 1 success */
2292 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2296 REGEXP *const rx = reginfo->prog;
2297 regexp *const prog = (struct regexp *)SvANY(rx);
2298 RXi_GET_DECL(prog,progi);
2299 GET_RE_DEBUG_FLAGS_DECL;
2301 PERL_ARGS_ASSERT_REGTRY;
2303 reginfo->cutpoint=NULL;
2305 if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2308 PL_reg_eval_set = RS_init;
2309 DEBUG_EXECUTE_r(DEBUG_s(
2310 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2311 (IV)(PL_stack_sp - PL_stack_base));
2314 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2315 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2317 /* Apparently this is not needed, judging by wantarray. */
2318 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2319 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2322 /* Make $_ available to executed code. */
2323 if (reginfo->sv != DEFSV) {
2325 DEFSV_set(reginfo->sv);
2328 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2329 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2330 /* prepare for quick setting of pos */
2331 #ifdef PERL_OLD_COPY_ON_WRITE
2332 if (SvIsCOW(reginfo->sv))
2333 sv_force_normal_flags(reginfo->sv, 0);
2335 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2336 &PL_vtbl_mglob, NULL, 0);
2340 PL_reg_oldpos = mg->mg_len;
2341 SAVEDESTRUCTOR_X(restore_pos, prog);
2343 if (!PL_reg_curpm) {
2344 Newxz(PL_reg_curpm, 1, PMOP);
2347 SV* const repointer = &PL_sv_undef;
2348 /* this regexp is also owned by the new PL_reg_curpm, which
2349 will try to free it. */
2350 av_push(PL_regex_padav, repointer);
2351 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2352 PL_regex_pad = AvARRAY(PL_regex_padav);
2357 /* It seems that non-ithreads works both with and without this code.
2358 So for efficiency reasons it seems best not to have the code
2359 compiled when it is not needed. */
2360 /* This is safe against NULLs: */
2361 ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2362 /* PM_reg_curpm owns a reference to this regexp. */
2365 PM_SETRE(PL_reg_curpm, rx);
2366 PL_reg_oldcurpm = PL_curpm;
2367 PL_curpm = PL_reg_curpm;
2368 if (RXp_MATCH_COPIED(prog)) {
2369 /* Here is a serious problem: we cannot rewrite subbeg,
2370 since it may be needed if this match fails. Thus
2371 $` inside (?{}) could fail... */
2372 PL_reg_oldsaved = prog->subbeg;
2373 PL_reg_oldsavedlen = prog->sublen;
2374 #ifdef PERL_OLD_COPY_ON_WRITE
2375 PL_nrs = prog->saved_copy;
2377 RXp_MATCH_COPIED_off(prog);
2380 PL_reg_oldsaved = NULL;
2381 prog->subbeg = PL_bostr;
2382 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2384 DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2385 prog->offs[0].start = *startpos - PL_bostr;
2386 PL_reginput = *startpos;
2387 PL_reglastparen = &prog->lastparen;
2388 PL_reglastcloseparen = &prog->lastcloseparen;
2389 prog->lastparen = 0;
2390 prog->lastcloseparen = 0;
2392 PL_regoffs = prog->offs;
2393 if (PL_reg_start_tmpl <= prog->nparens) {
2394 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2395 if(PL_reg_start_tmp)
2396 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2398 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2401 /* XXXX What this code is doing here?!!! There should be no need
2402 to do this again and again, PL_reglastparen should take care of
2405 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2406 * Actually, the code in regcppop() (which Ilya may be meaning by
2407 * PL_reglastparen), is not needed at all by the test suite
2408 * (op/regexp, op/pat, op/split), but that code is needed otherwise
2409 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2410 * Meanwhile, this code *is* needed for the
2411 * above-mentioned test suite tests to succeed. The common theme
2412 * on those tests seems to be returning null fields from matches.
2413 * --jhi updated by dapm */
2415 if (prog->nparens) {
2416 regexp_paren_pair *pp = PL_regoffs;
2418 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2426 if (regmatch(reginfo, progi->program + 1)) {
2427 PL_regoffs[0].end = PL_reginput - PL_bostr;
2430 if (reginfo->cutpoint)
2431 *startpos= reginfo->cutpoint;
2432 REGCP_UNWIND(lastcp);
2437 #define sayYES goto yes
2438 #define sayNO goto no
2439 #define sayNO_SILENT goto no_silent
2441 /* we dont use STMT_START/END here because it leads to
2442 "unreachable code" warnings, which are bogus, but distracting. */
2443 #define CACHEsayNO \
2444 if (ST.cache_mask) \
2445 PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2448 /* this is used to determine how far from the left messages like
2449 'failed...' are printed. It should be set such that messages
2450 are inline with the regop output that created them.
2452 #define REPORT_CODE_OFF 32
2455 /* Make sure there is a test for this +1 options in re_tests */
2456 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2458 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2459 #define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
2461 #define SLAB_FIRST(s) (&(s)->states[0])
2462 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2464 /* grab a new slab and return the first slot in it */
2466 STATIC regmatch_state *
2469 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2472 regmatch_slab *s = PL_regmatch_slab->next;
2474 Newx(s, 1, regmatch_slab);
2475 s->prev = PL_regmatch_slab;
2477 PL_regmatch_slab->next = s;
2479 PL_regmatch_slab = s;
2480 return SLAB_FIRST(s);
2484 /* push a new state then goto it */
2486 #define PUSH_STATE_GOTO(state, node) \
2488 st->resume_state = state; \
2491 /* push a new state with success backtracking, then goto it */
2493 #define PUSH_YES_STATE_GOTO(state, node) \
2495 st->resume_state = state; \
2496 goto push_yes_state;
2502 regmatch() - main matching routine
2504 This is basically one big switch statement in a loop. We execute an op,
2505 set 'next' to point the next op, and continue. If we come to a point which
2506 we may need to backtrack to on failure such as (A|B|C), we push a
2507 backtrack state onto the backtrack stack. On failure, we pop the top
2508 state, and re-enter the loop at the state indicated. If there are no more
2509 states to pop, we return failure.
2511 Sometimes we also need to backtrack on success; for example /A+/, where
2512 after successfully matching one A, we need to go back and try to
2513 match another one; similarly for lookahead assertions: if the assertion
2514 completes successfully, we backtrack to the state just before the assertion
2515 and then carry on. In these cases, the pushed state is marked as
2516 'backtrack on success too'. This marking is in fact done by a chain of
2517 pointers, each pointing to the previous 'yes' state. On success, we pop to
2518 the nearest yes state, discarding any intermediate failure-only states.
2519 Sometimes a yes state is pushed just to force some cleanup code to be
2520 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2521 it to free the inner regex.
2523 Note that failure backtracking rewinds the cursor position, while
2524 success backtracking leaves it alone.
2526 A pattern is complete when the END op is executed, while a subpattern
2527 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2528 ops trigger the "pop to last yes state if any, otherwise return true"
2531 A common convention in this function is to use A and B to refer to the two
2532 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2533 the subpattern to be matched possibly multiple times, while B is the entire
2534 rest of the pattern. Variable and state names reflect this convention.
2536 The states in the main switch are the union of ops and failure/success of
2537 substates associated with with that op. For example, IFMATCH is the op
2538 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2539 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2540 successfully matched A and IFMATCH_A_fail is a state saying that we have
2541 just failed to match A. Resume states always come in pairs. The backtrack
2542 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2543 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2544 on success or failure.
2546 The struct that holds a backtracking state is actually a big union, with
2547 one variant for each major type of op. The variable st points to the
2548 top-most backtrack struct. To make the code clearer, within each
2549 block of code we #define ST to alias the relevant union.
2551 Here's a concrete example of a (vastly oversimplified) IFMATCH
2557 #define ST st->u.ifmatch
2559 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2560 ST.foo = ...; // some state we wish to save
2562 // push a yes backtrack state with a resume value of
2563 // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2565 PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2568 case IFMATCH_A: // we have successfully executed A; now continue with B
2570 bar = ST.foo; // do something with the preserved value
2573 case IFMATCH_A_fail: // A failed, so the assertion failed
2574 ...; // do some housekeeping, then ...
2575 sayNO; // propagate the failure
2582 For any old-timers reading this who are familiar with the old recursive
2583 approach, the code above is equivalent to:
2585 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2594 ...; // do some housekeeping, then ...
2595 sayNO; // propagate the failure
2598 The topmost backtrack state, pointed to by st, is usually free. If you
2599 want to claim it, populate any ST.foo fields in it with values you wish to
2600 save, then do one of
2602 PUSH_STATE_GOTO(resume_state, node);
2603 PUSH_YES_STATE_GOTO(resume_state, node);
2605 which sets that backtrack state's resume value to 'resume_state', pushes a
2606 new free entry to the top of the backtrack stack, then goes to 'node'.
2607 On backtracking, the free slot is popped, and the saved state becomes the
2608 new free state. An ST.foo field in this new top state can be temporarily
2609 accessed to retrieve values, but once the main loop is re-entered, it
2610 becomes available for reuse.
2612 Note that the depth of the backtrack stack constantly increases during the
2613 left-to-right execution of the pattern, rather than going up and down with
2614 the pattern nesting. For example the stack is at its maximum at Z at the
2615 end of the pattern, rather than at X in the following:
2617 /(((X)+)+)+....(Y)+....Z/
2619 The only exceptions to this are lookahead/behind assertions and the cut,
2620 (?>A), which pop all the backtrack states associated with A before
2623 Bascktrack state structs are allocated in slabs of about 4K in size.
2624 PL_regmatch_state and st always point to the currently active state,
2625 and PL_regmatch_slab points to the slab currently containing
2626 PL_regmatch_state. The first time regmatch() is called, the first slab is
2627 allocated, and is never freed until interpreter destruction. When the slab
2628 is full, a new one is allocated and chained to the end. At exit from
2629 regmatch(), slabs allocated since entry are freed.
2634 #define DEBUG_STATE_pp(pp) \
2636 DUMP_EXEC_POS(locinput, scan, do_utf8); \
2637 PerlIO_printf(Perl_debug_log, \
2638 " %*s"pp" %s%s%s%s%s\n", \
2640 PL_reg_name[st->resume_state], \
2641 ((st==yes_state||st==mark_state) ? "[" : ""), \
2642 ((st==yes_state) ? "Y" : ""), \
2643 ((st==mark_state) ? "M" : ""), \
2644 ((st==yes_state||st==mark_state) ? "]" : "") \
2649 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2654 S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8,
2655 const char *start, const char *end, const char *blurb)
2657 const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2659 PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2664 RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2665 RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
2667 RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2668 start, end - start, 60);
2670 PerlIO_printf(Perl_debug_log,
2671 "%s%s REx%s %s against %s\n",
2672 PL_colors[4], blurb, PL_colors[5], s0, s1);
2674 if (do_utf8||utf8_pat)
2675 PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2676 utf8_pat ? "pattern" : "",
2677 utf8_pat && do_utf8 ? " and " : "",
2678 do_utf8 ? "string" : ""
2684 S_dump_exec_pos(pTHX_ const char *locinput,
2685 const regnode *scan,
2686 const char *loc_regeol,
2687 const char *loc_bostr,
2688 const char *loc_reg_starttry,
2691 const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2692 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2693 int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2694 /* The part of the string before starttry has one color
2695 (pref0_len chars), between starttry and current
2696 position another one (pref_len - pref0_len chars),
2697 after the current position the third one.
2698 We assume that pref0_len <= pref_len, otherwise we
2699 decrease pref0_len. */
2700 int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2701 ? (5 + taill) - l : locinput - loc_bostr;
2704 PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2706 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2708 pref0_len = pref_len - (locinput - loc_reg_starttry);
2709 if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2710 l = ( loc_regeol - locinput > (5 + taill) - pref_len
2711 ? (5 + taill) - pref_len : loc_regeol - locinput);
2712 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2716 if (pref0_len > pref_len)
2717 pref0_len = pref_len;
2719 const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2721 RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2722 (locinput - pref_len),pref0_len, 60, 4, 5);
2724 RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2725 (locinput - pref_len + pref0_len),
2726 pref_len - pref0_len, 60, 2, 3);
2728 RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2729 locinput, loc_regeol - locinput, 10, 0, 1);
2731 const STRLEN tlen=len0+len1+len2;
2732 PerlIO_printf(Perl_debug_log,
2733 "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2734 (IV)(locinput - loc_bostr),
2737 (docolor ? "" : "> <"),
2739 (int)(tlen > 19 ? 0 : 19 - tlen),
2746 /* reg_check_named_buff_matched()
2747 * Checks to see if a named buffer has matched. The data array of
2748 * buffer numbers corresponding to the buffer is expected to reside
2749 * in the regexp->data->data array in the slot stored in the ARG() of
2750 * node involved. Note that this routine doesn't actually care about the
2751 * name, that information is not preserved from compilation to execution.
2752 * Returns the index of the leftmost defined buffer with the given name
2753 * or 0 if non of the buffers matched.
2756 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2759 RXi_GET_DECL(rex,rexi);
2760 SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
2761 I32 *nums=(I32*)SvPVX(sv_dat);
2763 PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
2765 for ( n=0; n<SvIVX(sv_dat); n++ ) {
2766 if ((I32)*PL_reglastparen >= nums[n] &&
2767 PL_regoffs[nums[n]].end != -1)
2776 /* free all slabs above current one - called during LEAVE_SCOPE */
2779 S_clear_backtrack_stack(pTHX_ void *p)
2781 regmatch_slab *s = PL_regmatch_slab->next;
2786 PL_regmatch_slab->next = NULL;
2788 regmatch_slab * const osl = s;
2795 #define SETREX(Re1,Re2) \
2796 if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2799 STATIC I32 /* 0 failure, 1 success */
2800 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2802 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2806 register const bool do_utf8 = PL_reg_match_utf8;
2807 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2808 REGEXP *rex_sv = reginfo->prog;
2809 regexp *rex = (struct regexp *)SvANY(rex_sv);
2810 RXi_GET_DECL(rex,rexi);
2812 /* the current state. This is a cached copy of PL_regmatch_state */
2813 register regmatch_state *st;
2814 /* cache heavy used fields of st in registers */
2815 register regnode *scan;
2816 register regnode *next;
2817 register U32 n = 0; /* general value; init to avoid compiler warning */
2818 register I32 ln = 0; /* len or last; init to avoid compiler warning */
2819 register char *locinput = PL_reginput;
2820 register I32 nextchr; /* is always set to UCHARAT(locinput) */
2822 bool result = 0; /* return value of S_regmatch */
2823 int depth = 0; /* depth of backtrack stack */
2824 U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
2825 const U32 max_nochange_depth =
2826 (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
2827 3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
2828 regmatch_state *yes_state = NULL; /* state to pop to on success of
2830 /* mark_state piggy backs on the yes_state logic so that when we unwind
2831 the stack on success we can update the mark_state as we go */
2832 regmatch_state *mark_state = NULL; /* last mark state we have seen */
2833 regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2834 struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
2836 bool no_final = 0; /* prevent failure from backtracking? */
2837 bool do_cutgroup = 0; /* no_final only until next branch/trie entry */
2838 char *startpoint = PL_reginput;
2839 SV *popmark = NULL; /* are we looking for a mark? */
2840 SV *sv_commit = NULL; /* last mark name seen in failure */
2841 SV *sv_yes_mark = NULL; /* last mark name we have seen
2842 during a successfull match */
2843 U32 lastopen = 0; /* last open we saw */
2844 bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2845 SV* const oreplsv = GvSV(PL_replgv);
2846 /* these three flags are set by various ops to signal information to
2847 * the very next op. They have a useful lifetime of exactly one loop
2848 * iteration, and are not preserved or restored by state pushes/pops
2850 bool sw = 0; /* the condition value in (?(cond)a|b) */
2851 bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
2852 int logical = 0; /* the following EVAL is:
2856 or the following IFMATCH/UNLESSM is:
2857 false: plain (?=foo)
2858 true: used as a condition: (?(?=foo))
2861 GET_RE_DEBUG_FLAGS_DECL;
2864 PERL_ARGS_ASSERT_REGMATCH;
2866 DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
2867 PerlIO_printf(Perl_debug_log,"regmatch start\n");
2869 /* on first ever call to regmatch, allocate first slab */
2870 if (!PL_regmatch_slab) {
2871 Newx(PL_regmatch_slab, 1, regmatch_slab);
2872 PL_regmatch_slab->prev = NULL;
2873 PL_regmatch_slab->next = NULL;
2874 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2877 oldsave = PL_savestack_ix;
2878 SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
2879 SAVEVPTR(PL_regmatch_slab);
2880 SAVEVPTR(PL_regmatch_state);
2882 /* grab next free state slot */
2883 st = ++PL_regmatch_state;
2884 if (st > SLAB_LAST(PL_regmatch_slab))
2885 st = PL_regmatch_state = S_push_slab(aTHX);
2887 /* Note that nextchr is a byte even in UTF */
2888 nextchr = UCHARAT(locinput);
2890 while (scan != NULL) {
2893 SV * const prop = sv_newmortal();
2894 regnode *rnext=regnext(scan);
2895 DUMP_EXEC_POS( locinput, scan, do_utf8 );
2896 regprop(rex, prop, scan);
2898 PerlIO_printf(Perl_debug_log,
2899 "%3"IVdf":%*s%s(%"IVdf")\n",
2900 (IV)(scan - rexi->program), depth*2, "",
2902 (PL_regkind[OP(scan)] == END || !rnext) ?
2903 0 : (IV)(rnext - rexi->program));
2906 next = scan + NEXT_OFF(scan);
2909 state_num = OP(scan);
2913 assert(PL_reglastparen == &rex->lastparen);
2914 assert(PL_reglastcloseparen == &rex->lastcloseparen);
2915 assert(PL_regoffs == rex->offs);
2917 switch (state_num) {
2919 if (locinput == PL_bostr)
2921 /* reginfo->till = reginfo->bol; */
2926 if (locinput == PL_bostr ||
2927 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2933 if (locinput == PL_bostr)
2937 if (locinput == reginfo->ganch)
2942 /* update the startpoint */
2943 st->u.keeper.val = PL_regoffs[0].start;
2944 PL_reginput = locinput;
2945 PL_regoffs[0].start = locinput - PL_bostr;
2946 PUSH_STATE_GOTO(KEEPS_next, next);
2948 case KEEPS_next_fail:
2949 /* rollback the start point change */
2950 PL_regoffs[0].start = st->u.keeper.val;
2956 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2961 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2963 if (PL_regeol - locinput > 1)
2967 if (PL_regeol != locinput)
2971 if (!nextchr && locinput >= PL_regeol)
2974 locinput += PL_utf8skip[nextchr];
2975 if (locinput > PL_regeol)
2977 nextchr = UCHARAT(locinput);
2980 nextchr = UCHARAT(++locinput);
2983 if (!nextchr && locinput >= PL_regeol)
2985 nextchr = UCHARAT(++locinput);
2988 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2991 locinput += PL_utf8skip[nextchr];
2992 if (locinput > PL_regeol)
2994 nextchr = UCHARAT(locinput);
2997 nextchr = UCHARAT(++locinput);
3001 #define ST st->u.trie
3003 /* In this case the charclass data is available inline so
3004 we can fail fast without a lot of extra overhead.
3006 if (scan->flags == EXACT || !do_utf8) {
3007 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3009 PerlIO_printf(Perl_debug_log,
3010 "%*s %sfailed to match trie start class...%s\n",
3011 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3020 /* what type of TRIE am I? (utf8 makes this contextual) */
3021 DECL_TRIE_TYPE(scan);
3023 /* what trie are we using right now */
3024 reg_trie_data * const trie
3025 = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3026 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3027 U32 state = trie->startstate;
3029 if (trie->bitmap && trie_type != trie_utf8_fold &&
3030 !TRIE_BITMAP_TEST(trie,*locinput)
3032 if (trie->states[ state ].wordnum) {
3034 PerlIO_printf(Perl_debug_log,
3035 "%*s %smatched empty string...%s\n",
3036 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3041 PerlIO_printf(Perl_debug_log,
3042 "%*s %sfailed to match trie start class...%s\n",
3043 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3050 U8 *uc = ( U8* )locinput;
3054 U8 *uscan = (U8*)NULL;
3056 SV *sv_accept_buff = NULL;
3057 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3059 ST.accepted = 0; /* how many accepting states we have seen */
3061 ST.jump = trie->jump;
3064 traverse the TRIE keeping track of all accepting states
3065 we transition through until we get to a failing node.
3068 while ( state && uc <= (U8*)PL_regeol ) {
3069 U32 base = trie->states[ state ].trans.base;
3072 /* We use charid to hold the wordnum as we don't use it
3073 for charid until after we have done the wordnum logic.
3074 We define an alias just so that the wordnum logic reads
3077 #define got_wordnum charid
3078 got_wordnum = trie->states[ state ].wordnum;
3080 if ( got_wordnum ) {
3081 if ( ! ST.accepted ) {
3083 SAVETMPS; /* XXX is this necessary? dmq */
3084 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
3085 sv_accept_buff=newSV(bufflen *
3086 sizeof(reg_trie_accepted) - 1);
3087 SvCUR_set(sv_accept_buff, 0);
3088 SvPOK_on(sv_accept_buff);
3089 sv_2mortal(sv_accept_buff);
3092 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
3095 if (ST.accepted >= bufflen) {
3097 ST.accept_buff =(reg_trie_accepted*)
3098 SvGROW(sv_accept_buff,
3099 bufflen * sizeof(reg_trie_accepted));
3101 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
3102 + sizeof(reg_trie_accepted));
3105 ST.accept_buff[ST.accepted].wordnum = got_wordnum;
3106 ST.accept_buff[ST.accepted].endpos = uc;
3108 } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
3112 DEBUG_TRIE_EXECUTE_r({
3113 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
3114 PerlIO_printf( Perl_debug_log,
3115 "%*s %sState: %4"UVxf" Accepted: %4"UVxf" ",
3116 2+depth * 2, "", PL_colors[4],
3117 (UV)state, (UV)ST.accepted );
3121 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3122 uscan, len, uvc, charid, foldlen,
3126 (base + charid > trie->uniquecharcount )
3127 && (base + charid - 1 - trie->uniquecharcount
3129 && trie->trans[base + charid - 1 -
3130 trie->uniquecharcount].check == state)
3132 state = trie->trans[base + charid - 1 -
3133 trie->uniquecharcount ].next;
3144 DEBUG_TRIE_EXECUTE_r(
3145 PerlIO_printf( Perl_debug_log,
3146 "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3147 charid, uvc, (UV)state, PL_colors[5] );
3154 PerlIO_printf( Perl_debug_log,
3155 "%*s %sgot %"IVdf" possible matches%s\n",
3156 REPORT_CODE_OFF + depth * 2, "",
3157 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3160 goto trie_first_try; /* jump into the fail handler */
3162 case TRIE_next_fail: /* we failed - try next alterative */
3164 REGCP_UNWIND(ST.cp);
3165 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3166 PL_regoffs[n].end = -1;
3167 *PL_reglastparen = n;
3176 ST.lastparen = *PL_reglastparen;
3179 if ( ST.accepted == 1 ) {
3180 /* only one choice left - just continue */
3182 AV *const trie_words
3183 = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3184 SV ** const tmp = av_fetch( trie_words,
3185 ST.accept_buff[ 0 ].wordnum-1, 0 );
3186 SV *sv= tmp ? sv_newmortal() : NULL;
3188 PerlIO_printf( Perl_debug_log,
3189 "%*s %sonly one match left: #%d <%s>%s\n",
3190 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3191 ST.accept_buff[ 0 ].wordnum,
3192 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3193 PL_colors[0], PL_colors[1],
3194 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3196 : "not compiled under -Dr",
3199 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3200 /* in this case we free tmps/leave before we call regmatch
3201 as we wont be using accept_buff again. */
3203 locinput = PL_reginput;
3204 nextchr = UCHARAT(locinput);
3205 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
3208 scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3209 if (!has_cutgroup) {
3214 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3217 continue; /* execute rest of RE */
3220 if ( !ST.accepted-- ) {
3222 PerlIO_printf( Perl_debug_log,
3223 "%*s %sTRIE failed...%s\n",
3224 REPORT_CODE_OFF+depth*2, "",
3235 There are at least two accepting states left. Presumably
3236 the number of accepting states is going to be low,
3237 typically two. So we simply scan through to find the one
3238 with lowest wordnum. Once we find it, we swap the last
3239 state into its place and decrement the size. We then try to
3240 match the rest of the pattern at the point where the word
3241 ends. If we succeed, control just continues along the
3242 regex; if we fail we return here to try the next accepting
3249 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3250 DEBUG_TRIE_EXECUTE_r(
3251 PerlIO_printf( Perl_debug_log,
3252 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3253 REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3254 (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3255 ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3258 if (ST.accept_buff[cur].wordnum <
3259 ST.accept_buff[best].wordnum)
3264 AV *const trie_words
3265 = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3266 SV ** const tmp = av_fetch( trie_words,
3267 ST.accept_buff[ best ].wordnum - 1, 0 );
3268 regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
3270 ST.me + ST.jump[ST.accept_buff[best].wordnum];
3271 SV *sv= tmp ? sv_newmortal() : NULL;
3273 PerlIO_printf( Perl_debug_log,
3274 "%*s %strying alternation #%d <%s> at node #%d %s\n",
3275 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3276 ST.accept_buff[best].wordnum,
3277 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3278 PL_colors[0], PL_colors[1],
3279 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3280 ) : "not compiled under -Dr",
3281 REG_NODE_NUM(nextop),
3285 if ( best<ST.accepted ) {
3286 reg_trie_accepted tmp = ST.accept_buff[ best ];
3287 ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3288 ST.accept_buff[ ST.accepted ] = tmp;
3291 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3292 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3295 scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3297 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3302 /* we dont want to throw this away, see bug 57042*/
3303 if (oreplsv != GvSV(PL_replgv))
3304 sv_setsv(oreplsv, GvSV(PL_replgv));
3311 char *s = STRING(scan);
3313 if (do_utf8 != UTF) {
3314 /* The target and the pattern have differing utf8ness. */
3316 const char * const e = s + ln;
3319 /* The target is utf8, the pattern is not utf8. */
3324 if (NATIVE_TO_UNI(*(U8*)s) !=
3325 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3333 /* The target is not utf8, the pattern is utf8. */
3338 if (NATIVE_TO_UNI(*((U8*)l)) !=
3339 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3347 nextchr = UCHARAT(locinput);
3350 /* The target and the pattern have the same utf8ness. */
3351 /* Inline the first character, for speed. */
3352 if (UCHARAT(s) != nextchr)
3354 if (PL_regeol - locinput < ln)
3356 if (ln > 1 && memNE(s, locinput, ln))
3359 nextchr = UCHARAT(locinput);
3363 PL_reg_flags |= RF_tainted;
3366 char * const s = STRING(scan);
3369 if (do_utf8 || UTF) {
3370 /* Either target or the pattern are utf8. */
3371 const char * const l = locinput;
3372 char *e = PL_regeol;
3374 if (ibcmp_utf8(s, 0, ln, (bool)UTF,
3375 l, &e, 0, do_utf8)) {
3376 /* One more case for the sharp s:
3377 * pack("U0U*", 0xDF) =~ /ss/i,
3378 * the 0xC3 0x9F are the UTF-8
3379 * byte sequence for the U+00DF. */
3382 toLOWER(s[0]) == 's' &&
3384 toLOWER(s[1]) == 's' &&
3391 nextchr = UCHARAT(locinput);
3395 /* Neither the target and the pattern are utf8. */
3397 /* Inline the first character, for speed. */
3398 if (UCHARAT(s) != nextchr &&
3399 UCHARAT(s) != ((OP(scan) == EXACTF)
3400 ? PL_fold : PL_fold_locale)[nextchr])
3402 if (PL_regeol - locinput < ln)
3404 if (ln > 1 && (OP(scan) == EXACTF
3405 ? ibcmp(s, locinput, ln)
3406 : ibcmp_locale(s, locinput, ln)))
3409 nextchr = UCHARAT(locinput);
3414 PL_reg_flags |= RF_tainted;
3418 /* was last char in word? */
3420 if (locinput == PL_bostr)
3423 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3425 ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3427 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3428 ln = isALNUM_uni(ln);
3429 LOAD_UTF8_CHARCLASS_ALNUM();
3430 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3433 ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3434 n = isALNUM_LC_utf8((U8*)locinput);
3438 ln = (locinput != PL_bostr) ?
3439 UCHARAT(locinput - 1) : '\n';
3440 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3442 n = isALNUM(nextchr);
3445 ln = isALNUM_LC(ln);
3446 n = isALNUM_LC(nextchr);
3449 if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3450 OP(scan) == BOUNDL))
3455 STRLEN inclasslen = PL_regeol - locinput;
3457 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3459 if (locinput >= PL_regeol)
3461 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3462 nextchr = UCHARAT(locinput);
3467 nextchr = UCHARAT(locinput);
3468 if (!REGINCLASS(rex, scan, (U8*)locinput))
3470 if (!nextchr && locinput >= PL_regeol)
3472 nextchr = UCHARAT(++locinput);
3476 /* If we might have the case of the German sharp s
3477 * in a casefolding Unicode character class. */
3479 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3480 locinput += SHARP_S_SKIP;
3481 nextchr = UCHARAT(locinput);
3486 /* Special char classes - The defines start on line 129 or so */
3487 CCC_TRY_AFF( ALNUM, ALNUML, alnum, "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3488 CCC_TRY_NEG(NALNUM, NALNUML, alnum, "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3490 CCC_TRY_AFF( SPACE, SPACEL, space, " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3491 CCC_TRY_NEG(NSPACE, NSPACEL, space, " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3493 CCC_TRY_AFF( DIGIT, DIGITL, digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3494 CCC_TRY_NEG(NDIGIT, NDIGITL, digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3497 if (locinput >= PL_regeol)
3500 LOAD_UTF8_CHARCLASS_MARK();
3501 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3503 locinput += PL_utf8skip[nextchr];
3504 while (locinput < PL_regeol &&
3505 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3506 locinput += UTF8SKIP(locinput);
3507 if (locinput > PL_regeol)
3512 nextchr = UCHARAT(locinput);
3519 PL_reg_flags |= RF_tainted;
3524 n = reg_check_named_buff_matched(rex,scan);
3527 type = REF + ( type - NREF );
3534 PL_reg_flags |= RF_tainted;
3538 n = ARG(scan); /* which paren pair */
3541 ln = PL_regoffs[n].start;
3542 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3543 if (*PL_reglastparen < n || ln == -1)
3544 sayNO; /* Do not match unless seen CLOSEn. */
3545 if (ln == PL_regoffs[n].end)
3549 if (do_utf8 && type != REF) { /* REF can do byte comparison */
3551 const char *e = PL_bostr + PL_regoffs[n].end;
3553 * Note that we can't do the "other character" lookup trick as
3554 * in the 8-bit case (no pun intended) because in Unicode we
3555 * have to map both upper and title case to lower case.
3559 STRLEN ulen1, ulen2;
3560 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3561 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3565 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3566 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3567 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3574 nextchr = UCHARAT(locinput);
3578 /* Inline the first character, for speed. */
3579 if (UCHARAT(s) != nextchr &&
3581 (UCHARAT(s) != (type == REFF
3582 ? PL_fold : PL_fold_locale)[nextchr])))
3584 ln = PL_regoffs[n].end - ln;
3585 if (locinput + ln > PL_regeol)
3587 if (ln > 1 && (type == REF
3588 ? memNE(s, locinput, ln)
3590 ? ibcmp(s, locinput, ln)
3591 : ibcmp_locale(s, locinput, ln))))
3594 nextchr = UCHARAT(locinput);
3604 #define ST st->u.eval
3609 regexp_internal *rei;
3610 regnode *startpoint;
3613 case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */
3614 if (cur_eval && cur_eval->locinput==locinput) {
3615 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3616 Perl_croak(aTHX_ "Infinite recursion in regex");
3617 if ( ++nochange_depth > max_nochange_depth )
3619 "Pattern subroutine nesting without pos change"
3620 " exceeded limit in regex");
3627 (void)ReREFCNT_inc(rex_sv);
3628 if (OP(scan)==GOSUB) {
3629 startpoint = scan + ARG2L(scan);
3630 ST.close_paren = ARG(scan);
3632 startpoint = rei->program+1;
3635 goto eval_recurse_doit;
3637 case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
3638 if (cur_eval && cur_eval->locinput==locinput) {
3639 if ( ++nochange_depth > max_nochange_depth )
3640 Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3645 /* execute the code in the {...} */
3647 SV ** const before = SP;
3648 OP_4tree * const oop = PL_op;
3649 COP * const ocurcop = PL_curcop;
3651 char *saved_regeol = PL_regeol;
3654 PL_op = (OP_4tree*)rexi->data->data[n];
3655 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3656 " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3657 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3658 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3661 SV *sv_mrk = get_sv("REGMARK", 1);
3662 sv_setsv(sv_mrk, sv_yes_mark);
3665 CALLRUNOPS(aTHX); /* Scalar context. */
3668 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
3675 PAD_RESTORE_LOCAL(old_comppad);
3676 PL_curcop = ocurcop;
3677 PL_regeol = saved_regeol;
3680 sv_setsv(save_scalar(PL_replgv), ret);
3684 if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3687 /* extract RE object from returned value; compiling if
3693 SV *const sv = SvRV(ret);
3695 if (SvTYPE(sv) == SVt_REGEXP) {
3697 } else if (SvSMAGICAL(sv)) {
3698 mg = mg_find(sv, PERL_MAGIC_qr);
3701 } else if (SvTYPE(ret) == SVt_REGEXP) {
3703 } else if (SvSMAGICAL(ret)) {
3704 if (SvGMAGICAL(ret)) {
3705 /* I don't believe that there is ever qr magic
3707 assert(!mg_find(ret, PERL_MAGIC_qr));
3708 sv_unmagic(ret, PERL_MAGIC_qr);
3711 mg = mg_find(ret, PERL_MAGIC_qr);
3712 /* testing suggests mg only ends up non-NULL for
3713 scalars who were upgraded and compiled in the
3714 else block below. In turn, this is only
3715 triggered in the "postponed utf8 string" tests
3721 rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
3725 rx = reg_temp_copy(rx);
3729 const I32 osize = PL_regsize;
3732 assert (SvUTF8(ret));
3733 } else if (SvUTF8(ret)) {
3734 /* Not doing UTF-8, despite what the SV says. Is
3735 this only if we're trapped in use 'bytes'? */
3736 /* Make a copy of the octet sequence, but without
3737 the flag on, as the compiler now honours the
3738 SvUTF8 flag on ret. */
3740 const char *const p = SvPV(ret, len);
3741 ret = newSVpvn_flags(p, len, SVs_TEMP);
3743 rx = CALLREGCOMP(ret, pm_flags);
3745 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3747 /* This isn't a first class regexp. Instead, it's
3748 caching a regexp onto an existing, Perl visible
3750 sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
3755 re = (struct regexp *)SvANY(rx);
3757 RXp_MATCH_COPIED_off(re);
3758 re->subbeg = rex->subbeg;
3759 re->sublen = rex->sublen;
3762 debug_start_match(re_sv, do_utf8, locinput, PL_regeol,
3763 "Matching embedded");
3765 startpoint = rei->program + 1;
3766 ST.close_paren = 0; /* only used for GOSUB */
3767 /* borrowed from regtry */
3768 if (PL_reg_start_tmpl <= re->nparens) {
3769 PL_reg_start_tmpl = re->nparens*3/2 + 3;
3770 if(PL_reg_start_tmp)
3771 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3773 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3776 eval_recurse_doit: /* Share code with GOSUB below this line */
3777 /* run the pattern returned from (??{...}) */
3778 ST.cp = regcppush(0); /* Save *all* the positions. */
3779 REGCP_SET(ST.lastcp);
3781 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
3783 /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
3784 PL_reglastparen = &re->lastparen;
3785 PL_reglastcloseparen = &re->lastcloseparen;
3787 re->lastcloseparen = 0;
3789 PL_reginput = locinput;
3792 /* XXXX This is too dramatic a measure... */
3795 ST.toggle_reg_flags = PL_reg_flags;
3797 PL_reg_flags |= RF_utf8;
3799 PL_reg_flags &= ~RF_utf8;
3800 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3802 ST.prev_rex = rex_sv;
3803 ST.prev_curlyx = cur_curlyx;
3804 SETREX(rex_sv,re_sv);
3809 ST.prev_eval = cur_eval;
3811 /* now continue from first node in postoned RE */
3812 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
3815 /* logical is 1, /(?(?{...})X|Y)/ */
3816 sw = (bool)SvTRUE(ret);
3821 case EVAL_AB: /* cleanup after a successful (??{A})B */
3822 /* note: this is called twice; first after popping B, then A */
3823 PL_reg_flags ^= ST.toggle_reg_flags;
3824 ReREFCNT_dec(rex_sv);
3825 SETREX(rex_sv,ST.prev_rex);
3826 rex = (struct regexp *)SvANY(rex_sv);
3827 rexi = RXi_GET(rex);
3829 cur_eval = ST.prev_eval;
3830 cur_curlyx = ST.prev_curlyx;
3832 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
3833 PL_reglastparen = &rex->lastparen;
3834 PL_reglastcloseparen = &rex->lastcloseparen;
3835 /* also update PL_regoffs */
3836 PL_regoffs = rex->offs;
3838 /* XXXX This is too dramatic a measure... */
3840 if ( nochange_depth )
3845 case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3846 /* note: this is called twice; first after popping B, then A */
3847 PL_reg_flags ^= ST.toggle_reg_flags;
3848 ReREFCNT_dec(rex_sv);
3849 SETREX(rex_sv,ST.prev_rex);
3850 rex = (struct regexp *)SvANY(rex_sv);
3851 rexi = RXi_GET(rex);
3852 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
3853 PL_reglastparen = &rex->lastparen;
3854 PL_reglastcloseparen = &rex->lastcloseparen;
3856 PL_reginput = locinput;
3857 REGCP_UNWIND(ST.lastcp);
3859 cur_eval = ST.prev_eval;
3860 cur_curlyx = ST.prev_curlyx;
3861 /* XXXX This is too dramatic a measure... */
3863 if ( nochange_depth )
3869 n = ARG(scan); /* which paren pair */
3870 PL_reg_start_tmp[n] = locinput;
3876 n = ARG(scan); /* which paren pair */
3877 PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
3878 PL_regoffs[n].end = locinput - PL_bostr;
3879 /*if (n > PL_regsize)
3881 if (n > *PL_reglastparen)
3882 *PL_reglastparen = n;
3883 *PL_reglastcloseparen = n;
3884 if (cur_eval && cur_eval->u.eval.close_paren == n) {
3892 cursor && OP(cursor)!=END;
3893 cursor=regnext(cursor))
3895 if ( OP(cursor)==CLOSE ){
3897 if ( n <= lastopen ) {
3899 = PL_reg_start_tmp[n] - PL_bostr;
3900 PL_regoffs[n].end = locinput - PL_bostr;
3901 /*if (n > PL_regsize)
3903 if (n > *PL_reglastparen)
3904 *PL_reglastparen = n;
3905 *PL_reglastcloseparen = n;
3906 if ( n == ARG(scan) || (cur_eval &&
3907 cur_eval->u.eval.close_paren == n))
3916 n = ARG(scan); /* which paren pair */
3917 sw = (bool)(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
3920 /* reg_check_named_buff_matched returns 0 for no match */
3921 sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
3925 sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
3931 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3933 next = NEXTOPER(NEXTOPER(scan));
3935 next = scan + ARG(scan);
3936 if (OP(next) == IFTHEN) /* Fake one. */
3937 next = NEXTOPER(NEXTOPER(next));
3941 logical = scan->flags;
3944 /*******************************************************************
3946 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
3947 pattern, where A and B are subpatterns. (For simple A, CURLYM or
3948 STAR/PLUS/CURLY/CURLYN are used instead.)
3950 A*B is compiled as <CURLYX><A><WHILEM><B>
3952 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
3953 state, which contains the current count, initialised to -1. It also sets
3954 cur_curlyx to point to this state, with any previous value saved in the
3957 CURLYX then jumps straight to the WHILEM op, rather than executing A,
3958 since the pattern may possibly match zero times (i.e. it's a while {} loop
3959 rather than a do {} while loop).
3961 Each entry to WHILEM represents a successful match of A. The count in the
3962 CURLYX block is incremented, another WHILEM state is pushed, and execution
3963 passes to A or B depending on greediness and the current count.
3965 For example, if matching against the string a1a2a3b (where the aN are
3966 substrings that match /A/), then the match progresses as follows: (the
3967 pushed states are interspersed with the bits of strings matched so far):
3970 <CURLYX cnt=0><WHILEM>
3971 <CURLYX cnt=1><WHILEM> a1 <WHILEM>
3972 <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
3973 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
3974 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
3976 (Contrast this with something like CURLYM, which maintains only a single
3980 a1 <CURLYM cnt=1> a2
3981 a1 a2 <CURLYM cnt=2> a3
3982 a1 a2 a3 <CURLYM cnt=3> b
3985 Each WHILEM state block marks a point to backtrack to upon partial failure
3986 of A or B, and also contains some minor state data related to that
3987 iteration. The CURLYX block, pointed to by cur_curlyx, contains the
3988 overall state, such as the count, and pointers to the A and B ops.
3990 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
3991 must always point to the *current* CURLYX block, the rules are:
3993 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
3994 and set cur_curlyx to point the new block.
3996 When popping the CURLYX block after a successful or unsuccessful match,
3997 restore the previous cur_curlyx.
3999 When WHILEM is about to execute B, save the current cur_curlyx, and set it
4000 to the outer one saved in the CURLYX block.
4002 When popping the WHILEM block after a successful or unsuccessful B match,
4003 restore the previous cur_curlyx.
4005 Here's an example for the pattern (AI* BI)*BO
4006 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
4009 curlyx backtrack stack
4010 ------ ---------------
4012 CO <CO prev=NULL> <WO>
4013 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4014 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4015 NULL <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
4017 At this point the pattern succeeds, and we work back down the stack to
4018 clean up, restoring as we go:
4020 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4021 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4022 CO <CO prev=NULL> <WO>
4025 *******************************************************************/
4027 #define ST st->u.curlyx
4029 case CURLYX: /* start of /A*B/ (for complex A) */
4031 /* No need to save/restore up to this paren */
4032 I32 parenfloor = scan->flags;
4034 assert(next); /* keep Coverity happy */
4035 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4038 /* XXXX Probably it is better to teach regpush to support
4039 parenfloor > PL_regsize... */
4040 if (parenfloor > (I32)*PL_reglastparen)
4041 parenfloor = *PL_reglastparen; /* Pessimization... */
4043 ST.prev_curlyx= cur_curlyx;
4045 ST.cp = PL_savestack_ix;
4047 /* these fields contain the state of the current curly.
4048 * they are accessed by subsequent WHILEMs */
4049 ST.parenfloor = parenfloor;
4050 ST.min = ARG1(scan);
4051 ST.max = ARG2(scan);
4052 ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4056 ST.count = -1; /* this will be updated by WHILEM */
4057 ST.lastloc = NULL; /* this will be updated by WHILEM */
4059 PL_reginput = locinput;
4060 PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4064 case CURLYX_end: /* just finished matching all of A*B */
4065 cur_curlyx = ST.prev_curlyx;
4069 case CURLYX_end_fail: /* just failed to match all of A*B */
4071 cur_curlyx = ST.prev_curlyx;
4077 #define ST st->u.whilem
4079 case WHILEM: /* just matched an A in /A*B/ (for complex A) */
4081 /* see the discussion above about CURLYX/WHILEM */
4083 assert(cur_curlyx); /* keep Coverity happy */
4084 n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4085 ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4086 ST.cache_offset = 0;
4089 PL_reginput = locinput;
4091 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4092 "%*s whilem: matched %ld out of %ld..%ld\n",
4093 REPORT_CODE_OFF+depth*2, "", (long)n,
4094 (long)cur_curlyx->u.curlyx.min,
4095 (long)cur_curlyx->u.curlyx.max)
4098 /* First just match a string of min A's. */
4100 if (n < cur_curlyx->u.curlyx.min) {
4101 cur_curlyx->u.curlyx.lastloc = locinput;
4102 PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
4106 /* If degenerate A matches "", assume A done. */
4108 if (locinput == cur_curlyx->u.curlyx.lastloc) {
4109 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4110 "%*s whilem: empty match detected, trying continuation...\n",
4111 REPORT_CODE_OFF+depth*2, "")
4113 goto do_whilem_B_max;
4116 /* super-linear cache processing */
4120 if (!PL_reg_maxiter) {
4121 /* start the countdown: Postpone detection until we
4122 * know the match is not *that* much linear. */
4123 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4124 /* possible overflow for long strings and many CURLYX's */
4125 if (PL_reg_maxiter < 0)
4126 PL_reg_maxiter = I32_MAX;
4127 PL_reg_leftiter = PL_reg_maxiter;
4130 if (PL_reg_leftiter-- == 0) {
4131 /* initialise cache */
4132 const I32 size = (PL_reg_maxiter + 7)/8;
4133 if (PL_reg_poscache) {
4134 if ((I32)PL_reg_poscache_size < size) {
4135 Renew(PL_reg_poscache, size, char);
4136 PL_reg_poscache_size = size;
4138 Zero(PL_reg_poscache, size, char);
4141 PL_reg_poscache_size = size;
4142 Newxz(PL_reg_poscache, size, char);
4144 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4145 "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4146 PL_colors[4], PL_colors[5])
4150 if (PL_reg_leftiter < 0) {
4151 /* have we already failed at this position? */
4153 offset = (scan->flags & 0xf) - 1
4154 + (locinput - PL_bostr) * (scan->flags>>4);
4155 mask = 1 << (offset % 8);
4157 if (PL_reg_poscache[offset] & mask) {
4158 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4159 "%*s whilem: (cache) already tried at this position...\n",
4160 REPORT_CODE_OFF+depth*2, "")
4162 sayNO; /* cache records failure */
4164 ST.cache_offset = offset;
4165 ST.cache_mask = mask;
4169 /* Prefer B over A for minimal matching. */
4171 if (cur_curlyx->u.curlyx.minmod) {
4172 ST.save_curlyx = cur_curlyx;
4173 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4174 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4175 REGCP_SET(ST.lastcp);
4176 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4180 /* Prefer A over B for maximal matching. */
4182 if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
4183 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4184 cur_curlyx->u.curlyx.lastloc = locinput;
4185 REGCP_SET(ST.lastcp);
4186 PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
4189 goto do_whilem_B_max;
4193 case WHILEM_B_min: /* just matched B in a minimal match */
4194 case WHILEM_B_max: /* just matched B in a maximal match */
4195 cur_curlyx = ST.save_curlyx;
4199 case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4200 cur_curlyx = ST.save_curlyx;
4201 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4202 cur_curlyx->u.curlyx.count--;
4206 case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4207 REGCP_UNWIND(ST.lastcp);
4210 case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4211 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4212 cur_curlyx->u.curlyx.count--;
4216 case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4217 REGCP_UNWIND(ST.lastcp);
4218 regcppop(rex); /* Restore some previous $<digit>s? */
4219 PL_reginput = locinput;
4220 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4221 "%*s whilem: failed, trying continuation...\n",
4222 REPORT_CODE_OFF+depth*2, "")
4225 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4226 && ckWARN(WARN_REGEXP)
4227 && !(PL_reg_flags & RF_warned))
4229 PL_reg_flags |= RF_warned;
4230 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4231 "Complex regular subexpression recursion",
4236 ST.save_curlyx = cur_curlyx;
4237 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4238 PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4241 case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4242 cur_curlyx = ST.save_curlyx;
4243 REGCP_UNWIND(ST.lastcp);
4246 if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
4247 /* Maximum greed exceeded */
4248 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4249 && ckWARN(WARN_REGEXP)
4250 && !(PL_reg_flags & RF_warned))
4252 PL_reg_flags |= RF_warned;
4253 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4254 "%s limit (%d) exceeded",
4255 "Complex regular subexpression recursion",
4258 cur_curlyx->u.curlyx.count--;
4262 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4263 "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4265 /* Try grabbing another A and see if it helps. */
4266 PL_reginput = locinput;
4267 cur_curlyx->u.curlyx.lastloc = locinput;
4268 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4269 REGCP_SET(ST.lastcp);
4270 PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
4274 #define ST st->u.branch
4276 case BRANCHJ: /* /(...|A|...)/ with long next pointer */
4277 next = scan + ARG(scan);
4280 scan = NEXTOPER(scan);
4283 case BRANCH: /* /(...|A|...)/ */
4284 scan = NEXTOPER(scan); /* scan now points to inner node */
4285 ST.lastparen = *PL_reglastparen;
4286 ST.next_branch = next;
4288 PL_reginput = locinput;
4290 /* Now go into the branch */
4292 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4294 PUSH_STATE_GOTO(BRANCH_next, scan);
4298 PL_reginput = locinput;
4299 sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4300 MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4301 PUSH_STATE_GOTO(CUTGROUP_next,next);
4303 case CUTGROUP_next_fail:
4306 if (st->u.mark.mark_name)
4307 sv_commit = st->u.mark.mark_name;
4313 case BRANCH_next_fail: /* that branch failed; try the next, if any */
4318 REGCP_UNWIND(ST.cp);
4319 for (n = *PL_reglastparen; n > ST.lastparen; n--)
4320 PL_regoffs[n].end = -1;
4321 *PL_reglastparen = n;
4322 /*dmq: *PL_reglastcloseparen = n; */
4323 scan = ST.next_branch;
4324 /* no more branches? */
4325 if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4327 PerlIO_printf( Perl_debug_log,
4328 "%*s %sBRANCH failed...%s\n",
4329 REPORT_CODE_OFF+depth*2, "",
4335 continue; /* execute next BRANCH[J] op */
4343 #define ST st->u.curlym
4345 case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4347 /* This is an optimisation of CURLYX that enables us to push
4348 * only a single backtracking state, no matter how many matches
4349 * there are in {m,n}. It relies on the pattern being constant
4350 * length, with no parens to influence future backrefs
4354 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4356 /* if paren positive, emulate an OPEN/CLOSE around A */
4358 U32 paren = ST.me->flags;
4359 if (paren > PL_regsize)
4361 if (paren > *PL_reglastparen)
4362 *PL_reglastparen = paren;
4363 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4371 ST.c1 = CHRTEST_UNINIT;
4374 if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4377 curlym_do_A: /* execute the A in /A{m,n}B/ */
4378 PL_reginput = locinput;
4379 PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4382 case CURLYM_A: /* we've just matched an A */
4383 locinput = st->locinput;
4384 nextchr = UCHARAT(locinput);
4387 /* after first match, determine A's length: u.curlym.alen */
4388 if (ST.count == 1) {
4389 if (PL_reg_match_utf8) {
4391 while (s < PL_reginput) {
4397 ST.alen = PL_reginput - locinput;
4400 ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4403 PerlIO_printf(Perl_debug_log,
4404 "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4405 (int)(REPORT_CODE_OFF+(depth*2)), "",
4406 (IV) ST.count, (IV)ST.alen)
4409 locinput = PL_reginput;
4411 if (cur_eval && cur_eval->u.eval.close_paren &&
4412 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4416 I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
4417 if ( max == REG_INFTY || ST.count < max )
4418 goto curlym_do_A; /* try to match another A */
4420 goto curlym_do_B; /* try to match B */
4422 case CURLYM_A_fail: /* just failed to match an A */
4423 REGCP_UNWIND(ST.cp);
4425 if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4426 || (cur_eval && cur_eval->u.eval.close_paren &&
4427 cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4430 curlym_do_B: /* execute the B in /A{m,n}B/ */
4431 PL_reginput = locinput;
4432 if (ST.c1 == CHRTEST_UNINIT) {
4433 /* calculate c1 and c2 for possible match of 1st char
4434 * following curly */
4435 ST.c1 = ST.c2 = CHRTEST_VOID;
4436 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4437 regnode *text_node = ST.B;
4438 if (! HAS_TEXT(text_node))
4439 FIND_NEXT_IMPT(text_node);
4442 (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4444 But the former is redundant in light of the latter.
4446 if this changes back then the macro for
4447 IS_TEXT and friends need to change.
4449 if (PL_regkind[OP(text_node)] == EXACT)
4452 ST.c1 = (U8)*STRING(text_node);
4454 (IS_TEXTF(text_node))
4456 : (IS_TEXTFL(text_node))
4457 ? PL_fold_locale[ST.c1]
4464 PerlIO_printf(Perl_debug_log,
4465 "%*s CURLYM trying tail with matches=%"IVdf"...\n",
4466 (int)(REPORT_CODE_OFF+(depth*2)),
4469 if (ST.c1 != CHRTEST_VOID
4470 && UCHARAT(PL_reginput) != ST.c1
4471 && UCHARAT(PL_reginput) != ST.c2)
4473 /* simulate B failing */
4475 PerlIO_printf(Perl_debug_log,
4476 "%*s CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
4477 (int)(REPORT_CODE_OFF+(depth*2)),"",
4480 state_num = CURLYM_B_fail;
4481 goto reenter_switch;
4485 /* mark current A as captured */
4486 I32 paren = ST.me->flags;
4488 PL_regoffs[paren].start
4489 = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4490 PL_regoffs[paren].end = PL_reginput - PL_bostr;
4491 /*dmq: *PL_reglastcloseparen = paren; */
4494 PL_regoffs[paren].end = -1;
4495 if (cur_eval && cur_eval->u.eval.close_paren &&
4496 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4505 PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4508 case CURLYM_B_fail: /* just failed to match a B */
4509 REGCP_UNWIND(ST.cp);
4511 I32 max = ARG2(ST.me);
4512 if (max != REG_INFTY && ST.count == max)
4514 goto curlym_do_A; /* try to match a further A */
4516 /* backtrack one A */
4517 if (ST.count == ARG1(ST.me) /* min */)
4520 locinput = HOPc(locinput, -ST.alen);
4521 goto curlym_do_B; /* try to match B */
4524 #define ST st->u.curly
4526 #define CURLY_SETPAREN(paren, success) \
4529 PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
4530 PL_regoffs[paren].end = locinput - PL_bostr; \
4531 *PL_reglastcloseparen = paren; \
4534 PL_regoffs[paren].end = -1; \
4537 case STAR: /* /A*B/ where A is width 1 */
4541 scan = NEXTOPER(scan);
4543 case PLUS: /* /A+B/ where A is width 1 */
4547 scan = NEXTOPER(scan);
4549 case CURLYN: /* /(A){m,n}B/ where A is width 1 */
4550 ST.paren = scan->flags; /* Which paren to set */
4551 if (ST.paren > PL_regsize)
4552 PL_regsize = ST.paren;
4553 if (ST.paren > *PL_reglastparen)
4554 *PL_reglastparen = ST.paren;
4555 ST.min = ARG1(scan); /* min to match */
4556 ST.max = ARG2(scan); /* max to match */
4557 if (cur_eval && cur_eval->u.eval.close_paren &&
4558 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4562 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4564 case CURLY: /* /A{m,n}B/ where A is width 1 */
4566 ST.min = ARG1(scan); /* min to match */
4567 ST.max = ARG2(scan); /* max to match */
4568 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4571 * Lookahead to avoid useless match attempts
4572 * when we know what character comes next.
4574 * Used to only do .*x and .*?x, but now it allows
4575 * for )'s, ('s and (?{ ... })'s to be in the way
4576 * of the quantifier and the EXACT-like node. -- japhy
4579 if (ST.min > ST.max) /* XXX make this a compile-time check? */
4581 if (HAS_TEXT(next) || JUMPABLE(next)) {
4583 regnode *text_node = next;
4585 if (! HAS_TEXT(text_node))
4586 FIND_NEXT_IMPT(text_node);
4588 if (! HAS_TEXT(text_node))
4589 ST.c1 = ST.c2 = CHRTEST_VOID;
4591 if ( PL_regkind[OP(text_node)] != EXACT ) {
4592 ST.c1 = ST.c2 = CHRTEST_VOID;
4593 goto assume_ok_easy;
4596 s = (U8*)STRING(text_node);
4598 /* Currently we only get here when
4600 PL_rekind[OP(text_node)] == EXACT
4602 if this changes back then the macro for IS_TEXT and
4603 friends need to change. */
4606 if (IS_TEXTF(text_node))
4607 ST.c2 = PL_fold[ST.c1];
4608 else if (IS_TEXTFL(text_node))
4609 ST.c2 = PL_fold_locale[ST.c1];
4612 if (IS_TEXTF(text_node)) {
4613 STRLEN ulen1, ulen2;
4614 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4615 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4617 to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4618 to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4620 ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4622 0 : UTF8_ALLOW_ANY);
4623 ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4625 0 : UTF8_ALLOW_ANY);
4627 ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4629 ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4634 ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4641 ST.c1 = ST.c2 = CHRTEST_VOID;
4646 PL_reginput = locinput;
4649 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4652 locinput = PL_reginput;
4654 if (ST.c1 == CHRTEST_VOID)
4655 goto curly_try_B_min;
4657 ST.oldloc = locinput;
4659 /* set ST.maxpos to the furthest point along the
4660 * string that could possibly match */
4661 if (ST.max == REG_INFTY) {
4662 ST.maxpos = PL_regeol - 1;
4664 while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4668 int m = ST.max - ST.min;
4669 for (ST.maxpos = locinput;
4670 m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4671 ST.maxpos += UTF8SKIP(ST.maxpos);
4674 ST.maxpos = locinput + ST.max - ST.min;
4675 if (ST.maxpos >= PL_regeol)
4676 ST.maxpos = PL_regeol - 1;
4678 goto curly_try_B_min_known;
4682 ST.count = regrepeat(rex, ST.A, ST.max, depth);
4683 locinput = PL_reginput;
4684 if (ST.count < ST.min)
4686 if ((ST.count > ST.min)
4687 && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4689 /* A{m,n} must come at the end of the string, there's
4690 * no point in backing off ... */
4692 /* ...except that $ and \Z can match before *and* after
4693 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
4694 We may back off by one in this case. */
4695 if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4699 goto curly_try_B_max;
4704 case CURLY_B_min_known_fail:
4705 /* failed to find B in a non-greedy match where c1,c2 valid */
4706 if (ST.paren && ST.count)
4707 PL_regoffs[ST.paren].end = -1;
4709 PL_reginput = locinput; /* Could be reset... */
4710 REGCP_UNWIND(ST.cp);
4711 /* Couldn't or didn't -- move forward. */
4712 ST.oldloc = locinput;
4714 locinput += UTF8SKIP(locinput);
4718 curly_try_B_min_known:
4719 /* find the next place where 'B' could work, then call B */
4723 n = (ST.oldloc == locinput) ? 0 : 1;
4724 if (ST.c1 == ST.c2) {
4726 /* set n to utf8_distance(oldloc, locinput) */
4727 while (locinput <= ST.maxpos &&
4728 utf8n_to_uvchr((U8*)locinput,
4729 UTF8_MAXBYTES, &len,
4730 uniflags) != (UV)ST.c1) {
4736 /* set n to utf8_distance(oldloc, locinput) */
4737 while (locinput <= ST.maxpos) {
4739 const UV c = utf8n_to_uvchr((U8*)locinput,
4740 UTF8_MAXBYTES, &len,
4742 if (c == (UV)ST.c1 || c == (UV)ST.c2)
4750 if (ST.c1 == ST.c2) {
4751 while (locinput <= ST.maxpos &&
4752 UCHARAT(locinput) != ST.c1)
4756 while (locinput <= ST.maxpos
4757 && UCHARAT(locinput) != ST.c1
4758 && UCHARAT(locinput) != ST.c2)
4761 n = locinput - ST.oldloc;
4763 if (locinput > ST.maxpos)
4765 /* PL_reginput == oldloc now */
4768 if (regrepeat(rex, ST.A, n, depth) < n)
4771 PL_reginput = locinput;
4772 CURLY_SETPAREN(ST.paren, ST.count);
4773 if (cur_eval && cur_eval->u.eval.close_paren &&
4774 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4777 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
4782 case CURLY_B_min_fail:
4783 /* failed to find B in a non-greedy match where c1,c2 invalid */
4784 if (ST.paren && ST.count)
4785 PL_regoffs[ST.paren].end = -1;
4787 REGCP_UNWIND(ST.cp);
4788 /* failed -- move forward one */
4789 PL_reginput = locinput;
4790 if (regrepeat(rex, ST.A, 1, depth)) {
4792 locinput = PL_reginput;
4793 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
4794 ST.count > 0)) /* count overflow ? */
4797 CURLY_SETPAREN(ST.paren, ST.count);
4798 if (cur_eval && cur_eval->u.eval.close_paren &&
4799 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4802 PUSH_STATE_GOTO(CURLY_B_min, ST.B);
4810 /* a successful greedy match: now try to match B */
4811 if (cur_eval && cur_eval->u.eval.close_paren &&
4812 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4817 if (ST.c1 != CHRTEST_VOID)
4818 c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
4819 UTF8_MAXBYTES, 0, uniflags)
4820 : (UV) UCHARAT(PL_reginput);
4821 /* If it could work, try it. */
4822 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
4823 CURLY_SETPAREN(ST.paren, ST.count);
4824 PUSH_STATE_GOTO(CURLY_B_max, ST.B);
4829 case CURLY_B_max_fail:
4830 /* failed to find B in a greedy match */
4831 if (ST.paren && ST.count)
4832 PL_regoffs[ST.paren].end = -1;
4834 REGCP_UNWIND(ST.cp);
4836 if (--ST.count < ST.min)
4838 PL_reginput = locinput = HOPc(locinput, -1);
4839 goto curly_try_B_max;
4846 /* we've just finished A in /(??{A})B/; now continue with B */
4848 st->u.eval.toggle_reg_flags
4849 = cur_eval->u.eval.toggle_reg_flags;
4850 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
4852 st->u.eval.prev_rex = rex_sv; /* inner */
4853 SETREX(rex_sv,cur_eval->u.eval.prev_rex);
4854 rex = (struct regexp *)SvANY(rex_sv);
4855 rexi = RXi_GET(rex);
4856 cur_curlyx = cur_eval->u.eval.prev_curlyx;
4857 ReREFCNT_inc(rex_sv);
4858 st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
4860 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4861 PL_reglastparen = &rex->lastparen;
4862 PL_reglastcloseparen = &rex->lastcloseparen;
4864 REGCP_SET(st->u.eval.lastcp);
4865 PL_reginput = locinput;
4867 /* Restore parens of the outer rex without popping the
4869 tmpix = PL_savestack_ix;
4870 PL_savestack_ix = cur_eval->u.eval.lastcp;
4872 PL_savestack_ix = tmpix;
4874 st->u.eval.prev_eval = cur_eval;
4875 cur_eval = cur_eval->u.eval.prev_eval;
4877 PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n",
4878 REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
4879 if ( nochange_depth )
4882 PUSH_YES_STATE_GOTO(EVAL_AB,
4883 st->u.eval.prev_eval->u.eval.B); /* match B */
4886 if (locinput < reginfo->till) {
4887 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4888 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4890 (long)(locinput - PL_reg_starttry),
4891 (long)(reginfo->till - PL_reg_starttry),
4894 sayNO_SILENT; /* Cannot match: too short. */
4896 PL_reginput = locinput; /* put where regtry can find it */
4897 sayYES; /* Success! */
4899 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4901 PerlIO_printf(Perl_debug_log,
4902 "%*s %ssubpattern success...%s\n",
4903 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
4904 PL_reginput = locinput; /* put where regtry can find it */
4905 sayYES; /* Success! */
4908 #define ST st->u.ifmatch
4910 case SUSPEND: /* (?>A) */
4912 PL_reginput = locinput;
4915 case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
4917 goto ifmatch_trivial_fail_test;
4919 case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
4921 ifmatch_trivial_fail_test:
4923 char * const s = HOPBACKc(locinput, scan->flags);
4928 sw = 1 - (bool)ST.wanted;
4932 next = scan + ARG(scan);
4940 PL_reginput = locinput;
4944 ST.logical = logical;
4945 logical = 0; /* XXX: reset state of logical once it has been saved into ST */
4947 /* execute body of (?...A) */
4948 PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
4951 case IFMATCH_A_fail: /* body of (?...A) failed */
4952 ST.wanted = !ST.wanted;
4955 case IFMATCH_A: /* body of (?...A) succeeded */
4957 sw = (bool)ST.wanted;
4959 else if (!ST.wanted)
4962 if (OP(ST.me) == SUSPEND)
4963 locinput = PL_reginput;
4965 locinput = PL_reginput = st->locinput;
4966 nextchr = UCHARAT(locinput);
4968 scan = ST.me + ARG(ST.me);
4971 continue; /* execute B */
4976 next = scan + ARG(scan);
4981 reginfo->cutpoint = PL_regeol;
4984 PL_reginput = locinput;
4986 sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4987 PUSH_STATE_GOTO(COMMIT_next,next);
4989 case COMMIT_next_fail:
4996 #define ST st->u.mark
4998 ST.prev_mark = mark_state;
4999 ST.mark_name = sv_commit = sv_yes_mark
5000 = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5002 ST.mark_loc = PL_reginput = locinput;
5003 PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5005 case MARKPOINT_next:
5006 mark_state = ST.prev_mark;
5009 case MARKPOINT_next_fail:
5010 if (popmark && sv_eq(ST.mark_name,popmark))
5012 if (ST.mark_loc > startpoint)
5013 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5014 popmark = NULL; /* we found our mark */
5015 sv_commit = ST.mark_name;
5018 PerlIO_printf(Perl_debug_log,
5019 "%*s %ssetting cutpoint to mark:%"SVf"...%s\n",
5020 REPORT_CODE_OFF+depth*2, "",
5021 PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
5024 mark_state = ST.prev_mark;
5025 sv_yes_mark = mark_state ?
5026 mark_state->u.mark.mark_name : NULL;
5030 PL_reginput = locinput;
5032 /* (*SKIP) : if we fail we cut here*/
5033 ST.mark_name = NULL;
5034 ST.mark_loc = locinput;
5035 PUSH_STATE_GOTO(SKIP_next,next);
5037 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5038 otherwise do nothing. Meaning we need to scan
5040 regmatch_state *cur = mark_state;
5041 SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5044 if ( sv_eq( cur->u.mark.mark_name,
5047 ST.mark_name = find;
5048 PUSH_STATE_GOTO( SKIP_next, next );
5050 cur = cur->u.mark.prev_mark;
5053 /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5055 case SKIP_next_fail:
5057 /* (*CUT:NAME) - Set up to search for the name as we
5058 collapse the stack*/
5059 popmark = ST.mark_name;
5061 /* (*CUT) - No name, we cut here.*/
5062 if (ST.mark_loc > startpoint)
5063 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5064 /* but we set sv_commit to latest mark_name if there
5065 is one so they can test to see how things lead to this
5068 sv_commit=mark_state->u.mark.mark_name;
5076 if ( n == (U32)what_len_TRICKYFOLD(locinput,do_utf8,ln) ) {
5078 } else if ( 0xDF == n && !do_utf8 && !UTF ) {
5081 U8 folded[UTF8_MAXBYTES_CASE+1];
5083 const char * const l = locinput;
5084 char *e = PL_regeol;
5085 to_uni_fold(n, folded, &foldlen);
5087 if (ibcmp_utf8((const char*) folded, 0, foldlen, 1,
5088 l, &e, 0, do_utf8)) {
5093 nextchr = UCHARAT(locinput);
5096 if ((n=is_LNBREAK(locinput,do_utf8))) {
5098 nextchr = UCHARAT(locinput);
5103 #define CASE_CLASS(nAmE) \
5105 if ((n=is_##nAmE(locinput,do_utf8))) { \
5107 nextchr = UCHARAT(locinput); \
5112 if ((n=is_##nAmE(locinput,do_utf8))) { \
5115 locinput += UTF8SKIP(locinput); \
5116 nextchr = UCHARAT(locinput); \
5121 CASE_CLASS(HORIZWS);
5125 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5126 PTR2UV(scan), OP(scan));
5127 Perl_croak(aTHX_ "regexp memory corruption");
5131 /* switch break jumps here */
5132 scan = next; /* prepare to execute the next op and ... */
5133 continue; /* ... jump back to the top, reusing st */
5137 /* push a state that backtracks on success */
5138 st->u.yes.prev_yes_state = yes_state;
5142 /* push a new regex state, then continue at scan */
5144 regmatch_state *newst;
5147 regmatch_state *cur = st;
5148 regmatch_state *curyes = yes_state;
5150 regmatch_slab *slab = PL_regmatch_slab;
5151 for (;curd > -1;cur--,curd--) {
5152 if (cur < SLAB_FIRST(slab)) {
5154 cur = SLAB_LAST(slab);
5156 PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5157 REPORT_CODE_OFF + 2 + depth * 2,"",
5158 curd, PL_reg_name[cur->resume_state],
5159 (curyes == cur) ? "yes" : ""
5162 curyes = cur->u.yes.prev_yes_state;
5165 DEBUG_STATE_pp("push")
5168 st->locinput = locinput;
5170 if (newst > SLAB_LAST(PL_regmatch_slab))
5171 newst = S_push_slab(aTHX);
5172 PL_regmatch_state = newst;
5174 locinput = PL_reginput;
5175 nextchr = UCHARAT(locinput);
5183 * We get here only if there's trouble -- normally "case END" is
5184 * the terminating point.
5186 Perl_croak(aTHX_ "corrupted regexp pointers");
5192 /* we have successfully completed a subexpression, but we must now
5193 * pop to the state marked by yes_state and continue from there */
5194 assert(st != yes_state);
5196 while (st != yes_state) {
5198 if (st < SLAB_FIRST(PL_regmatch_slab)) {
5199 PL_regmatch_slab = PL_regmatch_slab->prev;
5200 st = SLAB_LAST(PL_regmatch_slab);
5204 DEBUG_STATE_pp("pop (no final)");
5206 DEBUG_STATE_pp("pop (yes)");
5212 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5213 || yes_state > SLAB_LAST(PL_regmatch_slab))
5215 /* not in this slab, pop slab */
5216 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5217 PL_regmatch_slab = PL_regmatch_slab->prev;
5218 st = SLAB_LAST(PL_regmatch_slab);
5220 depth -= (st - yes_state);
5223 yes_state = st->u.yes.prev_yes_state;
5224 PL_regmatch_state = st;
5227 locinput= st->locinput;
5228 nextchr = UCHARAT(locinput);
5230 state_num = st->resume_state + no_final;
5231 goto reenter_switch;
5234 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5235 PL_colors[4], PL_colors[5]));
5237 if (PL_reg_eval_set) {
5238 /* each successfully executed (?{...}) block does the equivalent of
5239 * local $^R = do {...}
5240 * When popping the save stack, all these locals would be undone;
5241 * bypass this by setting the outermost saved $^R to the latest
5243 if (oreplsv != GvSV(PL_replgv))
5244 sv_setsv(oreplsv, GvSV(PL_replgv));
5251 PerlIO_printf(Perl_debug_log,
5252 "%*s %sfailed...%s\n",
5253 REPORT_CODE_OFF+depth*2, "",
5254 PL_colors[4], PL_colors[5])
5266 /* there's a previous state to backtrack to */
5268 if (st < SLAB_FIRST(PL_regmatch_slab)) {
5269 PL_regmatch_slab = PL_regmatch_slab->prev;
5270 st = SLAB_LAST(PL_regmatch_slab);
5272 PL_regmatch_state = st;
5273 locinput= st->locinput;
5274 nextchr = UCHARAT(locinput);
5276 DEBUG_STATE_pp("pop");
5278 if (yes_state == st)
5279 yes_state = st->u.yes.prev_yes_state;
5281 state_num = st->resume_state + 1; /* failure = success + 1 */
5282 goto reenter_switch;
5287 if (rex->intflags & PREGf_VERBARG_SEEN) {
5288 SV *sv_err = get_sv("REGERROR", 1);
5289 SV *sv_mrk = get_sv("REGMARK", 1);
5291 sv_commit = &PL_sv_no;
5293 sv_yes_mark = &PL_sv_yes;
5296 sv_commit = &PL_sv_yes;
5297 sv_yes_mark = &PL_sv_no;
5299 sv_setsv(sv_err, sv_commit);
5300 sv_setsv(sv_mrk, sv_yes_mark);
5303 /* clean up; in particular, free all slabs above current one */
5304 LEAVE_SCOPE(oldsave);
5310 - regrepeat - repeatedly match something simple, report how many
5313 * [This routine now assumes that it will only match on things of length 1.
5314 * That was true before, but now we assume scan - reginput is the count,
5315 * rather than incrementing count on every character. [Er, except utf8.]]
5318 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5321 register char *scan;
5323 register char *loceol = PL_regeol;
5324 register I32 hardcount = 0;
5325 register bool do_utf8 = PL_reg_match_utf8;
5327 PERL_UNUSED_ARG(depth);
5330 PERL_ARGS_ASSERT_REGREPEAT;
5333 if (max == REG_INFTY)
5335 else if (max < loceol - scan)
5336 loceol = scan + max;
5341 while (scan < loceol && hardcount < max && *scan != '\n') {
5342 scan += UTF8SKIP(scan);
5346 while (scan < loceol && *scan != '\n')
5353 while (scan < loceol && hardcount < max) {
5354 scan += UTF8SKIP(scan);
5364 case EXACT: /* length of string is 1 */
5366 while (scan < loceol && UCHARAT(scan) == c)
5369 case EXACTF: /* length of string is 1 */
5371 while (scan < loceol &&
5372 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5375 case EXACTFL: /* length of string is 1 */
5376 PL_reg_flags |= RF_tainted;
5378 while (scan < loceol &&
5379 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5385 while (hardcount < max && scan < loceol &&
5386 reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
5387 scan += UTF8SKIP(scan);
5391 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5398 LOAD_UTF8_CHARCLASS_ALNUM();
5399 while (hardcount < max && scan < loceol &&
5400 swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5401 scan += UTF8SKIP(scan);
5405 while (scan < loceol && isALNUM(*scan))
5410 PL_reg_flags |= RF_tainted;
5413 while (hardcount < max && scan < loceol &&
5414 isALNUM_LC_utf8((U8*)scan)) {
5415 scan += UTF8SKIP(scan);
5419 while (scan < loceol && isALNUM_LC(*scan))
5426 LOAD_UTF8_CHARCLASS_ALNUM();
5427 while (hardcount < max && scan < loceol &&
5428 !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5429 scan += UTF8SKIP(scan);
5433 while (scan < loceol && !isALNUM(*scan))
5438 PL_reg_flags |= RF_tainted;
5441 while (hardcount < max && scan < loceol &&
5442 !isALNUM_LC_utf8((U8*)scan)) {
5443 scan += UTF8SKIP(scan);
5447 while (scan < loceol && !isALNUM_LC(*scan))
5454 LOAD_UTF8_CHARCLASS_SPACE();
5455 while (hardcount < max && scan < loceol &&
5457 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5458 scan += UTF8SKIP(scan);
5462 while (scan < loceol && isSPACE(*scan))
5467 PL_reg_flags |= RF_tainted;
5470 while (hardcount < max && scan < loceol &&
5471 (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5472 scan += UTF8SKIP(scan);
5476 while (scan < loceol && isSPACE_LC(*scan))
5483 LOAD_UTF8_CHARCLASS_SPACE();
5484 while (hardcount < max && scan < loceol &&
5486 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5487 scan += UTF8SKIP(scan);
5491 while (scan < loceol && !isSPACE(*scan))
5496 PL_reg_flags |= RF_tainted;
5499 while (hardcount < max && scan < loceol &&
5500 !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5501 scan += UTF8SKIP(scan);
5505 while (scan < loceol && !isSPACE_LC(*scan))
5512 LOAD_UTF8_CHARCLASS_DIGIT();
5513 while (hardcount < max && scan < loceol &&
5514 swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5515 scan += UTF8SKIP(scan);
5519 while (scan < loceol && isDIGIT(*scan))
5526 LOAD_UTF8_CHARCLASS_DIGIT();
5527 while (hardcount < max && scan < loceol &&
5528 !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5529 scan += UTF8SKIP(scan);
5533 while (scan < loceol && !isDIGIT(*scan))
5539 while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
5545 LNBREAK can match two latin chars, which is ok,
5546 because we have a null terminated string, but we
5547 have to use hardcount in this situation
5549 while (scan < loceol && (c=is_LNBREAK_latin1(scan))) {
5558 while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
5563 while (scan < loceol && is_HORIZWS_latin1(scan))
5570 while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
5571 scan += UTF8SKIP(scan);
5575 while (scan < loceol && !is_HORIZWS_latin1(scan))
5583 while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
5588 while (scan < loceol && is_VERTWS_latin1(scan))
5596 while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
5597 scan += UTF8SKIP(scan);
5601 while (scan < loceol && !is_VERTWS_latin1(scan))
5607 default: /* Called on something of 0 width. */
5608 break; /* So match right here or not at all. */
5614 c = scan - PL_reginput;
5618 GET_RE_DEBUG_FLAGS_DECL;
5620 SV * const prop = sv_newmortal();
5621 regprop(prog, prop, p);
5622 PerlIO_printf(Perl_debug_log,
5623 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
5624 REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5632 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5634 - regclass_swash - prepare the utf8 swash
5638 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5644 RXi_GET_DECL(prog,progi);
5645 const struct reg_data * const data = prog ? progi->data : NULL;
5647 PERL_ARGS_ASSERT_REGCLASS_SWASH;
5649 if (data && data->count) {
5650 const U32 n = ARG(node);
5652 if (data->what[n] == 's') {
5653 SV * const rv = MUTABLE_SV(data->data[n]);
5654 AV * const av = MUTABLE_AV(SvRV(rv));
5655 SV **const ary = AvARRAY(av);
5658 /* See the end of regcomp.c:S_regclass() for
5659 * documentation of these array elements. */
5662 a = SvROK(ary[1]) ? &ary[1] : NULL;
5663 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
5667 else if (si && doinit) {
5668 sw = swash_init("utf8", "", si, 1, 0);
5669 (void)av_store(av, 1, sw);
5686 - reginclass - determine if a character falls into a character class
5688 The n is the ANYOF regnode, the p is the target string, lenp
5689 is pointer to the maximum length of how far to go in the p
5690 (if the lenp is zero, UTF8SKIP(p) is used),
5691 do_utf8 tells whether the target string is in UTF-8.
5696 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5699 const char flags = ANYOF_FLAGS(n);
5705 PERL_ARGS_ASSERT_REGINCLASS;
5707 if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5708 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5709 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5710 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5711 if (len == (STRLEN)-1)
5712 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5715 plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5716 if (do_utf8 || (flags & ANYOF_UNICODE)) {
5719 if (do_utf8 && !ANYOF_RUNTIME(n)) {
5720 if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5723 if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5727 SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5735 utf8_p = bytes_to_utf8(p, &len);
5737 if (swash_fetch(sw, utf8_p, 1))
5739 else if (flags & ANYOF_FOLD) {
5740 if (!match && lenp && av) {
5742 for (i = 0; i <= av_len(av); i++) {
5743 SV* const sv = *av_fetch(av, i, FALSE);
5745 const char * const s = SvPV_const(sv, len);
5746 if (len <= plen && memEQ(s, (char*)utf8_p, len)) {
5754 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5757 to_utf8_fold(utf8_p, tmpbuf, &tmplen);
5758 if (swash_fetch(sw, tmpbuf, 1))
5763 /* If we allocated a string above, free it */
5764 if (! do_utf8) Safefree(utf8_p);
5767 if (match && lenp && *lenp == 0)
5768 *lenp = UNISKIP(NATIVE_TO_UNI(c));
5770 if (!match && c < 256) {
5771 if (ANYOF_BITMAP_TEST(n, c))
5773 else if (flags & ANYOF_FOLD) {
5776 if (flags & ANYOF_LOCALE) {
5777 PL_reg_flags |= RF_tainted;
5778 f = PL_fold_locale[c];
5782 if (f != c && ANYOF_BITMAP_TEST(n, f))
5786 if (!match && (flags & ANYOF_CLASS)) {
5787 PL_reg_flags |= RF_tainted;
5789 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
5790 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
5791 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
5792 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
5793 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
5794 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
5795 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
5796 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5797 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
5798 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
5799 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
5800 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
5801 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
5802 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
5803 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
5804 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
5805 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
5806 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
5807 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
5808 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
5809 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
5810 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
5811 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
5812 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
5813 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
5814 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
5815 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
5816 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
5817 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
5818 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
5819 ) /* How's that for a conditional? */
5826 return (flags & ANYOF_INVERT) ? !match : match;
5830 S_reghop3(U8 *s, I32 off, const U8* lim)
5834 PERL_ARGS_ASSERT_REGHOP3;
5837 while (off-- && s < lim) {
5838 /* XXX could check well-formedness here */
5843 while (off++ && s > lim) {
5845 if (UTF8_IS_CONTINUED(*s)) {
5846 while (s > lim && UTF8_IS_CONTINUATION(*s))
5849 /* XXX could check well-formedness here */
5856 /* there are a bunch of places where we use two reghop3's that should
5857 be replaced with this routine. but since thats not done yet
5858 we ifdef it out - dmq
5861 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
5865 PERL_ARGS_ASSERT_REGHOP4;
5868 while (off-- && s < rlim) {
5869 /* XXX could check well-formedness here */
5874 while (off++ && s > llim) {
5876 if (UTF8_IS_CONTINUED(*s)) {
5877 while (s > llim && UTF8_IS_CONTINUATION(*s))
5880 /* XXX could check well-formedness here */
5888 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5892 PERL_ARGS_ASSERT_REGHOPMAYBE3;
5895 while (off-- && s < lim) {
5896 /* XXX could check well-formedness here */
5903 while (off++ && s > lim) {
5905 if (UTF8_IS_CONTINUED(*s)) {
5906 while (s > lim && UTF8_IS_CONTINUATION(*s))
5909 /* XXX could check well-formedness here */
5918 restore_pos(pTHX_ void *arg)
5921 regexp * const rex = (regexp *)arg;
5922 if (PL_reg_eval_set) {
5923 if (PL_reg_oldsaved) {
5924 rex->subbeg = PL_reg_oldsaved;
5925 rex->sublen = PL_reg_oldsavedlen;
5926 #ifdef PERL_OLD_COPY_ON_WRITE
5927 rex->saved_copy = PL_nrs;
5929 RXp_MATCH_COPIED_on(rex);
5931 PL_reg_magic->mg_len = PL_reg_oldpos;
5932 PL_reg_eval_set = 0;
5933 PL_curpm = PL_reg_oldcurpm;
5938 S_to_utf8_substr(pTHX_ register regexp *prog)
5942 PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
5945 if (prog->substrs->data[i].substr
5946 && !prog->substrs->data[i].utf8_substr) {
5947 SV* const sv = newSVsv(prog->substrs->data[i].substr);
5948 prog->substrs->data[i].utf8_substr = sv;
5949 sv_utf8_upgrade(sv);
5950 if (SvVALID(prog->substrs->data[i].substr)) {
5951 const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
5952 if (flags & FBMcf_TAIL) {
5953 /* Trim the trailing \n that fbm_compile added last
5955 SvCUR_set(sv, SvCUR(sv) - 1);
5956 /* Whilst this makes the SV technically "invalid" (as its
5957 buffer is no longer followed by "\0") when fbm_compile()
5958 adds the "\n" back, a "\0" is restored. */
5960 fbm_compile(sv, flags);
5962 if (prog->substrs->data[i].substr == prog->check_substr)
5963 prog->check_utf8 = sv;
5969 S_to_byte_substr(pTHX_ register regexp *prog)
5974 PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
5977 if (prog->substrs->data[i].utf8_substr
5978 && !prog->substrs->data[i].substr) {
5979 SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
5980 if (sv_utf8_downgrade(sv, TRUE)) {
5981 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
5983 = BmFLAGS(prog->substrs->data[i].utf8_substr);
5984 if (flags & FBMcf_TAIL) {
5985 /* Trim the trailing \n that fbm_compile added last
5987 SvCUR_set(sv, SvCUR(sv) - 1);
5989 fbm_compile(sv, flags);
5995 prog->substrs->data[i].substr = sv;
5996 if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
5997 prog->check_substr = sv;
6004 * c-indentation-style: bsd
6006 * indent-tabs-mode: t
6009 * ex: set ts=8 sts=4 sw=4 noet: