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
124 /* Doesn't do an assert to verify that is correct */
125 #define LOAD_UTF8_CHARCLASS_NO_CHECK(class) STMT_START { \
126 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)" "); LEAVE; } } STMT_END
128 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
129 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
130 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
132 #define LOAD_UTF8_CHARCLASS_GCB() /* Grapheme cluster boundaries */ \
133 LOAD_UTF8_CHARCLASS(X_begin, " "); \
134 LOAD_UTF8_CHARCLASS(X_non_hangul, "A"); \
135 /* These are utf8 constants, and not utf-ebcdic constants, so the \
136 * assert should likely and hopefully fail on an EBCDIC machine */ \
137 LOAD_UTF8_CHARCLASS(X_extend, "\xcc\x80"); /* U+0300 */ \
139 /* No asserts are done for these, in case called on an early \
140 * Unicode version in which they map to nothing */ \
141 LOAD_UTF8_CHARCLASS_NO_CHECK(X_prepend);/* U+0E40 "\xe0\xb9\x80" */ \
142 LOAD_UTF8_CHARCLASS_NO_CHECK(X_L); /* U+1100 "\xe1\x84\x80" */ \
143 LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV); /* U+AC00 "\xea\xb0\x80" */ \
144 LOAD_UTF8_CHARCLASS_NO_CHECK(X_LVT); /* U+AC01 "\xea\xb0\x81" */ \
145 LOAD_UTF8_CHARCLASS_NO_CHECK(X_LV_LVT_V);/* U+AC01 "\xea\xb0\x81" */\
146 LOAD_UTF8_CHARCLASS_NO_CHECK(X_T); /* U+11A8 "\xe1\x86\xa8" */ \
147 LOAD_UTF8_CHARCLASS_NO_CHECK(X_V) /* U+1160 "\xe1\x85\xa0" */
150 We dont use PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS as the direct test
151 so that it is possible to override the option here without having to
152 rebuild the entire core. as we are required to do if we change regcomp.h
153 which is where PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS is defined.
155 #if PERL_LEGACY_UNICODE_CHARCLASS_MAPPINGS
156 #define BROKEN_UNICODE_CHARCLASS_MAPPINGS
159 #ifdef BROKEN_UNICODE_CHARCLASS_MAPPINGS
160 #define LOAD_UTF8_CHARCLASS_PERL_WORD() LOAD_UTF8_CHARCLASS_ALNUM()
161 #define LOAD_UTF8_CHARCLASS_PERL_SPACE() LOAD_UTF8_CHARCLASS_SPACE()
162 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS_DIGIT()
163 #define RE_utf8_perl_word PL_utf8_alnum
164 #define RE_utf8_perl_space PL_utf8_space
165 #define RE_utf8_posix_digit PL_utf8_digit
166 #define perl_word alnum
167 #define perl_space space
168 #define posix_digit digit
170 #define LOAD_UTF8_CHARCLASS_PERL_WORD() LOAD_UTF8_CHARCLASS(perl_word,"a")
171 #define LOAD_UTF8_CHARCLASS_PERL_SPACE() LOAD_UTF8_CHARCLASS(perl_space," ")
172 #define LOAD_UTF8_CHARCLASS_POSIX_DIGIT() LOAD_UTF8_CHARCLASS(posix_digit,"0")
173 #define RE_utf8_perl_word PL_utf8_perl_word
174 #define RE_utf8_perl_space PL_utf8_perl_space
175 #define RE_utf8_posix_digit PL_utf8_posix_digit
179 #define CCC_TRY_AFF(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC) \
181 PL_reg_flags |= RF_tainted; \
186 if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) { \
187 if (!CAT2(PL_utf8_,CLASS)) { \
191 ok=CAT2(is_utf8_,CLASS)((const U8*)STR); \
195 if (!(OP(scan) == NAME \
196 ? cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)) \
197 : LCFUNC_utf8((U8*)locinput))) \
201 locinput += PL_utf8skip[nextchr]; \
202 nextchr = UCHARAT(locinput); \
205 if (!(OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr))) \
207 nextchr = UCHARAT(++locinput); \
210 #define CCC_TRY_NEG(NAME,NAMEL,CLASS,STR,LCFUNC_utf8,FUNC,LCFUNC) \
212 PL_reg_flags |= RF_tainted; \
215 if (!nextchr && locinput >= PL_regeol) \
217 if (do_utf8 && UTF8_IS_CONTINUED(nextchr)) { \
218 if (!CAT2(PL_utf8_,CLASS)) { \
222 ok=CAT2(is_utf8_,CLASS)((const U8*)STR); \
226 if ((OP(scan) == NAME \
227 ? cBOOL(swash_fetch(CAT2(PL_utf8_,CLASS), (U8*)locinput, do_utf8)) \
228 : LCFUNC_utf8((U8*)locinput))) \
232 locinput += PL_utf8skip[nextchr]; \
233 nextchr = UCHARAT(locinput); \
236 if ((OP(scan) == NAME ? FUNC(nextchr) : LCFUNC(nextchr))) \
238 nextchr = UCHARAT(++locinput); \
245 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
247 /* for use after a quantifier and before an EXACT-like node -- japhy */
248 /* it would be nice to rework regcomp.sym to generate this stuff. sigh */
249 #define JUMPABLE(rn) ( \
251 (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
253 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
254 OP(rn) == PLUS || OP(rn) == MINMOD || \
255 OP(rn) == KEEPS || (PL_regkind[OP(rn)] == VERB) || \
256 (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
258 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
260 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
263 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
264 we don't need this definition. */
265 #define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF )
266 #define IS_TEXTF(rn) ( OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF )
267 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
270 /* ... so we use this as its faster. */
271 #define IS_TEXT(rn) ( OP(rn)==EXACT )
272 #define IS_TEXTF(rn) ( OP(rn)==EXACTF )
273 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
278 Search for mandatory following text node; for lookahead, the text must
279 follow but for lookbehind (rn->flags != 0) we skip to the next step.
281 #define FIND_NEXT_IMPT(rn) STMT_START { \
282 while (JUMPABLE(rn)) { \
283 const OPCODE type = OP(rn); \
284 if (type == SUSPEND || PL_regkind[type] == CURLY) \
285 rn = NEXTOPER(NEXTOPER(rn)); \
286 else if (type == PLUS) \
288 else if (type == IFMATCH) \
289 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
290 else rn += NEXT_OFF(rn); \
295 static void restore_pos(pTHX_ void *arg);
297 #define REGCP_PAREN_ELEMS 4
298 #define REGCP_OTHER_ELEMS 5
299 #define REGCP_FRAME_ELEMS 1
300 /* REGCP_FRAME_ELEMS are not part of the REGCP_OTHER_ELEMS and
301 * are needed for the regexp context stack bookkeeping. */
304 S_regcppush(pTHX_ I32 parenfloor)
307 const int retval = PL_savestack_ix;
308 const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
309 const UV total_elems = paren_elems_to_push + REGCP_OTHER_ELEMS;
310 const UV elems_shifted = total_elems << SAVE_TIGHT_SHIFT;
312 GET_RE_DEBUG_FLAGS_DECL;
314 if (paren_elems_to_push < 0)
315 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
317 if ((elems_shifted >> SAVE_TIGHT_SHIFT) != total_elems)
318 Perl_croak(aTHX_ "panic: paren_elems_to_push offset %"UVuf
319 " out of range (%d-%d)", total_elems, PL_regsize, parenfloor);
321 SSGROW(total_elems + REGCP_FRAME_ELEMS);
323 for (p = PL_regsize; p > parenfloor; p--) {
324 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
325 SSPUSHINT(PL_regoffs[p].end);
326 SSPUSHINT(PL_regoffs[p].start);
327 SSPUSHPTR(PL_reg_start_tmp[p]);
329 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
330 " saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
331 (UV)p, (IV)PL_regoffs[p].start,
332 (IV)(PL_reg_start_tmp[p] - PL_bostr),
333 (IV)PL_regoffs[p].end
336 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
337 SSPUSHPTR(PL_regoffs);
338 SSPUSHINT(PL_regsize);
339 SSPUSHINT(*PL_reglastparen);
340 SSPUSHINT(*PL_reglastcloseparen);
341 SSPUSHPTR(PL_reginput);
342 SSPUSHUV(SAVEt_REGCONTEXT | elems_shifted); /* Magic cookie. */
347 /* These are needed since we do not localize EVAL nodes: */
348 #define REGCP_SET(cp) \
350 PerlIO_printf(Perl_debug_log, \
351 " Setting an EVAL scope, savestack=%"IVdf"\n", \
352 (IV)PL_savestack_ix)); \
355 #define REGCP_UNWIND(cp) \
357 if (cp != PL_savestack_ix) \
358 PerlIO_printf(Perl_debug_log, \
359 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
360 (IV)(cp), (IV)PL_savestack_ix)); \
364 S_regcppop(pTHX_ const regexp *rex)
369 GET_RE_DEBUG_FLAGS_DECL;
371 PERL_ARGS_ASSERT_REGCPPOP;
373 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
375 assert((i & SAVE_MASK) == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
376 i >>= SAVE_TIGHT_SHIFT; /* Parentheses elements to pop. */
377 input = (char *) SSPOPPTR;
378 *PL_reglastcloseparen = SSPOPINT;
379 *PL_reglastparen = SSPOPINT;
380 PL_regsize = SSPOPINT;
381 PL_regoffs=(regexp_paren_pair *) SSPOPPTR;
383 i -= REGCP_OTHER_ELEMS;
384 /* Now restore the parentheses context. */
385 for ( ; i > 0; i -= REGCP_PAREN_ELEMS) {
387 U32 paren = (U32)SSPOPINT;
388 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
389 PL_regoffs[paren].start = SSPOPINT;
391 if (paren <= *PL_reglastparen)
392 PL_regoffs[paren].end = tmps;
394 PerlIO_printf(Perl_debug_log,
395 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
396 (UV)paren, (IV)PL_regoffs[paren].start,
397 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
398 (IV)PL_regoffs[paren].end,
399 (paren > *PL_reglastparen ? "(no)" : ""));
403 if (*PL_reglastparen + 1 <= rex->nparens) {
404 PerlIO_printf(Perl_debug_log,
405 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
406 (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
410 /* It would seem that the similar code in regtry()
411 * already takes care of this, and in fact it is in
412 * a better location to since this code can #if 0-ed out
413 * but the code in regtry() is needed or otherwise tests
414 * requiring null fields (pat.t#187 and split.t#{13,14}
415 * (as of patchlevel 7877) will fail. Then again,
416 * this code seems to be necessary or otherwise
417 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
418 * --jhi updated by dapm */
419 for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
421 PL_regoffs[i].start = -1;
422 PL_regoffs[i].end = -1;
428 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
431 * pregexec and friends
434 #ifndef PERL_IN_XSUB_RE
436 - pregexec - match a regexp against a string
439 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
440 char *strbeg, I32 minend, SV *screamer, U32 nosave)
441 /* strend: pointer to null at end of string */
442 /* strbeg: real beginning of string */
443 /* minend: end of match must be >=minend after stringarg. */
444 /* nosave: For optimizations. */
446 PERL_ARGS_ASSERT_PREGEXEC;
449 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
450 nosave ? 0 : REXEC_COPY_STR);
455 * Need to implement the following flags for reg_anch:
457 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
459 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
460 * INTUIT_AUTORITATIVE_ML
461 * INTUIT_ONCE_NOML - Intuit can match in one location only.
464 * Another flag for this function: SECOND_TIME (so that float substrs
465 * with giant delta may be not rechecked).
468 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
470 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
471 Otherwise, only SvCUR(sv) is used to get strbeg. */
473 /* XXXX We assume that strpos is strbeg unless sv. */
475 /* XXXX Some places assume that there is a fixed substring.
476 An update may be needed if optimizer marks as "INTUITable"
477 RExen without fixed substrings. Similarly, it is assumed that
478 lengths of all the strings are no more than minlen, thus they
479 cannot come from lookahead.
480 (Or minlen should take into account lookahead.)
481 NOTE: Some of this comment is not correct. minlen does now take account
482 of lookahead/behind. Further research is required. -- demerphq
486 /* A failure to find a constant substring means that there is no need to make
487 an expensive call to REx engine, thus we celebrate a failure. Similarly,
488 finding a substring too deep into the string means that less calls to
489 regtry() should be needed.
491 REx compiler's optimizer found 4 possible hints:
492 a) Anchored substring;
494 c) Whether we are anchored (beginning-of-line or \G);
495 d) First node (of those at offset 0) which may distingush positions;
496 We use a)b)d) and multiline-part of c), and try to find a position in the
497 string which does not contradict any of them.
500 /* Most of decisions we do here should have been done at compile time.
501 The nodes of the REx which we used for the search should have been
502 deleted from the finite automaton. */
505 Perl_re_intuit_start(pTHX_ REGEXP * const rx, SV *sv, char *strpos,
506 char *strend, const U32 flags, re_scream_pos_data *data)
509 struct regexp *const prog = (struct regexp *)SvANY(rx);
510 register I32 start_shift = 0;
511 /* Should be nonnegative! */
512 register I32 end_shift = 0;
517 const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
519 register char *other_last = NULL; /* other substr checked before this */
520 char *check_at = NULL; /* check substr found at this pos */
521 const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
522 RXi_GET_DECL(prog,progi);
524 const char * const i_strpos = strpos;
526 GET_RE_DEBUG_FLAGS_DECL;
528 PERL_ARGS_ASSERT_RE_INTUIT_START;
530 RX_MATCH_UTF8_set(rx,do_utf8);
533 PL_reg_flags |= RF_utf8;
536 debug_start_match(rx, do_utf8, strpos, strend,
537 sv ? "Guessing start of match in sv for"
538 : "Guessing start of match in string for");
541 /* CHR_DIST() would be more correct here but it makes things slow. */
542 if (prog->minlen > strend - strpos) {
543 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
544 "String too short... [re_intuit_start]\n"));
548 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
551 if (!prog->check_utf8 && prog->check_substr)
552 to_utf8_substr(prog);
553 check = prog->check_utf8;
555 if (!prog->check_substr && prog->check_utf8)
556 to_byte_substr(prog);
557 check = prog->check_substr;
559 if (check == &PL_sv_undef) {
560 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
561 "Non-utf8 string cannot match utf8 check string\n"));
564 if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */
565 ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
566 || ( (prog->extflags & RXf_ANCH_BOL)
567 && !multiline ) ); /* Check after \n? */
570 if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
571 && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
572 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
574 && (strpos != strbeg)) {
575 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
578 if (prog->check_offset_min == prog->check_offset_max &&
579 !(prog->extflags & RXf_CANY_SEEN)) {
580 /* Substring at constant offset from beg-of-str... */
583 s = HOP3c(strpos, prog->check_offset_min, strend);
586 slen = SvCUR(check); /* >= 1 */
588 if ( strend - s > slen || strend - s < slen - 1
589 || (strend - s == slen && strend[-1] != '\n')) {
590 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
593 /* Now should match s[0..slen-2] */
595 if (slen && (*SvPVX_const(check) != *s
597 && memNE(SvPVX_const(check), s, slen)))) {
599 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
603 else if (*SvPVX_const(check) != *s
604 || ((slen = SvCUR(check)) > 1
605 && memNE(SvPVX_const(check), s, slen)))
608 goto success_at_start;
611 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
613 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
614 end_shift = prog->check_end_shift;
617 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
618 - (SvTAIL(check) != 0);
619 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
621 if (end_shift < eshift)
625 else { /* Can match at random position */
628 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
629 end_shift = prog->check_end_shift;
631 /* end shift should be non negative here */
634 #ifdef QDEBUGGING /* 7/99: reports of failure (with the older version) */
636 Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
637 (IV)end_shift, RX_PRECOMP(prog));
641 /* Find a possible match in the region s..strend by looking for
642 the "check" substring in the region corrected by start/end_shift. */
645 I32 srch_start_shift = start_shift;
646 I32 srch_end_shift = end_shift;
647 if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
648 srch_end_shift -= ((strbeg - s) - srch_start_shift);
649 srch_start_shift = strbeg - s;
651 DEBUG_OPTIMISE_MORE_r({
652 PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
653 (IV)prog->check_offset_min,
654 (IV)srch_start_shift,
656 (IV)prog->check_end_shift);
659 if (flags & REXEC_SCREAM) {
660 I32 p = -1; /* Internal iterator of scream. */
661 I32 * const pp = data ? data->scream_pos : &p;
663 if (PL_screamfirst[BmRARE(check)] >= 0
664 || ( BmRARE(check) == '\n'
665 && (BmPREVIOUS(check) == SvCUR(check) - 1)
667 s = screaminstr(sv, check,
668 srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
671 /* we may be pointing at the wrong string */
672 if (s && RXp_MATCH_COPIED(prog))
673 s = strbeg + (s - SvPVX_const(sv));
675 *data->scream_olds = s;
680 if (prog->extflags & RXf_CANY_SEEN) {
681 start_point= (U8*)(s + srch_start_shift);
682 end_point= (U8*)(strend - srch_end_shift);
684 start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
685 end_point= HOP3(strend, -srch_end_shift, strbeg);
687 DEBUG_OPTIMISE_MORE_r({
688 PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
689 (int)(end_point - start_point),
690 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
694 s = fbm_instr( start_point, end_point,
695 check, multiline ? FBMrf_MULTILINE : 0);
698 /* Update the count-of-usability, remove useless subpatterns,
702 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
703 SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
704 PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
705 (s ? "Found" : "Did not find"),
706 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)
707 ? "anchored" : "floating"),
710 (s ? " at offset " : "...\n") );
715 /* Finish the diagnostic message */
716 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
718 /* XXX dmq: first branch is for positive lookbehind...
719 Our check string is offset from the beginning of the pattern.
720 So we need to do any stclass tests offset forward from that
729 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
730 Start with the other substr.
731 XXXX no SCREAM optimization yet - and a very coarse implementation
732 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
733 *always* match. Probably should be marked during compile...
734 Probably it is right to do no SCREAM here...
737 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
738 : (prog->float_substr && prog->anchored_substr))
740 /* Take into account the "other" substring. */
741 /* XXXX May be hopelessly wrong for UTF... */
744 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
747 char * const last = HOP3c(s, -start_shift, strbeg);
749 char * const saved_s = s;
752 t = s - prog->check_offset_max;
753 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
755 || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
760 t = HOP3c(t, prog->anchored_offset, strend);
761 if (t < other_last) /* These positions already checked */
763 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
766 /* XXXX It is not documented what units *_offsets are in.
767 We assume bytes, but this is clearly wrong.
768 Meaning this code needs to be carefully reviewed for errors.
772 /* On end-of-str: see comment below. */
773 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
774 if (must == &PL_sv_undef) {
776 DEBUG_r(must = prog->anchored_utf8); /* for debug */
781 HOP3(HOP3(last1, prog->anchored_offset, strend)
782 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
784 multiline ? FBMrf_MULTILINE : 0
787 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
788 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
789 PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
790 (s ? "Found" : "Contradicts"),
791 quoted, RE_SV_TAIL(must));
796 if (last1 >= last2) {
797 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
798 ", giving up...\n"));
801 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
802 ", trying floating at offset %ld...\n",
803 (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
804 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
805 s = HOP3c(last, 1, strend);
809 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
810 (long)(s - i_strpos)));
811 t = HOP3c(s, -prog->anchored_offset, strbeg);
812 other_last = HOP3c(s, 1, strend);
820 else { /* Take into account the floating substring. */
822 char * const saved_s = s;
825 t = HOP3c(s, -start_shift, strbeg);
827 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
828 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
829 last = HOP3c(t, prog->float_max_offset, strend);
830 s = HOP3c(t, prog->float_min_offset, strend);
833 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
834 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
835 /* fbm_instr() takes into account exact value of end-of-str
836 if the check is SvTAIL(ed). Since false positives are OK,
837 and end-of-str is not later than strend we are OK. */
838 if (must == &PL_sv_undef) {
840 DEBUG_r(must = prog->float_utf8); /* for debug message */
843 s = fbm_instr((unsigned char*)s,
844 (unsigned char*)last + SvCUR(must)
846 must, multiline ? FBMrf_MULTILINE : 0);
848 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
849 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
850 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
851 (s ? "Found" : "Contradicts"),
852 quoted, RE_SV_TAIL(must));
856 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
857 ", giving up...\n"));
860 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
861 ", trying anchored starting at offset %ld...\n",
862 (long)(saved_s + 1 - i_strpos)));
864 s = HOP3c(t, 1, strend);
868 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
869 (long)(s - i_strpos)));
870 other_last = s; /* Fix this later. --Hugo */
880 t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
882 DEBUG_OPTIMISE_MORE_r(
883 PerlIO_printf(Perl_debug_log,
884 "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
885 (IV)prog->check_offset_min,
886 (IV)prog->check_offset_max,
894 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
896 || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
899 /* Fixed substring is found far enough so that the match
900 cannot start at strpos. */
902 if (ml_anch && t[-1] != '\n') {
903 /* Eventually fbm_*() should handle this, but often
904 anchored_offset is not 0, so this check will not be wasted. */
905 /* XXXX In the code below we prefer to look for "^" even in
906 presence of anchored substrings. And we search even
907 beyond the found float position. These pessimizations
908 are historical artefacts only. */
910 while (t < strend - prog->minlen) {
912 if (t < check_at - prog->check_offset_min) {
913 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
914 /* Since we moved from the found position,
915 we definitely contradict the found anchored
916 substr. Due to the above check we do not
917 contradict "check" substr.
918 Thus we can arrive here only if check substr
919 is float. Redo checking for "other"=="fixed".
922 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
923 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
924 goto do_other_anchored;
926 /* We don't contradict the found floating substring. */
927 /* XXXX Why not check for STCLASS? */
929 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
930 PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
933 /* Position contradicts check-string */
934 /* XXXX probably better to look for check-string
935 than for "\n", so one should lower the limit for t? */
936 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
937 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
938 other_last = strpos = s = t + 1;
943 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
944 PL_colors[0], PL_colors[1]));
948 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
949 PL_colors[0], PL_colors[1]));
953 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
956 /* The found string does not prohibit matching at strpos,
957 - no optimization of calling REx engine can be performed,
958 unless it was an MBOL and we are not after MBOL,
959 or a future STCLASS check will fail this. */
961 /* Even in this situation we may use MBOL flag if strpos is offset
962 wrt the start of the string. */
963 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
964 && (strpos != strbeg) && strpos[-1] != '\n'
965 /* May be due to an implicit anchor of m{.*foo} */
966 && !(prog->intflags & PREGf_IMPLICIT))
971 DEBUG_EXECUTE_r( if (ml_anch)
972 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
973 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
976 if (!(prog->intflags & PREGf_NAUGHTY) /* XXXX If strpos moved? */
978 prog->check_utf8 /* Could be deleted already */
979 && --BmUSEFUL(prog->check_utf8) < 0
980 && (prog->check_utf8 == prog->float_utf8)
982 prog->check_substr /* Could be deleted already */
983 && --BmUSEFUL(prog->check_substr) < 0
984 && (prog->check_substr == prog->float_substr)
987 /* If flags & SOMETHING - do not do it many times on the same match */
988 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
989 /* XXX Does the destruction order has to change with do_utf8? */
990 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
991 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
992 prog->check_substr = prog->check_utf8 = NULL; /* disable */
993 prog->float_substr = prog->float_utf8 = NULL; /* clear */
994 check = NULL; /* abort */
996 /* XXXX This is a remnant of the old implementation. It
997 looks wasteful, since now INTUIT can use many
999 prog->extflags &= ~RXf_USE_INTUIT;
1005 /* Last resort... */
1006 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
1007 /* trie stclasses are too expensive to use here, we are better off to
1008 leave it to regmatch itself */
1009 if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
1010 /* minlen == 0 is possible if regstclass is \b or \B,
1011 and the fixed substr is ''$.
1012 Since minlen is already taken into account, s+1 is before strend;
1013 accidentally, minlen >= 1 guaranties no false positives at s + 1
1014 even for \b or \B. But (minlen? 1 : 0) below assumes that
1015 regstclass does not come from lookahead... */
1016 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
1017 This leaves EXACTF only, which is dealt with in find_byclass(). */
1018 const U8* const str = (U8*)STRING(progi->regstclass);
1019 const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
1020 ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
1023 if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
1024 endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
1025 else if (prog->float_substr || prog->float_utf8)
1026 endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
1030 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
1031 (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
1034 s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
1037 const char *what = NULL;
1039 if (endpos == strend) {
1040 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1041 "Could not match STCLASS...\n") );
1044 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1045 "This position contradicts STCLASS...\n") );
1046 if ((prog->extflags & RXf_ANCH) && !ml_anch)
1048 /* Contradict one of substrings */
1049 if (prog->anchored_substr || prog->anchored_utf8) {
1050 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
1051 DEBUG_EXECUTE_r( what = "anchored" );
1053 s = HOP3c(t, 1, strend);
1054 if (s + start_shift + end_shift > strend) {
1055 /* XXXX Should be taken into account earlier? */
1056 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1057 "Could not match STCLASS...\n") );
1062 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1063 "Looking for %s substr starting at offset %ld...\n",
1064 what, (long)(s + start_shift - i_strpos)) );
1067 /* Have both, check_string is floating */
1068 if (t + start_shift >= check_at) /* Contradicts floating=check */
1069 goto retry_floating_check;
1070 /* Recheck anchored substring, but not floating... */
1074 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1075 "Looking for anchored substr starting at offset %ld...\n",
1076 (long)(other_last - i_strpos)) );
1077 goto do_other_anchored;
1079 /* Another way we could have checked stclass at the
1080 current position only: */
1085 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
1086 "Looking for /%s^%s/m starting at offset %ld...\n",
1087 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
1090 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
1092 /* Check is floating subtring. */
1093 retry_floating_check:
1094 t = check_at - start_shift;
1095 DEBUG_EXECUTE_r( what = "floating" );
1096 goto hop_and_restart;
1099 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1100 "By STCLASS: moving %ld --> %ld\n",
1101 (long)(t - i_strpos), (long)(s - i_strpos))
1105 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1106 "Does not contradict STCLASS...\n");
1111 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
1112 PL_colors[4], (check ? "Guessed" : "Giving up"),
1113 PL_colors[5], (long)(s - i_strpos)) );
1116 fail_finish: /* Substring not found */
1117 if (prog->check_substr || prog->check_utf8) /* could be removed already */
1118 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
1120 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
1121 PL_colors[4], PL_colors[5]));
1125 #define DECL_TRIE_TYPE(scan) \
1126 const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
1127 trie_type = (scan->flags != EXACT) \
1128 ? (do_utf8 ? trie_utf8_fold : (UTF ? trie_latin_utf8_fold : trie_plain)) \
1129 : (do_utf8 ? trie_utf8 : trie_plain)
1131 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, \
1132 uvc, charid, foldlen, foldbuf, uniflags) STMT_START { \
1133 switch (trie_type) { \
1134 case trie_utf8_fold: \
1135 if ( foldlen>0 ) { \
1136 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1141 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1142 uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
1143 foldlen -= UNISKIP( uvc ); \
1144 uscan = foldbuf + UNISKIP( uvc ); \
1147 case trie_latin_utf8_fold: \
1148 if ( foldlen>0 ) { \
1149 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1155 uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen ); \
1156 foldlen -= UNISKIP( uvc ); \
1157 uscan = foldbuf + UNISKIP( uvc ); \
1161 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1168 charid = trie->charmap[ uvc ]; \
1172 if (widecharmap) { \
1173 SV** const svpp = hv_fetch(widecharmap, \
1174 (char*)&uvc, sizeof(UV), 0); \
1176 charid = (U16)SvIV(*svpp); \
1181 #define REXEC_FBC_EXACTISH_CHECK(CoNd) \
1183 char *my_strend= (char *)strend; \
1186 !ibcmp_utf8(s, &my_strend, 0, do_utf8, \
1187 m, NULL, ln, cBOOL(UTF))) \
1188 && (!reginfo || regtry(reginfo, &s)) ) \
1191 U8 foldbuf[UTF8_MAXBYTES_CASE+1]; \
1192 uvchr_to_utf8(tmpbuf, c); \
1193 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); \
1195 && (f == c1 || f == c2) \
1197 !ibcmp_utf8(s, &my_strend, 0, do_utf8,\
1198 m, NULL, ln, cBOOL(UTF)))\
1199 && (!reginfo || regtry(reginfo, &s)) ) \
1205 #define REXEC_FBC_EXACTISH_SCAN(CoNd) \
1209 && (ln == 1 || !(OP(c) == EXACTF \
1211 : ibcmp_locale(s, m, ln))) \
1212 && (!reginfo || regtry(reginfo, &s)) ) \
1218 #define REXEC_FBC_UTF8_SCAN(CoDe) \
1220 while (s + (uskip = UTF8SKIP(s)) <= strend) { \
1226 #define REXEC_FBC_SCAN(CoDe) \
1228 while (s < strend) { \
1234 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \
1235 REXEC_FBC_UTF8_SCAN( \
1237 if (tmp && (!reginfo || regtry(reginfo, &s))) \
1246 #define REXEC_FBC_CLASS_SCAN(CoNd) \
1249 if (tmp && (!reginfo || regtry(reginfo, &s))) \
1258 #define REXEC_FBC_TRYIT \
1259 if ((!reginfo || regtry(reginfo, &s))) \
1262 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \
1264 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1267 REXEC_FBC_CLASS_SCAN(CoNd); \
1271 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd) \
1274 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1277 REXEC_FBC_CLASS_SCAN(CoNd); \
1281 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd) \
1282 PL_reg_flags |= RF_tainted; \
1284 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1287 REXEC_FBC_CLASS_SCAN(CoNd); \
1291 #define DUMP_EXEC_POS(li,s,doutf8) \
1292 dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1294 /* We know what class REx starts with. Try to find this position... */
1295 /* if reginfo is NULL, its a dryrun */
1296 /* annoyingly all the vars in this routine have different names from their counterparts
1297 in regmatch. /grrr */
1300 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1301 const char *strend, regmatch_info *reginfo)
1304 const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1308 register STRLEN uskip;
1312 register I32 tmp = 1; /* Scratch variable? */
1313 register const bool do_utf8 = PL_reg_match_utf8;
1314 RXi_GET_DECL(prog,progi);
1316 PERL_ARGS_ASSERT_FIND_BYCLASS;
1318 /* We know what class it must start with. */
1322 REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1323 !UTF8_IS_INVARIANT((U8)s[0]) ?
1324 reginclass(prog, c, (U8*)s, 0, do_utf8) :
1325 REGINCLASS(prog, c, (U8*)s));
1328 while (s < strend) {
1331 if (REGINCLASS(prog, c, (U8*)s) ||
1332 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1333 /* The assignment of 2 is intentional:
1334 * for the folded sharp s, the skip is 2. */
1335 (skip = SHARP_S_SKIP))) {
1336 if (tmp && (!reginfo || regtry(reginfo, &s)))
1349 if (tmp && (!reginfo || regtry(reginfo, &s)))
1357 ln = STR_LEN(c); /* length to match in octets/bytes */
1358 lnc = (I32) ln; /* length to match in characters */
1360 STRLEN ulen1, ulen2;
1362 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1363 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1364 /* used by commented-out code below */
1365 /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1367 /* XXX: Since the node will be case folded at compile
1368 time this logic is a little odd, although im not
1369 sure that its actually wrong. --dmq */
1371 c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1372 c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1374 /* XXX: This is kinda strange. to_utf8_XYZ returns the
1375 codepoint of the first character in the converted
1376 form, yet originally we did the extra step.
1377 No tests fail by commenting this code out however
1378 so Ive left it out. -- dmq.
1380 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1382 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1387 while (sm < ((U8 *) m + ln)) {
1402 c2 = PL_fold_locale[c1];
1404 e = HOP3c(strend, -((I32)lnc), s);
1406 if (!reginfo && e < s)
1407 e = s; /* Due to minlen logic of intuit() */
1409 /* The idea in the EXACTF* cases is to first find the
1410 * first character of the EXACTF* node and then, if
1411 * necessary, case-insensitively compare the full
1412 * text of the node. The c1 and c2 are the first
1413 * characters (though in Unicode it gets a bit
1414 * more complicated because there are more cases
1415 * than just upper and lower: one needs to use
1416 * the so-called folding case for case-insensitive
1417 * matching (called "loose matching" in Unicode).
1418 * ibcmp_utf8() will do just that. */
1420 if (do_utf8 || UTF) {
1422 U8 tmpbuf [UTF8_MAXBYTES+1];
1425 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1427 /* Upper and lower of 1st char are equal -
1428 * probably not a "letter". */
1431 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1436 REXEC_FBC_EXACTISH_CHECK(c == c1);
1442 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1448 /* Handle some of the three Greek sigmas cases.
1449 * Note that not all the possible combinations
1450 * are handled here: some of them are handled
1451 * by the standard folding rules, and some of
1452 * them (the character class or ANYOF cases)
1453 * are handled during compiletime in
1454 * regexec.c:S_regclass(). */
1455 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1456 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1457 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1459 REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1464 /* Neither pattern nor string are UTF8 */
1466 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1468 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1472 PL_reg_flags |= RF_tainted;
1479 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1480 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1482 tmp = ((OP(c) == BOUND ?
1483 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1484 LOAD_UTF8_CHARCLASS_ALNUM();
1485 REXEC_FBC_UTF8_SCAN(
1486 if (tmp == !(OP(c) == BOUND ?
1487 cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) :
1488 isALNUM_LC_utf8((U8*)s)))
1496 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1497 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1500 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1506 if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1510 PL_reg_flags |= RF_tainted;
1517 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1518 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1520 tmp = ((OP(c) == NBOUND ?
1521 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1522 LOAD_UTF8_CHARCLASS_ALNUM();
1523 REXEC_FBC_UTF8_SCAN(
1524 if (tmp == !(OP(c) == NBOUND ?
1525 cBOOL(swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) :
1526 isALNUM_LC_utf8((U8*)s)))
1528 else REXEC_FBC_TRYIT;
1532 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1533 tmp = ((OP(c) == NBOUND ?
1534 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1537 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1539 else REXEC_FBC_TRYIT;
1542 if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1546 REXEC_FBC_CSCAN_PRELOAD(
1547 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1548 swash_fetch(RE_utf8_perl_word, (U8*)s, do_utf8),
1552 REXEC_FBC_CSCAN_TAINT(
1553 isALNUM_LC_utf8((U8*)s),
1557 REXEC_FBC_CSCAN_PRELOAD(
1558 LOAD_UTF8_CHARCLASS_PERL_WORD(),
1559 !swash_fetch(RE_utf8_perl_word, (U8*)s, do_utf8),
1563 REXEC_FBC_CSCAN_TAINT(
1564 !isALNUM_LC_utf8((U8*)s),
1568 REXEC_FBC_CSCAN_PRELOAD(
1569 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1570 *s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, do_utf8),
1574 REXEC_FBC_CSCAN_TAINT(
1575 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1579 REXEC_FBC_CSCAN_PRELOAD(
1580 LOAD_UTF8_CHARCLASS_PERL_SPACE(),
1581 !(*s == ' ' || swash_fetch(RE_utf8_perl_space,(U8*)s, do_utf8)),
1585 REXEC_FBC_CSCAN_TAINT(
1586 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1590 REXEC_FBC_CSCAN_PRELOAD(
1591 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1592 swash_fetch(RE_utf8_posix_digit,(U8*)s, do_utf8),
1596 REXEC_FBC_CSCAN_TAINT(
1597 isDIGIT_LC_utf8((U8*)s),
1601 REXEC_FBC_CSCAN_PRELOAD(
1602 LOAD_UTF8_CHARCLASS_POSIX_DIGIT(),
1603 !swash_fetch(RE_utf8_posix_digit,(U8*)s, do_utf8),
1607 REXEC_FBC_CSCAN_TAINT(
1608 !isDIGIT_LC_utf8((U8*)s),
1614 is_LNBREAK_latin1(s)
1624 !is_VERTWS_latin1(s)
1629 is_HORIZWS_latin1(s)
1633 !is_HORIZWS_utf8(s),
1634 !is_HORIZWS_latin1(s)
1640 /* what trie are we using right now */
1642 = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1644 = (reg_trie_data*)progi->data->data[ aho->trie ];
1645 HV *widecharmap = MUTABLE_HV(progi->data->data[ aho->trie + 1 ]);
1647 const char *last_start = strend - trie->minlen;
1649 const char *real_start = s;
1651 STRLEN maxlen = trie->maxlen;
1653 U8 **points; /* map of where we were in the input string
1654 when reading a given char. For ASCII this
1655 is unnecessary overhead as the relationship
1656 is always 1:1, but for Unicode, especially
1657 case folded Unicode this is not true. */
1658 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1662 GET_RE_DEBUG_FLAGS_DECL;
1664 /* We can't just allocate points here. We need to wrap it in
1665 * an SV so it gets freed properly if there is a croak while
1666 * running the match */
1669 sv_points=newSV(maxlen * sizeof(U8 *));
1670 SvCUR_set(sv_points,
1671 maxlen * sizeof(U8 *));
1672 SvPOK_on(sv_points);
1673 sv_2mortal(sv_points);
1674 points=(U8**)SvPV_nolen(sv_points );
1675 if ( trie_type != trie_utf8_fold
1676 && (trie->bitmap || OP(c)==AHOCORASICKC) )
1679 bitmap=(U8*)trie->bitmap;
1681 bitmap=(U8*)ANYOF_BITMAP(c);
1683 /* this is the Aho-Corasick algorithm modified a touch
1684 to include special handling for long "unknown char"
1685 sequences. The basic idea being that we use AC as long
1686 as we are dealing with a possible matching char, when
1687 we encounter an unknown char (and we have not encountered
1688 an accepting state) we scan forward until we find a legal
1690 AC matching is basically that of trie matching, except
1691 that when we encounter a failing transition, we fall back
1692 to the current states "fail state", and try the current char
1693 again, a process we repeat until we reach the root state,
1694 state 1, or a legal transition. If we fail on the root state
1695 then we can either terminate if we have reached an accepting
1696 state previously, or restart the entire process from the beginning
1700 while (s <= last_start) {
1701 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1709 U8 *uscan = (U8*)NULL;
1710 U8 *leftmost = NULL;
1712 U32 accepted_word= 0;
1716 while ( state && uc <= (U8*)strend ) {
1718 U32 word = aho->states[ state ].wordnum;
1722 DEBUG_TRIE_EXECUTE_r(
1723 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1724 dump_exec_pos( (char *)uc, c, strend, real_start,
1725 (char *)uc, do_utf8 );
1726 PerlIO_printf( Perl_debug_log,
1727 " Scanning for legal start char...\n");
1730 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1735 if (uc >(U8*)last_start) break;
1739 U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1740 if (!leftmost || lpos < leftmost) {
1741 DEBUG_r(accepted_word=word);
1747 points[pointpos++ % maxlen]= uc;
1748 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1749 uscan, len, uvc, charid, foldlen,
1751 DEBUG_TRIE_EXECUTE_r({
1752 dump_exec_pos( (char *)uc, c, strend, real_start,
1754 PerlIO_printf(Perl_debug_log,
1755 " Charid:%3u CP:%4"UVxf" ",
1761 word = aho->states[ state ].wordnum;
1763 base = aho->states[ state ].trans.base;
1765 DEBUG_TRIE_EXECUTE_r({
1767 dump_exec_pos( (char *)uc, c, strend, real_start,
1769 PerlIO_printf( Perl_debug_log,
1770 "%sState: %4"UVxf", word=%"UVxf,
1771 failed ? " Fail transition to " : "",
1772 (UV)state, (UV)word);
1777 (base + charid > trie->uniquecharcount )
1778 && (base + charid - 1 - trie->uniquecharcount
1780 && trie->trans[base + charid - 1 -
1781 trie->uniquecharcount].check == state
1782 && (tmp=trie->trans[base + charid - 1 -
1783 trie->uniquecharcount ].next))
1785 DEBUG_TRIE_EXECUTE_r(
1786 PerlIO_printf( Perl_debug_log," - legal\n"));
1791 DEBUG_TRIE_EXECUTE_r(
1792 PerlIO_printf( Perl_debug_log," - fail\n"));
1794 state = aho->fail[state];
1798 /* we must be accepting here */
1799 DEBUG_TRIE_EXECUTE_r(
1800 PerlIO_printf( Perl_debug_log," - accepting\n"));
1809 if (!state) state = 1;
1812 if ( aho->states[ state ].wordnum ) {
1813 U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1814 if (!leftmost || lpos < leftmost) {
1815 DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1820 s = (char*)leftmost;
1821 DEBUG_TRIE_EXECUTE_r({
1823 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1824 (UV)accepted_word, (IV)(s - real_start)
1827 if (!reginfo || regtry(reginfo, &s)) {
1833 DEBUG_TRIE_EXECUTE_r({
1834 PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1837 DEBUG_TRIE_EXECUTE_r(
1838 PerlIO_printf( Perl_debug_log,"No match.\n"));
1847 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1857 - regexec_flags - match a regexp against a string
1860 Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, register char *strend,
1861 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1862 /* strend: pointer to null at end of string */
1863 /* strbeg: real beginning of string */
1864 /* minend: end of match must be >=minend after stringarg. */
1865 /* data: May be used for some additional optimizations.
1866 Currently its only used, with a U32 cast, for transmitting
1867 the ganch offset when doing a /g match. This will change */
1868 /* nosave: For optimizations. */
1871 struct regexp *const prog = (struct regexp *)SvANY(rx);
1872 /*register*/ char *s;
1873 register regnode *c;
1874 /*register*/ char *startpos = stringarg;
1875 I32 minlen; /* must match at least this many chars */
1876 I32 dontbother = 0; /* how many characters not to try at end */
1877 I32 end_shift = 0; /* Same for the end. */ /* CC */
1878 I32 scream_pos = -1; /* Internal iterator of scream. */
1879 char *scream_olds = NULL;
1880 const bool do_utf8 = cBOOL(DO_UTF8(sv));
1882 RXi_GET_DECL(prog,progi);
1883 regmatch_info reginfo; /* create some info to pass to regtry etc */
1884 regexp_paren_pair *swap = NULL;
1885 GET_RE_DEBUG_FLAGS_DECL;
1887 PERL_ARGS_ASSERT_REGEXEC_FLAGS;
1888 PERL_UNUSED_ARG(data);
1890 /* Be paranoid... */
1891 if (prog == NULL || startpos == NULL) {
1892 Perl_croak(aTHX_ "NULL regexp parameter");
1896 multiline = prog->extflags & RXf_PMf_MULTILINE;
1897 reginfo.prog = rx; /* Yes, sorry that this is confusing. */
1899 RX_MATCH_UTF8_set(rx, do_utf8);
1901 debug_start_match(rx, do_utf8, startpos, strend,
1905 minlen = prog->minlen;
1907 if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1908 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1909 "String too short [regexec_flags]...\n"));
1914 /* Check validity of program. */
1915 if (UCHARAT(progi->program) != REG_MAGIC) {
1916 Perl_croak(aTHX_ "corrupted regexp program");
1920 PL_reg_eval_set = 0;
1924 PL_reg_flags |= RF_utf8;
1926 /* Mark beginning of line for ^ and lookbehind. */
1927 reginfo.bol = startpos; /* XXX not used ??? */
1931 /* Mark end of line for $ (and such) */
1934 /* see how far we have to get to not match where we matched before */
1935 reginfo.till = startpos+minend;
1937 /* If there is a "must appear" string, look for it. */
1940 if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
1942 if (flags & REXEC_IGNOREPOS){ /* Means: check only at start */
1943 reginfo.ganch = startpos + prog->gofs;
1944 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1945 "GPOS IGNOREPOS: reginfo.ganch = startpos + %"UVxf"\n",(UV)prog->gofs));
1946 } else if (sv && SvTYPE(sv) >= SVt_PVMG
1948 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1949 && mg->mg_len >= 0) {
1950 reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
1951 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1952 "GPOS MAGIC: reginfo.ganch = strbeg + %"IVdf"\n",(IV)mg->mg_len));
1954 if (prog->extflags & RXf_ANCH_GPOS) {
1955 if (s > reginfo.ganch)
1957 s = reginfo.ganch - prog->gofs;
1958 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1959 "GPOS ANCH_GPOS: s = ganch - %"UVxf"\n",(UV)prog->gofs));
1965 reginfo.ganch = strbeg + PTR2UV(data);
1966 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1967 "GPOS DATA: reginfo.ganch= strbeg + %"UVxf"\n",PTR2UV(data)));
1969 } else { /* pos() not defined */
1970 reginfo.ganch = strbeg;
1971 DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
1972 "GPOS: reginfo.ganch = strbeg\n"));
1975 if (PL_curpm && (PM_GETRE(PL_curpm) == rx)) {
1976 /* We have to be careful. If the previous successful match
1977 was from this regex we don't want a subsequent partially
1978 successful match to clobber the old results.
1979 So when we detect this possibility we add a swap buffer
1980 to the re, and switch the buffer each match. If we fail
1981 we switch it back, otherwise we leave it swapped.
1984 /* do we need a save destructor here for eval dies? */
1985 Newxz(prog->offs, (prog->nparens + 1), regexp_paren_pair);
1987 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1988 re_scream_pos_data d;
1990 d.scream_olds = &scream_olds;
1991 d.scream_pos = &scream_pos;
1992 s = re_intuit_start(rx, sv, s, strend, flags, &d);
1994 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1995 goto phooey; /* not present */
2001 /* Simplest case: anchored match need be tried only once. */
2002 /* [unless only anchor is BOL and multiline is set] */
2003 if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
2004 if (s == startpos && regtry(®info, &startpos))
2006 else if (multiline || (prog->intflags & PREGf_IMPLICIT)
2007 || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
2012 dontbother = minlen - 1;
2013 end = HOP3c(strend, -dontbother, strbeg) - 1;
2014 /* for multiline we only have to try after newlines */
2015 if (prog->check_substr || prog->check_utf8) {
2019 if (regtry(®info, &s))
2024 if (prog->extflags & RXf_USE_INTUIT) {
2025 s = re_intuit_start(rx, sv, s + 1, strend, flags, NULL);
2036 if (*s++ == '\n') { /* don't need PL_utf8skip here */
2037 if (regtry(®info, &s))
2044 } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
2046 /* the warning about reginfo.ganch being used without intialization
2047 is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
2048 and we only enter this block when the same bit is set. */
2049 char *tmp_s = reginfo.ganch - prog->gofs;
2051 if (tmp_s >= strbeg && regtry(®info, &tmp_s))
2056 /* Messy cases: unanchored match. */
2057 if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
2058 /* we have /x+whatever/ */
2059 /* it must be a one character string (XXXX Except UTF?) */
2064 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2065 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2066 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
2071 DEBUG_EXECUTE_r( did_match = 1 );
2072 if (regtry(®info, &s)) goto got_it;
2074 while (s < strend && *s == ch)
2082 DEBUG_EXECUTE_r( did_match = 1 );
2083 if (regtry(®info, &s)) goto got_it;
2085 while (s < strend && *s == ch)
2090 DEBUG_EXECUTE_r(if (!did_match)
2091 PerlIO_printf(Perl_debug_log,
2092 "Did not find anchored character...\n")
2095 else if (prog->anchored_substr != NULL
2096 || prog->anchored_utf8 != NULL
2097 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
2098 && prog->float_max_offset < strend - s)) {
2103 char *last1; /* Last position checked before */
2107 if (prog->anchored_substr || prog->anchored_utf8) {
2108 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2109 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2110 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
2111 back_max = back_min = prog->anchored_offset;
2113 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2114 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2115 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2116 back_max = prog->float_max_offset;
2117 back_min = prog->float_min_offset;
2121 if (must == &PL_sv_undef)
2122 /* could not downgrade utf8 check substring, so must fail */
2128 last = HOP3c(strend, /* Cannot start after this */
2129 -(I32)(CHR_SVLEN(must)
2130 - (SvTAIL(must) != 0) + back_min), strbeg);
2133 last1 = HOPc(s, -1);
2135 last1 = s - 1; /* bogus */
2137 /* XXXX check_substr already used to find "s", can optimize if
2138 check_substr==must. */
2140 dontbother = end_shift;
2141 strend = HOPc(strend, -dontbother);
2142 while ( (s <= last) &&
2143 ((flags & REXEC_SCREAM)
2144 ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2145 end_shift, &scream_pos, 0))
2146 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2147 (unsigned char*)strend, must,
2148 multiline ? FBMrf_MULTILINE : 0))) ) {
2149 /* we may be pointing at the wrong string */
2150 if ((flags & REXEC_SCREAM) && RXp_MATCH_COPIED(prog))
2151 s = strbeg + (s - SvPVX_const(sv));
2152 DEBUG_EXECUTE_r( did_match = 1 );
2153 if (HOPc(s, -back_max) > last1) {
2154 last1 = HOPc(s, -back_min);
2155 s = HOPc(s, -back_max);
2158 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2160 last1 = HOPc(s, -back_min);
2164 while (s <= last1) {
2165 if (regtry(®info, &s))
2171 while (s <= last1) {
2172 if (regtry(®info, &s))
2178 DEBUG_EXECUTE_r(if (!did_match) {
2179 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
2180 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2181 PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2182 ((must == prog->anchored_substr || must == prog->anchored_utf8)
2183 ? "anchored" : "floating"),
2184 quoted, RE_SV_TAIL(must));
2188 else if ( (c = progi->regstclass) ) {
2190 const OPCODE op = OP(progi->regstclass);
2191 /* don't bother with what can't match */
2192 if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2193 strend = HOPc(strend, -(minlen - 1));
2196 SV * const prop = sv_newmortal();
2197 regprop(prog, prop, c);
2199 RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
2201 PerlIO_printf(Perl_debug_log,
2202 "Matching stclass %.*s against %s (%d chars)\n",
2203 (int)SvCUR(prop), SvPVX_const(prop),
2204 quoted, (int)(strend - s));
2207 if (find_byclass(prog, c, s, strend, ®info))
2209 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2213 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2218 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2219 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2220 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2222 if (flags & REXEC_SCREAM) {
2223 last = screaminstr(sv, float_real, s - strbeg,
2224 end_shift, &scream_pos, 1); /* last one */
2226 last = scream_olds; /* Only one occurrence. */
2227 /* we may be pointing at the wrong string */
2228 else if (RXp_MATCH_COPIED(prog))
2229 s = strbeg + (s - SvPVX_const(sv));
2233 const char * const little = SvPV_const(float_real, len);
2235 if (SvTAIL(float_real)) {
2236 if (memEQ(strend - len + 1, little, len - 1))
2237 last = strend - len + 1;
2238 else if (!multiline)
2239 last = memEQ(strend - len, little, len)
2240 ? strend - len : NULL;
2246 last = rninstr(s, strend, little, little + len);
2248 last = strend; /* matching "$" */
2253 PerlIO_printf(Perl_debug_log,
2254 "%sCan't trim the tail, match fails (should not happen)%s\n",
2255 PL_colors[4], PL_colors[5]));
2256 goto phooey; /* Should not happen! */
2258 dontbother = strend - last + prog->float_min_offset;
2260 if (minlen && (dontbother < minlen))
2261 dontbother = minlen - 1;
2262 strend -= dontbother; /* this one's always in bytes! */
2263 /* We don't know much -- general case. */
2266 if (regtry(®info, &s))
2275 if (regtry(®info, &s))
2277 } while (s++ < strend);
2286 RX_MATCH_TAINTED_set(rx, PL_reg_flags & RF_tainted);
2288 if (PL_reg_eval_set)
2289 restore_pos(aTHX_ prog);
2290 if (RXp_PAREN_NAMES(prog))
2291 (void)hv_iterinit(RXp_PAREN_NAMES(prog));
2293 /* make sure $`, $&, $', and $digit will work later */
2294 if ( !(flags & REXEC_NOT_FIRST) ) {
2295 RX_MATCH_COPY_FREE(rx);
2296 if (flags & REXEC_COPY_STR) {
2297 const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2298 #ifdef PERL_OLD_COPY_ON_WRITE
2300 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2302 PerlIO_printf(Perl_debug_log,
2303 "Copy on write: regexp capture, type %d\n",
2306 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2307 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2308 assert (SvPOKp(prog->saved_copy));
2312 RX_MATCH_COPIED_on(rx);
2313 s = savepvn(strbeg, i);
2319 prog->subbeg = strbeg;
2320 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2327 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2328 PL_colors[4], PL_colors[5]));
2329 if (PL_reg_eval_set)
2330 restore_pos(aTHX_ prog);
2332 /* we failed :-( roll it back */
2333 Safefree(prog->offs);
2342 - regtry - try match at specific point
2344 STATIC I32 /* 0 failure, 1 success */
2345 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2349 REGEXP *const rx = reginfo->prog;
2350 regexp *const prog = (struct regexp *)SvANY(rx);
2351 RXi_GET_DECL(prog,progi);
2352 GET_RE_DEBUG_FLAGS_DECL;
2354 PERL_ARGS_ASSERT_REGTRY;
2356 reginfo->cutpoint=NULL;
2358 if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2361 PL_reg_eval_set = RS_init;
2362 DEBUG_EXECUTE_r(DEBUG_s(
2363 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2364 (IV)(PL_stack_sp - PL_stack_base));
2367 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2368 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2370 /* Apparently this is not needed, judging by wantarray. */
2371 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2372 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2375 /* Make $_ available to executed code. */
2376 if (reginfo->sv != DEFSV) {
2378 DEFSV_set(reginfo->sv);
2381 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2382 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2383 /* prepare for quick setting of pos */
2384 #ifdef PERL_OLD_COPY_ON_WRITE
2385 if (SvIsCOW(reginfo->sv))
2386 sv_force_normal_flags(reginfo->sv, 0);
2388 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2389 &PL_vtbl_mglob, NULL, 0);
2393 PL_reg_oldpos = mg->mg_len;
2394 SAVEDESTRUCTOR_X(restore_pos, prog);
2396 if (!PL_reg_curpm) {
2397 Newxz(PL_reg_curpm, 1, PMOP);
2400 SV* const repointer = &PL_sv_undef;
2401 /* this regexp is also owned by the new PL_reg_curpm, which
2402 will try to free it. */
2403 av_push(PL_regex_padav, repointer);
2404 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2405 PL_regex_pad = AvARRAY(PL_regex_padav);
2410 /* It seems that non-ithreads works both with and without this code.
2411 So for efficiency reasons it seems best not to have the code
2412 compiled when it is not needed. */
2413 /* This is safe against NULLs: */
2414 ReREFCNT_dec(PM_GETRE(PL_reg_curpm));
2415 /* PM_reg_curpm owns a reference to this regexp. */
2418 PM_SETRE(PL_reg_curpm, rx);
2419 PL_reg_oldcurpm = PL_curpm;
2420 PL_curpm = PL_reg_curpm;
2421 if (RXp_MATCH_COPIED(prog)) {
2422 /* Here is a serious problem: we cannot rewrite subbeg,
2423 since it may be needed if this match fails. Thus
2424 $` inside (?{}) could fail... */
2425 PL_reg_oldsaved = prog->subbeg;
2426 PL_reg_oldsavedlen = prog->sublen;
2427 #ifdef PERL_OLD_COPY_ON_WRITE
2428 PL_nrs = prog->saved_copy;
2430 RXp_MATCH_COPIED_off(prog);
2433 PL_reg_oldsaved = NULL;
2434 prog->subbeg = PL_bostr;
2435 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2437 DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2438 prog->offs[0].start = *startpos - PL_bostr;
2439 PL_reginput = *startpos;
2440 PL_reglastparen = &prog->lastparen;
2441 PL_reglastcloseparen = &prog->lastcloseparen;
2442 prog->lastparen = 0;
2443 prog->lastcloseparen = 0;
2445 PL_regoffs = prog->offs;
2446 if (PL_reg_start_tmpl <= prog->nparens) {
2447 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2448 if(PL_reg_start_tmp)
2449 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2451 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2454 /* XXXX What this code is doing here?!!! There should be no need
2455 to do this again and again, PL_reglastparen should take care of
2458 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2459 * Actually, the code in regcppop() (which Ilya may be meaning by
2460 * PL_reglastparen), is not needed at all by the test suite
2461 * (op/regexp, op/pat, op/split), but that code is needed otherwise
2462 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2463 * Meanwhile, this code *is* needed for the
2464 * above-mentioned test suite tests to succeed. The common theme
2465 * on those tests seems to be returning null fields from matches.
2466 * --jhi updated by dapm */
2468 if (prog->nparens) {
2469 regexp_paren_pair *pp = PL_regoffs;
2471 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2479 if (regmatch(reginfo, progi->program + 1)) {
2480 PL_regoffs[0].end = PL_reginput - PL_bostr;
2483 if (reginfo->cutpoint)
2484 *startpos= reginfo->cutpoint;
2485 REGCP_UNWIND(lastcp);
2490 #define sayYES goto yes
2491 #define sayNO goto no
2492 #define sayNO_SILENT goto no_silent
2494 /* we dont use STMT_START/END here because it leads to
2495 "unreachable code" warnings, which are bogus, but distracting. */
2496 #define CACHEsayNO \
2497 if (ST.cache_mask) \
2498 PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2501 /* this is used to determine how far from the left messages like
2502 'failed...' are printed. It should be set such that messages
2503 are inline with the regop output that created them.
2505 #define REPORT_CODE_OFF 32
2508 /* Make sure there is a test for this +1 options in re_tests */
2509 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2511 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2512 #define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
2514 #define SLAB_FIRST(s) (&(s)->states[0])
2515 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2517 /* grab a new slab and return the first slot in it */
2519 STATIC regmatch_state *
2522 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2525 regmatch_slab *s = PL_regmatch_slab->next;
2527 Newx(s, 1, regmatch_slab);
2528 s->prev = PL_regmatch_slab;
2530 PL_regmatch_slab->next = s;
2532 PL_regmatch_slab = s;
2533 return SLAB_FIRST(s);
2537 /* push a new state then goto it */
2539 #define PUSH_STATE_GOTO(state, node) \
2541 st->resume_state = state; \
2544 /* push a new state with success backtracking, then goto it */
2546 #define PUSH_YES_STATE_GOTO(state, node) \
2548 st->resume_state = state; \
2549 goto push_yes_state;
2555 regmatch() - main matching routine
2557 This is basically one big switch statement in a loop. We execute an op,
2558 set 'next' to point the next op, and continue. If we come to a point which
2559 we may need to backtrack to on failure such as (A|B|C), we push a
2560 backtrack state onto the backtrack stack. On failure, we pop the top
2561 state, and re-enter the loop at the state indicated. If there are no more
2562 states to pop, we return failure.
2564 Sometimes we also need to backtrack on success; for example /A+/, where
2565 after successfully matching one A, we need to go back and try to
2566 match another one; similarly for lookahead assertions: if the assertion
2567 completes successfully, we backtrack to the state just before the assertion
2568 and then carry on. In these cases, the pushed state is marked as
2569 'backtrack on success too'. This marking is in fact done by a chain of
2570 pointers, each pointing to the previous 'yes' state. On success, we pop to
2571 the nearest yes state, discarding any intermediate failure-only states.
2572 Sometimes a yes state is pushed just to force some cleanup code to be
2573 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2574 it to free the inner regex.
2576 Note that failure backtracking rewinds the cursor position, while
2577 success backtracking leaves it alone.
2579 A pattern is complete when the END op is executed, while a subpattern
2580 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2581 ops trigger the "pop to last yes state if any, otherwise return true"
2584 A common convention in this function is to use A and B to refer to the two
2585 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2586 the subpattern to be matched possibly multiple times, while B is the entire
2587 rest of the pattern. Variable and state names reflect this convention.
2589 The states in the main switch are the union of ops and failure/success of
2590 substates associated with with that op. For example, IFMATCH is the op
2591 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2592 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2593 successfully matched A and IFMATCH_A_fail is a state saying that we have
2594 just failed to match A. Resume states always come in pairs. The backtrack
2595 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2596 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2597 on success or failure.
2599 The struct that holds a backtracking state is actually a big union, with
2600 one variant for each major type of op. The variable st points to the
2601 top-most backtrack struct. To make the code clearer, within each
2602 block of code we #define ST to alias the relevant union.
2604 Here's a concrete example of a (vastly oversimplified) IFMATCH
2610 #define ST st->u.ifmatch
2612 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2613 ST.foo = ...; // some state we wish to save
2615 // push a yes backtrack state with a resume value of
2616 // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2618 PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2621 case IFMATCH_A: // we have successfully executed A; now continue with B
2623 bar = ST.foo; // do something with the preserved value
2626 case IFMATCH_A_fail: // A failed, so the assertion failed
2627 ...; // do some housekeeping, then ...
2628 sayNO; // propagate the failure
2635 For any old-timers reading this who are familiar with the old recursive
2636 approach, the code above is equivalent to:
2638 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2647 ...; // do some housekeeping, then ...
2648 sayNO; // propagate the failure
2651 The topmost backtrack state, pointed to by st, is usually free. If you
2652 want to claim it, populate any ST.foo fields in it with values you wish to
2653 save, then do one of
2655 PUSH_STATE_GOTO(resume_state, node);
2656 PUSH_YES_STATE_GOTO(resume_state, node);
2658 which sets that backtrack state's resume value to 'resume_state', pushes a
2659 new free entry to the top of the backtrack stack, then goes to 'node'.
2660 On backtracking, the free slot is popped, and the saved state becomes the
2661 new free state. An ST.foo field in this new top state can be temporarily
2662 accessed to retrieve values, but once the main loop is re-entered, it
2663 becomes available for reuse.
2665 Note that the depth of the backtrack stack constantly increases during the
2666 left-to-right execution of the pattern, rather than going up and down with
2667 the pattern nesting. For example the stack is at its maximum at Z at the
2668 end of the pattern, rather than at X in the following:
2670 /(((X)+)+)+....(Y)+....Z/
2672 The only exceptions to this are lookahead/behind assertions and the cut,
2673 (?>A), which pop all the backtrack states associated with A before
2676 Bascktrack state structs are allocated in slabs of about 4K in size.
2677 PL_regmatch_state and st always point to the currently active state,
2678 and PL_regmatch_slab points to the slab currently containing
2679 PL_regmatch_state. The first time regmatch() is called, the first slab is
2680 allocated, and is never freed until interpreter destruction. When the slab
2681 is full, a new one is allocated and chained to the end. At exit from
2682 regmatch(), slabs allocated since entry are freed.
2687 #define DEBUG_STATE_pp(pp) \
2689 DUMP_EXEC_POS(locinput, scan, do_utf8); \
2690 PerlIO_printf(Perl_debug_log, \
2691 " %*s"pp" %s%s%s%s%s\n", \
2693 PL_reg_name[st->resume_state], \
2694 ((st==yes_state||st==mark_state) ? "[" : ""), \
2695 ((st==yes_state) ? "Y" : ""), \
2696 ((st==mark_state) ? "M" : ""), \
2697 ((st==yes_state||st==mark_state) ? "]" : "") \
2702 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2707 S_debug_start_match(pTHX_ const REGEXP *prog, const bool do_utf8,
2708 const char *start, const char *end, const char *blurb)
2710 const bool utf8_pat = RX_UTF8(prog) ? 1 : 0;
2712 PERL_ARGS_ASSERT_DEBUG_START_MATCH;
2717 RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2718 RX_PRECOMP_const(prog), RX_PRELEN(prog), 60);
2720 RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2721 start, end - start, 60);
2723 PerlIO_printf(Perl_debug_log,
2724 "%s%s REx%s %s against %s\n",
2725 PL_colors[4], blurb, PL_colors[5], s0, s1);
2727 if (do_utf8||utf8_pat)
2728 PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2729 utf8_pat ? "pattern" : "",
2730 utf8_pat && do_utf8 ? " and " : "",
2731 do_utf8 ? "string" : ""
2737 S_dump_exec_pos(pTHX_ const char *locinput,
2738 const regnode *scan,
2739 const char *loc_regeol,
2740 const char *loc_bostr,
2741 const char *loc_reg_starttry,
2744 const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2745 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2746 int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2747 /* The part of the string before starttry has one color
2748 (pref0_len chars), between starttry and current
2749 position another one (pref_len - pref0_len chars),
2750 after the current position the third one.
2751 We assume that pref0_len <= pref_len, otherwise we
2752 decrease pref0_len. */
2753 int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2754 ? (5 + taill) - l : locinput - loc_bostr;
2757 PERL_ARGS_ASSERT_DUMP_EXEC_POS;
2759 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2761 pref0_len = pref_len - (locinput - loc_reg_starttry);
2762 if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2763 l = ( loc_regeol - locinput > (5 + taill) - pref_len
2764 ? (5 + taill) - pref_len : loc_regeol - locinput);
2765 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2769 if (pref0_len > pref_len)
2770 pref0_len = pref_len;
2772 const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2774 RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2775 (locinput - pref_len),pref0_len, 60, 4, 5);
2777 RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2778 (locinput - pref_len + pref0_len),
2779 pref_len - pref0_len, 60, 2, 3);
2781 RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2782 locinput, loc_regeol - locinput, 10, 0, 1);
2784 const STRLEN tlen=len0+len1+len2;
2785 PerlIO_printf(Perl_debug_log,
2786 "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2787 (IV)(locinput - loc_bostr),
2790 (docolor ? "" : "> <"),
2792 (int)(tlen > 19 ? 0 : 19 - tlen),
2799 /* reg_check_named_buff_matched()
2800 * Checks to see if a named buffer has matched. The data array of
2801 * buffer numbers corresponding to the buffer is expected to reside
2802 * in the regexp->data->data array in the slot stored in the ARG() of
2803 * node involved. Note that this routine doesn't actually care about the
2804 * name, that information is not preserved from compilation to execution.
2805 * Returns the index of the leftmost defined buffer with the given name
2806 * or 0 if non of the buffers matched.
2809 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan)
2812 RXi_GET_DECL(rex,rexi);
2813 SV *sv_dat= MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
2814 I32 *nums=(I32*)SvPVX(sv_dat);
2816 PERL_ARGS_ASSERT_REG_CHECK_NAMED_BUFF_MATCHED;
2818 for ( n=0; n<SvIVX(sv_dat); n++ ) {
2819 if ((I32)*PL_reglastparen >= nums[n] &&
2820 PL_regoffs[nums[n]].end != -1)
2829 /* free all slabs above current one - called during LEAVE_SCOPE */
2832 S_clear_backtrack_stack(pTHX_ void *p)
2834 regmatch_slab *s = PL_regmatch_slab->next;
2839 PL_regmatch_slab->next = NULL;
2841 regmatch_slab * const osl = s;
2848 #define SETREX(Re1,Re2) \
2849 if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2852 STATIC I32 /* 0 failure, 1 success */
2853 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2855 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2859 register const bool do_utf8 = PL_reg_match_utf8;
2860 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2861 REGEXP *rex_sv = reginfo->prog;
2862 regexp *rex = (struct regexp *)SvANY(rex_sv);
2863 RXi_GET_DECL(rex,rexi);
2865 /* the current state. This is a cached copy of PL_regmatch_state */
2866 register regmatch_state *st;
2867 /* cache heavy used fields of st in registers */
2868 register regnode *scan;
2869 register regnode *next;
2870 register U32 n = 0; /* general value; init to avoid compiler warning */
2871 register I32 ln = 0; /* len or last; init to avoid compiler warning */
2872 register char *locinput = PL_reginput;
2873 register I32 nextchr; /* is always set to UCHARAT(locinput) */
2875 bool result = 0; /* return value of S_regmatch */
2876 int depth = 0; /* depth of backtrack stack */
2877 U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
2878 const U32 max_nochange_depth =
2879 (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
2880 3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
2881 regmatch_state *yes_state = NULL; /* state to pop to on success of
2883 /* mark_state piggy backs on the yes_state logic so that when we unwind
2884 the stack on success we can update the mark_state as we go */
2885 regmatch_state *mark_state = NULL; /* last mark state we have seen */
2886 regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2887 struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
2889 bool no_final = 0; /* prevent failure from backtracking? */
2890 bool do_cutgroup = 0; /* no_final only until next branch/trie entry */
2891 char *startpoint = PL_reginput;
2892 SV *popmark = NULL; /* are we looking for a mark? */
2893 SV *sv_commit = NULL; /* last mark name seen in failure */
2894 SV *sv_yes_mark = NULL; /* last mark name we have seen
2895 during a successfull match */
2896 U32 lastopen = 0; /* last open we saw */
2897 bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2898 SV* const oreplsv = GvSV(PL_replgv);
2899 /* these three flags are set by various ops to signal information to
2900 * the very next op. They have a useful lifetime of exactly one loop
2901 * iteration, and are not preserved or restored by state pushes/pops
2903 bool sw = 0; /* the condition value in (?(cond)a|b) */
2904 bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
2905 int logical = 0; /* the following EVAL is:
2909 or the following IFMATCH/UNLESSM is:
2910 false: plain (?=foo)
2911 true: used as a condition: (?(?=foo))
2914 GET_RE_DEBUG_FLAGS_DECL;
2917 PERL_ARGS_ASSERT_REGMATCH;
2919 DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
2920 PerlIO_printf(Perl_debug_log,"regmatch start\n");
2922 /* on first ever call to regmatch, allocate first slab */
2923 if (!PL_regmatch_slab) {
2924 Newx(PL_regmatch_slab, 1, regmatch_slab);
2925 PL_regmatch_slab->prev = NULL;
2926 PL_regmatch_slab->next = NULL;
2927 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2930 oldsave = PL_savestack_ix;
2931 SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
2932 SAVEVPTR(PL_regmatch_slab);
2933 SAVEVPTR(PL_regmatch_state);
2935 /* grab next free state slot */
2936 st = ++PL_regmatch_state;
2937 if (st > SLAB_LAST(PL_regmatch_slab))
2938 st = PL_regmatch_state = S_push_slab(aTHX);
2940 /* Note that nextchr is a byte even in UTF */
2941 nextchr = UCHARAT(locinput);
2943 while (scan != NULL) {
2946 SV * const prop = sv_newmortal();
2947 regnode *rnext=regnext(scan);
2948 DUMP_EXEC_POS( locinput, scan, do_utf8 );
2949 regprop(rex, prop, scan);
2951 PerlIO_printf(Perl_debug_log,
2952 "%3"IVdf":%*s%s(%"IVdf")\n",
2953 (IV)(scan - rexi->program), depth*2, "",
2955 (PL_regkind[OP(scan)] == END || !rnext) ?
2956 0 : (IV)(rnext - rexi->program));
2959 next = scan + NEXT_OFF(scan);
2962 state_num = OP(scan);
2966 assert(PL_reglastparen == &rex->lastparen);
2967 assert(PL_reglastcloseparen == &rex->lastcloseparen);
2968 assert(PL_regoffs == rex->offs);
2970 switch (state_num) {
2972 if (locinput == PL_bostr)
2974 /* reginfo->till = reginfo->bol; */
2979 if (locinput == PL_bostr ||
2980 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2986 if (locinput == PL_bostr)
2990 if (locinput == reginfo->ganch)
2995 /* update the startpoint */
2996 st->u.keeper.val = PL_regoffs[0].start;
2997 PL_reginput = locinput;
2998 PL_regoffs[0].start = locinput - PL_bostr;
2999 PUSH_STATE_GOTO(KEEPS_next, next);
3001 case KEEPS_next_fail:
3002 /* rollback the start point change */
3003 PL_regoffs[0].start = st->u.keeper.val;
3009 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3014 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
3016 if (PL_regeol - locinput > 1)
3020 if (PL_regeol != locinput)
3024 if (!nextchr && locinput >= PL_regeol)
3027 locinput += PL_utf8skip[nextchr];
3028 if (locinput > PL_regeol)
3030 nextchr = UCHARAT(locinput);
3033 nextchr = UCHARAT(++locinput);
3036 if (!nextchr && locinput >= PL_regeol)
3038 nextchr = UCHARAT(++locinput);
3041 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
3044 locinput += PL_utf8skip[nextchr];
3045 if (locinput > PL_regeol)
3047 nextchr = UCHARAT(locinput);
3050 nextchr = UCHARAT(++locinput);
3054 #define ST st->u.trie
3056 /* In this case the charclass data is available inline so
3057 we can fail fast without a lot of extra overhead.
3059 if (scan->flags == EXACT || !do_utf8) {
3060 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
3062 PerlIO_printf(Perl_debug_log,
3063 "%*s %sfailed to match trie start class...%s\n",
3064 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3073 /* what type of TRIE am I? (utf8 makes this contextual) */
3074 DECL_TRIE_TYPE(scan);
3076 /* what trie are we using right now */
3077 reg_trie_data * const trie
3078 = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
3079 HV * widecharmap = MUTABLE_HV(rexi->data->data[ ARG( scan ) + 1 ]);
3080 U32 state = trie->startstate;
3082 if (trie->bitmap && trie_type != trie_utf8_fold &&
3083 !TRIE_BITMAP_TEST(trie,*locinput)
3085 if (trie->states[ state ].wordnum) {
3087 PerlIO_printf(Perl_debug_log,
3088 "%*s %smatched empty string...%s\n",
3089 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3094 PerlIO_printf(Perl_debug_log,
3095 "%*s %sfailed to match trie start class...%s\n",
3096 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
3103 U8 *uc = ( U8* )locinput;
3107 U8 *uscan = (U8*)NULL;
3109 SV *sv_accept_buff = NULL;
3110 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
3112 ST.accepted = 0; /* how many accepting states we have seen */
3114 ST.jump = trie->jump;
3117 traverse the TRIE keeping track of all accepting states
3118 we transition through until we get to a failing node.
3121 while ( state && uc <= (U8*)PL_regeol ) {
3122 U32 base = trie->states[ state ].trans.base;
3125 /* We use charid to hold the wordnum as we don't use it
3126 for charid until after we have done the wordnum logic.
3127 We define an alias just so that the wordnum logic reads
3130 #define got_wordnum charid
3131 got_wordnum = trie->states[ state ].wordnum;
3133 if ( got_wordnum ) {
3134 if ( ! ST.accepted ) {
3136 SAVETMPS; /* XXX is this necessary? dmq */
3137 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
3138 sv_accept_buff=newSV(bufflen *
3139 sizeof(reg_trie_accepted) - 1);
3140 SvCUR_set(sv_accept_buff, 0);
3141 SvPOK_on(sv_accept_buff);
3142 sv_2mortal(sv_accept_buff);
3145 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
3148 if (ST.accepted >= bufflen) {
3150 ST.accept_buff =(reg_trie_accepted*)
3151 SvGROW(sv_accept_buff,
3152 bufflen * sizeof(reg_trie_accepted));
3154 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
3155 + sizeof(reg_trie_accepted));
3158 ST.accept_buff[ST.accepted].wordnum = got_wordnum;
3159 ST.accept_buff[ST.accepted].endpos = uc;
3161 } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
3165 DEBUG_TRIE_EXECUTE_r({
3166 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
3167 PerlIO_printf( Perl_debug_log,
3168 "%*s %sState: %4"UVxf" Accepted: %4"UVxf" ",
3169 2+depth * 2, "", PL_colors[4],
3170 (UV)state, (UV)ST.accepted );
3174 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3175 uscan, len, uvc, charid, foldlen,
3179 (base + charid > trie->uniquecharcount )
3180 && (base + charid - 1 - trie->uniquecharcount
3182 && trie->trans[base + charid - 1 -
3183 trie->uniquecharcount].check == state)
3185 state = trie->trans[base + charid - 1 -
3186 trie->uniquecharcount ].next;
3197 DEBUG_TRIE_EXECUTE_r(
3198 PerlIO_printf( Perl_debug_log,
3199 "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3200 charid, uvc, (UV)state, PL_colors[5] );
3207 PerlIO_printf( Perl_debug_log,
3208 "%*s %sgot %"IVdf" possible matches%s\n",
3209 REPORT_CODE_OFF + depth * 2, "",
3210 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3213 goto trie_first_try; /* jump into the fail handler */
3215 case TRIE_next_fail: /* we failed - try next alterative */
3217 REGCP_UNWIND(ST.cp);
3218 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3219 PL_regoffs[n].end = -1;
3220 *PL_reglastparen = n;
3229 ST.lastparen = *PL_reglastparen;
3232 if ( ST.accepted == 1 ) {
3233 /* only one choice left - just continue */
3235 AV *const trie_words
3236 = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3237 SV ** const tmp = av_fetch( trie_words,
3238 ST.accept_buff[ 0 ].wordnum-1, 0 );
3239 SV *sv= tmp ? sv_newmortal() : NULL;
3241 PerlIO_printf( Perl_debug_log,
3242 "%*s %sonly one match left: #%d <%s>%s\n",
3243 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3244 ST.accept_buff[ 0 ].wordnum,
3245 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3246 PL_colors[0], PL_colors[1],
3247 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3249 : "not compiled under -Dr",
3252 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3253 /* in this case we free tmps/leave before we call regmatch
3254 as we wont be using accept_buff again. */
3256 locinput = PL_reginput;
3257 nextchr = UCHARAT(locinput);
3258 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
3261 scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3262 if (!has_cutgroup) {
3267 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3270 continue; /* execute rest of RE */
3273 if ( !ST.accepted-- ) {
3275 PerlIO_printf( Perl_debug_log,
3276 "%*s %sTRIE failed...%s\n",
3277 REPORT_CODE_OFF+depth*2, "",
3288 There are at least two accepting states left. Presumably
3289 the number of accepting states is going to be low,
3290 typically two. So we simply scan through to find the one
3291 with lowest wordnum. Once we find it, we swap the last
3292 state into its place and decrement the size. We then try to
3293 match the rest of the pattern at the point where the word
3294 ends. If we succeed, control just continues along the
3295 regex; if we fail we return here to try the next accepting
3302 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3303 DEBUG_TRIE_EXECUTE_r(
3304 PerlIO_printf( Perl_debug_log,
3305 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3306 REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3307 (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3308 ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3311 if (ST.accept_buff[cur].wordnum <
3312 ST.accept_buff[best].wordnum)
3317 AV *const trie_words
3318 = MUTABLE_AV(rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET]);
3319 SV ** const tmp = av_fetch( trie_words,
3320 ST.accept_buff[ best ].wordnum - 1, 0 );
3321 regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
3323 ST.me + ST.jump[ST.accept_buff[best].wordnum];
3324 SV *sv= tmp ? sv_newmortal() : NULL;
3326 PerlIO_printf( Perl_debug_log,
3327 "%*s %strying alternation #%d <%s> at node #%d %s\n",
3328 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3329 ST.accept_buff[best].wordnum,
3330 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3331 PL_colors[0], PL_colors[1],
3332 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3333 ) : "not compiled under -Dr",
3334 REG_NODE_NUM(nextop),
3338 if ( best<ST.accepted ) {
3339 reg_trie_accepted tmp = ST.accept_buff[ best ];
3340 ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3341 ST.accept_buff[ ST.accepted ] = tmp;
3344 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3345 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3348 scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3350 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3355 /* we dont want to throw this away, see bug 57042*/
3356 if (oreplsv != GvSV(PL_replgv))
3357 sv_setsv(oreplsv, GvSV(PL_replgv));
3364 char *s = STRING(scan);
3366 if (do_utf8 != UTF) {
3367 /* The target and the pattern have differing utf8ness. */
3369 const char * const e = s + ln;
3372 /* The target is utf8, the pattern is not utf8. */
3377 if (NATIVE_TO_UNI(*(U8*)s) !=
3378 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3386 /* The target is not utf8, the pattern is utf8. */
3391 if (NATIVE_TO_UNI(*((U8*)l)) !=
3392 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3400 nextchr = UCHARAT(locinput);
3403 /* The target and the pattern have the same utf8ness. */
3404 /* Inline the first character, for speed. */
3405 if (UCHARAT(s) != nextchr)
3407 if (PL_regeol - locinput < ln)
3409 if (ln > 1 && memNE(s, locinput, ln))
3412 nextchr = UCHARAT(locinput);
3416 PL_reg_flags |= RF_tainted;
3419 char * const s = STRING(scan);
3422 if (do_utf8 || UTF) {
3423 /* Either target or the pattern are utf8. */
3424 const char * const l = locinput;
3425 char *e = PL_regeol;
3427 if (ibcmp_utf8(s, 0, ln, cBOOL(UTF),
3428 l, &e, 0, do_utf8)) {
3429 /* One more case for the sharp s:
3430 * pack("U0U*", 0xDF) =~ /ss/i,
3431 * the 0xC3 0x9F are the UTF-8
3432 * byte sequence for the U+00DF. */
3435 toLOWER(s[0]) == 's' &&
3437 toLOWER(s[1]) == 's' &&
3444 nextchr = UCHARAT(locinput);
3448 /* Neither the target and the pattern are utf8. */
3450 /* Inline the first character, for speed. */
3451 if (UCHARAT(s) != nextchr &&
3452 UCHARAT(s) != ((OP(scan) == EXACTF)
3453 ? PL_fold : PL_fold_locale)[nextchr])
3455 if (PL_regeol - locinput < ln)
3457 if (ln > 1 && (OP(scan) == EXACTF
3458 ? ibcmp(s, locinput, ln)
3459 : ibcmp_locale(s, locinput, ln)))
3462 nextchr = UCHARAT(locinput);
3467 PL_reg_flags |= RF_tainted;
3471 /* was last char in word? */
3473 if (locinput == PL_bostr)
3476 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3478 ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3480 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3481 ln = isALNUM_uni(ln);
3482 LOAD_UTF8_CHARCLASS_ALNUM();
3483 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3486 ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3487 n = isALNUM_LC_utf8((U8*)locinput);
3491 ln = (locinput != PL_bostr) ?
3492 UCHARAT(locinput - 1) : '\n';
3493 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3495 n = isALNUM(nextchr);
3498 ln = isALNUM_LC(ln);
3499 n = isALNUM_LC(nextchr);
3502 if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3503 OP(scan) == BOUNDL))
3508 STRLEN inclasslen = PL_regeol - locinput;
3510 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3512 if (locinput >= PL_regeol)
3514 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3515 nextchr = UCHARAT(locinput);
3520 nextchr = UCHARAT(locinput);
3521 if (!REGINCLASS(rex, scan, (U8*)locinput))
3523 if (!nextchr && locinput >= PL_regeol)
3525 nextchr = UCHARAT(++locinput);
3529 /* If we might have the case of the German sharp s
3530 * in a casefolding Unicode character class. */
3532 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3533 locinput += SHARP_S_SKIP;
3534 nextchr = UCHARAT(locinput);
3539 /* Special char classes - The defines start on line 129 or so */
3540 CCC_TRY_AFF( ALNUM, ALNUML, perl_word, "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3541 CCC_TRY_NEG(NALNUM, NALNUML, perl_word, "a", isALNUM_LC_utf8, isALNUM, isALNUM_LC);
3543 CCC_TRY_AFF( SPACE, SPACEL, perl_space, " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3544 CCC_TRY_NEG(NSPACE, NSPACEL, perl_space, " ", isSPACE_LC_utf8, isSPACE, isSPACE_LC);
3546 CCC_TRY_AFF( DIGIT, DIGITL, posix_digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3547 CCC_TRY_NEG(NDIGIT, NDIGITL, posix_digit, "0", isDIGIT_LC_utf8, isDIGIT, isDIGIT_LC);
3549 case CLUMP: /* Match \X: logical Unicode character. This is defined as
3550 a Unicode extended Grapheme Cluster */
3551 /* From http://www.unicode.org/reports/tr29 (5.2 version). An
3552 extended Grapheme Cluster is:
3555 | Prepend* Begin Extend*
3558 Begin is (Hangul-syllable | ! Control)
3559 Extend is (Grapheme_Extend | Spacing_Mark)
3560 Control is [ GCB_Control CR LF ]
3562 The discussion below shows how the code for CLUMP is derived
3563 from this regex. Note that most of these concepts are from
3564 property values of the Grapheme Cluster Boundary (GCB) property.
3565 No code point can have multiple property values for a given
3566 property. Thus a code point in Prepend can't be in Control, but
3567 it must be in !Control. This is why Control above includes
3568 GCB_Control plus CR plus LF. The latter two are used in the GCB
3569 property separately, and so can't be in GCB_Control, even though
3570 they logically are controls. Control is not the same as gc=cc,
3571 but includes format and other characters as well.
3573 The Unicode definition of Hangul-syllable is:
3575 | (L* ( ( V | LV ) V* | LVT ) T*)
3578 Each of these is a value for the GCB property, and hence must be
3579 disjoint, so the order they are tested is immaterial, so the
3580 above can safely be changed to
3583 | (L* ( LVT | ( V | LV ) V*) T*)
3585 The last two terms can be combined like this:
3587 | (( LVT | ( V | LV ) V*) T*))
3589 And refactored into this:
3590 L* (L | LVT T* | V V* T* | LV V* T*)
3592 That means that if we have seen any L's at all we can quit
3593 there, but if the next character is a LVT, a V or and LV we
3596 There is a subtlety with Prepend* which showed up in testing.
3597 Note that the Begin, and only the Begin is required in:
3598 | Prepend* Begin Extend*
3599 Also, Begin contains '! Control'. A Prepend must be a '!
3600 Control', which means it must be a Begin. What it comes down to
3601 is that if we match Prepend* and then find no suitable Begin
3602 afterwards, that if we backtrack the last Prepend, that one will
3603 be a suitable Begin.
3606 if (locinput >= PL_regeol)
3610 /* Match either CR LF or '.', as all the other possibilities
3612 locinput++; /* Match the . or CR */
3614 && locinput < PL_regeol
3615 && UCHARAT(locinput) == '\n') locinput++;
3619 /* Utf8: See if is ( CR LF ); already know that locinput <
3620 * PL_regeol, so locinput+1 is in bounds */
3621 if (nextchr == '\r' && UCHARAT(locinput + 1) == '\n') {
3625 /* In case have to backtrack to beginning, then match '.' */
3626 char *starting = locinput;
3628 /* In case have to backtrack the last prepend */
3629 char *previous_prepend = 0;
3631 LOAD_UTF8_CHARCLASS_GCB();
3633 /* Match (prepend)* */
3634 while (locinput < PL_regeol
3635 && swash_fetch(PL_utf8_X_prepend,
3636 (U8*)locinput, do_utf8))
3638 previous_prepend = locinput;
3639 locinput += UTF8SKIP(locinput);
3642 /* As noted above, if we matched a prepend character, but
3643 * the next thing won't match, back off the last prepend we
3644 * matched, as it is guaranteed to match the begin */
3645 if (previous_prepend
3646 && (locinput >= PL_regeol
3647 || ! swash_fetch(PL_utf8_X_begin,
3648 (U8*)locinput, do_utf8)))
3650 locinput = previous_prepend;
3653 /* Note that here we know PL_regeol > locinput, as we
3654 * tested that upon input to this switch case, and if we
3655 * moved locinput forward, we tested the result just above
3656 * and it either passed, or we backed off so that it will
3658 if (! swash_fetch(PL_utf8_X_begin, (U8*)locinput, do_utf8)) {
3660 /* Here did not match the required 'Begin' in the
3661 * second term. So just match the very first
3662 * character, the '.' of the final term of the regex */
3663 locinput = starting + UTF8SKIP(starting);
3666 /* Here is the beginning of a character that can have
3667 * an extender. It is either a hangul syllable, or a
3669 if (swash_fetch(PL_utf8_X_non_hangul,
3670 (U8*)locinput, do_utf8))
3673 /* Here not a Hangul syllable, must be a
3674 * ('! * Control') */
3675 locinput += UTF8SKIP(locinput);
3678 /* Here is a Hangul syllable. It can be composed
3679 * of several individual characters. One
3680 * possibility is T+ */
3681 if (swash_fetch(PL_utf8_X_T,
3682 (U8*)locinput, do_utf8))
3684 while (locinput < PL_regeol
3685 && swash_fetch(PL_utf8_X_T,
3686 (U8*)locinput, do_utf8))
3688 locinput += UTF8SKIP(locinput);
3692 /* Here, not T+, but is a Hangul. That means
3693 * it is one of the others: L, LV, LVT or V,
3695 * L* (L | LVT T* | V V* T* | LV V* T*) */
3698 while (locinput < PL_regeol
3699 && swash_fetch(PL_utf8_X_L,
3700 (U8*)locinput, do_utf8))
3702 locinput += UTF8SKIP(locinput);
3705 /* Here, have exhausted L*. If the next
3706 * character is not an LV, LVT nor V, it means
3707 * we had to have at least one L, so matches L+
3708 * in the original equation, we have a complete
3709 * hangul syllable. Are done. */
3711 if (locinput < PL_regeol
3712 && swash_fetch(PL_utf8_X_LV_LVT_V,
3713 (U8*)locinput, do_utf8))
3716 /* Otherwise keep going. Must be LV, LVT
3717 * or V. See if LVT */
3718 if (swash_fetch(PL_utf8_X_LVT,
3719 (U8*)locinput, do_utf8))
3721 locinput += UTF8SKIP(locinput);
3724 /* Must be V or LV. Take it, then
3726 locinput += UTF8SKIP(locinput);
3727 while (locinput < PL_regeol
3728 && swash_fetch(PL_utf8_X_V,
3729 (U8*)locinput, do_utf8))
3731 locinput += UTF8SKIP(locinput);
3735 /* And any of LV, LVT, or V can be followed
3737 while (locinput < PL_regeol
3738 && swash_fetch(PL_utf8_X_T,
3742 locinput += UTF8SKIP(locinput);
3748 /* Match any extender */
3749 while (locinput < PL_regeol
3750 && swash_fetch(PL_utf8_X_extend,
3751 (U8*)locinput, do_utf8))
3753 locinput += UTF8SKIP(locinput);
3757 if (locinput > PL_regeol) sayNO;
3759 nextchr = UCHARAT(locinput);
3766 PL_reg_flags |= RF_tainted;
3771 n = reg_check_named_buff_matched(rex,scan);
3774 type = REF + ( type - NREF );
3781 PL_reg_flags |= RF_tainted;
3785 n = ARG(scan); /* which paren pair */
3788 ln = PL_regoffs[n].start;
3789 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3790 if (*PL_reglastparen < n || ln == -1)
3791 sayNO; /* Do not match unless seen CLOSEn. */
3792 if (ln == PL_regoffs[n].end)
3796 if (do_utf8 && type != REF) { /* REF can do byte comparison */
3798 const char *e = PL_bostr + PL_regoffs[n].end;
3800 * Note that we can't do the "other character" lookup trick as
3801 * in the 8-bit case (no pun intended) because in Unicode we
3802 * have to map both upper and title case to lower case.
3806 STRLEN ulen1, ulen2;
3807 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3808 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3812 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3813 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3814 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3821 nextchr = UCHARAT(locinput);
3825 /* Inline the first character, for speed. */
3826 if (UCHARAT(s) != nextchr &&
3828 (UCHARAT(s) != (type == REFF
3829 ? PL_fold : PL_fold_locale)[nextchr])))
3831 ln = PL_regoffs[n].end - ln;
3832 if (locinput + ln > PL_regeol)
3834 if (ln > 1 && (type == REF
3835 ? memNE(s, locinput, ln)
3837 ? ibcmp(s, locinput, ln)
3838 : ibcmp_locale(s, locinput, ln))))
3841 nextchr = UCHARAT(locinput);
3851 #define ST st->u.eval
3856 regexp_internal *rei;
3857 regnode *startpoint;
3860 case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */
3861 if (cur_eval && cur_eval->locinput==locinput) {
3862 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3863 Perl_croak(aTHX_ "Infinite recursion in regex");
3864 if ( ++nochange_depth > max_nochange_depth )
3866 "Pattern subroutine nesting without pos change"
3867 " exceeded limit in regex");
3874 (void)ReREFCNT_inc(rex_sv);
3875 if (OP(scan)==GOSUB) {
3876 startpoint = scan + ARG2L(scan);
3877 ST.close_paren = ARG(scan);
3879 startpoint = rei->program+1;
3882 goto eval_recurse_doit;
3884 case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
3885 if (cur_eval && cur_eval->locinput==locinput) {
3886 if ( ++nochange_depth > max_nochange_depth )
3887 Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3892 /* execute the code in the {...} */
3894 SV ** const before = SP;
3895 OP_4tree * const oop = PL_op;
3896 COP * const ocurcop = PL_curcop;
3898 char *saved_regeol = PL_regeol;
3901 PL_op = (OP_4tree*)rexi->data->data[n];
3902 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3903 " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3904 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3905 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3908 SV *sv_mrk = get_sv("REGMARK", 1);
3909 sv_setsv(sv_mrk, sv_yes_mark);
3912 CALLRUNOPS(aTHX); /* Scalar context. */
3915 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
3922 PAD_RESTORE_LOCAL(old_comppad);
3923 PL_curcop = ocurcop;
3924 PL_regeol = saved_regeol;
3927 sv_setsv(save_scalar(PL_replgv), ret);
3931 if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3934 /* extract RE object from returned value; compiling if
3940 SV *const sv = SvRV(ret);
3942 if (SvTYPE(sv) == SVt_REGEXP) {
3944 } else if (SvSMAGICAL(sv)) {
3945 mg = mg_find(sv, PERL_MAGIC_qr);
3948 } else if (SvTYPE(ret) == SVt_REGEXP) {
3950 } else if (SvSMAGICAL(ret)) {
3951 if (SvGMAGICAL(ret)) {
3952 /* I don't believe that there is ever qr magic
3954 assert(!mg_find(ret, PERL_MAGIC_qr));
3955 sv_unmagic(ret, PERL_MAGIC_qr);
3958 mg = mg_find(ret, PERL_MAGIC_qr);
3959 /* testing suggests mg only ends up non-NULL for
3960 scalars who were upgraded and compiled in the
3961 else block below. In turn, this is only
3962 triggered in the "postponed utf8 string" tests
3968 rx = (REGEXP *) mg->mg_obj; /*XXX:dmq*/
3972 rx = reg_temp_copy(NULL, rx);
3976 const I32 osize = PL_regsize;
3979 assert (SvUTF8(ret));
3980 } else if (SvUTF8(ret)) {
3981 /* Not doing UTF-8, despite what the SV says. Is
3982 this only if we're trapped in use 'bytes'? */
3983 /* Make a copy of the octet sequence, but without
3984 the flag on, as the compiler now honours the
3985 SvUTF8 flag on ret. */
3987 const char *const p = SvPV(ret, len);
3988 ret = newSVpvn_flags(p, len, SVs_TEMP);
3990 rx = CALLREGCOMP(ret, pm_flags);
3992 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3994 /* This isn't a first class regexp. Instead, it's
3995 caching a regexp onto an existing, Perl visible
3997 sv_magic(ret, MUTABLE_SV(rx), PERL_MAGIC_qr, 0, 0);
4002 re = (struct regexp *)SvANY(rx);
4004 RXp_MATCH_COPIED_off(re);
4005 re->subbeg = rex->subbeg;
4006 re->sublen = rex->sublen;
4009 debug_start_match(re_sv, do_utf8, locinput, PL_regeol,
4010 "Matching embedded");
4012 startpoint = rei->program + 1;
4013 ST.close_paren = 0; /* only used for GOSUB */
4014 /* borrowed from regtry */
4015 if (PL_reg_start_tmpl <= re->nparens) {
4016 PL_reg_start_tmpl = re->nparens*3/2 + 3;
4017 if(PL_reg_start_tmp)
4018 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4020 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
4023 eval_recurse_doit: /* Share code with GOSUB below this line */
4024 /* run the pattern returned from (??{...}) */
4025 ST.cp = regcppush(0); /* Save *all* the positions. */
4026 REGCP_SET(ST.lastcp);
4028 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
4030 /* see regtry, specifically PL_reglast(?:close)?paren is a pointer! (i dont know why) :dmq */
4031 PL_reglastparen = &re->lastparen;
4032 PL_reglastcloseparen = &re->lastcloseparen;
4034 re->lastcloseparen = 0;
4036 PL_reginput = locinput;
4039 /* XXXX This is too dramatic a measure... */
4042 ST.toggle_reg_flags = PL_reg_flags;
4044 PL_reg_flags |= RF_utf8;
4046 PL_reg_flags &= ~RF_utf8;
4047 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
4049 ST.prev_rex = rex_sv;
4050 ST.prev_curlyx = cur_curlyx;
4051 SETREX(rex_sv,re_sv);
4056 ST.prev_eval = cur_eval;
4058 /* now continue from first node in postoned RE */
4059 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
4062 /* logical is 1, /(?(?{...})X|Y)/ */
4063 sw = cBOOL(SvTRUE(ret));
4068 case EVAL_AB: /* cleanup after a successful (??{A})B */
4069 /* note: this is called twice; first after popping B, then A */
4070 PL_reg_flags ^= ST.toggle_reg_flags;
4071 ReREFCNT_dec(rex_sv);
4072 SETREX(rex_sv,ST.prev_rex);
4073 rex = (struct regexp *)SvANY(rex_sv);
4074 rexi = RXi_GET(rex);
4076 cur_eval = ST.prev_eval;
4077 cur_curlyx = ST.prev_curlyx;
4079 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4080 PL_reglastparen = &rex->lastparen;
4081 PL_reglastcloseparen = &rex->lastcloseparen;
4082 /* also update PL_regoffs */
4083 PL_regoffs = rex->offs;
4085 /* XXXX This is too dramatic a measure... */
4087 if ( nochange_depth )
4092 case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
4093 /* note: this is called twice; first after popping B, then A */
4094 PL_reg_flags ^= ST.toggle_reg_flags;
4095 ReREFCNT_dec(rex_sv);
4096 SETREX(rex_sv,ST.prev_rex);
4097 rex = (struct regexp *)SvANY(rex_sv);
4098 rexi = RXi_GET(rex);
4099 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
4100 PL_reglastparen = &rex->lastparen;
4101 PL_reglastcloseparen = &rex->lastcloseparen;
4103 PL_reginput = locinput;
4104 REGCP_UNWIND(ST.lastcp);
4106 cur_eval = ST.prev_eval;
4107 cur_curlyx = ST.prev_curlyx;
4108 /* XXXX This is too dramatic a measure... */
4110 if ( nochange_depth )
4116 n = ARG(scan); /* which paren pair */
4117 PL_reg_start_tmp[n] = locinput;
4123 n = ARG(scan); /* which paren pair */
4124 PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
4125 PL_regoffs[n].end = locinput - PL_bostr;
4126 /*if (n > PL_regsize)
4128 if (n > *PL_reglastparen)
4129 *PL_reglastparen = n;
4130 *PL_reglastcloseparen = n;
4131 if (cur_eval && cur_eval->u.eval.close_paren == n) {
4139 cursor && OP(cursor)!=END;
4140 cursor=regnext(cursor))
4142 if ( OP(cursor)==CLOSE ){
4144 if ( n <= lastopen ) {
4146 = PL_reg_start_tmp[n] - PL_bostr;
4147 PL_regoffs[n].end = locinput - PL_bostr;
4148 /*if (n > PL_regsize)
4150 if (n > *PL_reglastparen)
4151 *PL_reglastparen = n;
4152 *PL_reglastcloseparen = n;
4153 if ( n == ARG(scan) || (cur_eval &&
4154 cur_eval->u.eval.close_paren == n))
4163 n = ARG(scan); /* which paren pair */
4164 sw = cBOOL(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
4167 /* reg_check_named_buff_matched returns 0 for no match */
4168 sw = cBOOL(0 < reg_check_named_buff_matched(rex,scan));
4172 sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
4178 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
4180 next = NEXTOPER(NEXTOPER(scan));
4182 next = scan + ARG(scan);
4183 if (OP(next) == IFTHEN) /* Fake one. */
4184 next = NEXTOPER(NEXTOPER(next));
4188 logical = scan->flags;
4191 /*******************************************************************
4193 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
4194 pattern, where A and B are subpatterns. (For simple A, CURLYM or
4195 STAR/PLUS/CURLY/CURLYN are used instead.)
4197 A*B is compiled as <CURLYX><A><WHILEM><B>
4199 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
4200 state, which contains the current count, initialised to -1. It also sets
4201 cur_curlyx to point to this state, with any previous value saved in the
4204 CURLYX then jumps straight to the WHILEM op, rather than executing A,
4205 since the pattern may possibly match zero times (i.e. it's a while {} loop
4206 rather than a do {} while loop).
4208 Each entry to WHILEM represents a successful match of A. The count in the
4209 CURLYX block is incremented, another WHILEM state is pushed, and execution
4210 passes to A or B depending on greediness and the current count.
4212 For example, if matching against the string a1a2a3b (where the aN are
4213 substrings that match /A/), then the match progresses as follows: (the
4214 pushed states are interspersed with the bits of strings matched so far):
4217 <CURLYX cnt=0><WHILEM>
4218 <CURLYX cnt=1><WHILEM> a1 <WHILEM>
4219 <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
4220 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
4221 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
4223 (Contrast this with something like CURLYM, which maintains only a single
4227 a1 <CURLYM cnt=1> a2
4228 a1 a2 <CURLYM cnt=2> a3
4229 a1 a2 a3 <CURLYM cnt=3> b
4232 Each WHILEM state block marks a point to backtrack to upon partial failure
4233 of A or B, and also contains some minor state data related to that
4234 iteration. The CURLYX block, pointed to by cur_curlyx, contains the
4235 overall state, such as the count, and pointers to the A and B ops.
4237 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
4238 must always point to the *current* CURLYX block, the rules are:
4240 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
4241 and set cur_curlyx to point the new block.
4243 When popping the CURLYX block after a successful or unsuccessful match,
4244 restore the previous cur_curlyx.
4246 When WHILEM is about to execute B, save the current cur_curlyx, and set it
4247 to the outer one saved in the CURLYX block.
4249 When popping the WHILEM block after a successful or unsuccessful B match,
4250 restore the previous cur_curlyx.
4252 Here's an example for the pattern (AI* BI)*BO
4253 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
4256 curlyx backtrack stack
4257 ------ ---------------
4259 CO <CO prev=NULL> <WO>
4260 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4261 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4262 NULL <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
4264 At this point the pattern succeeds, and we work back down the stack to
4265 clean up, restoring as we go:
4267 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
4268 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
4269 CO <CO prev=NULL> <WO>
4272 *******************************************************************/
4274 #define ST st->u.curlyx
4276 case CURLYX: /* start of /A*B/ (for complex A) */
4278 /* No need to save/restore up to this paren */
4279 I32 parenfloor = scan->flags;
4281 assert(next); /* keep Coverity happy */
4282 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4285 /* XXXX Probably it is better to teach regpush to support
4286 parenfloor > PL_regsize... */
4287 if (parenfloor > (I32)*PL_reglastparen)
4288 parenfloor = *PL_reglastparen; /* Pessimization... */
4290 ST.prev_curlyx= cur_curlyx;
4292 ST.cp = PL_savestack_ix;
4294 /* these fields contain the state of the current curly.
4295 * they are accessed by subsequent WHILEMs */
4296 ST.parenfloor = parenfloor;
4297 ST.min = ARG1(scan);
4298 ST.max = ARG2(scan);
4299 ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4303 ST.count = -1; /* this will be updated by WHILEM */
4304 ST.lastloc = NULL; /* this will be updated by WHILEM */
4306 PL_reginput = locinput;
4307 PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4311 case CURLYX_end: /* just finished matching all of A*B */
4312 cur_curlyx = ST.prev_curlyx;
4316 case CURLYX_end_fail: /* just failed to match all of A*B */
4318 cur_curlyx = ST.prev_curlyx;
4324 #define ST st->u.whilem
4326 case WHILEM: /* just matched an A in /A*B/ (for complex A) */
4328 /* see the discussion above about CURLYX/WHILEM */
4330 assert(cur_curlyx); /* keep Coverity happy */
4331 n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4332 ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4333 ST.cache_offset = 0;
4336 PL_reginput = locinput;
4338 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4339 "%*s whilem: matched %ld out of %ld..%ld\n",
4340 REPORT_CODE_OFF+depth*2, "", (long)n,
4341 (long)cur_curlyx->u.curlyx.min,
4342 (long)cur_curlyx->u.curlyx.max)
4345 /* First just match a string of min A's. */
4347 if (n < cur_curlyx->u.curlyx.min) {
4348 cur_curlyx->u.curlyx.lastloc = locinput;
4349 PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
4353 /* If degenerate A matches "", assume A done. */
4355 if (locinput == cur_curlyx->u.curlyx.lastloc) {
4356 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4357 "%*s whilem: empty match detected, trying continuation...\n",
4358 REPORT_CODE_OFF+depth*2, "")
4360 goto do_whilem_B_max;
4363 /* super-linear cache processing */
4367 if (!PL_reg_maxiter) {
4368 /* start the countdown: Postpone detection until we
4369 * know the match is not *that* much linear. */
4370 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4371 /* possible overflow for long strings and many CURLYX's */
4372 if (PL_reg_maxiter < 0)
4373 PL_reg_maxiter = I32_MAX;
4374 PL_reg_leftiter = PL_reg_maxiter;
4377 if (PL_reg_leftiter-- == 0) {
4378 /* initialise cache */
4379 const I32 size = (PL_reg_maxiter + 7)/8;
4380 if (PL_reg_poscache) {
4381 if ((I32)PL_reg_poscache_size < size) {
4382 Renew(PL_reg_poscache, size, char);
4383 PL_reg_poscache_size = size;
4385 Zero(PL_reg_poscache, size, char);
4388 PL_reg_poscache_size = size;
4389 Newxz(PL_reg_poscache, size, char);
4391 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4392 "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4393 PL_colors[4], PL_colors[5])
4397 if (PL_reg_leftiter < 0) {
4398 /* have we already failed at this position? */
4400 offset = (scan->flags & 0xf) - 1
4401 + (locinput - PL_bostr) * (scan->flags>>4);
4402 mask = 1 << (offset % 8);
4404 if (PL_reg_poscache[offset] & mask) {
4405 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4406 "%*s whilem: (cache) already tried at this position...\n",
4407 REPORT_CODE_OFF+depth*2, "")
4409 sayNO; /* cache records failure */
4411 ST.cache_offset = offset;
4412 ST.cache_mask = mask;
4416 /* Prefer B over A for minimal matching. */
4418 if (cur_curlyx->u.curlyx.minmod) {
4419 ST.save_curlyx = cur_curlyx;
4420 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4421 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4422 REGCP_SET(ST.lastcp);
4423 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4427 /* Prefer A over B for maximal matching. */
4429 if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
4430 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4431 cur_curlyx->u.curlyx.lastloc = locinput;
4432 REGCP_SET(ST.lastcp);
4433 PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
4436 goto do_whilem_B_max;
4440 case WHILEM_B_min: /* just matched B in a minimal match */
4441 case WHILEM_B_max: /* just matched B in a maximal match */
4442 cur_curlyx = ST.save_curlyx;
4446 case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4447 cur_curlyx = ST.save_curlyx;
4448 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4449 cur_curlyx->u.curlyx.count--;
4453 case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4454 REGCP_UNWIND(ST.lastcp);
4457 case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4458 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4459 cur_curlyx->u.curlyx.count--;
4463 case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4464 REGCP_UNWIND(ST.lastcp);
4465 regcppop(rex); /* Restore some previous $<digit>s? */
4466 PL_reginput = locinput;
4467 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4468 "%*s whilem: failed, trying continuation...\n",
4469 REPORT_CODE_OFF+depth*2, "")
4472 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4473 && ckWARN(WARN_REGEXP)
4474 && !(PL_reg_flags & RF_warned))
4476 PL_reg_flags |= RF_warned;
4477 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4478 "Complex regular subexpression recursion",
4483 ST.save_curlyx = cur_curlyx;
4484 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4485 PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4488 case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4489 cur_curlyx = ST.save_curlyx;
4490 REGCP_UNWIND(ST.lastcp);
4493 if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
4494 /* Maximum greed exceeded */
4495 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4496 && ckWARN(WARN_REGEXP)
4497 && !(PL_reg_flags & RF_warned))
4499 PL_reg_flags |= RF_warned;
4500 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4501 "%s limit (%d) exceeded",
4502 "Complex regular subexpression recursion",
4505 cur_curlyx->u.curlyx.count--;
4509 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4510 "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4512 /* Try grabbing another A and see if it helps. */
4513 PL_reginput = locinput;
4514 cur_curlyx->u.curlyx.lastloc = locinput;
4515 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4516 REGCP_SET(ST.lastcp);
4517 PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
4521 #define ST st->u.branch
4523 case BRANCHJ: /* /(...|A|...)/ with long next pointer */
4524 next = scan + ARG(scan);
4527 scan = NEXTOPER(scan);
4530 case BRANCH: /* /(...|A|...)/ */
4531 scan = NEXTOPER(scan); /* scan now points to inner node */
4532 ST.lastparen = *PL_reglastparen;
4533 ST.next_branch = next;
4535 PL_reginput = locinput;
4537 /* Now go into the branch */
4539 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4541 PUSH_STATE_GOTO(BRANCH_next, scan);
4545 PL_reginput = locinput;
4546 sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4547 MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
4548 PUSH_STATE_GOTO(CUTGROUP_next,next);
4550 case CUTGROUP_next_fail:
4553 if (st->u.mark.mark_name)
4554 sv_commit = st->u.mark.mark_name;
4560 case BRANCH_next_fail: /* that branch failed; try the next, if any */
4565 REGCP_UNWIND(ST.cp);
4566 for (n = *PL_reglastparen; n > ST.lastparen; n--)
4567 PL_regoffs[n].end = -1;
4568 *PL_reglastparen = n;
4569 /*dmq: *PL_reglastcloseparen = n; */
4570 scan = ST.next_branch;
4571 /* no more branches? */
4572 if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4574 PerlIO_printf( Perl_debug_log,
4575 "%*s %sBRANCH failed...%s\n",
4576 REPORT_CODE_OFF+depth*2, "",
4582 continue; /* execute next BRANCH[J] op */
4590 #define ST st->u.curlym
4592 case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4594 /* This is an optimisation of CURLYX that enables us to push
4595 * only a single backtracking state, no matter how many matches
4596 * there are in {m,n}. It relies on the pattern being constant
4597 * length, with no parens to influence future backrefs
4601 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4603 /* if paren positive, emulate an OPEN/CLOSE around A */
4605 U32 paren = ST.me->flags;
4606 if (paren > PL_regsize)
4608 if (paren > *PL_reglastparen)
4609 *PL_reglastparen = paren;
4610 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4618 ST.c1 = CHRTEST_UNINIT;
4621 if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4624 curlym_do_A: /* execute the A in /A{m,n}B/ */
4625 PL_reginput = locinput;
4626 PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4629 case CURLYM_A: /* we've just matched an A */
4630 locinput = st->locinput;
4631 nextchr = UCHARAT(locinput);
4634 /* after first match, determine A's length: u.curlym.alen */
4635 if (ST.count == 1) {
4636 if (PL_reg_match_utf8) {
4638 while (s < PL_reginput) {
4644 ST.alen = PL_reginput - locinput;
4647 ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4650 PerlIO_printf(Perl_debug_log,
4651 "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4652 (int)(REPORT_CODE_OFF+(depth*2)), "",
4653 (IV) ST.count, (IV)ST.alen)
4656 locinput = PL_reginput;
4658 if (cur_eval && cur_eval->u.eval.close_paren &&
4659 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4663 I32 max = (ST.minmod ? ARG1(ST.me) : ARG2(ST.me));
4664 if ( max == REG_INFTY || ST.count < max )
4665 goto curlym_do_A; /* try to match another A */
4667 goto curlym_do_B; /* try to match B */
4669 case CURLYM_A_fail: /* just failed to match an A */
4670 REGCP_UNWIND(ST.cp);
4672 if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4673 || (cur_eval && cur_eval->u.eval.close_paren &&
4674 cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4677 curlym_do_B: /* execute the B in /A{m,n}B/ */
4678 PL_reginput = locinput;
4679 if (ST.c1 == CHRTEST_UNINIT) {
4680 /* calculate c1 and c2 for possible match of 1st char
4681 * following curly */
4682 ST.c1 = ST.c2 = CHRTEST_VOID;
4683 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4684 regnode *text_node = ST.B;
4685 if (! HAS_TEXT(text_node))
4686 FIND_NEXT_IMPT(text_node);
4689 (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4691 But the former is redundant in light of the latter.
4693 if this changes back then the macro for
4694 IS_TEXT and friends need to change.
4696 if (PL_regkind[OP(text_node)] == EXACT)
4699 ST.c1 = (U8)*STRING(text_node);
4701 (IS_TEXTF(text_node))
4703 : (IS_TEXTFL(text_node))
4704 ? PL_fold_locale[ST.c1]
4711 PerlIO_printf(Perl_debug_log,
4712 "%*s CURLYM trying tail with matches=%"IVdf"...\n",
4713 (int)(REPORT_CODE_OFF+(depth*2)),
4716 if (ST.c1 != CHRTEST_VOID
4717 && UCHARAT(PL_reginput) != ST.c1
4718 && UCHARAT(PL_reginput) != ST.c2)
4720 /* simulate B failing */
4722 PerlIO_printf(Perl_debug_log,
4723 "%*s CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
4724 (int)(REPORT_CODE_OFF+(depth*2)),"",
4727 state_num = CURLYM_B_fail;
4728 goto reenter_switch;
4732 /* mark current A as captured */
4733 I32 paren = ST.me->flags;
4735 PL_regoffs[paren].start
4736 = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4737 PL_regoffs[paren].end = PL_reginput - PL_bostr;
4738 /*dmq: *PL_reglastcloseparen = paren; */
4741 PL_regoffs[paren].end = -1;
4742 if (cur_eval && cur_eval->u.eval.close_paren &&
4743 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4752 PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4755 case CURLYM_B_fail: /* just failed to match a B */
4756 REGCP_UNWIND(ST.cp);
4758 I32 max = ARG2(ST.me);
4759 if (max != REG_INFTY && ST.count == max)
4761 goto curlym_do_A; /* try to match a further A */
4763 /* backtrack one A */
4764 if (ST.count == ARG1(ST.me) /* min */)
4767 locinput = HOPc(locinput, -ST.alen);
4768 goto curlym_do_B; /* try to match B */
4771 #define ST st->u.curly
4773 #define CURLY_SETPAREN(paren, success) \
4776 PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
4777 PL_regoffs[paren].end = locinput - PL_bostr; \
4778 *PL_reglastcloseparen = paren; \
4781 PL_regoffs[paren].end = -1; \
4784 case STAR: /* /A*B/ where A is width 1 */
4788 scan = NEXTOPER(scan);
4790 case PLUS: /* /A+B/ where A is width 1 */
4794 scan = NEXTOPER(scan);
4796 case CURLYN: /* /(A){m,n}B/ where A is width 1 */
4797 ST.paren = scan->flags; /* Which paren to set */
4798 if (ST.paren > PL_regsize)
4799 PL_regsize = ST.paren;
4800 if (ST.paren > *PL_reglastparen)
4801 *PL_reglastparen = ST.paren;
4802 ST.min = ARG1(scan); /* min to match */
4803 ST.max = ARG2(scan); /* max to match */
4804 if (cur_eval && cur_eval->u.eval.close_paren &&
4805 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4809 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4811 case CURLY: /* /A{m,n}B/ where A is width 1 */
4813 ST.min = ARG1(scan); /* min to match */
4814 ST.max = ARG2(scan); /* max to match */
4815 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4818 * Lookahead to avoid useless match attempts
4819 * when we know what character comes next.
4821 * Used to only do .*x and .*?x, but now it allows
4822 * for )'s, ('s and (?{ ... })'s to be in the way
4823 * of the quantifier and the EXACT-like node. -- japhy
4826 if (ST.min > ST.max) /* XXX make this a compile-time check? */
4828 if (HAS_TEXT(next) || JUMPABLE(next)) {
4830 regnode *text_node = next;
4832 if (! HAS_TEXT(text_node))
4833 FIND_NEXT_IMPT(text_node);
4835 if (! HAS_TEXT(text_node))
4836 ST.c1 = ST.c2 = CHRTEST_VOID;
4838 if ( PL_regkind[OP(text_node)] != EXACT ) {
4839 ST.c1 = ST.c2 = CHRTEST_VOID;
4840 goto assume_ok_easy;
4843 s = (U8*)STRING(text_node);
4845 /* Currently we only get here when
4847 PL_rekind[OP(text_node)] == EXACT
4849 if this changes back then the macro for IS_TEXT and
4850 friends need to change. */
4853 if (IS_TEXTF(text_node))
4854 ST.c2 = PL_fold[ST.c1];
4855 else if (IS_TEXTFL(text_node))
4856 ST.c2 = PL_fold_locale[ST.c1];
4859 if (IS_TEXTF(text_node)) {
4860 STRLEN ulen1, ulen2;
4861 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4862 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4864 to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4865 to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4867 ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4869 0 : UTF8_ALLOW_ANY);
4870 ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4872 0 : UTF8_ALLOW_ANY);
4874 ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4876 ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4881 ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4888 ST.c1 = ST.c2 = CHRTEST_VOID;
4893 PL_reginput = locinput;
4896 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4899 locinput = PL_reginput;
4901 if (ST.c1 == CHRTEST_VOID)
4902 goto curly_try_B_min;
4904 ST.oldloc = locinput;
4906 /* set ST.maxpos to the furthest point along the
4907 * string that could possibly match */
4908 if (ST.max == REG_INFTY) {
4909 ST.maxpos = PL_regeol - 1;
4911 while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4915 int m = ST.max - ST.min;
4916 for (ST.maxpos = locinput;
4917 m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4918 ST.maxpos += UTF8SKIP(ST.maxpos);
4921 ST.maxpos = locinput + ST.max - ST.min;
4922 if (ST.maxpos >= PL_regeol)
4923 ST.maxpos = PL_regeol - 1;
4925 goto curly_try_B_min_known;
4929 ST.count = regrepeat(rex, ST.A, ST.max, depth);
4930 locinput = PL_reginput;
4931 if (ST.count < ST.min)
4933 if ((ST.count > ST.min)
4934 && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4936 /* A{m,n} must come at the end of the string, there's
4937 * no point in backing off ... */
4939 /* ...except that $ and \Z can match before *and* after
4940 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
4941 We may back off by one in this case. */
4942 if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4946 goto curly_try_B_max;
4951 case CURLY_B_min_known_fail:
4952 /* failed to find B in a non-greedy match where c1,c2 valid */
4953 if (ST.paren && ST.count)
4954 PL_regoffs[ST.paren].end = -1;
4956 PL_reginput = locinput; /* Could be reset... */
4957 REGCP_UNWIND(ST.cp);
4958 /* Couldn't or didn't -- move forward. */
4959 ST.oldloc = locinput;
4961 locinput += UTF8SKIP(locinput);
4965 curly_try_B_min_known:
4966 /* find the next place where 'B' could work, then call B */
4970 n = (ST.oldloc == locinput) ? 0 : 1;
4971 if (ST.c1 == ST.c2) {
4973 /* set n to utf8_distance(oldloc, locinput) */
4974 while (locinput <= ST.maxpos &&
4975 utf8n_to_uvchr((U8*)locinput,
4976 UTF8_MAXBYTES, &len,
4977 uniflags) != (UV)ST.c1) {
4983 /* set n to utf8_distance(oldloc, locinput) */
4984 while (locinput <= ST.maxpos) {
4986 const UV c = utf8n_to_uvchr((U8*)locinput,
4987 UTF8_MAXBYTES, &len,
4989 if (c == (UV)ST.c1 || c == (UV)ST.c2)
4997 if (ST.c1 == ST.c2) {
4998 while (locinput <= ST.maxpos &&
4999 UCHARAT(locinput) != ST.c1)
5003 while (locinput <= ST.maxpos
5004 && UCHARAT(locinput) != ST.c1
5005 && UCHARAT(locinput) != ST.c2)
5008 n = locinput - ST.oldloc;
5010 if (locinput > ST.maxpos)
5012 /* PL_reginput == oldloc now */
5015 if (regrepeat(rex, ST.A, n, depth) < n)
5018 PL_reginput = locinput;
5019 CURLY_SETPAREN(ST.paren, ST.count);
5020 if (cur_eval && cur_eval->u.eval.close_paren &&
5021 cur_eval->u.eval.close_paren == (U32)ST.paren) {
5024 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
5029 case CURLY_B_min_fail:
5030 /* failed to find B in a non-greedy match where c1,c2 invalid */
5031 if (ST.paren && ST.count)
5032 PL_regoffs[ST.paren].end = -1;
5034 REGCP_UNWIND(ST.cp);
5035 /* failed -- move forward one */
5036 PL_reginput = locinput;
5037 if (regrepeat(rex, ST.A, 1, depth)) {
5039 locinput = PL_reginput;
5040 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
5041 ST.count > 0)) /* count overflow ? */
5044 CURLY_SETPAREN(ST.paren, ST.count);
5045 if (cur_eval && cur_eval->u.eval.close_paren &&
5046 cur_eval->u.eval.close_paren == (U32)ST.paren) {
5049 PUSH_STATE_GOTO(CURLY_B_min, ST.B);
5057 /* a successful greedy match: now try to match B */
5058 if (cur_eval && cur_eval->u.eval.close_paren &&
5059 cur_eval->u.eval.close_paren == (U32)ST.paren) {
5064 if (ST.c1 != CHRTEST_VOID)
5065 c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
5066 UTF8_MAXBYTES, 0, uniflags)
5067 : (UV) UCHARAT(PL_reginput);
5068 /* If it could work, try it. */
5069 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
5070 CURLY_SETPAREN(ST.paren, ST.count);
5071 PUSH_STATE_GOTO(CURLY_B_max, ST.B);
5076 case CURLY_B_max_fail:
5077 /* failed to find B in a greedy match */
5078 if (ST.paren && ST.count)
5079 PL_regoffs[ST.paren].end = -1;
5081 REGCP_UNWIND(ST.cp);
5083 if (--ST.count < ST.min)
5085 PL_reginput = locinput = HOPc(locinput, -1);
5086 goto curly_try_B_max;
5093 /* we've just finished A in /(??{A})B/; now continue with B */
5095 st->u.eval.toggle_reg_flags
5096 = cur_eval->u.eval.toggle_reg_flags;
5097 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
5099 st->u.eval.prev_rex = rex_sv; /* inner */
5100 SETREX(rex_sv,cur_eval->u.eval.prev_rex);
5101 rex = (struct regexp *)SvANY(rex_sv);
5102 rexi = RXi_GET(rex);
5103 cur_curlyx = cur_eval->u.eval.prev_curlyx;
5104 ReREFCNT_inc(rex_sv);
5105 st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
5107 /* rex was changed so update the pointer in PL_reglastparen and PL_reglastcloseparen */
5108 PL_reglastparen = &rex->lastparen;
5109 PL_reglastcloseparen = &rex->lastcloseparen;
5111 REGCP_SET(st->u.eval.lastcp);
5112 PL_reginput = locinput;
5114 /* Restore parens of the outer rex without popping the
5116 tmpix = PL_savestack_ix;
5117 PL_savestack_ix = cur_eval->u.eval.lastcp;
5119 PL_savestack_ix = tmpix;
5121 st->u.eval.prev_eval = cur_eval;
5122 cur_eval = cur_eval->u.eval.prev_eval;
5124 PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n",
5125 REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
5126 if ( nochange_depth )
5129 PUSH_YES_STATE_GOTO(EVAL_AB,
5130 st->u.eval.prev_eval->u.eval.B); /* match B */
5133 if (locinput < reginfo->till) {
5134 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
5135 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
5137 (long)(locinput - PL_reg_starttry),
5138 (long)(reginfo->till - PL_reg_starttry),
5141 sayNO_SILENT; /* Cannot match: too short. */
5143 PL_reginput = locinput; /* put where regtry can find it */
5144 sayYES; /* Success! */
5146 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
5148 PerlIO_printf(Perl_debug_log,
5149 "%*s %ssubpattern success...%s\n",
5150 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
5151 PL_reginput = locinput; /* put where regtry can find it */
5152 sayYES; /* Success! */
5155 #define ST st->u.ifmatch
5157 case SUSPEND: /* (?>A) */
5159 PL_reginput = locinput;
5162 case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
5164 goto ifmatch_trivial_fail_test;
5166 case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
5168 ifmatch_trivial_fail_test:
5170 char * const s = HOPBACKc(locinput, scan->flags);
5175 sw = 1 - cBOOL(ST.wanted);
5179 next = scan + ARG(scan);
5187 PL_reginput = locinput;
5191 ST.logical = logical;
5192 logical = 0; /* XXX: reset state of logical once it has been saved into ST */
5194 /* execute body of (?...A) */
5195 PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
5198 case IFMATCH_A_fail: /* body of (?...A) failed */
5199 ST.wanted = !ST.wanted;
5202 case IFMATCH_A: /* body of (?...A) succeeded */
5204 sw = cBOOL(ST.wanted);
5206 else if (!ST.wanted)
5209 if (OP(ST.me) == SUSPEND)
5210 locinput = PL_reginput;
5212 locinput = PL_reginput = st->locinput;
5213 nextchr = UCHARAT(locinput);
5215 scan = ST.me + ARG(ST.me);
5218 continue; /* execute B */
5223 next = scan + ARG(scan);
5228 reginfo->cutpoint = PL_regeol;
5231 PL_reginput = locinput;
5233 sv_yes_mark = sv_commit = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5234 PUSH_STATE_GOTO(COMMIT_next,next);
5236 case COMMIT_next_fail:
5243 #define ST st->u.mark
5245 ST.prev_mark = mark_state;
5246 ST.mark_name = sv_commit = sv_yes_mark
5247 = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5249 ST.mark_loc = PL_reginput = locinput;
5250 PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
5252 case MARKPOINT_next:
5253 mark_state = ST.prev_mark;
5256 case MARKPOINT_next_fail:
5257 if (popmark && sv_eq(ST.mark_name,popmark))
5259 if (ST.mark_loc > startpoint)
5260 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5261 popmark = NULL; /* we found our mark */
5262 sv_commit = ST.mark_name;
5265 PerlIO_printf(Perl_debug_log,
5266 "%*s %ssetting cutpoint to mark:%"SVf"...%s\n",
5267 REPORT_CODE_OFF+depth*2, "",
5268 PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
5271 mark_state = ST.prev_mark;
5272 sv_yes_mark = mark_state ?
5273 mark_state->u.mark.mark_name : NULL;
5277 PL_reginput = locinput;
5279 /* (*SKIP) : if we fail we cut here*/
5280 ST.mark_name = NULL;
5281 ST.mark_loc = locinput;
5282 PUSH_STATE_GOTO(SKIP_next,next);
5284 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
5285 otherwise do nothing. Meaning we need to scan
5287 regmatch_state *cur = mark_state;
5288 SV *find = MUTABLE_SV(rexi->data->data[ ARG( scan ) ]);
5291 if ( sv_eq( cur->u.mark.mark_name,
5294 ST.mark_name = find;
5295 PUSH_STATE_GOTO( SKIP_next, next );
5297 cur = cur->u.mark.prev_mark;
5300 /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5302 case SKIP_next_fail:
5304 /* (*CUT:NAME) - Set up to search for the name as we
5305 collapse the stack*/
5306 popmark = ST.mark_name;
5308 /* (*CUT) - No name, we cut here.*/
5309 if (ST.mark_loc > startpoint)
5310 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5311 /* but we set sv_commit to latest mark_name if there
5312 is one so they can test to see how things lead to this
5315 sv_commit=mark_state->u.mark.mark_name;
5323 if ( n == (U32)what_len_TRICKYFOLD(locinput,do_utf8,ln) ) {
5325 } else if ( 0xDF == n && !do_utf8 && !UTF ) {
5328 U8 folded[UTF8_MAXBYTES_CASE+1];
5330 const char * const l = locinput;
5331 char *e = PL_regeol;
5332 to_uni_fold(n, folded, &foldlen);
5334 if (ibcmp_utf8((const char*) folded, 0, foldlen, 1,
5335 l, &e, 0, do_utf8)) {
5340 nextchr = UCHARAT(locinput);
5343 if ((n=is_LNBREAK(locinput,do_utf8))) {
5345 nextchr = UCHARAT(locinput);
5350 #define CASE_CLASS(nAmE) \
5352 if ((n=is_##nAmE(locinput,do_utf8))) { \
5354 nextchr = UCHARAT(locinput); \
5359 if ((n=is_##nAmE(locinput,do_utf8))) { \
5362 locinput += UTF8SKIP(locinput); \
5363 nextchr = UCHARAT(locinput); \
5368 CASE_CLASS(HORIZWS);
5372 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5373 PTR2UV(scan), OP(scan));
5374 Perl_croak(aTHX_ "regexp memory corruption");
5378 /* switch break jumps here */
5379 scan = next; /* prepare to execute the next op and ... */
5380 continue; /* ... jump back to the top, reusing st */
5384 /* push a state that backtracks on success */
5385 st->u.yes.prev_yes_state = yes_state;
5389 /* push a new regex state, then continue at scan */
5391 regmatch_state *newst;
5394 regmatch_state *cur = st;
5395 regmatch_state *curyes = yes_state;
5397 regmatch_slab *slab = PL_regmatch_slab;
5398 for (;curd > -1;cur--,curd--) {
5399 if (cur < SLAB_FIRST(slab)) {
5401 cur = SLAB_LAST(slab);
5403 PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5404 REPORT_CODE_OFF + 2 + depth * 2,"",
5405 curd, PL_reg_name[cur->resume_state],
5406 (curyes == cur) ? "yes" : ""
5409 curyes = cur->u.yes.prev_yes_state;
5412 DEBUG_STATE_pp("push")
5415 st->locinput = locinput;
5417 if (newst > SLAB_LAST(PL_regmatch_slab))
5418 newst = S_push_slab(aTHX);
5419 PL_regmatch_state = newst;
5421 locinput = PL_reginput;
5422 nextchr = UCHARAT(locinput);
5430 * We get here only if there's trouble -- normally "case END" is
5431 * the terminating point.
5433 Perl_croak(aTHX_ "corrupted regexp pointers");
5439 /* we have successfully completed a subexpression, but we must now
5440 * pop to the state marked by yes_state and continue from there */
5441 assert(st != yes_state);
5443 while (st != yes_state) {
5445 if (st < SLAB_FIRST(PL_regmatch_slab)) {
5446 PL_regmatch_slab = PL_regmatch_slab->prev;
5447 st = SLAB_LAST(PL_regmatch_slab);
5451 DEBUG_STATE_pp("pop (no final)");
5453 DEBUG_STATE_pp("pop (yes)");
5459 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5460 || yes_state > SLAB_LAST(PL_regmatch_slab))
5462 /* not in this slab, pop slab */
5463 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5464 PL_regmatch_slab = PL_regmatch_slab->prev;
5465 st = SLAB_LAST(PL_regmatch_slab);
5467 depth -= (st - yes_state);
5470 yes_state = st->u.yes.prev_yes_state;
5471 PL_regmatch_state = st;
5474 locinput= st->locinput;
5475 nextchr = UCHARAT(locinput);
5477 state_num = st->resume_state + no_final;
5478 goto reenter_switch;
5481 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5482 PL_colors[4], PL_colors[5]));
5484 if (PL_reg_eval_set) {
5485 /* each successfully executed (?{...}) block does the equivalent of
5486 * local $^R = do {...}
5487 * When popping the save stack, all these locals would be undone;
5488 * bypass this by setting the outermost saved $^R to the latest
5490 if (oreplsv != GvSV(PL_replgv))
5491 sv_setsv(oreplsv, GvSV(PL_replgv));
5498 PerlIO_printf(Perl_debug_log,
5499 "%*s %sfailed...%s\n",
5500 REPORT_CODE_OFF+depth*2, "",
5501 PL_colors[4], PL_colors[5])
5513 /* there's a previous state to backtrack to */
5515 if (st < SLAB_FIRST(PL_regmatch_slab)) {
5516 PL_regmatch_slab = PL_regmatch_slab->prev;
5517 st = SLAB_LAST(PL_regmatch_slab);
5519 PL_regmatch_state = st;
5520 locinput= st->locinput;
5521 nextchr = UCHARAT(locinput);
5523 DEBUG_STATE_pp("pop");
5525 if (yes_state == st)
5526 yes_state = st->u.yes.prev_yes_state;
5528 state_num = st->resume_state + 1; /* failure = success + 1 */
5529 goto reenter_switch;
5534 if (rex->intflags & PREGf_VERBARG_SEEN) {
5535 SV *sv_err = get_sv("REGERROR", 1);
5536 SV *sv_mrk = get_sv("REGMARK", 1);
5538 sv_commit = &PL_sv_no;
5540 sv_yes_mark = &PL_sv_yes;
5543 sv_commit = &PL_sv_yes;
5544 sv_yes_mark = &PL_sv_no;
5546 sv_setsv(sv_err, sv_commit);
5547 sv_setsv(sv_mrk, sv_yes_mark);
5550 /* clean up; in particular, free all slabs above current one */
5551 LEAVE_SCOPE(oldsave);
5557 - regrepeat - repeatedly match something simple, report how many
5560 * [This routine now assumes that it will only match on things of length 1.
5561 * That was true before, but now we assume scan - reginput is the count,
5562 * rather than incrementing count on every character. [Er, except utf8.]]
5565 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5568 register char *scan;
5570 register char *loceol = PL_regeol;
5571 register I32 hardcount = 0;
5572 register bool do_utf8 = PL_reg_match_utf8;
5574 PERL_UNUSED_ARG(depth);
5577 PERL_ARGS_ASSERT_REGREPEAT;
5580 if (max == REG_INFTY)
5582 else if (max < loceol - scan)
5583 loceol = scan + max;
5588 while (scan < loceol && hardcount < max && *scan != '\n') {
5589 scan += UTF8SKIP(scan);
5593 while (scan < loceol && *scan != '\n')
5600 while (scan < loceol && hardcount < max) {
5601 scan += UTF8SKIP(scan);
5611 case EXACT: /* length of string is 1 */
5613 while (scan < loceol && UCHARAT(scan) == c)
5616 case EXACTF: /* length of string is 1 */
5618 while (scan < loceol &&
5619 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5622 case EXACTFL: /* length of string is 1 */
5623 PL_reg_flags |= RF_tainted;
5625 while (scan < loceol &&
5626 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5632 while (hardcount < max && scan < loceol &&
5633 reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
5634 scan += UTF8SKIP(scan);
5638 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5645 LOAD_UTF8_CHARCLASS_ALNUM();
5646 while (hardcount < max && scan < loceol &&
5647 swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5648 scan += UTF8SKIP(scan);
5652 while (scan < loceol && isALNUM(*scan))
5657 PL_reg_flags |= RF_tainted;
5660 while (hardcount < max && scan < loceol &&
5661 isALNUM_LC_utf8((U8*)scan)) {
5662 scan += UTF8SKIP(scan);
5666 while (scan < loceol && isALNUM_LC(*scan))
5673 LOAD_UTF8_CHARCLASS_ALNUM();
5674 while (hardcount < max && scan < loceol &&
5675 !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5676 scan += UTF8SKIP(scan);
5680 while (scan < loceol && !isALNUM(*scan))
5685 PL_reg_flags |= RF_tainted;
5688 while (hardcount < max && scan < loceol &&
5689 !isALNUM_LC_utf8((U8*)scan)) {
5690 scan += UTF8SKIP(scan);
5694 while (scan < loceol && !isALNUM_LC(*scan))
5701 LOAD_UTF8_CHARCLASS_SPACE();
5702 while (hardcount < max && scan < loceol &&
5704 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5705 scan += UTF8SKIP(scan);
5709 while (scan < loceol && isSPACE(*scan))
5714 PL_reg_flags |= RF_tainted;
5717 while (hardcount < max && scan < loceol &&
5718 (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5719 scan += UTF8SKIP(scan);
5723 while (scan < loceol && isSPACE_LC(*scan))
5730 LOAD_UTF8_CHARCLASS_SPACE();
5731 while (hardcount < max && scan < loceol &&
5733 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5734 scan += UTF8SKIP(scan);
5738 while (scan < loceol && !isSPACE(*scan))
5743 PL_reg_flags |= RF_tainted;
5746 while (hardcount < max && scan < loceol &&
5747 !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5748 scan += UTF8SKIP(scan);
5752 while (scan < loceol && !isSPACE_LC(*scan))
5759 LOAD_UTF8_CHARCLASS_DIGIT();
5760 while (hardcount < max && scan < loceol &&
5761 swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5762 scan += UTF8SKIP(scan);
5766 while (scan < loceol && isDIGIT(*scan))
5773 LOAD_UTF8_CHARCLASS_DIGIT();
5774 while (hardcount < max && scan < loceol &&
5775 !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5776 scan += UTF8SKIP(scan);
5780 while (scan < loceol && !isDIGIT(*scan))
5786 while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
5792 LNBREAK can match two latin chars, which is ok,
5793 because we have a null terminated string, but we
5794 have to use hardcount in this situation
5796 while (scan < loceol && (c=is_LNBREAK_latin1(scan))) {
5805 while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
5810 while (scan < loceol && is_HORIZWS_latin1(scan))
5817 while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
5818 scan += UTF8SKIP(scan);
5822 while (scan < loceol && !is_HORIZWS_latin1(scan))
5830 while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
5835 while (scan < loceol && is_VERTWS_latin1(scan))
5843 while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
5844 scan += UTF8SKIP(scan);
5848 while (scan < loceol && !is_VERTWS_latin1(scan))
5854 default: /* Called on something of 0 width. */
5855 break; /* So match right here or not at all. */
5861 c = scan - PL_reginput;
5865 GET_RE_DEBUG_FLAGS_DECL;
5867 SV * const prop = sv_newmortal();
5868 regprop(prog, prop, p);
5869 PerlIO_printf(Perl_debug_log,
5870 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
5871 REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5879 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5881 - regclass_swash - prepare the utf8 swash
5885 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5891 RXi_GET_DECL(prog,progi);
5892 const struct reg_data * const data = prog ? progi->data : NULL;
5894 PERL_ARGS_ASSERT_REGCLASS_SWASH;
5896 if (data && data->count) {
5897 const U32 n = ARG(node);
5899 if (data->what[n] == 's') {
5900 SV * const rv = MUTABLE_SV(data->data[n]);
5901 AV * const av = MUTABLE_AV(SvRV(rv));
5902 SV **const ary = AvARRAY(av);
5905 /* See the end of regcomp.c:S_regclass() for
5906 * documentation of these array elements. */
5909 a = SvROK(ary[1]) ? &ary[1] : NULL;
5910 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
5914 else if (si && doinit) {
5915 sw = swash_init("utf8", "", si, 1, 0);
5916 (void)av_store(av, 1, sw);
5933 - reginclass - determine if a character falls into a character class
5935 The n is the ANYOF regnode, the p is the target string, lenp
5936 is pointer to the maximum length of how far to go in the p
5937 (if the lenp is zero, UTF8SKIP(p) is used),
5938 do_utf8 tells whether the target string is in UTF-8.
5943 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5946 const char flags = ANYOF_FLAGS(n);
5952 PERL_ARGS_ASSERT_REGINCLASS;
5954 if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5955 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5956 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV)
5957 | UTF8_ALLOW_FFFF | UTF8_CHECK_ONLY);
5958 /* see [perl #37836] for UTF8_ALLOW_ANYUV; [perl #38293] for
5959 * UTF8_ALLOW_FFFF */
5960 if (len == (STRLEN)-1)
5961 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5964 plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5965 if (do_utf8 || (flags & ANYOF_UNICODE)) {
5968 if (do_utf8 && !ANYOF_RUNTIME(n)) {
5969 if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5972 if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5976 SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5984 utf8_p = bytes_to_utf8(p, &len);
5986 if (swash_fetch(sw, utf8_p, 1))
5988 else if (flags & ANYOF_FOLD) {
5989 if (!match && lenp && av) {
5991 for (i = 0; i <= av_len(av); i++) {
5992 SV* const sv = *av_fetch(av, i, FALSE);
5994 const char * const s = SvPV_const(sv, len);
5995 if (len <= plen && memEQ(s, (char*)utf8_p, len)) {
6003 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
6006 to_utf8_fold(utf8_p, tmpbuf, &tmplen);
6007 if (swash_fetch(sw, tmpbuf, 1))
6012 /* If we allocated a string above, free it */
6013 if (! do_utf8) Safefree(utf8_p);
6016 if (match && lenp && *lenp == 0)
6017 *lenp = UNISKIP(NATIVE_TO_UNI(c));
6019 if (!match && c < 256) {
6020 if (ANYOF_BITMAP_TEST(n, c))
6022 else if (flags & ANYOF_FOLD) {
6025 if (flags & ANYOF_LOCALE) {
6026 PL_reg_flags |= RF_tainted;
6027 f = PL_fold_locale[c];
6031 if (f != c && ANYOF_BITMAP_TEST(n, f))
6035 if (!match && (flags & ANYOF_CLASS)) {
6036 PL_reg_flags |= RF_tainted;
6038 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
6039 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
6040 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
6041 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
6042 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
6043 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
6044 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
6045 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
6046 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
6047 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
6048 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
6049 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
6050 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
6051 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
6052 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
6053 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
6054 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
6055 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
6056 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
6057 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
6058 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
6059 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
6060 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
6061 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
6062 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
6063 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
6064 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
6065 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
6066 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
6067 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
6068 ) /* How's that for a conditional? */
6075 return (flags & ANYOF_INVERT) ? !match : match;
6079 S_reghop3(U8 *s, I32 off, const U8* lim)
6083 PERL_ARGS_ASSERT_REGHOP3;
6086 while (off-- && s < lim) {
6087 /* XXX could check well-formedness here */
6092 while (off++ && s > lim) {
6094 if (UTF8_IS_CONTINUED(*s)) {
6095 while (s > lim && UTF8_IS_CONTINUATION(*s))
6098 /* XXX could check well-formedness here */
6105 /* there are a bunch of places where we use two reghop3's that should
6106 be replaced with this routine. but since thats not done yet
6107 we ifdef it out - dmq
6110 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
6114 PERL_ARGS_ASSERT_REGHOP4;
6117 while (off-- && s < rlim) {
6118 /* XXX could check well-formedness here */
6123 while (off++ && s > llim) {
6125 if (UTF8_IS_CONTINUED(*s)) {
6126 while (s > llim && UTF8_IS_CONTINUATION(*s))
6129 /* XXX could check well-formedness here */
6137 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
6141 PERL_ARGS_ASSERT_REGHOPMAYBE3;
6144 while (off-- && s < lim) {
6145 /* XXX could check well-formedness here */
6152 while (off++ && s > lim) {
6154 if (UTF8_IS_CONTINUED(*s)) {
6155 while (s > lim && UTF8_IS_CONTINUATION(*s))
6158 /* XXX could check well-formedness here */
6167 restore_pos(pTHX_ void *arg)
6170 regexp * const rex = (regexp *)arg;
6171 if (PL_reg_eval_set) {
6172 if (PL_reg_oldsaved) {
6173 rex->subbeg = PL_reg_oldsaved;
6174 rex->sublen = PL_reg_oldsavedlen;
6175 #ifdef PERL_OLD_COPY_ON_WRITE
6176 rex->saved_copy = PL_nrs;
6178 RXp_MATCH_COPIED_on(rex);
6180 PL_reg_magic->mg_len = PL_reg_oldpos;
6181 PL_reg_eval_set = 0;
6182 PL_curpm = PL_reg_oldcurpm;
6187 S_to_utf8_substr(pTHX_ register regexp *prog)
6191 PERL_ARGS_ASSERT_TO_UTF8_SUBSTR;
6194 if (prog->substrs->data[i].substr
6195 && !prog->substrs->data[i].utf8_substr) {
6196 SV* const sv = newSVsv(prog->substrs->data[i].substr);
6197 prog->substrs->data[i].utf8_substr = sv;
6198 sv_utf8_upgrade(sv);
6199 if (SvVALID(prog->substrs->data[i].substr)) {
6200 const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
6201 if (flags & FBMcf_TAIL) {
6202 /* Trim the trailing \n that fbm_compile added last
6204 SvCUR_set(sv, SvCUR(sv) - 1);
6205 /* Whilst this makes the SV technically "invalid" (as its
6206 buffer is no longer followed by "\0") when fbm_compile()
6207 adds the "\n" back, a "\0" is restored. */
6209 fbm_compile(sv, flags);
6211 if (prog->substrs->data[i].substr == prog->check_substr)
6212 prog->check_utf8 = sv;
6218 S_to_byte_substr(pTHX_ register regexp *prog)
6223 PERL_ARGS_ASSERT_TO_BYTE_SUBSTR;
6226 if (prog->substrs->data[i].utf8_substr
6227 && !prog->substrs->data[i].substr) {
6228 SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
6229 if (sv_utf8_downgrade(sv, TRUE)) {
6230 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
6232 = BmFLAGS(prog->substrs->data[i].utf8_substr);
6233 if (flags & FBMcf_TAIL) {
6234 /* Trim the trailing \n that fbm_compile added last
6236 SvCUR_set(sv, SvCUR(sv) - 1);
6238 fbm_compile(sv, flags);
6244 prog->substrs->data[i].substr = sv;
6245 if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
6246 prog->check_substr = sv;
6253 * c-indentation-style: bsd
6255 * indent-tabs-mode: t
6258 * ex: set ts=8 sts=4 sw=4 noet: