5 * "One Ring to rule them all, One Ring to find them..."
8 /* This file contains functions for executing a regular expression. See
9 * also regcomp.c which funnily enough, contains functions for compiling
10 * a regular expression.
12 * This file is also copied at build time to ext/re/re_exec.c, where
13 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
14 * This causes the main functions to be compiled under new names and with
15 * debugging support added, which makes "use re 'debug'" work.
18 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
19 * confused with the original package (see point 3 below). Thanks, Henry!
22 /* Additional note: this code is very heavily munged from Henry's version
23 * in places. In some spots I've traded clarity for efficiency, so don't
24 * blame Henry for some of the lack of readability.
27 /* The names of the functions have been changed from regcomp and
28 * regexec to pregcomp and pregexec in order to avoid conflicts
29 * with the POSIX routines of the same names.
32 #ifdef PERL_EXT_RE_BUILD
37 * pregcomp and pregexec -- regsub and regerror are not used in perl
39 * Copyright (c) 1986 by University of Toronto.
40 * Written by Henry Spencer. Not derived from licensed software.
42 * Permission is granted to anyone to use this software for any
43 * purpose on any computer system, and to redistribute it freely,
44 * subject to the following restrictions:
46 * 1. The author is not responsible for the consequences of use of
47 * this software, no matter how awful, even if they arise
50 * 2. The origin of this software must not be misrepresented, either
51 * by explicit claim or by omission.
53 * 3. Altered versions must be plainly marked as such, and must not
54 * be misrepresented as being the original software.
56 **** Alterations to Henry's code are...
58 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
59 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
61 **** You may distribute under the terms of either the GNU General Public
62 **** License or the Artistic License, as specified in the README file.
64 * Beware that some of this code is subtly aware of the way operator
65 * precedence is structured in regular expressions. Serious changes in
66 * regular-expression syntax might require a total rethink.
69 #define PERL_IN_REGEXEC_C
72 #ifdef PERL_IN_XSUB_RE
78 #define RF_tainted 1 /* tainted information used? */
79 #define RF_warned 2 /* warned about big count? */
81 #define RF_utf8 8 /* Pattern contains multibyte chars? */
83 #define UTF ((PL_reg_flags & RF_utf8) != 0)
85 #define RS_init 1 /* eval environment created */
86 #define RS_set 2 /* replsv value is set */
92 #define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
98 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
99 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
101 #define HOPc(pos,off) \
102 (char *)(PL_reg_match_utf8 \
103 ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
105 #define HOPBACKc(pos, off) \
106 (char*)(PL_reg_match_utf8\
107 ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
108 : (pos - off >= PL_bostr) \
112 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
113 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
115 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
116 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
117 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
118 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
119 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
120 #define LOAD_UTF8_CHARCLASS_MARK() LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
122 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
124 /* for use after a quantifier and before an EXACT-like node -- japhy */
125 #define JUMPABLE(rn) ( \
126 OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
127 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
128 OP(rn) == PLUS || OP(rn) == MINMOD || \
129 (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
132 #define HAS_TEXT(rn) ( \
133 PL_regkind[OP(rn)] == EXACT || PL_regkind[OP(rn)] == REF \
137 Search for mandatory following text node; for lookahead, the text must
138 follow but for lookbehind (rn->flags != 0) we skip to the next step.
140 #define FIND_NEXT_IMPT(rn) STMT_START { \
141 while (JUMPABLE(rn)) { \
142 const OPCODE type = OP(rn); \
143 if (type == SUSPEND || PL_regkind[type] == CURLY) \
144 rn = NEXTOPER(NEXTOPER(rn)); \
145 else if (type == PLUS) \
147 else if (type == IFMATCH) \
148 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
149 else rn += NEXT_OFF(rn); \
154 static void restore_pos(pTHX_ void *arg);
157 S_regcppush(pTHX_ I32 parenfloor)
160 const int retval = PL_savestack_ix;
161 #define REGCP_PAREN_ELEMS 4
162 const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
164 GET_RE_DEBUG_FLAGS_DECL;
166 if (paren_elems_to_push < 0)
167 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
169 #define REGCP_OTHER_ELEMS 8
170 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
172 for (p = PL_regsize; p > parenfloor; p--) {
173 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
174 SSPUSHINT(PL_regendp[p]);
175 SSPUSHINT(PL_regstartp[p]);
176 SSPUSHPTR(PL_reg_start_tmp[p]);
178 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
179 " saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
180 (UV)p, (IV)PL_regstartp[p],
181 (IV)(PL_reg_start_tmp[p] - PL_bostr),
185 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
186 SSPUSHPTR(PL_regstartp);
187 SSPUSHPTR(PL_regendp);
188 SSPUSHINT(PL_regsize);
189 SSPUSHINT(*PL_reglastparen);
190 SSPUSHINT(*PL_reglastcloseparen);
191 SSPUSHPTR(PL_reginput);
192 #define REGCP_FRAME_ELEMS 2
193 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
194 * are needed for the regexp context stack bookkeeping. */
195 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
196 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
201 /* These are needed since we do not localize EVAL nodes: */
202 #define REGCP_SET(cp) \
204 PerlIO_printf(Perl_debug_log, \
205 " Setting an EVAL scope, savestack=%"IVdf"\n", \
206 (IV)PL_savestack_ix)); \
209 #define REGCP_UNWIND(cp) \
211 if (cp != PL_savestack_ix) \
212 PerlIO_printf(Perl_debug_log, \
213 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
214 (IV)(cp), (IV)PL_savestack_ix)); \
218 S_regcppop(pTHX_ const regexp *rex)
224 GET_RE_DEBUG_FLAGS_DECL;
226 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
228 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
229 i = SSPOPINT; /* Parentheses elements to pop. */
230 input = (char *) SSPOPPTR;
231 *PL_reglastcloseparen = SSPOPINT;
232 *PL_reglastparen = SSPOPINT;
233 PL_regsize = SSPOPINT;
234 PL_regendp=(I32 *) SSPOPPTR;
235 PL_regstartp=(I32 *) SSPOPPTR;
238 /* Now restore the parentheses context. */
239 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
240 i > 0; i -= REGCP_PAREN_ELEMS) {
242 U32 paren = (U32)SSPOPINT;
243 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
244 PL_regstartp[paren] = SSPOPINT;
246 if (paren <= *PL_reglastparen)
247 PL_regendp[paren] = tmps;
249 PerlIO_printf(Perl_debug_log,
250 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
251 (UV)paren, (IV)PL_regstartp[paren],
252 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
253 (IV)PL_regendp[paren],
254 (paren > *PL_reglastparen ? "(no)" : ""));
258 if (*PL_reglastparen + 1 <= rex->nparens) {
259 PerlIO_printf(Perl_debug_log,
260 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
261 (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
265 /* It would seem that the similar code in regtry()
266 * already takes care of this, and in fact it is in
267 * a better location to since this code can #if 0-ed out
268 * but the code in regtry() is needed or otherwise tests
269 * requiring null fields (pat.t#187 and split.t#{13,14}
270 * (as of patchlevel 7877) will fail. Then again,
271 * this code seems to be necessary or otherwise
272 * building DynaLoader will fail:
273 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
275 for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
277 PL_regstartp[i] = -1;
284 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
287 * pregexec and friends
290 #ifndef PERL_IN_XSUB_RE
292 - pregexec - match a regexp against a string
295 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
296 char *strbeg, I32 minend, SV *screamer, U32 nosave)
297 /* strend: pointer to null at end of string */
298 /* strbeg: real beginning of string */
299 /* minend: end of match must be >=minend after stringarg. */
300 /* nosave: For optimizations. */
303 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
304 nosave ? 0 : REXEC_COPY_STR);
309 * Need to implement the following flags for reg_anch:
311 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
313 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
314 * INTUIT_AUTORITATIVE_ML
315 * INTUIT_ONCE_NOML - Intuit can match in one location only.
318 * Another flag for this function: SECOND_TIME (so that float substrs
319 * with giant delta may be not rechecked).
322 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
324 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
325 Otherwise, only SvCUR(sv) is used to get strbeg. */
327 /* XXXX We assume that strpos is strbeg unless sv. */
329 /* XXXX Some places assume that there is a fixed substring.
330 An update may be needed if optimizer marks as "INTUITable"
331 RExen without fixed substrings. Similarly, it is assumed that
332 lengths of all the strings are no more than minlen, thus they
333 cannot come from lookahead.
334 (Or minlen should take into account lookahead.)
335 NOTE: Some of this comment is not correct. minlen does now take account
336 of lookahead/behind. Further research is required. -- demerphq
340 /* A failure to find a constant substring means that there is no need to make
341 an expensive call to REx engine, thus we celebrate a failure. Similarly,
342 finding a substring too deep into the string means that less calls to
343 regtry() should be needed.
345 REx compiler's optimizer found 4 possible hints:
346 a) Anchored substring;
348 c) Whether we are anchored (beginning-of-line or \G);
349 d) First node (of those at offset 0) which may distingush positions;
350 We use a)b)d) and multiline-part of c), and try to find a position in the
351 string which does not contradict any of them.
354 /* Most of decisions we do here should have been done at compile time.
355 The nodes of the REx which we used for the search should have been
356 deleted from the finite automaton. */
359 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
360 char *strend, U32 flags, re_scream_pos_data *data)
363 register I32 start_shift = 0;
364 /* Should be nonnegative! */
365 register I32 end_shift = 0;
370 const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
372 register char *other_last = NULL; /* other substr checked before this */
373 char *check_at = NULL; /* check substr found at this pos */
374 const I32 multiline = prog->reganch & PMf_MULTILINE;
376 const char * const i_strpos = strpos;
379 GET_RE_DEBUG_FLAGS_DECL;
381 RX_MATCH_UTF8_set(prog,do_utf8);
383 if (prog->reganch & ROPT_UTF8) {
384 PL_reg_flags |= RF_utf8;
387 debug_start_match(prog, do_utf8, strpos, strend,
388 sv ? "Guessing start of match in sv for"
389 : "Guessing start of match in string for");
392 /* CHR_DIST() would be more correct here but it makes things slow. */
393 if (prog->minlen > strend - strpos) {
394 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
395 "String too short... [re_intuit_start]\n"));
399 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
402 if (!prog->check_utf8 && prog->check_substr)
403 to_utf8_substr(prog);
404 check = prog->check_utf8;
406 if (!prog->check_substr && prog->check_utf8)
407 to_byte_substr(prog);
408 check = prog->check_substr;
410 if (check == &PL_sv_undef) {
411 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
412 "Non-utf8 string cannot match utf8 check string\n"));
415 if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
416 ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
417 || ( (prog->reganch & ROPT_ANCH_BOL)
418 && !multiline ) ); /* Check after \n? */
421 if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
422 | ROPT_IMPLICIT)) /* not a real BOL */
423 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
425 && (strpos != strbeg)) {
426 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
429 if (prog->check_offset_min == prog->check_offset_max &&
430 !(prog->reganch & ROPT_CANY_SEEN)) {
431 /* Substring at constant offset from beg-of-str... */
434 s = HOP3c(strpos, prog->check_offset_min, strend);
437 slen = SvCUR(check); /* >= 1 */
439 if ( strend - s > slen || strend - s < slen - 1
440 || (strend - s == slen && strend[-1] != '\n')) {
441 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
444 /* Now should match s[0..slen-2] */
446 if (slen && (*SvPVX_const(check) != *s
448 && memNE(SvPVX_const(check), s, slen)))) {
450 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
454 else if (*SvPVX_const(check) != *s
455 || ((slen = SvCUR(check)) > 1
456 && memNE(SvPVX_const(check), s, slen)))
459 goto success_at_start;
462 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
464 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
465 end_shift = prog->check_end_shift;
468 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
469 - (SvTAIL(check) != 0);
470 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
472 if (end_shift < eshift)
476 else { /* Can match at random position */
479 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
480 end_shift = prog->check_end_shift;
482 /* end shift should be non negative here */
485 #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
487 Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
488 (IV)end_shift, prog->precomp);
492 /* Find a possible match in the region s..strend by looking for
493 the "check" substring in the region corrected by start/end_shift. */
496 I32 srch_start_shift = start_shift;
497 I32 srch_end_shift = end_shift;
498 if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
499 srch_end_shift -= ((strbeg - s) - srch_start_shift);
500 srch_start_shift = strbeg - s;
502 DEBUG_OPTIMISE_MORE_r({
503 PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
504 (IV)prog->check_offset_min,
505 (IV)srch_start_shift,
507 (IV)prog->check_end_shift);
510 if (flags & REXEC_SCREAM) {
511 I32 p = -1; /* Internal iterator of scream. */
512 I32 * const pp = data ? data->scream_pos : &p;
514 if (PL_screamfirst[BmRARE(check)] >= 0
515 || ( BmRARE(check) == '\n'
516 && (BmPREVIOUS(check) == SvCUR(check) - 1)
518 s = screaminstr(sv, check,
519 srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
522 /* we may be pointing at the wrong string */
523 if (s && RX_MATCH_COPIED(prog))
524 s = strbeg + (s - SvPVX_const(sv));
526 *data->scream_olds = s;
531 if (prog->reganch & ROPT_CANY_SEEN) {
532 start_point= (U8*)(s + srch_start_shift);
533 end_point= (U8*)(strend - srch_end_shift);
535 start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
536 end_point= HOP3(strend, -srch_end_shift, strbeg);
538 DEBUG_OPTIMISE_MORE_r({
539 PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
540 (int)(end_point - start_point),
541 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
545 s = fbm_instr( start_point, end_point,
546 check, multiline ? FBMrf_MULTILINE : 0);
549 /* Update the count-of-usability, remove useless subpatterns,
553 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
554 SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
555 PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
556 (s ? "Found" : "Did not find"),
557 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)
558 ? "anchored" : "floating"),
561 (s ? " at offset " : "...\n") );
566 /* Finish the diagnostic message */
567 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
569 /* XXX dmq: first branch is for positive lookbehind...
570 Our check string is offset from the beginning of the pattern.
571 So we need to do any stclass tests offset forward from that
580 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
581 Start with the other substr.
582 XXXX no SCREAM optimization yet - and a very coarse implementation
583 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
584 *always* match. Probably should be marked during compile...
585 Probably it is right to do no SCREAM here...
588 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
589 : (prog->float_substr && prog->anchored_substr))
591 /* Take into account the "other" substring. */
592 /* XXXX May be hopelessly wrong for UTF... */
595 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
598 char * const last = HOP3c(s, -start_shift, strbeg);
600 char * const saved_s = s;
603 t = s - prog->check_offset_max;
604 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
606 || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
611 t = HOP3c(t, prog->anchored_offset, strend);
612 if (t < other_last) /* These positions already checked */
614 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
617 /* XXXX It is not documented what units *_offsets are in.
618 We assume bytes, but this is clearly wrong.
619 Meaning this code needs to be carefully reviewed for errors.
623 /* On end-of-str: see comment below. */
624 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
625 if (must == &PL_sv_undef) {
627 DEBUG_r(must = prog->anchored_utf8); /* for debug */
632 HOP3(HOP3(last1, prog->anchored_offset, strend)
633 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
635 multiline ? FBMrf_MULTILINE : 0
638 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
639 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
640 PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
641 (s ? "Found" : "Contradicts"),
642 quoted, RE_SV_TAIL(must));
647 if (last1 >= last2) {
648 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
649 ", giving up...\n"));
652 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
653 ", trying floating at offset %ld...\n",
654 (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
655 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
656 s = HOP3c(last, 1, strend);
660 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
661 (long)(s - i_strpos)));
662 t = HOP3c(s, -prog->anchored_offset, strbeg);
663 other_last = HOP3c(s, 1, strend);
671 else { /* Take into account the floating substring. */
673 char * const saved_s = s;
676 t = HOP3c(s, -start_shift, strbeg);
678 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
679 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
680 last = HOP3c(t, prog->float_max_offset, strend);
681 s = HOP3c(t, prog->float_min_offset, strend);
684 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
685 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
686 /* fbm_instr() takes into account exact value of end-of-str
687 if the check is SvTAIL(ed). Since false positives are OK,
688 and end-of-str is not later than strend we are OK. */
689 if (must == &PL_sv_undef) {
691 DEBUG_r(must = prog->float_utf8); /* for debug message */
694 s = fbm_instr((unsigned char*)s,
695 (unsigned char*)last + SvCUR(must)
697 must, multiline ? FBMrf_MULTILINE : 0);
699 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
700 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
701 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
702 (s ? "Found" : "Contradicts"),
703 quoted, RE_SV_TAIL(must));
707 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
708 ", giving up...\n"));
711 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
712 ", trying anchored starting at offset %ld...\n",
713 (long)(saved_s + 1 - i_strpos)));
715 s = HOP3c(t, 1, strend);
719 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
720 (long)(s - i_strpos)));
721 other_last = s; /* Fix this later. --Hugo */
731 t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
733 DEBUG_OPTIMISE_MORE_r(
734 PerlIO_printf(Perl_debug_log,
735 "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
736 (IV)prog->check_offset_min,
737 (IV)prog->check_offset_max,
745 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
747 || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
750 /* Fixed substring is found far enough so that the match
751 cannot start at strpos. */
753 if (ml_anch && t[-1] != '\n') {
754 /* Eventually fbm_*() should handle this, but often
755 anchored_offset is not 0, so this check will not be wasted. */
756 /* XXXX In the code below we prefer to look for "^" even in
757 presence of anchored substrings. And we search even
758 beyond the found float position. These pessimizations
759 are historical artefacts only. */
761 while (t < strend - prog->minlen) {
763 if (t < check_at - prog->check_offset_min) {
764 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
765 /* Since we moved from the found position,
766 we definitely contradict the found anchored
767 substr. Due to the above check we do not
768 contradict "check" substr.
769 Thus we can arrive here only if check substr
770 is float. Redo checking for "other"=="fixed".
773 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
774 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
775 goto do_other_anchored;
777 /* We don't contradict the found floating substring. */
778 /* XXXX Why not check for STCLASS? */
780 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
781 PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
784 /* Position contradicts check-string */
785 /* XXXX probably better to look for check-string
786 than for "\n", so one should lower the limit for t? */
787 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
788 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
789 other_last = strpos = s = t + 1;
794 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
795 PL_colors[0], PL_colors[1]));
799 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
800 PL_colors[0], PL_colors[1]));
804 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
807 /* The found string does not prohibit matching at strpos,
808 - no optimization of calling REx engine can be performed,
809 unless it was an MBOL and we are not after MBOL,
810 or a future STCLASS check will fail this. */
812 /* Even in this situation we may use MBOL flag if strpos is offset
813 wrt the start of the string. */
814 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
815 && (strpos != strbeg) && strpos[-1] != '\n'
816 /* May be due to an implicit anchor of m{.*foo} */
817 && !(prog->reganch & ROPT_IMPLICIT))
822 DEBUG_EXECUTE_r( if (ml_anch)
823 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
824 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
827 if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
829 prog->check_utf8 /* Could be deleted already */
830 && --BmUSEFUL(prog->check_utf8) < 0
831 && (prog->check_utf8 == prog->float_utf8)
833 prog->check_substr /* Could be deleted already */
834 && --BmUSEFUL(prog->check_substr) < 0
835 && (prog->check_substr == prog->float_substr)
838 /* If flags & SOMETHING - do not do it many times on the same match */
839 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
840 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
841 if (do_utf8 ? prog->check_substr : prog->check_utf8)
842 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
843 prog->check_substr = prog->check_utf8 = NULL; /* disable */
844 prog->float_substr = prog->float_utf8 = NULL; /* clear */
845 check = NULL; /* abort */
847 /* XXXX This is a remnant of the old implementation. It
848 looks wasteful, since now INTUIT can use many
850 prog->reganch &= ~RE_USE_INTUIT;
857 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
858 /* trie stclasses are too expensive to use here, we are better off to
859 leave it to regmatch itself */
860 if (prog->regstclass && PL_regkind[OP(prog->regstclass)]!=TRIE) {
861 /* minlen == 0 is possible if regstclass is \b or \B,
862 and the fixed substr is ''$.
863 Since minlen is already taken into account, s+1 is before strend;
864 accidentally, minlen >= 1 guaranties no false positives at s + 1
865 even for \b or \B. But (minlen? 1 : 0) below assumes that
866 regstclass does not come from lookahead... */
867 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
868 This leaves EXACTF only, which is dealt with in find_byclass(). */
869 const U8* const str = (U8*)STRING(prog->regstclass);
870 const int cl_l = (PL_regkind[OP(prog->regstclass)] == EXACT
871 ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
874 if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
875 endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
876 else if (prog->float_substr || prog->float_utf8)
877 endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
881 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %d s: %d endpos: %d\n",
882 (IV)start_shift, check_at - strbeg, s - strbeg, endpos - strbeg));
885 s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
888 const char *what = NULL;
890 if (endpos == strend) {
891 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
892 "Could not match STCLASS...\n") );
895 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
896 "This position contradicts STCLASS...\n") );
897 if ((prog->reganch & ROPT_ANCH) && !ml_anch)
899 /* Contradict one of substrings */
900 if (prog->anchored_substr || prog->anchored_utf8) {
901 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
902 DEBUG_EXECUTE_r( what = "anchored" );
904 s = HOP3c(t, 1, strend);
905 if (s + start_shift + end_shift > strend) {
906 /* XXXX Should be taken into account earlier? */
907 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
908 "Could not match STCLASS...\n") );
913 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
914 "Looking for %s substr starting at offset %ld...\n",
915 what, (long)(s + start_shift - i_strpos)) );
918 /* Have both, check_string is floating */
919 if (t + start_shift >= check_at) /* Contradicts floating=check */
920 goto retry_floating_check;
921 /* Recheck anchored substring, but not floating... */
925 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
926 "Looking for anchored substr starting at offset %ld...\n",
927 (long)(other_last - i_strpos)) );
928 goto do_other_anchored;
930 /* Another way we could have checked stclass at the
931 current position only: */
936 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
937 "Looking for /%s^%s/m starting at offset %ld...\n",
938 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
941 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
943 /* Check is floating subtring. */
944 retry_floating_check:
945 t = check_at - start_shift;
946 DEBUG_EXECUTE_r( what = "floating" );
947 goto hop_and_restart;
950 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
951 "By STCLASS: moving %ld --> %ld\n",
952 (long)(t - i_strpos), (long)(s - i_strpos))
956 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
957 "Does not contradict STCLASS...\n");
962 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
963 PL_colors[4], (check ? "Guessed" : "Giving up"),
964 PL_colors[5], (long)(s - i_strpos)) );
967 fail_finish: /* Substring not found */
968 if (prog->check_substr || prog->check_utf8) /* could be removed already */
969 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
971 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
972 PL_colors[4], PL_colors[5]));
978 #define REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len, uvc, charid, \
979 foldlen, foldbuf, uniflags) STMT_START { \
980 switch (trie_type) { \
981 case trie_utf8_fold: \
983 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
988 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
989 uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
990 foldlen -= UNISKIP( uvc ); \
991 uscan = foldbuf + UNISKIP( uvc ); \
995 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1003 charid = trie->charmap[ uvc ]; \
1007 if (trie->widecharmap) { \
1008 SV** const svpp = hv_fetch(trie->widecharmap, \
1009 (char*)&uvc, sizeof(UV), 0); \
1011 charid = (U16)SvIV(*svpp); \
1016 #define REXEC_FBC_EXACTISH_CHECK(CoNd) \
1019 ibcmp_utf8(s, NULL, 0, do_utf8, \
1020 m, NULL, ln, (bool)UTF)) \
1021 && (!reginfo || regtry(reginfo, &s)) ) \
1024 U8 foldbuf[UTF8_MAXBYTES_CASE+1]; \
1025 uvchr_to_utf8(tmpbuf, c); \
1026 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); \
1028 && (f == c1 || f == c2) \
1029 && (ln == foldlen || \
1030 !ibcmp_utf8((char *) foldbuf, \
1031 NULL, foldlen, do_utf8, \
1033 NULL, ln, (bool)UTF)) \
1034 && (!reginfo || regtry(reginfo, &s)) ) \
1039 #define REXEC_FBC_EXACTISH_SCAN(CoNd) \
1043 && (ln == 1 || !(OP(c) == EXACTF \
1045 : ibcmp_locale(s, m, ln))) \
1046 && (!reginfo || regtry(reginfo, &s)) ) \
1052 #define REXEC_FBC_UTF8_SCAN(CoDe) \
1054 while (s + (uskip = UTF8SKIP(s)) <= strend) { \
1060 #define REXEC_FBC_SCAN(CoDe) \
1062 while (s < strend) { \
1068 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \
1069 REXEC_FBC_UTF8_SCAN( \
1071 if (tmp && (!reginfo || regtry(reginfo, &s))) \
1080 #define REXEC_FBC_CLASS_SCAN(CoNd) \
1083 if (tmp && (!reginfo || regtry(reginfo, &s))) \
1092 #define REXEC_FBC_TRYIT \
1093 if ((!reginfo || regtry(reginfo, &s))) \
1096 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd) \
1099 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1102 REXEC_FBC_CLASS_SCAN(CoNd); \
1106 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd) \
1107 PL_reg_flags |= RF_tainted; \
1109 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1112 REXEC_FBC_CLASS_SCAN(CoNd); \
1116 #define DUMP_EXEC_POS(li,s,doutf8) \
1117 dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1119 /* We know what class REx starts with. Try to find this position... */
1120 /* if reginfo is NULL, its a dryrun */
1121 /* annoyingly all the vars in this routine have different names from their counterparts
1122 in regmatch. /grrr */
1125 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1126 const char *strend, regmatch_info *reginfo)
1129 const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
1133 register STRLEN uskip;
1137 register I32 tmp = 1; /* Scratch variable? */
1138 register const bool do_utf8 = PL_reg_match_utf8;
1140 /* We know what class it must start with. */
1144 REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1145 !UTF8_IS_INVARIANT((U8)s[0]) ?
1146 reginclass(prog, c, (U8*)s, 0, do_utf8) :
1147 REGINCLASS(prog, c, (U8*)s));
1150 while (s < strend) {
1153 if (REGINCLASS(prog, c, (U8*)s) ||
1154 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1155 /* The assignment of 2 is intentional:
1156 * for the folded sharp s, the skip is 2. */
1157 (skip = SHARP_S_SKIP))) {
1158 if (tmp && (!reginfo || regtry(reginfo, &s)))
1171 if (tmp && (!reginfo || regtry(reginfo, &s)))
1179 ln = STR_LEN(c); /* length to match in octets/bytes */
1180 lnc = (I32) ln; /* length to match in characters */
1182 STRLEN ulen1, ulen2;
1184 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1185 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1186 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1188 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1189 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1191 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1193 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1196 while (sm < ((U8 *) m + ln)) {
1211 c2 = PL_fold_locale[c1];
1213 e = HOP3c(strend, -((I32)lnc), s);
1215 if (!reginfo && e < s)
1216 e = s; /* Due to minlen logic of intuit() */
1218 /* The idea in the EXACTF* cases is to first find the
1219 * first character of the EXACTF* node and then, if
1220 * necessary, case-insensitively compare the full
1221 * text of the node. The c1 and c2 are the first
1222 * characters (though in Unicode it gets a bit
1223 * more complicated because there are more cases
1224 * than just upper and lower: one needs to use
1225 * the so-called folding case for case-insensitive
1226 * matching (called "loose matching" in Unicode).
1227 * ibcmp_utf8() will do just that. */
1231 U8 tmpbuf [UTF8_MAXBYTES+1];
1232 STRLEN len, foldlen;
1233 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1235 /* Upper and lower of 1st char are equal -
1236 * probably not a "letter". */
1238 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1240 REXEC_FBC_EXACTISH_CHECK(c == c1);
1245 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1248 /* Handle some of the three Greek sigmas cases.
1249 * Note that not all the possible combinations
1250 * are handled here: some of them are handled
1251 * by the standard folding rules, and some of
1252 * them (the character class or ANYOF cases)
1253 * are handled during compiletime in
1254 * regexec.c:S_regclass(). */
1255 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1256 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1257 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1259 REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1265 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1267 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1271 PL_reg_flags |= RF_tainted;
1278 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1279 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1281 tmp = ((OP(c) == BOUND ?
1282 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1283 LOAD_UTF8_CHARCLASS_ALNUM();
1284 REXEC_FBC_UTF8_SCAN(
1285 if (tmp == !(OP(c) == BOUND ?
1286 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1287 isALNUM_LC_utf8((U8*)s)))
1295 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1296 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1299 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1305 if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1309 PL_reg_flags |= RF_tainted;
1316 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1317 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1319 tmp = ((OP(c) == NBOUND ?
1320 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1321 LOAD_UTF8_CHARCLASS_ALNUM();
1322 REXEC_FBC_UTF8_SCAN(
1323 if (tmp == !(OP(c) == NBOUND ?
1324 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1325 isALNUM_LC_utf8((U8*)s)))
1327 else REXEC_FBC_TRYIT;
1331 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1332 tmp = ((OP(c) == NBOUND ?
1333 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1336 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1338 else REXEC_FBC_TRYIT;
1341 if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1345 REXEC_FBC_CSCAN_PRELOAD(
1346 LOAD_UTF8_CHARCLASS_ALNUM(),
1347 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1351 REXEC_FBC_CSCAN_TAINT(
1352 isALNUM_LC_utf8((U8*)s),
1356 REXEC_FBC_CSCAN_PRELOAD(
1357 LOAD_UTF8_CHARCLASS_ALNUM(),
1358 !swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1362 REXEC_FBC_CSCAN_TAINT(
1363 !isALNUM_LC_utf8((U8*)s),
1367 REXEC_FBC_CSCAN_PRELOAD(
1368 LOAD_UTF8_CHARCLASS_SPACE(),
1369 *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8),
1373 REXEC_FBC_CSCAN_TAINT(
1374 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1378 REXEC_FBC_CSCAN_PRELOAD(
1379 LOAD_UTF8_CHARCLASS_SPACE(),
1380 !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)),
1384 REXEC_FBC_CSCAN_TAINT(
1385 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1389 REXEC_FBC_CSCAN_PRELOAD(
1390 LOAD_UTF8_CHARCLASS_DIGIT(),
1391 swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1395 REXEC_FBC_CSCAN_TAINT(
1396 isDIGIT_LC_utf8((U8*)s),
1400 REXEC_FBC_CSCAN_PRELOAD(
1401 LOAD_UTF8_CHARCLASS_DIGIT(),
1402 !swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1406 REXEC_FBC_CSCAN_TAINT(
1407 !isDIGIT_LC_utf8((U8*)s),
1413 const enum { trie_plain, trie_utf8, trie_utf8_fold }
1414 trie_type = do_utf8 ?
1415 (c->flags == EXACT ? trie_utf8 : trie_utf8_fold)
1417 /* what trie are we using right now */
1419 = (reg_ac_data*)prog->data->data[ ARG( c ) ];
1420 reg_trie_data *trie=aho->trie;
1422 const char *last_start = strend - trie->minlen;
1424 const char *real_start = s;
1426 STRLEN maxlen = trie->maxlen;
1428 U8 **points; /* map of where we were in the input string
1429 when reading a given char. For ASCII this
1430 is unnecessary overhead as the relationship
1431 is always 1:1, but for unicode, especially
1432 case folded unicode this is not true. */
1433 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1437 GET_RE_DEBUG_FLAGS_DECL;
1439 /* We can't just allocate points here. We need to wrap it in
1440 * an SV so it gets freed properly if there is a croak while
1441 * running the match */
1444 sv_points=newSV(maxlen * sizeof(U8 *));
1445 SvCUR_set(sv_points,
1446 maxlen * sizeof(U8 *));
1447 SvPOK_on(sv_points);
1448 sv_2mortal(sv_points);
1449 points=(U8**)SvPV_nolen(sv_points );
1450 if ( trie_type != trie_utf8_fold
1451 && (trie->bitmap || OP(c)==AHOCORASICKC) )
1454 bitmap=(U8*)trie->bitmap;
1456 bitmap=(U8*)ANYOF_BITMAP(c);
1458 /* this is the Aho-Corasick algorithm modified a touch
1459 to include special handling for long "unknown char"
1460 sequences. The basic idea being that we use AC as long
1461 as we are dealing with a possible matching char, when
1462 we encounter an unknown char (and we have not encountered
1463 an accepting state) we scan forward until we find a legal
1465 AC matching is basically that of trie matching, except
1466 that when we encounter a failing transition, we fall back
1467 to the current states "fail state", and try the current char
1468 again, a process we repeat until we reach the root state,
1469 state 1, or a legal transition. If we fail on the root state
1470 then we can either terminate if we have reached an accepting
1471 state previously, or restart the entire process from the beginning
1475 while (s <= last_start) {
1476 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1484 U8 *uscan = (U8*)NULL;
1485 U8 *leftmost = NULL;
1487 U32 accepted_word= 0;
1491 while ( state && uc <= (U8*)strend ) {
1493 U32 word = aho->states[ state ].wordnum;
1497 DEBUG_TRIE_EXECUTE_r(
1498 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1499 dump_exec_pos( (char *)uc, c, strend, real_start,
1500 (char *)uc, do_utf8 );
1501 PerlIO_printf( Perl_debug_log,
1502 " Scanning for legal start char...\n");
1505 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1510 if (uc >(U8*)last_start) break;
1514 U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1515 if (!leftmost || lpos < leftmost) {
1516 DEBUG_r(accepted_word=word);
1522 points[pointpos++ % maxlen]= uc;
1523 REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
1524 uvc, charid, foldlen, foldbuf, uniflags);
1525 DEBUG_TRIE_EXECUTE_r({
1526 dump_exec_pos( (char *)uc, c, strend, real_start,
1528 PerlIO_printf(Perl_debug_log,
1529 " Charid:%3u CP:%4"UVxf" ",
1535 word = aho->states[ state ].wordnum;
1537 base = aho->states[ state ].trans.base;
1539 DEBUG_TRIE_EXECUTE_r({
1541 dump_exec_pos( (char *)uc, c, strend, real_start,
1543 PerlIO_printf( Perl_debug_log,
1544 "%sState: %4"UVxf", word=%"UVxf,
1545 failed ? " Fail transition to " : "",
1546 (UV)state, (UV)word);
1551 (base + charid > trie->uniquecharcount )
1552 && (base + charid - 1 - trie->uniquecharcount
1554 && trie->trans[base + charid - 1 -
1555 trie->uniquecharcount].check == state
1556 && (tmp=trie->trans[base + charid - 1 -
1557 trie->uniquecharcount ].next))
1559 DEBUG_TRIE_EXECUTE_r(
1560 PerlIO_printf( Perl_debug_log," - legal\n"));
1565 DEBUG_TRIE_EXECUTE_r(
1566 PerlIO_printf( Perl_debug_log," - fail\n"));
1568 state = aho->fail[state];
1572 /* we must be accepting here */
1573 DEBUG_TRIE_EXECUTE_r(
1574 PerlIO_printf( Perl_debug_log," - accepting\n"));
1583 if (!state) state = 1;
1586 if ( aho->states[ state ].wordnum ) {
1587 U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1588 if (!leftmost || lpos < leftmost) {
1589 DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1594 s = (char*)leftmost;
1595 DEBUG_TRIE_EXECUTE_r({
1597 Perl_debug_log,"Matches word #%"UVxf" at position %d. Trying full pattern...\n",
1598 (UV)accepted_word, s - real_start
1601 if (!reginfo || regtry(reginfo, &s)) {
1607 DEBUG_TRIE_EXECUTE_r({
1608 PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1611 DEBUG_TRIE_EXECUTE_r(
1612 PerlIO_printf( Perl_debug_log,"No match.\n"));
1621 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1630 - regexec_flags - match a regexp against a string
1633 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1634 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1635 /* strend: pointer to null at end of string */
1636 /* strbeg: real beginning of string */
1637 /* minend: end of match must be >=minend after stringarg. */
1638 /* data: May be used for some additional optimizations. */
1639 /* nosave: For optimizations. */
1642 /*register*/ char *s;
1643 register regnode *c;
1644 /*register*/ char *startpos = stringarg;
1645 I32 minlen; /* must match at least this many chars */
1646 I32 dontbother = 0; /* how many characters not to try at end */
1647 I32 end_shift = 0; /* Same for the end. */ /* CC */
1648 I32 scream_pos = -1; /* Internal iterator of scream. */
1649 char *scream_olds = NULL;
1650 SV* const oreplsv = GvSV(PL_replgv);
1651 const bool do_utf8 = (bool)DO_UTF8(sv);
1654 regmatch_info reginfo; /* create some info to pass to regtry etc */
1656 GET_RE_DEBUG_FLAGS_DECL;
1658 PERL_UNUSED_ARG(data);
1660 /* Be paranoid... */
1661 if (prog == NULL || startpos == NULL) {
1662 Perl_croak(aTHX_ "NULL regexp parameter");
1666 multiline = prog->reganch & PMf_MULTILINE;
1667 reginfo.prog = prog;
1669 RX_MATCH_UTF8_set(prog, do_utf8);
1671 debug_start_match(prog, do_utf8, startpos, strend,
1675 minlen = prog->minlen;
1677 if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1678 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1679 "String too short [regexec_flags]...\n"));
1684 /* Check validity of program. */
1685 if (UCHARAT(prog->program) != REG_MAGIC) {
1686 Perl_croak(aTHX_ "corrupted regexp program");
1690 PL_reg_eval_set = 0;
1693 if (prog->reganch & ROPT_UTF8)
1694 PL_reg_flags |= RF_utf8;
1696 /* Mark beginning of line for ^ and lookbehind. */
1697 reginfo.bol = startpos; /* XXX not used ??? */
1701 /* Mark end of line for $ (and such) */
1704 /* see how far we have to get to not match where we matched before */
1705 reginfo.till = startpos+minend;
1707 /* If there is a "must appear" string, look for it. */
1710 if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to set reginfo->ganch */
1713 if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
1714 reginfo.ganch = startpos;
1715 else if (sv && SvTYPE(sv) >= SVt_PVMG
1717 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1718 && mg->mg_len >= 0) {
1719 reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
1720 if (prog->reganch & ROPT_ANCH_GPOS) {
1721 if (s > reginfo.ganch)
1726 else /* pos() not defined */
1727 reginfo.ganch = strbeg;
1730 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1731 re_scream_pos_data d;
1733 d.scream_olds = &scream_olds;
1734 d.scream_pos = &scream_pos;
1735 s = re_intuit_start(prog, sv, s, strend, flags, &d);
1737 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1738 goto phooey; /* not present */
1744 /* Simplest case: anchored match need be tried only once. */
1745 /* [unless only anchor is BOL and multiline is set] */
1746 if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1747 if (s == startpos && regtry(®info, &startpos))
1749 else if (multiline || (prog->reganch & ROPT_IMPLICIT)
1750 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1755 dontbother = minlen - 1;
1756 end = HOP3c(strend, -dontbother, strbeg) - 1;
1757 /* for multiline we only have to try after newlines */
1758 if (prog->check_substr || prog->check_utf8) {
1762 if (regtry(®info, &s))
1767 if (prog->reganch & RE_USE_INTUIT) {
1768 s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1779 if (*s++ == '\n') { /* don't need PL_utf8skip here */
1780 if (regtry(®info, &s))
1787 } else if (ROPT_GPOS_CHECK == (prog->reganch & ROPT_GPOS_CHECK))
1789 /* the warning about reginfo.ganch being used without intialization
1790 is bogus -- we set it above, when prog->reganch & ROPT_GPOS_SEEN
1791 and we only enter this block when the same bit is set. */
1792 if (regtry(®info, ®info.ganch))
1797 /* Messy cases: unanchored match. */
1798 if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1799 /* we have /x+whatever/ */
1800 /* it must be a one character string (XXXX Except UTF?) */
1805 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1806 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1807 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1812 DEBUG_EXECUTE_r( did_match = 1 );
1813 if (regtry(®info, &s)) goto got_it;
1815 while (s < strend && *s == ch)
1823 DEBUG_EXECUTE_r( did_match = 1 );
1824 if (regtry(®info, &s)) goto got_it;
1826 while (s < strend && *s == ch)
1831 DEBUG_EXECUTE_r(if (!did_match)
1832 PerlIO_printf(Perl_debug_log,
1833 "Did not find anchored character...\n")
1836 else if (prog->anchored_substr != NULL
1837 || prog->anchored_utf8 != NULL
1838 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1839 && prog->float_max_offset < strend - s)) {
1844 char *last1; /* Last position checked before */
1848 if (prog->anchored_substr || prog->anchored_utf8) {
1849 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1850 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1851 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1852 back_max = back_min = prog->anchored_offset;
1854 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1855 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1856 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1857 back_max = prog->float_max_offset;
1858 back_min = prog->float_min_offset;
1862 if (must == &PL_sv_undef)
1863 /* could not downgrade utf8 check substring, so must fail */
1869 last = HOP3c(strend, /* Cannot start after this */
1870 -(I32)(CHR_SVLEN(must)
1871 - (SvTAIL(must) != 0) + back_min), strbeg);
1874 last1 = HOPc(s, -1);
1876 last1 = s - 1; /* bogus */
1878 /* XXXX check_substr already used to find "s", can optimize if
1879 check_substr==must. */
1881 dontbother = end_shift;
1882 strend = HOPc(strend, -dontbother);
1883 while ( (s <= last) &&
1884 ((flags & REXEC_SCREAM)
1885 ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
1886 end_shift, &scream_pos, 0))
1887 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
1888 (unsigned char*)strend, must,
1889 multiline ? FBMrf_MULTILINE : 0))) ) {
1890 /* we may be pointing at the wrong string */
1891 if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
1892 s = strbeg + (s - SvPVX_const(sv));
1893 DEBUG_EXECUTE_r( did_match = 1 );
1894 if (HOPc(s, -back_max) > last1) {
1895 last1 = HOPc(s, -back_min);
1896 s = HOPc(s, -back_max);
1899 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1901 last1 = HOPc(s, -back_min);
1905 while (s <= last1) {
1906 if (regtry(®info, &s))
1912 while (s <= last1) {
1913 if (regtry(®info, &s))
1919 DEBUG_EXECUTE_r(if (!did_match) {
1920 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
1921 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
1922 PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
1923 ((must == prog->anchored_substr || must == prog->anchored_utf8)
1924 ? "anchored" : "floating"),
1925 quoted, RE_SV_TAIL(must));
1929 else if ( (c = prog->regstclass) ) {
1931 const OPCODE op = OP(prog->regstclass);
1932 /* don't bother with what can't match */
1933 if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
1934 strend = HOPc(strend, -(minlen - 1));
1937 SV * const prop = sv_newmortal();
1938 regprop(prog, prop, c);
1940 RE_PV_QUOTED_DECL(quoted,UTF,PERL_DEBUG_PAD_ZERO(1),
1942 PerlIO_printf(Perl_debug_log,
1943 "Matching stclass %.*s against %s (%d chars)\n",
1944 (int)SvCUR(prop), SvPVX_const(prop),
1945 quoted, (int)(strend - s));
1948 if (find_byclass(prog, c, s, strend, ®info))
1950 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
1954 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
1959 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1960 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1961 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
1963 if (flags & REXEC_SCREAM) {
1964 last = screaminstr(sv, float_real, s - strbeg,
1965 end_shift, &scream_pos, 1); /* last one */
1967 last = scream_olds; /* Only one occurrence. */
1968 /* we may be pointing at the wrong string */
1969 else if (RX_MATCH_COPIED(prog))
1970 s = strbeg + (s - SvPVX_const(sv));
1974 const char * const little = SvPV_const(float_real, len);
1976 if (SvTAIL(float_real)) {
1977 if (memEQ(strend - len + 1, little, len - 1))
1978 last = strend - len + 1;
1979 else if (!multiline)
1980 last = memEQ(strend - len, little, len)
1981 ? strend - len : NULL;
1987 last = rninstr(s, strend, little, little + len);
1989 last = strend; /* matching "$" */
1994 PerlIO_printf(Perl_debug_log,
1995 "%sCan't trim the tail, match fails (should not happen)%s\n",
1996 PL_colors[4], PL_colors[5]));
1997 goto phooey; /* Should not happen! */
1999 dontbother = strend - last + prog->float_min_offset;
2001 if (minlen && (dontbother < minlen))
2002 dontbother = minlen - 1;
2003 strend -= dontbother; /* this one's always in bytes! */
2004 /* We don't know much -- general case. */
2007 if (regtry(®info, &s))
2016 if (regtry(®info, &s))
2018 } while (s++ < strend);
2026 RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2028 if (PL_reg_eval_set) {
2029 /* Preserve the current value of $^R */
2030 if (oreplsv != GvSV(PL_replgv))
2031 sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2032 restored, the value remains
2034 restore_pos(aTHX_ prog);
2036 if (prog->paren_names)
2037 (void)hv_iterinit(prog->paren_names);
2039 /* make sure $`, $&, $', and $digit will work later */
2040 if ( !(flags & REXEC_NOT_FIRST) ) {
2041 RX_MATCH_COPY_FREE(prog);
2042 if (flags & REXEC_COPY_STR) {
2043 const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2044 #ifdef PERL_OLD_COPY_ON_WRITE
2046 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2048 PerlIO_printf(Perl_debug_log,
2049 "Copy on write: regexp capture, type %d\n",
2052 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2053 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2054 assert (SvPOKp(prog->saved_copy));
2058 RX_MATCH_COPIED_on(prog);
2059 s = savepvn(strbeg, i);
2065 prog->subbeg = strbeg;
2066 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2073 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2074 PL_colors[4], PL_colors[5]));
2075 if (PL_reg_eval_set)
2076 restore_pos(aTHX_ prog);
2082 - regtry - try match at specific point
2084 STATIC I32 /* 0 failure, 1 success */
2085 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2091 regexp *prog = reginfo->prog;
2092 GET_RE_DEBUG_FLAGS_DECL;
2093 reginfo->cutpoint=NULL;
2095 if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2098 PL_reg_eval_set = RS_init;
2099 DEBUG_EXECUTE_r(DEBUG_s(
2100 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2101 (IV)(PL_stack_sp - PL_stack_base));
2104 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2105 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2107 /* Apparently this is not needed, judging by wantarray. */
2108 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2109 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2112 /* Make $_ available to executed code. */
2113 if (reginfo->sv != DEFSV) {
2115 DEFSV = reginfo->sv;
2118 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2119 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2120 /* prepare for quick setting of pos */
2121 #ifdef PERL_OLD_COPY_ON_WRITE
2122 if (SvIsCOW(reginfo->sv))
2123 sv_force_normal_flags(reginfo->sv, 0);
2125 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2126 &PL_vtbl_mglob, NULL, 0);
2130 PL_reg_oldpos = mg->mg_len;
2131 SAVEDESTRUCTOR_X(restore_pos, prog);
2133 if (!PL_reg_curpm) {
2134 Newxz(PL_reg_curpm, 1, PMOP);
2137 SV* const repointer = newSViv(0);
2138 /* so we know which PL_regex_padav element is PL_reg_curpm */
2139 SvFLAGS(repointer) |= SVf_BREAK;
2140 av_push(PL_regex_padav,repointer);
2141 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2142 PL_regex_pad = AvARRAY(PL_regex_padav);
2146 PM_SETRE(PL_reg_curpm, prog);
2147 PL_reg_oldcurpm = PL_curpm;
2148 PL_curpm = PL_reg_curpm;
2149 if (RX_MATCH_COPIED(prog)) {
2150 /* Here is a serious problem: we cannot rewrite subbeg,
2151 since it may be needed if this match fails. Thus
2152 $` inside (?{}) could fail... */
2153 PL_reg_oldsaved = prog->subbeg;
2154 PL_reg_oldsavedlen = prog->sublen;
2155 #ifdef PERL_OLD_COPY_ON_WRITE
2156 PL_nrs = prog->saved_copy;
2158 RX_MATCH_COPIED_off(prog);
2161 PL_reg_oldsaved = NULL;
2162 prog->subbeg = PL_bostr;
2163 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2165 DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2166 prog->startp[0] = *startpos - PL_bostr;
2167 PL_reginput = *startpos;
2168 PL_reglastparen = &prog->lastparen;
2169 PL_reglastcloseparen = &prog->lastcloseparen;
2170 prog->lastparen = 0;
2171 prog->lastcloseparen = 0;
2173 PL_regstartp = prog->startp;
2174 PL_regendp = prog->endp;
2175 if (PL_reg_start_tmpl <= prog->nparens) {
2176 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2177 if(PL_reg_start_tmp)
2178 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2180 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2183 /* XXXX What this code is doing here?!!! There should be no need
2184 to do this again and again, PL_reglastparen should take care of
2187 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2188 * Actually, the code in regcppop() (which Ilya may be meaning by
2189 * PL_reglastparen), is not needed at all by the test suite
2190 * (op/regexp, op/pat, op/split), but that code is needed, oddly
2191 * enough, for building DynaLoader, or otherwise this
2192 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2193 * will happen. Meanwhile, this code *is* needed for the
2194 * above-mentioned test suite tests to succeed. The common theme
2195 * on those tests seems to be returning null fields from matches.
2200 if (prog->nparens) {
2202 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2209 if (regmatch(reginfo, prog->program + 1)) {
2210 prog->endp[0] = PL_reginput - PL_bostr;
2213 if (reginfo->cutpoint)
2214 *startpos= reginfo->cutpoint;
2215 REGCP_UNWIND(lastcp);
2220 #define sayYES goto yes
2221 #define sayNO goto no
2222 #define sayNO_SILENT goto no_silent
2224 /* we dont use STMT_START/END here because it leads to
2225 "unreachable code" warnings, which are bogus, but distracting. */
2226 #define CACHEsayNO \
2227 if (ST.cache_mask) \
2228 PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2231 /* this is used to determine how far from the left messages like
2232 'failed...' are printed. It should be set such that messages
2233 are inline with the regop output that created them.
2235 #define REPORT_CODE_OFF 32
2238 /* Make sure there is a test for this +1 options in re_tests */
2239 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2241 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2242 #define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
2244 #define SLAB_FIRST(s) (&(s)->states[0])
2245 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2247 /* grab a new slab and return the first slot in it */
2249 STATIC regmatch_state *
2252 #if PERL_VERSION < 9
2255 regmatch_slab *s = PL_regmatch_slab->next;
2257 Newx(s, 1, regmatch_slab);
2258 s->prev = PL_regmatch_slab;
2260 PL_regmatch_slab->next = s;
2262 PL_regmatch_slab = s;
2263 return SLAB_FIRST(s);
2267 /* push a new state then goto it */
2269 #define PUSH_STATE_GOTO(state, node) \
2271 st->resume_state = state; \
2274 /* push a new state with success backtracking, then goto it */
2276 #define PUSH_YES_STATE_GOTO(state, node) \
2278 st->resume_state = state; \
2279 goto push_yes_state;
2285 regmatch() - main matching routine
2287 This is basically one big switch statement in a loop. We execute an op,
2288 set 'next' to point the next op, and continue. If we come to a point which
2289 we may need to backtrack to on failure such as (A|B|C), we push a
2290 backtrack state onto the backtrack stack. On failure, we pop the top
2291 state, and re-enter the loop at the state indicated. If there are no more
2292 states to pop, we return failure.
2294 Sometimes we also need to backtrack on success; for example /A+/, where
2295 after successfully matching one A, we need to go back and try to
2296 match another one; similarly for lookahead assertions: if the assertion
2297 completes successfully, we backtrack to the state just before the assertion
2298 and then carry on. In these cases, the pushed state is marked as
2299 'backtrack on success too'. This marking is in fact done by a chain of
2300 pointers, each pointing to the previous 'yes' state. On success, we pop to
2301 the nearest yes state, discarding any intermediate failure-only states.
2302 Sometimes a yes state is pushed just to force some cleanup code to be
2303 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2304 it to free the inner regex.
2306 Note that failure backtracking rewinds the cursor position, while
2307 success backtracking leaves it alone.
2309 A pattern is complete when the END op is executed, while a subpattern
2310 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2311 ops trigger the "pop to last yes state if any, otherwise return true"
2314 A common convention in this function is to use A and B to refer to the two
2315 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2316 the subpattern to be matched possibly multiple times, while B is the entire
2317 rest of the pattern. Variable and state names reflect this convention.
2319 The states in the main switch are the union of ops and failure/success of
2320 substates associated with with that op. For example, IFMATCH is the op
2321 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2322 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2323 successfully matched A and IFMATCH_A_fail is a state saying that we have
2324 just failed to match A. Resume states always come in pairs. The backtrack
2325 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2326 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2327 on success or failure.
2329 The struct that holds a backtracking state is actually a big union, with
2330 one variant for each major type of op. The variable st points to the
2331 top-most backtrack struct. To make the code clearer, within each
2332 block of code we #define ST to alias the relevant union.
2334 Here's a concrete example of a (vastly oversimplified) IFMATCH
2340 #define ST st->u.ifmatch
2342 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2343 ST.foo = ...; // some state we wish to save
2345 // push a yes backtrack state with a resume value of
2346 // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2348 PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2351 case IFMATCH_A: // we have successfully executed A; now continue with B
2353 bar = ST.foo; // do something with the preserved value
2356 case IFMATCH_A_fail: // A failed, so the assertion failed
2357 ...; // do some housekeeping, then ...
2358 sayNO; // propagate the failure
2365 For any old-timers reading this who are familiar with the old recursive
2366 approach, the code above is equivalent to:
2368 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2377 ...; // do some housekeeping, then ...
2378 sayNO; // propagate the failure
2381 The topmost backtrack state, pointed to by st, is usually free. If you
2382 want to claim it, populate any ST.foo fields in it with values you wish to
2383 save, then do one of
2385 PUSH_STATE_GOTO(resume_state, node);
2386 PUSH_YES_STATE_GOTO(resume_state, node);
2388 which sets that backtrack state's resume value to 'resume_state', pushes a
2389 new free entry to the top of the backtrack stack, then goes to 'node'.
2390 On backtracking, the free slot is popped, and the saved state becomes the
2391 new free state. An ST.foo field in this new top state can be temporarily
2392 accessed to retrieve values, but once the main loop is re-entered, it
2393 becomes available for reuse.
2395 Note that the depth of the backtrack stack constantly increases during the
2396 left-to-right execution of the pattern, rather than going up and down with
2397 the pattern nesting. For example the stack is at its maximum at Z at the
2398 end of the pattern, rather than at X in the following:
2400 /(((X)+)+)+....(Y)+....Z/
2402 The only exceptions to this are lookahead/behind assertions and the cut,
2403 (?>A), which pop all the backtrack states associated with A before
2406 Bascktrack state structs are allocated in slabs of about 4K in size.
2407 PL_regmatch_state and st always point to the currently active state,
2408 and PL_regmatch_slab points to the slab currently containing
2409 PL_regmatch_state. The first time regmatch() is called, the first slab is
2410 allocated, and is never freed until interpreter destruction. When the slab
2411 is full, a new one is allocated and chained to the end. At exit from
2412 regmatch(), slabs allocated since entry are freed.
2417 #define DEBUG_STATE_pp(pp) \
2419 DUMP_EXEC_POS(locinput, scan, do_utf8); \
2420 PerlIO_printf(Perl_debug_log, \
2421 " %*s"pp" %s%s%s%s%s\n", \
2423 reg_name[st->resume_state], \
2424 ((st==yes_state||st==mark_state) ? "[" : ""), \
2425 ((st==yes_state) ? "Y" : ""), \
2426 ((st==mark_state) ? "M" : ""), \
2427 ((st==yes_state||st==mark_state) ? "]" : "") \
2432 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2437 S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
2438 const char *start, const char *end, const char *blurb)
2440 const bool utf8_pat= prog->reganch & ROPT_UTF8 ? 1 : 0;
2444 RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2445 prog->precomp, prog->prelen, 60);
2447 RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2448 start, end - start, 60);
2450 PerlIO_printf(Perl_debug_log,
2451 "%s%s REx%s %s against %s\n",
2452 PL_colors[4], blurb, PL_colors[5], s0, s1);
2454 if (do_utf8||utf8_pat)
2455 PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2456 utf8_pat ? "pattern" : "",
2457 utf8_pat && do_utf8 ? " and " : "",
2458 do_utf8 ? "string" : ""
2464 S_dump_exec_pos(pTHX_ const char *locinput,
2465 const regnode *scan,
2466 const char *loc_regeol,
2467 const char *loc_bostr,
2468 const char *loc_reg_starttry,
2471 const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2472 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2473 int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2474 /* The part of the string before starttry has one color
2475 (pref0_len chars), between starttry and current
2476 position another one (pref_len - pref0_len chars),
2477 after the current position the third one.
2478 We assume that pref0_len <= pref_len, otherwise we
2479 decrease pref0_len. */
2480 int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2481 ? (5 + taill) - l : locinput - loc_bostr;
2484 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2486 pref0_len = pref_len - (locinput - loc_reg_starttry);
2487 if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2488 l = ( loc_regeol - locinput > (5 + taill) - pref_len
2489 ? (5 + taill) - pref_len : loc_regeol - locinput);
2490 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2494 if (pref0_len > pref_len)
2495 pref0_len = pref_len;
2497 const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2499 RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2500 (locinput - pref_len),pref0_len, 60, 4, 5);
2502 RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2503 (locinput - pref_len + pref0_len),
2504 pref_len - pref0_len, 60, 2, 3);
2506 RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2507 locinput, loc_regeol - locinput, 10, 0, 1);
2509 const STRLEN tlen=len0+len1+len2;
2510 PerlIO_printf(Perl_debug_log,
2511 "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2512 (IV)(locinput - loc_bostr),
2515 (docolor ? "" : "> <"),
2517 (int)(tlen > 19 ? 0 : 19 - tlen),
2524 /* reg_check_named_buff_matched()
2525 * Checks to see if a named buffer has matched. The data array of
2526 * buffer numbers corresponding to the buffer is expected to reside
2527 * in the regexp->data->data array in the slot stored in the ARG() of
2528 * node involved. Note that this routine doesn't actually care about the
2529 * name, that information is not preserved from compilation to execution.
2530 * Returns the index of the leftmost defined buffer with the given name
2531 * or 0 if non of the buffers matched.
2534 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) {
2536 SV *sv_dat=(SV*)rex->data->data[ ARG( scan ) ];
2537 I32 *nums=(I32*)SvPVX(sv_dat);
2538 for ( n=0; n<SvIVX(sv_dat); n++ ) {
2539 if ((I32)*PL_reglastparen >= nums[n] &&
2540 PL_regendp[nums[n]] != -1)
2548 STATIC I32 /* 0 failure, 1 success */
2549 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2551 #if PERL_VERSION < 9
2555 register const bool do_utf8 = PL_reg_match_utf8;
2556 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2558 regexp *rex = reginfo->prog;
2560 regmatch_slab *orig_slab;
2561 regmatch_state *orig_state;
2563 /* the current state. This is a cached copy of PL_regmatch_state */
2564 register regmatch_state *st;
2566 /* cache heavy used fields of st in registers */
2567 register regnode *scan;
2568 register regnode *next;
2569 register U32 n = 0; /* general value; init to avoid compiler warning */
2570 register I32 ln = 0; /* len or last; init to avoid compiler warning */
2571 register char *locinput = PL_reginput;
2572 register I32 nextchr; /* is always set to UCHARAT(locinput) */
2574 bool result = 0; /* return value of S_regmatch */
2575 int depth = 0; /* depth of backtrack stack */
2576 int nochange_depth = 0; /* depth of GOSUB recursion with nochange*/
2577 regmatch_state *yes_state = NULL; /* state to pop to on success of
2579 /* mark_state piggy backs on the yes_state logic so that when we unwind
2580 the stack on success we can update the mark_state as we go */
2581 regmatch_state *mark_state = NULL; /* last mark state we have seen */
2583 regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2584 struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
2586 bool no_final = 0; /* prevent failure from backtracking? */
2587 bool do_cutgroup = 0; /* no_final only until next branch/trie entry */
2588 char *startpoint = PL_reginput;
2589 SV *popmark = NULL; /* are we looking for a mark? */
2590 SV *sv_commit = NULL; /* last mark name seen in failure */
2591 SV *sv_yes_mark = NULL; /* last mark name we have seen
2592 during a successfull match */
2593 U32 lastopen = 0; /* last open we saw */
2594 bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2596 /* these three flags are set by various ops to signal information to
2597 * the very next op. They have a useful lifetime of exactly one loop
2598 * iteration, and are not preserved or restored by state pushes/pops
2600 bool sw = 0; /* the condition value in (?(cond)a|b) */
2601 bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
2602 int logical = 0; /* the following EVAL is:
2606 or the following IFMATCH/UNLESSM is:
2607 false: plain (?=foo)
2608 true: used as a condition: (?(?=foo))
2612 GET_RE_DEBUG_FLAGS_DECL;
2616 PerlIO_printf(Perl_debug_log,"regmatch start\n");
2618 /* on first ever call to regmatch, allocate first slab */
2619 if (!PL_regmatch_slab) {
2620 Newx(PL_regmatch_slab, 1, regmatch_slab);
2621 PL_regmatch_slab->prev = NULL;
2622 PL_regmatch_slab->next = NULL;
2623 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2626 /* remember current high-water mark for exit */
2627 /* XXX this should be done with SAVE* instead */
2628 orig_slab = PL_regmatch_slab;
2629 orig_state = PL_regmatch_state;
2631 /* grab next free state slot */
2632 st = ++PL_regmatch_state;
2633 if (st > SLAB_LAST(PL_regmatch_slab))
2634 st = PL_regmatch_state = S_push_slab(aTHX);
2636 /* Note that nextchr is a byte even in UTF */
2637 nextchr = UCHARAT(locinput);
2639 while (scan != NULL) {
2642 SV * const prop = sv_newmortal();
2643 regnode *rnext=regnext(scan);
2644 DUMP_EXEC_POS( locinput, scan, do_utf8 );
2645 regprop(rex, prop, scan);
2647 PerlIO_printf(Perl_debug_log,
2648 "%3"IVdf":%*s%s(%"IVdf")\n",
2649 (IV)(scan - rex->program), depth*2, "",
2651 (PL_regkind[OP(scan)] == END || !rnext) ?
2652 0 : (IV)(rnext - rex->program));
2655 next = scan + NEXT_OFF(scan);
2658 state_num = OP(scan);
2661 switch (state_num) {
2663 if (locinput == PL_bostr)
2665 /* reginfo->till = reginfo->bol; */
2670 if (locinput == PL_bostr ||
2671 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2677 if (locinput == PL_bostr)
2681 if (locinput == reginfo->ganch)
2687 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2692 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2694 if (PL_regeol - locinput > 1)
2698 if (PL_regeol != locinput)
2702 if (!nextchr && locinput >= PL_regeol)
2705 locinput += PL_utf8skip[nextchr];
2706 if (locinput > PL_regeol)
2708 nextchr = UCHARAT(locinput);
2711 nextchr = UCHARAT(++locinput);
2714 if (!nextchr && locinput >= PL_regeol)
2716 nextchr = UCHARAT(++locinput);
2719 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2722 locinput += PL_utf8skip[nextchr];
2723 if (locinput > PL_regeol)
2725 nextchr = UCHARAT(locinput);
2728 nextchr = UCHARAT(++locinput);
2732 #define ST st->u.trie
2734 /* In this case the charclass data is available inline so
2735 we can fail fast without a lot of extra overhead.
2737 if (scan->flags == EXACT || !do_utf8) {
2738 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
2740 PerlIO_printf(Perl_debug_log,
2741 "%*s %sfailed to match trie start class...%s\n",
2742 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2751 /* what type of TRIE am I? (utf8 makes this contextual) */
2752 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2753 trie_type = do_utf8 ?
2754 (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2757 /* what trie are we using right now */
2758 reg_trie_data * const trie
2759 = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2760 U32 state = trie->startstate;
2762 if (trie->bitmap && trie_type != trie_utf8_fold &&
2763 !TRIE_BITMAP_TEST(trie,*locinput)
2765 if (trie->states[ state ].wordnum) {
2767 PerlIO_printf(Perl_debug_log,
2768 "%*s %smatched empty string...%s\n",
2769 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2774 PerlIO_printf(Perl_debug_log,
2775 "%*s %sfailed to match trie start class...%s\n",
2776 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2783 U8 *uc = ( U8* )locinput;
2787 U8 *uscan = (U8*)NULL;
2789 SV *sv_accept_buff = NULL;
2790 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2792 ST.accepted = 0; /* how many accepting states we have seen */
2794 ST.jump = trie->jump;
2798 traverse the TRIE keeping track of all accepting states
2799 we transition through until we get to a failing node.
2802 while ( state && uc <= (U8*)PL_regeol ) {
2803 U32 base = trie->states[ state ].trans.base;
2806 /* We use charid to hold the wordnum as we don't use it
2807 for charid until after we have done the wordnum logic.
2808 We define an alias just so that the wordnum logic reads
2811 #define got_wordnum charid
2812 got_wordnum = trie->states[ state ].wordnum;
2814 if ( got_wordnum ) {
2815 if ( ! ST.accepted ) {
2818 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2819 sv_accept_buff=newSV(bufflen *
2820 sizeof(reg_trie_accepted) - 1);
2821 SvCUR_set(sv_accept_buff, 0);
2822 SvPOK_on(sv_accept_buff);
2823 sv_2mortal(sv_accept_buff);
2826 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2829 if (ST.accepted >= bufflen) {
2831 ST.accept_buff =(reg_trie_accepted*)
2832 SvGROW(sv_accept_buff,
2833 bufflen * sizeof(reg_trie_accepted));
2835 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2836 + sizeof(reg_trie_accepted));
2839 ST.accept_buff[ST.accepted].wordnum = got_wordnum;
2840 ST.accept_buff[ST.accepted].endpos = uc;
2842 } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
2846 DEBUG_TRIE_EXECUTE_r({
2847 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
2848 PerlIO_printf( Perl_debug_log,
2849 "%*s %sState: %4"UVxf" Accepted: %4"UVxf" ",
2850 2+depth * 2, "", PL_colors[4],
2851 (UV)state, (UV)ST.accepted );
2855 REXEC_TRIE_READ_CHAR(trie_type, trie, uc, uscan, len,
2856 uvc, charid, foldlen, foldbuf, uniflags);
2859 (base + charid > trie->uniquecharcount )
2860 && (base + charid - 1 - trie->uniquecharcount
2862 && trie->trans[base + charid - 1 -
2863 trie->uniquecharcount].check == state)
2865 state = trie->trans[base + charid - 1 -
2866 trie->uniquecharcount ].next;
2877 DEBUG_TRIE_EXECUTE_r(
2878 PerlIO_printf( Perl_debug_log,
2879 "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
2880 charid, uvc, (UV)state, PL_colors[5] );
2887 PerlIO_printf( Perl_debug_log,
2888 "%*s %sgot %"IVdf" possible matches%s\n",
2889 REPORT_CODE_OFF + depth * 2, "",
2890 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
2895 case TRIE_next_fail: /* we failed - try next alterative */
2900 if ( ST.accepted == 1 ) {
2901 /* only one choice left - just continue */
2903 reg_trie_data * const trie
2904 = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2905 SV ** const tmp = RX_DEBUG(reginfo->prog)
2906 ? av_fetch( trie->words, ST.accept_buff[ 0 ].wordnum-1, 0 )
2908 PerlIO_printf( Perl_debug_log,
2909 "%*s %sonly one match left: #%d <%s>%s\n",
2910 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
2911 ST.accept_buff[ 0 ].wordnum,
2912 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2915 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
2916 /* in this case we free tmps/leave before we call regmatch
2917 as we wont be using accept_buff again. */
2919 locinput = PL_reginput;
2920 nextchr = UCHARAT(locinput);
2921 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
2924 scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
2925 if (!has_cutgroup) {
2930 PUSH_YES_STATE_GOTO(TRIE_next, scan);
2933 continue; /* execute rest of RE */
2936 if (!ST.accepted-- ) {
2938 PerlIO_printf( Perl_debug_log,
2939 "%*s %sTRIE failed...%s\n",
2940 REPORT_CODE_OFF+depth*2, "",
2950 There are at least two accepting states left. Presumably
2951 the number of accepting states is going to be low,
2952 typically two. So we simply scan through to find the one
2953 with lowest wordnum. Once we find it, we swap the last
2954 state into its place and decrement the size. We then try to
2955 match the rest of the pattern at the point where the word
2956 ends. If we succeed, control just continues along the
2957 regex; if we fail we return here to try the next accepting
2964 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
2965 DEBUG_TRIE_EXECUTE_r(
2966 PerlIO_printf( Perl_debug_log,
2967 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
2968 REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
2969 (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
2970 ST.accept_buff[ cur ].wordnum, PL_colors[5] );
2973 if (ST.accept_buff[cur].wordnum <
2974 ST.accept_buff[best].wordnum)
2979 reg_trie_data * const trie
2980 = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
2981 SV ** const tmp = RX_DEBUG(reginfo->prog)
2982 ? av_fetch( trie->words, ST.accept_buff[ best ].wordnum - 1, 0 )
2984 regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
2986 ST.me + ST.jump[ST.accept_buff[best].wordnum];
2987 PerlIO_printf( Perl_debug_log,
2988 "%*s %strying alternation #%d <%s> at node #%d %s\n",
2989 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
2990 ST.accept_buff[best].wordnum,
2991 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2992 REG_NODE_NUM(nextop),
2996 if ( best<ST.accepted ) {
2997 reg_trie_accepted tmp = ST.accept_buff[ best ];
2998 ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
2999 ST.accept_buff[ ST.accepted ] = tmp;
3002 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3003 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3007 scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3011 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3014 PUSH_STATE_GOTO(TRIE_next, scan);
3027 char *s = STRING(scan);
3029 if (do_utf8 != UTF) {
3030 /* The target and the pattern have differing utf8ness. */
3032 const char * const e = s + ln;
3035 /* The target is utf8, the pattern is not utf8. */
3040 if (NATIVE_TO_UNI(*(U8*)s) !=
3041 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3049 /* The target is not utf8, the pattern is utf8. */
3054 if (NATIVE_TO_UNI(*((U8*)l)) !=
3055 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3063 nextchr = UCHARAT(locinput);
3066 /* The target and the pattern have the same utf8ness. */
3067 /* Inline the first character, for speed. */
3068 if (UCHARAT(s) != nextchr)
3070 if (PL_regeol - locinput < ln)
3072 if (ln > 1 && memNE(s, locinput, ln))
3075 nextchr = UCHARAT(locinput);
3079 PL_reg_flags |= RF_tainted;
3082 char * const s = STRING(scan);
3085 if (do_utf8 || UTF) {
3086 /* Either target or the pattern are utf8. */
3087 const char * const l = locinput;
3088 char *e = PL_regeol;
3090 if (ibcmp_utf8(s, 0, ln, (bool)UTF,
3091 l, &e, 0, do_utf8)) {
3092 /* One more case for the sharp s:
3093 * pack("U0U*", 0xDF) =~ /ss/i,
3094 * the 0xC3 0x9F are the UTF-8
3095 * byte sequence for the U+00DF. */
3097 toLOWER(s[0]) == 's' &&
3099 toLOWER(s[1]) == 's' &&
3106 nextchr = UCHARAT(locinput);
3110 /* Neither the target and the pattern are utf8. */
3112 /* Inline the first character, for speed. */
3113 if (UCHARAT(s) != nextchr &&
3114 UCHARAT(s) != ((OP(scan) == EXACTF)
3115 ? PL_fold : PL_fold_locale)[nextchr])
3117 if (PL_regeol - locinput < ln)
3119 if (ln > 1 && (OP(scan) == EXACTF
3120 ? ibcmp(s, locinput, ln)
3121 : ibcmp_locale(s, locinput, ln)))
3124 nextchr = UCHARAT(locinput);
3129 STRLEN inclasslen = PL_regeol - locinput;
3131 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3133 if (locinput >= PL_regeol)
3135 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3136 nextchr = UCHARAT(locinput);
3141 nextchr = UCHARAT(locinput);
3142 if (!REGINCLASS(rex, scan, (U8*)locinput))
3144 if (!nextchr && locinput >= PL_regeol)
3146 nextchr = UCHARAT(++locinput);
3150 /* If we might have the case of the German sharp s
3151 * in a casefolding Unicode character class. */
3153 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3154 locinput += SHARP_S_SKIP;
3155 nextchr = UCHARAT(locinput);
3161 PL_reg_flags |= RF_tainted;
3167 LOAD_UTF8_CHARCLASS_ALNUM();
3168 if (!(OP(scan) == ALNUM
3169 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3170 : isALNUM_LC_utf8((U8*)locinput)))
3174 locinput += PL_utf8skip[nextchr];
3175 nextchr = UCHARAT(locinput);
3178 if (!(OP(scan) == ALNUM
3179 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3181 nextchr = UCHARAT(++locinput);
3184 PL_reg_flags |= RF_tainted;
3187 if (!nextchr && locinput >= PL_regeol)
3190 LOAD_UTF8_CHARCLASS_ALNUM();
3191 if (OP(scan) == NALNUM
3192 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3193 : isALNUM_LC_utf8((U8*)locinput))
3197 locinput += PL_utf8skip[nextchr];
3198 nextchr = UCHARAT(locinput);
3201 if (OP(scan) == NALNUM
3202 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3204 nextchr = UCHARAT(++locinput);
3208 PL_reg_flags |= RF_tainted;
3212 /* was last char in word? */
3214 if (locinput == PL_bostr)
3217 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3219 ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3221 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3222 ln = isALNUM_uni(ln);
3223 LOAD_UTF8_CHARCLASS_ALNUM();
3224 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3227 ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3228 n = isALNUM_LC_utf8((U8*)locinput);
3232 ln = (locinput != PL_bostr) ?
3233 UCHARAT(locinput - 1) : '\n';
3234 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3236 n = isALNUM(nextchr);
3239 ln = isALNUM_LC(ln);
3240 n = isALNUM_LC(nextchr);
3243 if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3244 OP(scan) == BOUNDL))
3248 PL_reg_flags |= RF_tainted;
3254 if (UTF8_IS_CONTINUED(nextchr)) {
3255 LOAD_UTF8_CHARCLASS_SPACE();
3256 if (!(OP(scan) == SPACE
3257 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3258 : isSPACE_LC_utf8((U8*)locinput)))
3262 locinput += PL_utf8skip[nextchr];
3263 nextchr = UCHARAT(locinput);
3266 if (!(OP(scan) == SPACE
3267 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3269 nextchr = UCHARAT(++locinput);
3272 if (!(OP(scan) == SPACE
3273 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3275 nextchr = UCHARAT(++locinput);
3279 PL_reg_flags |= RF_tainted;
3282 if (!nextchr && locinput >= PL_regeol)
3285 LOAD_UTF8_CHARCLASS_SPACE();
3286 if (OP(scan) == NSPACE
3287 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3288 : isSPACE_LC_utf8((U8*)locinput))
3292 locinput += PL_utf8skip[nextchr];
3293 nextchr = UCHARAT(locinput);
3296 if (OP(scan) == NSPACE
3297 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3299 nextchr = UCHARAT(++locinput);
3302 PL_reg_flags |= RF_tainted;
3308 LOAD_UTF8_CHARCLASS_DIGIT();
3309 if (!(OP(scan) == DIGIT
3310 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3311 : isDIGIT_LC_utf8((U8*)locinput)))
3315 locinput += PL_utf8skip[nextchr];
3316 nextchr = UCHARAT(locinput);
3319 if (!(OP(scan) == DIGIT
3320 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3322 nextchr = UCHARAT(++locinput);
3325 PL_reg_flags |= RF_tainted;
3328 if (!nextchr && locinput >= PL_regeol)
3331 LOAD_UTF8_CHARCLASS_DIGIT();
3332 if (OP(scan) == NDIGIT
3333 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3334 : isDIGIT_LC_utf8((U8*)locinput))
3338 locinput += PL_utf8skip[nextchr];
3339 nextchr = UCHARAT(locinput);
3342 if (OP(scan) == NDIGIT
3343 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3345 nextchr = UCHARAT(++locinput);
3348 if (locinput >= PL_regeol)
3351 LOAD_UTF8_CHARCLASS_MARK();
3352 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3354 locinput += PL_utf8skip[nextchr];
3355 while (locinput < PL_regeol &&
3356 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3357 locinput += UTF8SKIP(locinput);
3358 if (locinput > PL_regeol)
3363 nextchr = UCHARAT(locinput);
3370 PL_reg_flags |= RF_tainted;
3375 n = reg_check_named_buff_matched(rex,scan);
3378 type = REF + ( type - NREF );
3385 PL_reg_flags |= RF_tainted;
3389 n = ARG(scan); /* which paren pair */
3392 ln = PL_regstartp[n];
3393 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3394 if (*PL_reglastparen < n || ln == -1)
3395 sayNO; /* Do not match unless seen CLOSEn. */
3396 if (ln == PL_regendp[n])
3400 if (do_utf8 && type != REF) { /* REF can do byte comparison */
3402 const char *e = PL_bostr + PL_regendp[n];
3404 * Note that we can't do the "other character" lookup trick as
3405 * in the 8-bit case (no pun intended) because in Unicode we
3406 * have to map both upper and title case to lower case.
3410 STRLEN ulen1, ulen2;
3411 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3412 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3416 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3417 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3418 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3425 nextchr = UCHARAT(locinput);
3429 /* Inline the first character, for speed. */
3430 if (UCHARAT(s) != nextchr &&
3432 (UCHARAT(s) != (type == REFF
3433 ? PL_fold : PL_fold_locale)[nextchr])))
3435 ln = PL_regendp[n] - ln;
3436 if (locinput + ln > PL_regeol)
3438 if (ln > 1 && (type == REF
3439 ? memNE(s, locinput, ln)
3441 ? ibcmp(s, locinput, ln)
3442 : ibcmp_locale(s, locinput, ln))))
3445 nextchr = UCHARAT(locinput);
3455 #define ST st->u.eval
3459 regnode *startpoint;
3462 case GOSUB: /* /(...(?1))/ */
3463 if (cur_eval && cur_eval->locinput==locinput) {
3464 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3465 Perl_croak(aTHX_ "Infinite recursion in regex");
3466 if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH )
3468 "Pattern subroutine nesting without pos change"
3469 " exceeded limit in regex");
3474 (void)ReREFCNT_inc(rex);
3475 if (OP(scan)==GOSUB) {
3476 startpoint = scan + ARG2L(scan);
3477 ST.close_paren = ARG(scan);
3479 startpoint = re->program+1;
3482 goto eval_recurse_doit;
3484 case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
3485 if (cur_eval && cur_eval->locinput==locinput) {
3486 if ( ++nochange_depth > MAX_RECURSE_EVAL_NOCHANGE_DEPTH )
3487 Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3492 /* execute the code in the {...} */
3494 SV ** const before = SP;
3495 OP_4tree * const oop = PL_op;
3496 COP * const ocurcop = PL_curcop;
3500 PL_op = (OP_4tree*)rex->data->data[n];
3501 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3502 " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3503 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3504 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3506 CALLRUNOPS(aTHX); /* Scalar context. */
3509 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
3516 PAD_RESTORE_LOCAL(old_comppad);
3517 PL_curcop = ocurcop;
3520 sv_setsv(save_scalar(PL_replgv), ret);
3524 if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3527 /* extract RE object from returned value; compiling if
3532 if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3533 mg = mg_find(sv, PERL_MAGIC_qr);
3534 else if (SvSMAGICAL(ret)) {
3535 if (SvGMAGICAL(ret))
3536 sv_unmagic(ret, PERL_MAGIC_qr);
3538 mg = mg_find(ret, PERL_MAGIC_qr);
3542 re = (regexp *)mg->mg_obj;
3543 (void)ReREFCNT_inc(re);
3547 const char * const t = SvPV_const(ret, len);
3549 const I32 osize = PL_regsize;
3552 if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3553 re = CALLREGCOMP((char*)t, (char*)t + len, &pm);
3555 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3557 sv_magic(ret,(SV*)ReREFCNT_inc(re),
3563 debug_start_match(re, do_utf8, locinput, PL_regeol,
3564 "Matching embedded");
3566 startpoint = re->program + 1;
3567 ST.close_paren = 0; /* only used for GOSUB */
3568 /* borrowed from regtry */
3569 if (PL_reg_start_tmpl <= re->nparens) {
3570 PL_reg_start_tmpl = re->nparens*3/2 + 3;
3571 if(PL_reg_start_tmp)
3572 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3574 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3577 eval_recurse_doit: /* Share code with GOSUB below this line */
3578 /* run the pattern returned from (??{...}) */
3579 ST.cp = regcppush(0); /* Save *all* the positions. */
3580 REGCP_SET(ST.lastcp);
3582 PL_regstartp = re->startp; /* essentially NOOP on GOSUB */
3583 PL_regendp = re->endp; /* essentially NOOP on GOSUB */
3585 *PL_reglastparen = 0;
3586 *PL_reglastcloseparen = 0;
3587 PL_reginput = locinput;
3590 /* XXXX This is too dramatic a measure... */
3593 ST.toggle_reg_flags = PL_reg_flags;
3594 if (re->reganch & ROPT_UTF8)
3595 PL_reg_flags |= RF_utf8;
3597 PL_reg_flags &= ~RF_utf8;
3598 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3601 ST.prev_curlyx = cur_curlyx;
3605 ST.prev_eval = cur_eval;
3607 /* now continue from first node in postoned RE */
3608 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
3611 /* logical is 1, /(?(?{...})X|Y)/ */
3612 sw = (bool)SvTRUE(ret);
3617 case EVAL_AB: /* cleanup after a successful (??{A})B */
3618 /* note: this is called twice; first after popping B, then A */
3619 PL_reg_flags ^= ST.toggle_reg_flags;
3623 cur_eval = ST.prev_eval;
3624 cur_curlyx = ST.prev_curlyx;
3625 /* XXXX This is too dramatic a measure... */
3630 case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3631 /* note: this is called twice; first after popping B, then A */
3632 PL_reg_flags ^= ST.toggle_reg_flags;
3635 PL_reginput = locinput;
3636 REGCP_UNWIND(ST.lastcp);
3638 cur_eval = ST.prev_eval;
3639 cur_curlyx = ST.prev_curlyx;
3640 /* XXXX This is too dramatic a measure... */
3646 n = ARG(scan); /* which paren pair */
3647 PL_reg_start_tmp[n] = locinput;
3653 n = ARG(scan); /* which paren pair */
3654 PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3655 PL_regendp[n] = locinput - PL_bostr;
3656 /*if (n > PL_regsize)
3658 if (n > *PL_reglastparen)
3659 *PL_reglastparen = n;
3660 *PL_reglastcloseparen = n;
3661 if (cur_eval && cur_eval->u.eval.close_paren == n) {
3669 cursor && OP(cursor)!=END;
3670 cursor=regnext(cursor))
3672 if ( OP(cursor)==CLOSE ){
3674 if ( n <= lastopen ) {
3675 PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3676 PL_regendp[n] = locinput - PL_bostr;
3677 /*if (n > PL_regsize)
3679 if (n > *PL_reglastparen)
3680 *PL_reglastparen = n;
3681 *PL_reglastcloseparen = n;
3682 if ( n == ARG(scan) || (cur_eval &&
3683 cur_eval->u.eval.close_paren == n))
3692 n = ARG(scan); /* which paren pair */
3693 sw = (bool)(*PL_reglastparen >= n && PL_regendp[n] != -1);
3696 /* reg_check_named_buff_matched returns 0 for no match */
3697 sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
3701 sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
3707 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3709 next = NEXTOPER(NEXTOPER(scan));
3711 next = scan + ARG(scan);
3712 if (OP(next) == IFTHEN) /* Fake one. */
3713 next = NEXTOPER(NEXTOPER(next));
3717 logical = scan->flags;
3720 /*******************************************************************
3722 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
3723 pattern, where A and B are subpatterns. (For simple A, CURLYM or
3724 STAR/PLUS/CURLY/CURLYN are used instead.)
3726 A*B is compiled as <CURLYX><A><WHILEM><B>
3728 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
3729 state, which contains the current count, initialised to -1. It also sets
3730 cur_curlyx to point to this state, with any previous value saved in the
3733 CURLYX then jumps straight to the WHILEM op, rather than executing A,
3734 since the pattern may possibly match zero times (i.e. it's a while {} loop
3735 rather than a do {} while loop).
3737 Each entry to WHILEM represents a successful match of A. The count in the
3738 CURLYX block is incremented, another WHILEM state is pushed, and execution
3739 passes to A or B depending on greediness and the current count.
3741 For example, if matching against the string a1a2a3b (where the aN are
3742 substrings that match /A/), then the match progresses as follows: (the
3743 pushed states are interspersed with the bits of strings matched so far):
3746 <CURLYX cnt=0><WHILEM>
3747 <CURLYX cnt=1><WHILEM> a1 <WHILEM>
3748 <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
3749 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
3750 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
3752 (Contrast this with something like CURLYM, which maintains only a single
3756 a1 <CURLYM cnt=1> a2
3757 a1 a2 <CURLYM cnt=2> a3
3758 a1 a2 a3 <CURLYM cnt=3> b
3761 Each WHILEM state block marks a point to backtrack to upon partial failure
3762 of A or B, and also contains some minor state data related to that
3763 iteration. The CURLYX block, pointed to by cur_curlyx, contains the
3764 overall state, such as the count, and pointers to the A and B ops.
3766 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
3767 must always point to the *current* CURLYX block, the rules are:
3769 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
3770 and set cur_curlyx to point the new block.
3772 When popping the CURLYX block after a successful or unsuccessful match,
3773 restore the previous cur_curlyx.
3775 When WHILEM is about to execute B, save the current cur_curlyx, and set it
3776 to the outer one saved in the CURLYX block.
3778 When popping the WHILEM block after a successful or unsuccessful B match,
3779 restore the previous cur_curlyx.
3781 Here's an example for the pattern (AI* BI)*BO
3782 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
3785 curlyx backtrack stack
3786 ------ ---------------
3788 CO <CO prev=NULL> <WO>
3789 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
3790 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
3791 NULL <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
3793 At this point the pattern succeeds, and we work back down the stack to
3794 clean up, restoring as we go:
3796 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
3797 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
3798 CO <CO prev=NULL> <WO>
3801 *******************************************************************/
3803 #define ST st->u.curlyx
3805 case CURLYX: /* start of /A*B/ (for complex A) */
3807 /* No need to save/restore up to this paren */
3808 I32 parenfloor = scan->flags;
3810 assert(next); /* keep Coverity happy */
3811 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3814 /* XXXX Probably it is better to teach regpush to support
3815 parenfloor > PL_regsize... */
3816 if (parenfloor > (I32)*PL_reglastparen)
3817 parenfloor = *PL_reglastparen; /* Pessimization... */
3819 ST.prev_curlyx= cur_curlyx;
3821 ST.cp = PL_savestack_ix;
3823 /* these fields contain the state of the current curly.
3824 * they are accessed by subsequent WHILEMs */
3825 ST.parenfloor = parenfloor;
3826 ST.min = ARG1(scan);
3827 ST.max = ARG2(scan);
3828 ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3832 ST.count = -1; /* this will be updated by WHILEM */
3833 ST.lastloc = NULL; /* this will be updated by WHILEM */
3835 PL_reginput = locinput;
3836 PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
3840 case CURLYX_end: /* just finished matching all of A*B */
3842 cur_curlyx = ST.prev_curlyx;
3846 case CURLYX_end_fail: /* just failed to match all of A*B */
3848 cur_curlyx = ST.prev_curlyx;
3854 #define ST st->u.whilem
3856 case WHILEM: /* just matched an A in /A*B/ (for complex A) */
3858 /* see the discussion above about CURLYX/WHILEM */
3860 assert(cur_curlyx); /* keep Coverity happy */
3861 n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
3862 ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
3863 ST.cache_offset = 0;
3866 PL_reginput = locinput;
3868 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3869 "%*s whilem: matched %ld out of %ld..%ld\n",
3870 REPORT_CODE_OFF+depth*2, "", (long)n,
3871 (long)cur_curlyx->u.curlyx.min,
3872 (long)cur_curlyx->u.curlyx.max)
3875 /* First just match a string of min A's. */
3877 if (n < cur_curlyx->u.curlyx.min) {
3878 cur_curlyx->u.curlyx.lastloc = locinput;
3879 PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
3883 /* If degenerate A matches "", assume A done. */
3885 if (locinput == cur_curlyx->u.curlyx.lastloc) {
3886 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3887 "%*s whilem: empty match detected, trying continuation...\n",
3888 REPORT_CODE_OFF+depth*2, "")
3890 goto do_whilem_B_max;
3893 /* super-linear cache processing */
3897 if (!PL_reg_maxiter) {
3898 /* start the countdown: Postpone detection until we
3899 * know the match is not *that* much linear. */
3900 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3901 /* possible overflow for long strings and many CURLYX's */
3902 if (PL_reg_maxiter < 0)
3903 PL_reg_maxiter = I32_MAX;
3904 PL_reg_leftiter = PL_reg_maxiter;
3907 if (PL_reg_leftiter-- == 0) {
3908 /* initialise cache */
3909 const I32 size = (PL_reg_maxiter + 7)/8;
3910 if (PL_reg_poscache) {
3911 if ((I32)PL_reg_poscache_size < size) {
3912 Renew(PL_reg_poscache, size, char);
3913 PL_reg_poscache_size = size;
3915 Zero(PL_reg_poscache, size, char);
3918 PL_reg_poscache_size = size;
3919 Newxz(PL_reg_poscache, size, char);
3921 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3922 "%swhilem: Detected a super-linear match, switching on caching%s...\n",
3923 PL_colors[4], PL_colors[5])
3927 if (PL_reg_leftiter < 0) {
3928 /* have we already failed at this position? */
3930 offset = (scan->flags & 0xf) - 1
3931 + (locinput - PL_bostr) * (scan->flags>>4);
3932 mask = 1 << (offset % 8);
3934 if (PL_reg_poscache[offset] & mask) {
3935 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
3936 "%*s whilem: (cache) already tried at this position...\n",
3937 REPORT_CODE_OFF+depth*2, "")
3939 sayNO; /* cache records failure */
3941 ST.cache_offset = offset;
3942 ST.cache_mask = mask;
3946 /* Prefer B over A for minimal matching. */
3948 if (cur_curlyx->u.curlyx.minmod) {
3949 ST.save_curlyx = cur_curlyx;
3950 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
3951 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
3952 REGCP_SET(ST.lastcp);
3953 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
3957 /* Prefer A over B for maximal matching. */
3959 if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
3960 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
3961 cur_curlyx->u.curlyx.lastloc = locinput;
3962 REGCP_SET(ST.lastcp);
3963 PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
3966 goto do_whilem_B_max;
3970 case WHILEM_B_min: /* just matched B in a minimal match */
3971 case WHILEM_B_max: /* just matched B in a maximal match */
3972 cur_curlyx = ST.save_curlyx;
3976 case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
3977 cur_curlyx = ST.save_curlyx;
3978 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
3979 cur_curlyx->u.curlyx.count--;
3983 case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
3984 REGCP_UNWIND(ST.lastcp);
3987 case WHILEM_A_pre_fail: /* just failed to match even minimal A */
3988 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
3989 cur_curlyx->u.curlyx.count--;
3993 case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
3994 REGCP_UNWIND(ST.lastcp);
3995 regcppop(rex); /* Restore some previous $<digit>s? */
3996 PL_reginput = locinput;
3997 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
3998 "%*s whilem: failed, trying continuation...\n",
3999 REPORT_CODE_OFF+depth*2, "")
4002 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4003 && ckWARN(WARN_REGEXP)
4004 && !(PL_reg_flags & RF_warned))
4006 PL_reg_flags |= RF_warned;
4007 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4008 "Complex regular subexpression recursion",
4013 ST.save_curlyx = cur_curlyx;
4014 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4015 PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4018 case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4019 cur_curlyx = ST.save_curlyx;
4020 REGCP_UNWIND(ST.lastcp);
4023 if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
4024 /* Maximum greed exceeded */
4025 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4026 && ckWARN(WARN_REGEXP)
4027 && !(PL_reg_flags & RF_warned))
4029 PL_reg_flags |= RF_warned;
4030 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4031 "%s limit (%d) exceeded",
4032 "Complex regular subexpression recursion",
4035 cur_curlyx->u.curlyx.count--;
4039 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4040 "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4042 /* Try grabbing another A and see if it helps. */
4043 PL_reginput = locinput;
4044 cur_curlyx->u.curlyx.lastloc = locinput;
4045 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4046 REGCP_SET(ST.lastcp);
4047 PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
4051 #define ST st->u.branch
4053 case BRANCHJ: /* /(...|A|...)/ with long next pointer */
4054 next = scan + ARG(scan);
4057 scan = NEXTOPER(scan);
4060 case BRANCH: /* /(...|A|...)/ */
4061 scan = NEXTOPER(scan); /* scan now points to inner node */
4062 if ((!next || (OP(next) != BRANCH && OP(next) != BRANCHJ))
4065 /* last branch; skip state push and jump direct to node */
4068 ST.lastparen = *PL_reglastparen;
4069 ST.next_branch = next;
4071 PL_reginput = locinput;
4073 /* Now go into the branch */
4075 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4077 PUSH_STATE_GOTO(BRANCH_next, scan);
4081 PL_reginput = locinput;
4082 sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4083 (SV*)rex->data->data[ ARG( scan ) ];
4084 PUSH_STATE_GOTO(CUTGROUP_next,next);
4086 case CUTGROUP_next_fail:
4089 if (st->u.mark.mark_name)
4090 sv_commit = st->u.mark.mark_name;
4096 case BRANCH_next_fail: /* that branch failed; try the next, if any */
4101 REGCP_UNWIND(ST.cp);
4102 for (n = *PL_reglastparen; n > ST.lastparen; n--)
4104 *PL_reglastparen = n;
4105 /*dmq: *PL_reglastcloseparen = n; */
4106 scan = ST.next_branch;
4107 /* no more branches? */
4108 if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4110 PerlIO_printf( Perl_debug_log,
4111 "%*s %sBRANCH failed...%s\n",
4112 REPORT_CODE_OFF+depth*2, "",
4118 continue; /* execute next BRANCH[J] op */
4126 #define ST st->u.curlym
4128 case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4130 /* This is an optimisation of CURLYX that enables us to push
4131 * only a single backtracking state, no matter now many matches
4132 * there are in {m,n}. It relies on the pattern being constant
4133 * length, with no parens to influence future backrefs
4137 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4139 /* if paren positive, emulate an OPEN/CLOSE around A */
4141 U32 paren = ST.me->flags;
4142 if (paren > PL_regsize)
4144 if (paren > *PL_reglastparen)
4145 *PL_reglastparen = paren;
4146 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4154 ST.c1 = CHRTEST_UNINIT;
4157 if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4160 curlym_do_A: /* execute the A in /A{m,n}B/ */
4161 PL_reginput = locinput;
4162 PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4165 case CURLYM_A: /* we've just matched an A */
4166 locinput = st->locinput;
4167 nextchr = UCHARAT(locinput);
4170 /* after first match, determine A's length: u.curlym.alen */
4171 if (ST.count == 1) {
4172 if (PL_reg_match_utf8) {
4174 while (s < PL_reginput) {
4180 ST.alen = PL_reginput - locinput;
4183 ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4186 PerlIO_printf(Perl_debug_log,
4187 "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4188 (int)(REPORT_CODE_OFF+(depth*2)), "",
4189 (IV) ST.count, (IV)ST.alen)
4192 locinput = PL_reginput;
4194 if (cur_eval && cur_eval->u.eval.close_paren &&
4195 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4198 if ( ST.count < (ST.minmod ? ARG1(ST.me) : ARG2(ST.me)) )
4199 goto curlym_do_A; /* try to match another A */
4200 goto curlym_do_B; /* try to match B */
4202 case CURLYM_A_fail: /* just failed to match an A */
4203 REGCP_UNWIND(ST.cp);
4205 if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4206 || (cur_eval && cur_eval->u.eval.close_paren &&
4207 cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4210 curlym_do_B: /* execute the B in /A{m,n}B/ */
4211 PL_reginput = locinput;
4212 if (ST.c1 == CHRTEST_UNINIT) {
4213 /* calculate c1 and c2 for possible match of 1st char
4214 * following curly */
4215 ST.c1 = ST.c2 = CHRTEST_VOID;
4216 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4217 regnode *text_node = ST.B;
4218 if (! HAS_TEXT(text_node))
4219 FIND_NEXT_IMPT(text_node);
4220 if (HAS_TEXT(text_node)
4221 && PL_regkind[OP(text_node)] != REF)
4223 ST.c1 = (U8)*STRING(text_node);
4225 (OP(text_node) == EXACTF || OP(text_node) == REFF)
4227 : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4228 ? PL_fold_locale[ST.c1]
4235 PerlIO_printf(Perl_debug_log,
4236 "%*s CURLYM trying tail with matches=%"IVdf"...\n",
4237 (int)(REPORT_CODE_OFF+(depth*2)),
4240 if (ST.c1 != CHRTEST_VOID
4241 && UCHARAT(PL_reginput) != ST.c1
4242 && UCHARAT(PL_reginput) != ST.c2)
4244 /* simulate B failing */
4245 state_num = CURLYM_B_fail;
4246 goto reenter_switch;
4250 /* mark current A as captured */
4251 I32 paren = ST.me->flags;
4254 = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4255 PL_regendp[paren] = PL_reginput - PL_bostr;
4256 /*dmq: *PL_reglastcloseparen = paren; */
4259 PL_regendp[paren] = -1;
4260 if (cur_eval && cur_eval->u.eval.close_paren &&
4261 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4270 PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4273 case CURLYM_B_fail: /* just failed to match a B */
4274 REGCP_UNWIND(ST.cp);
4276 if (ST.count == ARG2(ST.me) /* max */)
4278 goto curlym_do_A; /* try to match a further A */
4280 /* backtrack one A */
4281 if (ST.count == ARG1(ST.me) /* min */)
4284 locinput = HOPc(locinput, -ST.alen);
4285 goto curlym_do_B; /* try to match B */
4288 #define ST st->u.curly
4290 #define CURLY_SETPAREN(paren, success) \
4293 PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr; \
4294 PL_regendp[paren] = locinput - PL_bostr; \
4295 *PL_reglastcloseparen = paren; \
4298 PL_regendp[paren] = -1; \
4301 case STAR: /* /A*B/ where A is width 1 */
4305 scan = NEXTOPER(scan);
4307 case PLUS: /* /A+B/ where A is width 1 */
4311 scan = NEXTOPER(scan);
4313 case CURLYN: /* /(A){m,n}B/ where A is width 1 */
4314 ST.paren = scan->flags; /* Which paren to set */
4315 if (ST.paren > PL_regsize)
4316 PL_regsize = ST.paren;
4317 if (ST.paren > *PL_reglastparen)
4318 *PL_reglastparen = ST.paren;
4319 ST.min = ARG1(scan); /* min to match */
4320 ST.max = ARG2(scan); /* max to match */
4321 if (cur_eval && cur_eval->u.eval.close_paren &&
4322 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4326 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4328 case CURLY: /* /A{m,n}B/ where A is width 1 */
4330 ST.min = ARG1(scan); /* min to match */
4331 ST.max = ARG2(scan); /* max to match */
4332 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4335 * Lookahead to avoid useless match attempts
4336 * when we know what character comes next.
4338 * Used to only do .*x and .*?x, but now it allows
4339 * for )'s, ('s and (?{ ... })'s to be in the way
4340 * of the quantifier and the EXACT-like node. -- japhy
4343 if (ST.min > ST.max) /* XXX make this a compile-time check? */
4345 if (HAS_TEXT(next) || JUMPABLE(next)) {
4347 regnode *text_node = next;
4349 if (! HAS_TEXT(text_node))
4350 FIND_NEXT_IMPT(text_node);
4352 if (! HAS_TEXT(text_node))
4353 ST.c1 = ST.c2 = CHRTEST_VOID;
4355 if (PL_regkind[OP(text_node)] == REF) {
4356 ST.c1 = ST.c2 = CHRTEST_VOID;
4357 goto assume_ok_easy;
4360 s = (U8*)STRING(text_node);
4364 if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4365 ST.c2 = PL_fold[ST.c1];
4366 else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4367 ST.c2 = PL_fold_locale[ST.c1];
4370 if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4371 STRLEN ulen1, ulen2;
4372 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4373 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4375 to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4376 to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4378 ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4380 0 : UTF8_ALLOW_ANY);
4381 ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4383 0 : UTF8_ALLOW_ANY);
4385 ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4387 ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4392 ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4399 ST.c1 = ST.c2 = CHRTEST_VOID;
4404 PL_reginput = locinput;
4407 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4410 locinput = PL_reginput;
4412 if (ST.c1 == CHRTEST_VOID)
4413 goto curly_try_B_min;
4415 ST.oldloc = locinput;
4417 /* set ST.maxpos to the furthest point along the
4418 * string that could possibly match */
4419 if (ST.max == REG_INFTY) {
4420 ST.maxpos = PL_regeol - 1;
4422 while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4426 int m = ST.max - ST.min;
4427 for (ST.maxpos = locinput;
4428 m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4429 ST.maxpos += UTF8SKIP(ST.maxpos);
4432 ST.maxpos = locinput + ST.max - ST.min;
4433 if (ST.maxpos >= PL_regeol)
4434 ST.maxpos = PL_regeol - 1;
4436 goto curly_try_B_min_known;
4440 ST.count = regrepeat(rex, ST.A, ST.max, depth);
4441 locinput = PL_reginput;
4442 if (ST.count < ST.min)
4444 if ((ST.count > ST.min)
4445 && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4447 /* A{m,n} must come at the end of the string, there's
4448 * no point in backing off ... */
4450 /* ...except that $ and \Z can match before *and* after
4451 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
4452 We may back off by one in this case. */
4453 if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4457 goto curly_try_B_max;
4462 case CURLY_B_min_known_fail:
4463 /* failed to find B in a non-greedy match where c1,c2 valid */
4464 if (ST.paren && ST.count)
4465 PL_regendp[ST.paren] = -1;
4467 PL_reginput = locinput; /* Could be reset... */
4468 REGCP_UNWIND(ST.cp);
4469 /* Couldn't or didn't -- move forward. */
4470 ST.oldloc = locinput;
4472 locinput += UTF8SKIP(locinput);
4476 curly_try_B_min_known:
4477 /* find the next place where 'B' could work, then call B */
4481 n = (ST.oldloc == locinput) ? 0 : 1;
4482 if (ST.c1 == ST.c2) {
4484 /* set n to utf8_distance(oldloc, locinput) */
4485 while (locinput <= ST.maxpos &&
4486 utf8n_to_uvchr((U8*)locinput,
4487 UTF8_MAXBYTES, &len,
4488 uniflags) != (UV)ST.c1) {
4494 /* set n to utf8_distance(oldloc, locinput) */
4495 while (locinput <= ST.maxpos) {
4497 const UV c = utf8n_to_uvchr((U8*)locinput,
4498 UTF8_MAXBYTES, &len,
4500 if (c == (UV)ST.c1 || c == (UV)ST.c2)
4508 if (ST.c1 == ST.c2) {
4509 while (locinput <= ST.maxpos &&
4510 UCHARAT(locinput) != ST.c1)
4514 while (locinput <= ST.maxpos
4515 && UCHARAT(locinput) != ST.c1
4516 && UCHARAT(locinput) != ST.c2)
4519 n = locinput - ST.oldloc;
4521 if (locinput > ST.maxpos)
4523 /* PL_reginput == oldloc now */
4526 if (regrepeat(rex, ST.A, n, depth) < n)
4529 PL_reginput = locinput;
4530 CURLY_SETPAREN(ST.paren, ST.count);
4531 if (cur_eval && cur_eval->u.eval.close_paren &&
4532 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4535 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
4540 case CURLY_B_min_fail:
4541 /* failed to find B in a non-greedy match where c1,c2 invalid */
4542 if (ST.paren && ST.count)
4543 PL_regendp[ST.paren] = -1;
4545 REGCP_UNWIND(ST.cp);
4546 /* failed -- move forward one */
4547 PL_reginput = locinput;
4548 if (regrepeat(rex, ST.A, 1, depth)) {
4550 locinput = PL_reginput;
4551 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
4552 ST.count > 0)) /* count overflow ? */
4555 CURLY_SETPAREN(ST.paren, ST.count);
4556 if (cur_eval && cur_eval->u.eval.close_paren &&
4557 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4560 PUSH_STATE_GOTO(CURLY_B_min, ST.B);
4568 /* a successful greedy match: now try to match B */
4569 if (cur_eval && cur_eval->u.eval.close_paren &&
4570 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4575 if (ST.c1 != CHRTEST_VOID)
4576 c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
4577 UTF8_MAXBYTES, 0, uniflags)
4578 : (UV) UCHARAT(PL_reginput);
4579 /* If it could work, try it. */
4580 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
4581 CURLY_SETPAREN(ST.paren, ST.count);
4582 PUSH_STATE_GOTO(CURLY_B_max, ST.B);
4587 case CURLY_B_max_fail:
4588 /* failed to find B in a greedy match */
4589 if (ST.paren && ST.count)
4590 PL_regendp[ST.paren] = -1;
4592 REGCP_UNWIND(ST.cp);
4594 if (--ST.count < ST.min)
4596 PL_reginput = locinput = HOPc(locinput, -1);
4597 goto curly_try_B_max;
4604 /* we've just finished A in /(??{A})B/; now continue with B */
4608 st->u.eval.toggle_reg_flags
4609 = cur_eval->u.eval.toggle_reg_flags;
4610 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
4612 st->u.eval.prev_rex = rex; /* inner */
4613 rex = cur_eval->u.eval.prev_rex; /* outer */
4614 cur_curlyx = cur_eval->u.eval.prev_curlyx;
4616 st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
4617 REGCP_SET(st->u.eval.lastcp);
4618 PL_reginput = locinput;
4620 /* Restore parens of the outer rex without popping the
4622 tmpix = PL_savestack_ix;
4623 PL_savestack_ix = cur_eval->u.eval.lastcp;
4625 PL_savestack_ix = tmpix;
4627 st->u.eval.prev_eval = cur_eval;
4628 cur_eval = cur_eval->u.eval.prev_eval;
4630 PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n",
4631 REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
4632 PUSH_YES_STATE_GOTO(EVAL_AB,
4633 st->u.eval.prev_eval->u.eval.B); /* match B */
4636 if (locinput < reginfo->till) {
4637 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4638 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4640 (long)(locinput - PL_reg_starttry),
4641 (long)(reginfo->till - PL_reg_starttry),
4643 sayNO_SILENT; /* Cannot match: too short. */
4645 PL_reginput = locinput; /* put where regtry can find it */
4646 sayYES; /* Success! */
4648 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4650 PerlIO_printf(Perl_debug_log,
4651 "%*s %ssubpattern success...%s\n",
4652 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
4653 PL_reginput = locinput; /* put where regtry can find it */
4654 sayYES; /* Success! */
4657 #define ST st->u.ifmatch
4659 case SUSPEND: /* (?>A) */
4661 PL_reginput = locinput;
4664 case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
4666 goto ifmatch_trivial_fail_test;
4668 case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
4670 ifmatch_trivial_fail_test:
4672 char * const s = HOPBACKc(locinput, scan->flags);
4677 sw = 1 - (bool)ST.wanted;
4681 next = scan + ARG(scan);
4689 PL_reginput = locinput;
4693 ST.logical = logical;
4694 /* execute body of (?...A) */
4695 PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
4698 case IFMATCH_A_fail: /* body of (?...A) failed */
4699 ST.wanted = !ST.wanted;
4702 case IFMATCH_A: /* body of (?...A) succeeded */
4704 sw = (bool)ST.wanted;
4706 else if (!ST.wanted)
4709 if (OP(ST.me) == SUSPEND)
4710 locinput = PL_reginput;
4712 locinput = PL_reginput = st->locinput;
4713 nextchr = UCHARAT(locinput);
4715 scan = ST.me + ARG(ST.me);
4718 continue; /* execute B */
4723 next = scan + ARG(scan);
4728 reginfo->cutpoint = PL_regeol;
4731 PL_reginput = locinput;
4733 sv_yes_mark = sv_commit = (SV*)rex->data->data[ ARG( scan ) ];
4734 PUSH_STATE_GOTO(COMMIT_next,next);
4736 case COMMIT_next_fail:
4743 #define ST st->u.mark
4745 ST.prev_mark = mark_state;
4746 ST.mark_name = sv_commit = sv_yes_mark
4747 = (SV*)rex->data->data[ ARG( scan ) ];
4749 ST.mark_loc = PL_reginput = locinput;
4750 PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
4752 case MARKPOINT_next:
4753 mark_state = ST.prev_mark;
4756 case MARKPOINT_next_fail:
4757 if (popmark && sv_eq(ST.mark_name,popmark))
4759 if (ST.mark_loc > startpoint)
4760 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
4761 popmark = NULL; /* we found our mark */
4762 sv_commit = ST.mark_name;
4765 PerlIO_printf(Perl_debug_log,
4766 "%*s %ssetting cutpoint to mark:%"SVf"...%s\n",
4767 REPORT_CODE_OFF+depth*2, "",
4768 PL_colors[4], sv_commit, PL_colors[5]);
4771 mark_state = ST.prev_mark;
4772 sv_yes_mark = mark_state ?
4773 mark_state->u.mark.mark_name : NULL;
4777 PL_reginput = locinput;
4779 /* (*CUT) : if we fail we cut here*/
4780 ST.mark_name = NULL;
4781 ST.mark_loc = locinput;
4782 PUSH_STATE_GOTO(SKIP_next,next);
4784 /* (*CUT:NAME) : if there is a (*MARK:NAME) fail where it was,
4785 otherwise do nothing. Meaning we need to scan
4787 regmatch_state *cur = mark_state;
4788 SV *find = (SV*)rex->data->data[ ARG( scan ) ];
4791 if ( sv_eq( cur->u.mark.mark_name,
4794 ST.mark_name = find;
4795 PUSH_STATE_GOTO( SKIP_next, next );
4797 cur = cur->u.mark.prev_mark;
4800 /* Didn't find our (*MARK:NAME) so ignore this (*CUT:NAME) */
4802 case SKIP_next_fail:
4804 /* (*CUT:NAME) - Set up to search for the name as we
4805 collapse the stack*/
4806 popmark = ST.mark_name;
4808 /* (*CUT) - No name, we cut here.*/
4809 if (ST.mark_loc > startpoint)
4810 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
4811 /* but we set sv_commit to latest mark_name if there
4812 is one so they can test to see how things lead to this
4815 sv_commit=mark_state->u.mark.mark_name;
4823 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4824 PTR2UV(scan), OP(scan));
4825 Perl_croak(aTHX_ "regexp memory corruption");
4829 /* switch break jumps here */
4830 scan = next; /* prepare to execute the next op and ... */
4831 continue; /* ... jump back to the top, reusing st */
4835 /* push a state that backtracks on success */
4836 st->u.yes.prev_yes_state = yes_state;
4840 /* push a new regex state, then continue at scan */
4842 regmatch_state *newst;
4845 regmatch_state *cur = st;
4846 regmatch_state *curyes = yes_state;
4848 regmatch_slab *slab = PL_regmatch_slab;
4849 for (;curd > -1;cur--,curd--) {
4850 if (cur < SLAB_FIRST(slab)) {
4852 cur = SLAB_LAST(slab);
4854 PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
4855 REPORT_CODE_OFF + 2 + depth * 2,"",
4856 curd, reg_name[cur->resume_state],
4857 (curyes == cur) ? "yes" : ""
4860 curyes = cur->u.yes.prev_yes_state;
4863 DEBUG_STATE_pp("push")
4866 st->locinput = locinput;
4868 if (newst > SLAB_LAST(PL_regmatch_slab))
4869 newst = S_push_slab(aTHX);
4870 PL_regmatch_state = newst;
4872 locinput = PL_reginput;
4873 nextchr = UCHARAT(locinput);
4881 * We get here only if there's trouble -- normally "case END" is
4882 * the terminating point.
4884 Perl_croak(aTHX_ "corrupted regexp pointers");
4890 /* we have successfully completed a subexpression, but we must now
4891 * pop to the state marked by yes_state and continue from there */
4892 assert(st != yes_state);
4894 while (st != yes_state) {
4896 if (st < SLAB_FIRST(PL_regmatch_slab)) {
4897 PL_regmatch_slab = PL_regmatch_slab->prev;
4898 st = SLAB_LAST(PL_regmatch_slab);
4902 DEBUG_STATE_pp("pop (no final)");
4904 DEBUG_STATE_pp("pop (yes)");
4910 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
4911 || yes_state > SLAB_LAST(PL_regmatch_slab))
4913 /* not in this slab, pop slab */
4914 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
4915 PL_regmatch_slab = PL_regmatch_slab->prev;
4916 st = SLAB_LAST(PL_regmatch_slab);
4918 depth -= (st - yes_state);
4921 yes_state = st->u.yes.prev_yes_state;
4922 PL_regmatch_state = st;
4925 locinput= st->locinput;
4926 nextchr = UCHARAT(locinput);
4928 state_num = st->resume_state + no_final;
4929 goto reenter_switch;
4932 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4933 PL_colors[4], PL_colors[5]));
4940 PerlIO_printf(Perl_debug_log,
4941 "%*s %sfailed...%s\n",
4942 REPORT_CODE_OFF+depth*2, "",
4943 PL_colors[4], PL_colors[5])
4955 /* there's a previous state to backtrack to */
4957 if (st < SLAB_FIRST(PL_regmatch_slab)) {
4958 PL_regmatch_slab = PL_regmatch_slab->prev;
4959 st = SLAB_LAST(PL_regmatch_slab);
4961 PL_regmatch_state = st;
4962 locinput= st->locinput;
4963 nextchr = UCHARAT(locinput);
4965 DEBUG_STATE_pp("pop");
4967 if (yes_state == st)
4968 yes_state = st->u.yes.prev_yes_state;
4970 state_num = st->resume_state + 1; /* failure = success + 1 */
4971 goto reenter_switch;
4976 if (rex->reganch & ROPT_VERBARG_SEEN) {
4977 SV *sv_err = get_sv("REGERROR", 1);
4978 SV *sv_mrk = get_sv("REGMARK", 1);
4980 sv_commit = &PL_sv_no;
4982 sv_yes_mark = &PL_sv_yes;
4985 sv_commit = &PL_sv_yes;
4986 sv_yes_mark = &PL_sv_no;
4988 sv_setsv(sv_err, sv_commit);
4989 sv_setsv(sv_mrk, sv_yes_mark);
4991 /* restore original high-water mark */
4992 PL_regmatch_slab = orig_slab;
4993 PL_regmatch_state = orig_state;
4995 /* free all slabs above current one */
4996 if (orig_slab->next) {
4997 regmatch_slab *sl = orig_slab->next;
4998 orig_slab->next = NULL;
5000 regmatch_slab * const osl = sl;
5010 - regrepeat - repeatedly match something simple, report how many
5013 * [This routine now assumes that it will only match on things of length 1.
5014 * That was true before, but now we assume scan - reginput is the count,
5015 * rather than incrementing count on every character. [Er, except utf8.]]
5018 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5021 register char *scan;
5023 register char *loceol = PL_regeol;
5024 register I32 hardcount = 0;
5025 register bool do_utf8 = PL_reg_match_utf8;
5028 if (max == REG_INFTY)
5030 else if (max < loceol - scan)
5031 loceol = scan + max;
5036 while (scan < loceol && hardcount < max && *scan != '\n') {
5037 scan += UTF8SKIP(scan);
5041 while (scan < loceol && *scan != '\n')
5048 while (scan < loceol && hardcount < max) {
5049 scan += UTF8SKIP(scan);
5059 case EXACT: /* length of string is 1 */
5061 while (scan < loceol && UCHARAT(scan) == c)
5064 case EXACTF: /* length of string is 1 */
5066 while (scan < loceol &&
5067 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5070 case EXACTFL: /* length of string is 1 */
5071 PL_reg_flags |= RF_tainted;
5073 while (scan < loceol &&
5074 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5080 while (hardcount < max && scan < loceol &&
5081 reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
5082 scan += UTF8SKIP(scan);
5086 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5093 LOAD_UTF8_CHARCLASS_ALNUM();
5094 while (hardcount < max && scan < loceol &&
5095 swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5096 scan += UTF8SKIP(scan);
5100 while (scan < loceol && isALNUM(*scan))
5105 PL_reg_flags |= RF_tainted;
5108 while (hardcount < max && scan < loceol &&
5109 isALNUM_LC_utf8((U8*)scan)) {
5110 scan += UTF8SKIP(scan);
5114 while (scan < loceol && isALNUM_LC(*scan))
5121 LOAD_UTF8_CHARCLASS_ALNUM();
5122 while (hardcount < max && scan < loceol &&
5123 !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5124 scan += UTF8SKIP(scan);
5128 while (scan < loceol && !isALNUM(*scan))
5133 PL_reg_flags |= RF_tainted;
5136 while (hardcount < max && scan < loceol &&
5137 !isALNUM_LC_utf8((U8*)scan)) {
5138 scan += UTF8SKIP(scan);
5142 while (scan < loceol && !isALNUM_LC(*scan))
5149 LOAD_UTF8_CHARCLASS_SPACE();
5150 while (hardcount < max && scan < loceol &&
5152 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5153 scan += UTF8SKIP(scan);
5157 while (scan < loceol && isSPACE(*scan))
5162 PL_reg_flags |= RF_tainted;
5165 while (hardcount < max && scan < loceol &&
5166 (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5167 scan += UTF8SKIP(scan);
5171 while (scan < loceol && isSPACE_LC(*scan))
5178 LOAD_UTF8_CHARCLASS_SPACE();
5179 while (hardcount < max && scan < loceol &&
5181 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5182 scan += UTF8SKIP(scan);
5186 while (scan < loceol && !isSPACE(*scan))
5191 PL_reg_flags |= RF_tainted;
5194 while (hardcount < max && scan < loceol &&
5195 !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5196 scan += UTF8SKIP(scan);
5200 while (scan < loceol && !isSPACE_LC(*scan))
5207 LOAD_UTF8_CHARCLASS_DIGIT();
5208 while (hardcount < max && scan < loceol &&
5209 swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5210 scan += UTF8SKIP(scan);
5214 while (scan < loceol && isDIGIT(*scan))
5221 LOAD_UTF8_CHARCLASS_DIGIT();
5222 while (hardcount < max && scan < loceol &&
5223 !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5224 scan += UTF8SKIP(scan);
5228 while (scan < loceol && !isDIGIT(*scan))
5232 default: /* Called on something of 0 width. */
5233 break; /* So match right here or not at all. */
5239 c = scan - PL_reginput;
5243 GET_RE_DEBUG_FLAGS_DECL;
5245 SV * const prop = sv_newmortal();
5246 regprop(prog, prop, p);
5247 PerlIO_printf(Perl_debug_log,
5248 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
5249 REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5257 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5259 - regclass_swash - prepare the utf8 swash
5263 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5269 const struct reg_data * const data = prog ? prog->data : NULL;
5271 if (data && data->count) {
5272 const U32 n = ARG(node);
5274 if (data->what[n] == 's') {
5275 SV * const rv = (SV*)data->data[n];
5276 AV * const av = (AV*)SvRV((SV*)rv);
5277 SV **const ary = AvARRAY(av);
5280 /* See the end of regcomp.c:S_regclass() for
5281 * documentation of these array elements. */
5284 a = SvROK(ary[1]) ? &ary[1] : 0;
5285 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
5289 else if (si && doinit) {
5290 sw = swash_init("utf8", "", si, 1, 0);
5291 (void)av_store(av, 1, sw);
5308 - reginclass - determine if a character falls into a character class
5310 The n is the ANYOF regnode, the p is the target string, lenp
5311 is pointer to the maximum length of how far to go in the p
5312 (if the lenp is zero, UTF8SKIP(p) is used),
5313 do_utf8 tells whether the target string is in UTF-8.
5318 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5321 const char flags = ANYOF_FLAGS(n);
5327 if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5328 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5329 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5330 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5331 if (len == (STRLEN)-1)
5332 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5335 plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5336 if (do_utf8 || (flags & ANYOF_UNICODE)) {
5339 if (do_utf8 && !ANYOF_RUNTIME(n)) {
5340 if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5343 if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5347 SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5350 if (swash_fetch(sw, p, do_utf8))
5352 else if (flags & ANYOF_FOLD) {
5353 if (!match && lenp && av) {
5355 for (i = 0; i <= av_len(av); i++) {
5356 SV* const sv = *av_fetch(av, i, FALSE);
5358 const char * const s = SvPV_const(sv, len);
5360 if (len <= plen && memEQ(s, (char*)p, len)) {
5368 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5371 to_utf8_fold(p, tmpbuf, &tmplen);
5372 if (swash_fetch(sw, tmpbuf, do_utf8))
5378 if (match && lenp && *lenp == 0)
5379 *lenp = UNISKIP(NATIVE_TO_UNI(c));
5381 if (!match && c < 256) {
5382 if (ANYOF_BITMAP_TEST(n, c))
5384 else if (flags & ANYOF_FOLD) {
5387 if (flags & ANYOF_LOCALE) {
5388 PL_reg_flags |= RF_tainted;
5389 f = PL_fold_locale[c];
5393 if (f != c && ANYOF_BITMAP_TEST(n, f))
5397 if (!match && (flags & ANYOF_CLASS)) {
5398 PL_reg_flags |= RF_tainted;
5400 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
5401 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
5402 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
5403 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
5404 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
5405 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
5406 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
5407 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5408 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
5409 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
5410 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
5411 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
5412 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
5413 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
5414 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
5415 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
5416 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
5417 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
5418 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
5419 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
5420 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
5421 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
5422 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
5423 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
5424 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
5425 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
5426 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
5427 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
5428 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
5429 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
5430 ) /* How's that for a conditional? */
5437 return (flags & ANYOF_INVERT) ? !match : match;
5441 S_reghop3(U8 *s, I32 off, const U8* lim)
5445 while (off-- && s < lim) {
5446 /* XXX could check well-formedness here */
5451 while (off++ && s > lim) {
5453 if (UTF8_IS_CONTINUED(*s)) {
5454 while (s > lim && UTF8_IS_CONTINUATION(*s))
5457 /* XXX could check well-formedness here */
5464 /* there are a bunch of places where we use two reghop3's that should
5465 be replaced with this routine. but since thats not done yet
5466 we ifdef it out - dmq
5469 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
5473 while (off-- && s < rlim) {
5474 /* XXX could check well-formedness here */
5479 while (off++ && s > llim) {
5481 if (UTF8_IS_CONTINUED(*s)) {
5482 while (s > llim && UTF8_IS_CONTINUATION(*s))
5485 /* XXX could check well-formedness here */
5493 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5497 while (off-- && s < lim) {
5498 /* XXX could check well-formedness here */
5505 while (off++ && s > lim) {
5507 if (UTF8_IS_CONTINUED(*s)) {
5508 while (s > lim && UTF8_IS_CONTINUATION(*s))
5511 /* XXX could check well-formedness here */
5520 restore_pos(pTHX_ void *arg)
5523 regexp * const rex = (regexp *)arg;
5524 if (PL_reg_eval_set) {
5525 if (PL_reg_oldsaved) {
5526 rex->subbeg = PL_reg_oldsaved;
5527 rex->sublen = PL_reg_oldsavedlen;
5528 #ifdef PERL_OLD_COPY_ON_WRITE
5529 rex->saved_copy = PL_nrs;
5531 RX_MATCH_COPIED_on(rex);
5533 PL_reg_magic->mg_len = PL_reg_oldpos;
5534 PL_reg_eval_set = 0;
5535 PL_curpm = PL_reg_oldcurpm;
5540 S_to_utf8_substr(pTHX_ register regexp *prog)
5542 if (prog->float_substr && !prog->float_utf8) {
5543 SV* const sv = newSVsv(prog->float_substr);
5544 prog->float_utf8 = sv;
5545 sv_utf8_upgrade(sv);
5546 if (SvTAIL(prog->float_substr))
5548 if (prog->float_substr == prog->check_substr)
5549 prog->check_utf8 = sv;
5551 if (prog->anchored_substr && !prog->anchored_utf8) {
5552 SV* const sv = newSVsv(prog->anchored_substr);
5553 prog->anchored_utf8 = sv;
5554 sv_utf8_upgrade(sv);
5555 if (SvTAIL(prog->anchored_substr))
5557 if (prog->anchored_substr == prog->check_substr)
5558 prog->check_utf8 = sv;
5563 S_to_byte_substr(pTHX_ register regexp *prog)
5566 if (prog->float_utf8 && !prog->float_substr) {
5567 SV* sv = newSVsv(prog->float_utf8);
5568 prog->float_substr = sv;
5569 if (sv_utf8_downgrade(sv, TRUE)) {
5570 if (SvTAIL(prog->float_utf8))
5574 prog->float_substr = sv = &PL_sv_undef;
5576 if (prog->float_utf8 == prog->check_utf8)
5577 prog->check_substr = sv;
5579 if (prog->anchored_utf8 && !prog->anchored_substr) {
5580 SV* sv = newSVsv(prog->anchored_utf8);
5581 prog->anchored_substr = sv;
5582 if (sv_utf8_downgrade(sv, TRUE)) {
5583 if (SvTAIL(prog->anchored_utf8))
5587 prog->anchored_substr = sv = &PL_sv_undef;
5589 if (prog->anchored_utf8 == prog->check_utf8)
5590 prog->check_substr = sv;
5596 * c-indentation-style: bsd
5598 * indent-tabs-mode: t
5601 * ex: set ts=8 sts=4 sw=4 noet: