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.
19 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
20 * confused with the original package (see point 3 below). Thanks, Henry!
23 /* Additional note: this code is very heavily munged from Henry's version
24 * in places. In some spots I've traded clarity for efficiency, so don't
25 * blame Henry for some of the lack of readability.
28 /* The names of the functions have been changed from regcomp and
29 * regexec to pregcomp and pregexec in order to avoid conflicts
30 * with the POSIX routines of the same names.
33 #ifdef PERL_EXT_RE_BUILD
38 * pregcomp and pregexec -- regsub and regerror are not used in perl
40 * Copyright (c) 1986 by University of Toronto.
41 * Written by Henry Spencer. Not derived from licensed software.
43 * Permission is granted to anyone to use this software for any
44 * purpose on any computer system, and to redistribute it freely,
45 * subject to the following restrictions:
47 * 1. The author is not responsible for the consequences of use of
48 * this software, no matter how awful, even if they arise
51 * 2. The origin of this software must not be misrepresented, either
52 * by explicit claim or by omission.
54 * 3. Altered versions must be plainly marked as such, and must not
55 * be misrepresented as being the original software.
57 **** Alterations to Henry's code are...
59 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
60 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
62 **** You may distribute under the terms of either the GNU General Public
63 **** License or the Artistic License, as specified in the README file.
65 * Beware that some of this code is subtly aware of the way operator
66 * precedence is structured in regular expressions. Serious changes in
67 * regular-expression syntax might require a total rethink.
70 #define PERL_IN_REGEXEC_C
73 #ifdef PERL_IN_XSUB_RE
79 #define RF_tainted 1 /* tainted information used? */
80 #define RF_warned 2 /* warned about big count? */
81 #define RF_evaled 4 /* Did an EVAL with setting? */
82 #define RF_utf8 8 /* String contains multibyte chars? */
84 #define UTF ((PL_reg_flags & RF_utf8) != 0)
86 #define RS_init 1 /* eval environment created */
87 #define RS_set 2 /* replsv value is set */
93 #define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
99 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
100 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
102 #define HOPc(pos,off) \
103 (char *)(PL_reg_match_utf8 \
104 ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
106 #define HOPBACKc(pos, off) \
107 (char*)(PL_reg_match_utf8\
108 ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
109 : (pos - off >= PL_bostr) \
113 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
114 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
116 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
117 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
118 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
119 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
120 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
121 #define LOAD_UTF8_CHARCLASS_MARK() LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
123 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
125 /* for use after a quantifier and before an EXACT-like node -- japhy */
126 #define JUMPABLE(rn) ( \
127 OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
128 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
129 OP(rn) == PLUS || OP(rn) == MINMOD || \
130 (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
133 #define HAS_TEXT(rn) ( \
134 PL_regkind[OP(rn)] == EXACT || PL_regkind[OP(rn)] == REF \
138 Search for mandatory following text node; for lookahead, the text must
139 follow but for lookbehind (rn->flags != 0) we skip to the next step.
141 #define FIND_NEXT_IMPT(rn) STMT_START { \
142 while (JUMPABLE(rn)) { \
143 const OPCODE type = OP(rn); \
144 if (type == SUSPEND || PL_regkind[type] == CURLY) \
145 rn = NEXTOPER(NEXTOPER(rn)); \
146 else if (type == PLUS) \
148 else if (type == IFMATCH) \
149 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
150 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;
165 if (paren_elems_to_push < 0)
166 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
168 #define REGCP_OTHER_ELEMS 6
169 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
170 for (p = PL_regsize; p > parenfloor; p--) {
171 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
172 SSPUSHINT(PL_regendp[p]);
173 SSPUSHINT(PL_regstartp[p]);
174 SSPUSHPTR(PL_reg_start_tmp[p]);
177 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
178 SSPUSHINT(PL_regsize);
179 SSPUSHINT(*PL_reglastparen);
180 SSPUSHINT(*PL_reglastcloseparen);
181 SSPUSHPTR(PL_reginput);
182 #define REGCP_FRAME_ELEMS 2
183 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
184 * are needed for the regexp context stack bookkeeping. */
185 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
186 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
191 /* These are needed since we do not localize EVAL nodes: */
192 # define REGCP_SET(cp) DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, \
193 " Setting an EVAL scope, savestack=%"IVdf"\n", \
194 (IV)PL_savestack_ix)); cp = PL_savestack_ix
196 # define REGCP_UNWIND(cp) DEBUG_EXECUTE_r(cp != PL_savestack_ix ? \
197 PerlIO_printf(Perl_debug_log, \
198 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
199 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
202 S_regcppop(pTHX_ const regexp *rex)
208 GET_RE_DEBUG_FLAGS_DECL;
210 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
212 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
213 i = SSPOPINT; /* Parentheses elements to pop. */
214 input = (char *) SSPOPPTR;
215 *PL_reglastcloseparen = SSPOPINT;
216 *PL_reglastparen = SSPOPINT;
217 PL_regsize = SSPOPINT;
219 /* Now restore the parentheses context. */
220 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
221 i > 0; i -= REGCP_PAREN_ELEMS) {
223 U32 paren = (U32)SSPOPINT;
224 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
225 PL_regstartp[paren] = SSPOPINT;
227 if (paren <= *PL_reglastparen)
228 PL_regendp[paren] = tmps;
230 PerlIO_printf(Perl_debug_log,
231 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
232 (UV)paren, (IV)PL_regstartp[paren],
233 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
234 (IV)PL_regendp[paren],
235 (paren > *PL_reglastparen ? "(no)" : ""));
239 if (*PL_reglastparen + 1 <= rex->nparens) {
240 PerlIO_printf(Perl_debug_log,
241 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
242 (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
246 /* It would seem that the similar code in regtry()
247 * already takes care of this, and in fact it is in
248 * a better location to since this code can #if 0-ed out
249 * but the code in regtry() is needed or otherwise tests
250 * requiring null fields (pat.t#187 and split.t#{13,14}
251 * (as of patchlevel 7877) will fail. Then again,
252 * this code seems to be necessary or otherwise
253 * building DynaLoader will fail:
254 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
256 for (i = *PL_reglastparen + 1; (U32)i <= rex->nparens; i++) {
258 PL_regstartp[i] = -1;
265 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
267 #define TRYPAREN(paren, n, input, where) { \
270 PL_regstartp[paren] = HOPc(input, -1) - PL_bostr; \
271 PL_regendp[paren] = input - PL_bostr; \
274 PL_regendp[paren] = -1; \
276 REGMATCH(next, where); \
280 PL_regendp[paren] = -1; \
285 * pregexec and friends
288 #ifndef PERL_IN_XSUB_RE
290 - pregexec - match a regexp against a string
293 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
294 char *strbeg, I32 minend, SV *screamer, U32 nosave)
295 /* strend: pointer to null at end of string */
296 /* strbeg: real beginning of string */
297 /* minend: end of match must be >=minend after stringarg. */
298 /* nosave: For optimizations. */
301 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
302 nosave ? 0 : REXEC_COPY_STR);
307 * Need to implement the following flags for reg_anch:
309 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
311 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
312 * INTUIT_AUTORITATIVE_ML
313 * INTUIT_ONCE_NOML - Intuit can match in one location only.
316 * Another flag for this function: SECOND_TIME (so that float substrs
317 * with giant delta may be not rechecked).
320 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
322 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
323 Otherwise, only SvCUR(sv) is used to get strbeg. */
325 /* XXXX We assume that strpos is strbeg unless sv. */
327 /* XXXX Some places assume that there is a fixed substring.
328 An update may be needed if optimizer marks as "INTUITable"
329 RExen without fixed substrings. Similarly, it is assumed that
330 lengths of all the strings are no more than minlen, thus they
331 cannot come from lookahead.
332 (Or minlen should take into account lookahead.) */
334 /* A failure to find a constant substring means that there is no need to make
335 an expensive call to REx engine, thus we celebrate a failure. Similarly,
336 finding a substring too deep into the string means that less calls to
337 regtry() should be needed.
339 REx compiler's optimizer found 4 possible hints:
340 a) Anchored substring;
342 c) Whether we are anchored (beginning-of-line or \G);
343 d) First node (of those at offset 0) which may distingush positions;
344 We use a)b)d) and multiline-part of c), and try to find a position in the
345 string which does not contradict any of them.
348 /* Most of decisions we do here should have been done at compile time.
349 The nodes of the REx which we used for the search should have been
350 deleted from the finite automaton. */
353 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
354 char *strend, U32 flags, re_scream_pos_data *data)
357 register I32 start_shift = 0;
358 /* Should be nonnegative! */
359 register I32 end_shift = 0;
364 const int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */
366 register char *other_last = NULL; /* other substr checked before this */
367 char *check_at = NULL; /* check substr found at this pos */
368 const I32 multiline = prog->reganch & PMf_MULTILINE;
370 const char * const i_strpos = strpos;
371 SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
374 GET_RE_DEBUG_FLAGS_DECL;
376 RX_MATCH_UTF8_set(prog,do_utf8);
378 if (prog->reganch & ROPT_UTF8) {
379 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
380 "UTF-8 regex...\n"));
381 PL_reg_flags |= RF_utf8;
385 const char *s = PL_reg_match_utf8 ?
386 sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
388 const int len = PL_reg_match_utf8 ?
389 (int)strlen(s) : strend - strpos;
392 if (PL_reg_match_utf8)
393 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
394 "UTF-8 target...\n"));
395 PerlIO_printf(Perl_debug_log,
396 "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n",
397 PL_colors[4], PL_colors[5], PL_colors[0],
400 (strlen(prog->precomp) > 60 ? "..." : ""),
402 (int)(len > 60 ? 60 : len),
404 (len > 60 ? "..." : "")
408 /* CHR_DIST() would be more correct here but it makes things slow. */
409 if (prog->minlen > strend - strpos) {
410 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
411 "String too short... [re_intuit_start]\n"));
414 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
417 if (!prog->check_utf8 && prog->check_substr)
418 to_utf8_substr(prog);
419 check = prog->check_utf8;
421 if (!prog->check_substr && prog->check_utf8)
422 to_byte_substr(prog);
423 check = prog->check_substr;
425 if (check == &PL_sv_undef) {
426 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
427 "Non-utf string cannot match utf check string\n"));
430 if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
431 ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
432 || ( (prog->reganch & ROPT_ANCH_BOL)
433 && !multiline ) ); /* Check after \n? */
436 if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
437 | ROPT_IMPLICIT)) /* not a real BOL */
438 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
440 && (strpos != strbeg)) {
441 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
444 if (prog->check_offset_min == prog->check_offset_max &&
445 !(prog->reganch & ROPT_CANY_SEEN)) {
446 /* Substring at constant offset from beg-of-str... */
449 s = HOP3c(strpos, prog->check_offset_min, strend);
451 slen = SvCUR(check); /* >= 1 */
453 if ( strend - s > slen || strend - s < slen - 1
454 || (strend - s == slen && strend[-1] != '\n')) {
455 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
458 /* Now should match s[0..slen-2] */
460 if (slen && (*SvPVX_const(check) != *s
462 && memNE(SvPVX_const(check), s, slen)))) {
464 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
468 else if (*SvPVX_const(check) != *s
469 || ((slen = SvCUR(check)) > 1
470 && memNE(SvPVX_const(check), s, slen)))
473 goto success_at_start;
476 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
478 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
479 end_shift = prog->minlen - start_shift -
480 CHR_SVLEN(check) + (SvTAIL(check) != 0);
482 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
483 - (SvTAIL(check) != 0);
484 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
486 if (end_shift < eshift)
490 else { /* Can match at random position */
493 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
494 /* Should be nonnegative! */
495 end_shift = prog->minlen - start_shift -
496 CHR_SVLEN(check) + (SvTAIL(check) != 0);
499 #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
501 Perl_croak(aTHX_ "panic: end_shift");
505 /* Find a possible match in the region s..strend by looking for
506 the "check" substring in the region corrected by start/end_shift. */
507 if (flags & REXEC_SCREAM) {
508 I32 p = -1; /* Internal iterator of scream. */
509 I32 * const pp = data ? data->scream_pos : &p;
511 if (PL_screamfirst[BmRARE(check)] >= 0
512 || ( BmRARE(check) == '\n'
513 && (BmPREVIOUS(check) == SvCUR(check) - 1)
515 s = screaminstr(sv, check,
516 start_shift + (s - strbeg), end_shift, pp, 0);
519 /* we may be pointing at the wrong string */
520 if (s && RX_MATCH_COPIED(prog))
521 s = strbeg + (s - SvPVX_const(sv));
523 *data->scream_olds = s;
525 else if (prog->reganch & ROPT_CANY_SEEN)
526 s = fbm_instr((U8*)(s + start_shift),
527 (U8*)(strend - end_shift),
528 check, multiline ? FBMrf_MULTILINE : 0);
530 s = fbm_instr(HOP3(s, start_shift, strend),
531 HOP3(strend, -end_shift, strbeg),
532 check, multiline ? FBMrf_MULTILINE : 0);
534 /* Update the count-of-usability, remove useless subpatterns,
537 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s",
538 (s ? "Found" : "Did not find"),
539 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
541 (int)(SvCUR(check) - (SvTAIL(check)!=0)),
543 PL_colors[1], (SvTAIL(check) ? "$" : ""),
544 (s ? " at offset " : "...\n") ) );
551 /* Finish the diagnostic message */
552 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
554 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
555 Start with the other substr.
556 XXXX no SCREAM optimization yet - and a very coarse implementation
557 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
558 *always* match. Probably should be marked during compile...
559 Probably it is right to do no SCREAM here...
562 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
563 /* Take into account the "other" substring. */
564 /* XXXX May be hopelessly wrong for UTF... */
567 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
570 char * const last = HOP3c(s, -start_shift, strbeg);
572 char * const saved_s = s;
575 t = s - prog->check_offset_max;
576 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
578 || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
583 t = HOP3c(t, prog->anchored_offset, strend);
584 if (t < other_last) /* These positions already checked */
586 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
589 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
590 /* On end-of-str: see comment below. */
591 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
592 if (must == &PL_sv_undef) {
594 DEBUG_EXECUTE_r(must = prog->anchored_utf8); /* for debug */
599 HOP3(HOP3(last1, prog->anchored_offset, strend)
600 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
602 multiline ? FBMrf_MULTILINE : 0
604 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
605 "%s anchored substr \"%s%.*s%s\"%s",
606 (s ? "Found" : "Contradicts"),
609 - (SvTAIL(must)!=0)),
611 PL_colors[1], (SvTAIL(must) ? "$" : "")));
613 if (last1 >= last2) {
614 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
615 ", giving up...\n"));
618 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
619 ", trying floating at offset %ld...\n",
620 (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
621 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
622 s = HOP3c(last, 1, strend);
626 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
627 (long)(s - i_strpos)));
628 t = HOP3c(s, -prog->anchored_offset, strbeg);
629 other_last = HOP3c(s, 1, strend);
637 else { /* Take into account the floating substring. */
639 char * const saved_s = s;
642 t = HOP3c(s, -start_shift, strbeg);
644 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
645 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
646 last = HOP3c(t, prog->float_max_offset, strend);
647 s = HOP3c(t, prog->float_min_offset, strend);
650 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
651 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
652 /* fbm_instr() takes into account exact value of end-of-str
653 if the check is SvTAIL(ed). Since false positives are OK,
654 and end-of-str is not later than strend we are OK. */
655 if (must == &PL_sv_undef) {
657 DEBUG_EXECUTE_r(must = prog->float_utf8); /* for debug message */
660 s = fbm_instr((unsigned char*)s,
661 (unsigned char*)last + SvCUR(must)
663 must, multiline ? FBMrf_MULTILINE : 0);
664 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
665 (s ? "Found" : "Contradicts"),
667 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
669 PL_colors[1], (SvTAIL(must) ? "$" : "")));
672 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
673 ", giving up...\n"));
676 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
677 ", trying anchored starting at offset %ld...\n",
678 (long)(saved_s + 1 - i_strpos)));
680 s = HOP3c(t, 1, strend);
684 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
685 (long)(s - i_strpos)));
686 other_last = s; /* Fix this later. --Hugo */
695 t = s - prog->check_offset_max;
696 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
698 || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*)strpos))
700 /* Fixed substring is found far enough so that the match
701 cannot start at strpos. */
703 if (ml_anch && t[-1] != '\n') {
704 /* Eventually fbm_*() should handle this, but often
705 anchored_offset is not 0, so this check will not be wasted. */
706 /* XXXX In the code below we prefer to look for "^" even in
707 presence of anchored substrings. And we search even
708 beyond the found float position. These pessimizations
709 are historical artefacts only. */
711 while (t < strend - prog->minlen) {
713 if (t < check_at - prog->check_offset_min) {
714 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
715 /* Since we moved from the found position,
716 we definitely contradict the found anchored
717 substr. Due to the above check we do not
718 contradict "check" substr.
719 Thus we can arrive here only if check substr
720 is float. Redo checking for "other"=="fixed".
723 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
724 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
725 goto do_other_anchored;
727 /* We don't contradict the found floating substring. */
728 /* XXXX Why not check for STCLASS? */
730 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
731 PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
734 /* Position contradicts check-string */
735 /* XXXX probably better to look for check-string
736 than for "\n", so one should lower the limit for t? */
737 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
738 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
739 other_last = strpos = s = t + 1;
744 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
745 PL_colors[0], PL_colors[1]));
749 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
750 PL_colors[0], PL_colors[1]));
754 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
757 /* The found string does not prohibit matching at strpos,
758 - no optimization of calling REx engine can be performed,
759 unless it was an MBOL and we are not after MBOL,
760 or a future STCLASS check will fail this. */
762 /* Even in this situation we may use MBOL flag if strpos is offset
763 wrt the start of the string. */
764 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
765 && (strpos != strbeg) && strpos[-1] != '\n'
766 /* May be due to an implicit anchor of m{.*foo} */
767 && !(prog->reganch & ROPT_IMPLICIT))
772 DEBUG_EXECUTE_r( if (ml_anch)
773 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
774 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
777 if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
779 prog->check_utf8 /* Could be deleted already */
780 && --BmUSEFUL(prog->check_utf8) < 0
781 && (prog->check_utf8 == prog->float_utf8)
783 prog->check_substr /* Could be deleted already */
784 && --BmUSEFUL(prog->check_substr) < 0
785 && (prog->check_substr == prog->float_substr)
788 /* If flags & SOMETHING - do not do it many times on the same match */
789 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
790 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
791 if (do_utf8 ? prog->check_substr : prog->check_utf8)
792 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
793 prog->check_substr = prog->check_utf8 = NULL; /* disable */
794 prog->float_substr = prog->float_utf8 = NULL; /* clear */
795 check = NULL; /* abort */
797 /* XXXX This is a remnant of the old implementation. It
798 looks wasteful, since now INTUIT can use many
800 prog->reganch &= ~RE_USE_INTUIT;
807 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
808 if (prog->regstclass && OP(prog->regstclass)!=TRIE) {
809 /* minlen == 0 is possible if regstclass is \b or \B,
810 and the fixed substr is ''$.
811 Since minlen is already taken into account, s+1 is before strend;
812 accidentally, minlen >= 1 guaranties no false positives at s + 1
813 even for \b or \B. But (minlen? 1 : 0) below assumes that
814 regstclass does not come from lookahead... */
815 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
816 This leaves EXACTF only, which is dealt with in find_byclass(). */
817 const U8* const str = (U8*)STRING(prog->regstclass);
818 const int cl_l = (PL_regkind[OP(prog->regstclass)] == EXACT
819 ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
821 const char * endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
822 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
823 : (prog->float_substr || prog->float_utf8
824 ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
827 /*if (OP(prog->regstclass) == TRIE)
830 s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
833 const char *what = NULL;
835 if (endpos == strend) {
836 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
837 "Could not match STCLASS...\n") );
840 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
841 "This position contradicts STCLASS...\n") );
842 if ((prog->reganch & ROPT_ANCH) && !ml_anch)
844 /* Contradict one of substrings */
845 if (prog->anchored_substr || prog->anchored_utf8) {
846 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
847 DEBUG_EXECUTE_r( what = "anchored" );
849 s = HOP3c(t, 1, strend);
850 if (s + start_shift + end_shift > strend) {
851 /* XXXX Should be taken into account earlier? */
852 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
853 "Could not match STCLASS...\n") );
858 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
859 "Looking for %s substr starting at offset %ld...\n",
860 what, (long)(s + start_shift - i_strpos)) );
863 /* Have both, check_string is floating */
864 if (t + start_shift >= check_at) /* Contradicts floating=check */
865 goto retry_floating_check;
866 /* Recheck anchored substring, but not floating... */
870 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
871 "Looking for anchored substr starting at offset %ld...\n",
872 (long)(other_last - i_strpos)) );
873 goto do_other_anchored;
875 /* Another way we could have checked stclass at the
876 current position only: */
881 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
882 "Looking for /%s^%s/m starting at offset %ld...\n",
883 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
886 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
888 /* Check is floating subtring. */
889 retry_floating_check:
890 t = check_at - start_shift;
891 DEBUG_EXECUTE_r( what = "floating" );
892 goto hop_and_restart;
895 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
896 "By STCLASS: moving %ld --> %ld\n",
897 (long)(t - i_strpos), (long)(s - i_strpos))
901 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
902 "Does not contradict STCLASS...\n");
907 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
908 PL_colors[4], (check ? "Guessed" : "Giving up"),
909 PL_colors[5], (long)(s - i_strpos)) );
912 fail_finish: /* Substring not found */
913 if (prog->check_substr || prog->check_utf8) /* could be removed already */
914 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
916 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
917 PL_colors[4], PL_colors[5]));
921 /* We know what class REx starts with. Try to find this position... */
922 /* if reginfo is NULL, its a dryrun */
923 /* annoyingly all the vars in this routine have different names from their counterparts
924 in regmatch. /grrr */
927 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
928 const char *strend, const regmatch_info *reginfo)
931 const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
935 register STRLEN uskip;
939 register I32 tmp = 1; /* Scratch variable? */
940 register const bool do_utf8 = PL_reg_match_utf8;
942 /* We know what class it must start with. */
946 while (s + (uskip = UTF8SKIP(s)) <= strend) {
947 if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
948 !UTF8_IS_INVARIANT((U8)s[0]) ?
949 reginclass(prog, c, (U8*)s, 0, do_utf8) :
950 REGINCLASS(prog, c, (U8*)s)) {
951 if (tmp && (!reginfo || regtry(reginfo, s)))
965 if (REGINCLASS(prog, c, (U8*)s) ||
966 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
967 /* The assignment of 2 is intentional:
968 * for the folded sharp s, the skip is 2. */
969 (skip = SHARP_S_SKIP))) {
970 if (tmp && (!reginfo || regtry(reginfo, s)))
983 if (tmp && (!reginfo || regtry(reginfo, s)))
992 ln = STR_LEN(c); /* length to match in octets/bytes */
993 lnc = (I32) ln; /* length to match in characters */
997 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
998 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
999 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1001 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1002 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1004 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1006 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1009 while (sm < ((U8 *) m + ln)) {
1024 c2 = PL_fold_locale[c1];
1026 e = HOP3c(strend, -((I32)lnc), s);
1028 if (!reginfo && e < s)
1029 e = s; /* Due to minlen logic of intuit() */
1031 /* The idea in the EXACTF* cases is to first find the
1032 * first character of the EXACTF* node and then, if
1033 * necessary, case-insensitively compare the full
1034 * text of the node. The c1 and c2 are the first
1035 * characters (though in Unicode it gets a bit
1036 * more complicated because there are more cases
1037 * than just upper and lower: one needs to use
1038 * the so-called folding case for case-insensitive
1039 * matching (called "loose matching" in Unicode).
1040 * ibcmp_utf8() will do just that. */
1044 U8 tmpbuf [UTF8_MAXBYTES+1];
1045 STRLEN len, foldlen;
1046 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1048 /* Upper and lower of 1st char are equal -
1049 * probably not a "letter". */
1051 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1055 ibcmp_utf8(s, NULL, 0, do_utf8,
1056 m, NULL, ln, (bool)UTF))
1057 && (!reginfo || regtry(reginfo, s)) )
1060 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1061 uvchr_to_utf8(tmpbuf, c);
1062 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1064 && (f == c1 || f == c2)
1065 && (ln == foldlen ||
1066 !ibcmp_utf8((char *) foldbuf,
1067 NULL, foldlen, do_utf8,
1069 NULL, ln, (bool)UTF))
1070 && (!reginfo || regtry(reginfo, s)) )
1078 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1081 /* Handle some of the three Greek sigmas cases.
1082 * Note that not all the possible combinations
1083 * are handled here: some of them are handled
1084 * by the standard folding rules, and some of
1085 * them (the character class or ANYOF cases)
1086 * are handled during compiletime in
1087 * regexec.c:S_regclass(). */
1088 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1089 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1090 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1092 if ( (c == c1 || c == c2)
1094 ibcmp_utf8(s, NULL, 0, do_utf8,
1095 m, NULL, ln, (bool)UTF))
1096 && (!reginfo || regtry(reginfo, s)) )
1099 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1100 uvchr_to_utf8(tmpbuf, c);
1101 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1103 && (f == c1 || f == c2)
1104 && (ln == foldlen ||
1105 !ibcmp_utf8((char *) foldbuf,
1106 NULL, foldlen, do_utf8,
1108 NULL, ln, (bool)UTF))
1109 && (!reginfo || regtry(reginfo, s)) )
1120 && (ln == 1 || !(OP(c) == EXACTF
1122 : ibcmp_locale(s, m, ln)))
1123 && (!reginfo || regtry(reginfo, s)) )
1129 if ( (*(U8*)s == c1 || *(U8*)s == c2)
1130 && (ln == 1 || !(OP(c) == EXACTF
1132 : ibcmp_locale(s, m, ln)))
1133 && (!reginfo || regtry(reginfo, s)) )
1140 PL_reg_flags |= RF_tainted;
1147 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1148 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1150 tmp = ((OP(c) == BOUND ?
1151 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1152 LOAD_UTF8_CHARCLASS_ALNUM();
1153 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1154 if (tmp == !(OP(c) == BOUND ?
1155 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1156 isALNUM_LC_utf8((U8*)s)))
1159 if ((!reginfo || regtry(reginfo, s)))
1166 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1167 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1168 while (s < strend) {
1170 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1172 if ((!reginfo || regtry(reginfo, s)))
1178 if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, s)))
1182 PL_reg_flags |= RF_tainted;
1189 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1190 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1192 tmp = ((OP(c) == NBOUND ?
1193 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1194 LOAD_UTF8_CHARCLASS_ALNUM();
1195 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1196 if (tmp == !(OP(c) == NBOUND ?
1197 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1198 isALNUM_LC_utf8((U8*)s)))
1200 else if ((!reginfo || regtry(reginfo, s)))
1206 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1207 tmp = ((OP(c) == NBOUND ?
1208 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1209 while (s < strend) {
1211 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1213 else if ((!reginfo || regtry(reginfo, s)))
1218 if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, s)))
1223 LOAD_UTF8_CHARCLASS_ALNUM();
1224 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1225 if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1226 if (tmp && (!reginfo || regtry(reginfo, s)))
1237 while (s < strend) {
1239 if (tmp && (!reginfo || regtry(reginfo, s)))
1251 PL_reg_flags |= RF_tainted;
1253 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1254 if (isALNUM_LC_utf8((U8*)s)) {
1255 if (tmp && (!reginfo || regtry(reginfo, s)))
1266 while (s < strend) {
1267 if (isALNUM_LC(*s)) {
1268 if (tmp && (!reginfo || regtry(reginfo, s)))
1281 LOAD_UTF8_CHARCLASS_ALNUM();
1282 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1283 if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1284 if (tmp && (!reginfo || regtry(reginfo, s)))
1295 while (s < strend) {
1297 if (tmp && (!reginfo || regtry(reginfo, s)))
1309 PL_reg_flags |= RF_tainted;
1311 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1312 if (!isALNUM_LC_utf8((U8*)s)) {
1313 if (tmp && (!reginfo || regtry(reginfo, s)))
1324 while (s < strend) {
1325 if (!isALNUM_LC(*s)) {
1326 if (tmp && (!reginfo || regtry(reginfo, s)))
1339 LOAD_UTF8_CHARCLASS_SPACE();
1340 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1341 if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1342 if (tmp && (!reginfo || regtry(reginfo, s)))
1353 while (s < strend) {
1355 if (tmp && (!reginfo || regtry(reginfo, s)))
1367 PL_reg_flags |= RF_tainted;
1369 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1370 if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1371 if (tmp && (!reginfo || regtry(reginfo, s)))
1382 while (s < strend) {
1383 if (isSPACE_LC(*s)) {
1384 if (tmp && (!reginfo || regtry(reginfo, s)))
1397 LOAD_UTF8_CHARCLASS_SPACE();
1398 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1399 if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1400 if (tmp && (!reginfo || regtry(reginfo, s)))
1411 while (s < strend) {
1413 if (tmp && (!reginfo || regtry(reginfo, s)))
1425 PL_reg_flags |= RF_tainted;
1427 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1428 if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1429 if (tmp && (!reginfo || regtry(reginfo, s)))
1440 while (s < strend) {
1441 if (!isSPACE_LC(*s)) {
1442 if (tmp && (!reginfo || regtry(reginfo, s)))
1455 LOAD_UTF8_CHARCLASS_DIGIT();
1456 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1457 if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1458 if (tmp && (!reginfo || regtry(reginfo, s)))
1469 while (s < strend) {
1471 if (tmp && (!reginfo || regtry(reginfo, s)))
1483 PL_reg_flags |= RF_tainted;
1485 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1486 if (isDIGIT_LC_utf8((U8*)s)) {
1487 if (tmp && (!reginfo || regtry(reginfo, s)))
1498 while (s < strend) {
1499 if (isDIGIT_LC(*s)) {
1500 if (tmp && (!reginfo || regtry(reginfo, s)))
1513 LOAD_UTF8_CHARCLASS_DIGIT();
1514 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1515 if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1516 if (tmp && (!reginfo || regtry(reginfo, s)))
1527 while (s < strend) {
1529 if (tmp && (!reginfo || regtry(reginfo, s)))
1541 PL_reg_flags |= RF_tainted;
1543 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1544 if (!isDIGIT_LC_utf8((U8*)s)) {
1545 if (tmp && (!reginfo || regtry(reginfo, s)))
1556 while (s < strend) {
1557 if (!isDIGIT_LC(*s)) {
1558 if (tmp && (!reginfo || regtry(reginfo, s)))
1570 /*Perl_croak(aTHX_ "panic: unknown regstclass TRIE");*/
1572 const enum { trie_plain, trie_utf8, trie_utf8_fold }
1573 trie_type = do_utf8 ?
1574 (c->flags == EXACT ? trie_utf8 : trie_utf8_fold)
1576 /* what trie are we using right now */
1578 = (reg_ac_data*)prog->data->data[ ARG( c ) ];
1579 reg_trie_data *trie=aho->trie;
1581 const char *last_start = strend - trie->minlen;
1582 const char *real_start = s;
1583 STRLEN maxlen = trie->maxlen;
1585 U8 **points; /* map of where we were in the input string
1586 when reading a given string. For ASCII this
1587 is unnecessary overhead as the relationship
1588 is always 1:1, but for unicode, especially
1589 case folded unicode this is not true. */
1591 GET_RE_DEBUG_FLAGS_DECL;
1593 /* We can't just allocate points here. We need to wrap it in
1594 * an SV so it gets freed properly if there is a croak while
1595 * running the match */
1598 sv_points=newSV(maxlen * sizeof(U8 *));
1599 SvCUR_set(sv_points,
1600 maxlen * sizeof(U8 *));
1601 SvPOK_on(sv_points);
1602 sv_2mortal(sv_points);
1603 points=(U8**)SvPV_nolen(sv_points );
1605 if (trie->bitmap && trie_type != trie_utf8_fold) {
1606 while (!TRIE_BITMAP_TEST(trie,*s) && s <= last_start ) {
1611 while (s <= last_start) {
1612 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1620 U8 *uscan = (U8*)NULL;
1621 U8 *leftmost = NULL;
1625 while ( state && uc <= (U8*)strend ) {
1627 if (aho->states[ state ].wordnum) {
1628 U8 *lpos= points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1] ) % maxlen ];
1629 if (!leftmost || lpos < leftmost)
1633 points[pointpos++ % maxlen]= uc;
1634 switch (trie_type) {
1635 case trie_utf8_fold:
1637 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
1642 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1643 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
1644 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
1645 foldlen -= UNISKIP( uvc );
1646 uscan = foldbuf + UNISKIP( uvc );
1650 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
1659 charid = trie->charmap[ uvc ];
1663 if (trie->widecharmap) {
1664 SV** const svpp = hv_fetch(trie->widecharmap,
1665 (char*)&uvc, sizeof(UV), 0);
1667 charid = (U16)SvIV(*svpp);
1670 DEBUG_TRIE_EXECUTE_r(
1671 PerlIO_printf(Perl_debug_log,
1672 "Pos: %d Charid:%3x CV:%4"UVxf" ",
1673 (int)((const char*)uc - real_start), charid, uvc)
1678 U32 word = aho->states[ state ].wordnum;
1679 base = aho->states[ state ].trans.base;
1681 DEBUG_TRIE_EXECUTE_r(
1682 PerlIO_printf( Perl_debug_log,
1683 "%sState: %4"UVxf", Base: 0x%-4"UVxf" uvc=%"UVxf" word=%"UVxf"\n",
1684 failed ? "Fail transition to " : "",
1685 state, base, uvc, word)
1690 (base + charid > trie->uniquecharcount )
1691 && (base + charid - 1 - trie->uniquecharcount
1693 && trie->trans[base + charid - 1 -
1694 trie->uniquecharcount].check == state
1695 && (tmp=trie->trans[base + charid - 1 -
1696 trie->uniquecharcount ].next))
1706 state = aho->fail[state];
1710 /* we must be accepting here */
1718 else if (!charid && trie->bitmap && trie_type != trie_utf8_fold) {
1719 while (!TRIE_BITMAP_TEST(trie,*uc) && uc <= (U8*)last_start ) {
1725 if ( aho->states[ state ].wordnum ) {
1726 U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1727 if (!leftmost || lpos < leftmost)
1730 DEBUG_TRIE_EXECUTE_r(
1731 PerlIO_printf( Perl_debug_log,
1732 "%sState: %4"UVxf", Base: 0x%-4"UVxf" uvc=%"UVxf"\n",
1737 s = (char*)leftmost;
1738 if (!reginfo || regtry(reginfo, s)) {
1753 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1762 - regexec_flags - match a regexp against a string
1765 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1766 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1767 /* strend: pointer to null at end of string */
1768 /* strbeg: real beginning of string */
1769 /* minend: end of match must be >=minend after stringarg. */
1770 /* data: May be used for some additional optimizations. */
1771 /* nosave: For optimizations. */
1775 register regnode *c;
1776 register char *startpos = stringarg;
1777 I32 minlen; /* must match at least this many chars */
1778 I32 dontbother = 0; /* how many characters not to try at end */
1779 I32 end_shift = 0; /* Same for the end. */ /* CC */
1780 I32 scream_pos = -1; /* Internal iterator of scream. */
1781 char *scream_olds = NULL;
1782 SV* const oreplsv = GvSV(PL_replgv);
1783 const bool do_utf8 = DO_UTF8(sv);
1789 regmatch_info reginfo; /* create some info to pass to regtry etc */
1791 GET_RE_DEBUG_FLAGS_DECL;
1793 PERL_UNUSED_ARG(data);
1795 /* Be paranoid... */
1796 if (prog == NULL || startpos == NULL) {
1797 Perl_croak(aTHX_ "NULL regexp parameter");
1801 multiline = prog->reganch & PMf_MULTILINE;
1802 reginfo.prog = prog;
1805 dsv0 = PERL_DEBUG_PAD_ZERO(0);
1806 dsv1 = PERL_DEBUG_PAD_ZERO(1);
1809 RX_MATCH_UTF8_set(prog, do_utf8);
1811 minlen = prog->minlen;
1812 if (strend - startpos < minlen) {
1813 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1814 "String too short [regexec_flags]...\n"));
1818 /* Check validity of program. */
1819 if (UCHARAT(prog->program) != REG_MAGIC) {
1820 Perl_croak(aTHX_ "corrupted regexp program");
1824 PL_reg_eval_set = 0;
1827 if (prog->reganch & ROPT_UTF8)
1828 PL_reg_flags |= RF_utf8;
1830 /* Mark beginning of line for ^ and lookbehind. */
1831 reginfo.bol = startpos; /* XXX not used ??? */
1835 /* Mark end of line for $ (and such) */
1838 /* see how far we have to get to not match where we matched before */
1839 reginfo.till = startpos+minend;
1841 /* If there is a "must appear" string, look for it. */
1844 if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to set reginfo->ganch */
1847 if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
1848 reginfo.ganch = startpos;
1849 else if (sv && SvTYPE(sv) >= SVt_PVMG
1851 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1852 && mg->mg_len >= 0) {
1853 reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
1854 if (prog->reganch & ROPT_ANCH_GPOS) {
1855 if (s > reginfo.ganch)
1860 else /* pos() not defined */
1861 reginfo.ganch = strbeg;
1864 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1865 re_scream_pos_data d;
1867 d.scream_olds = &scream_olds;
1868 d.scream_pos = &scream_pos;
1869 s = re_intuit_start(prog, sv, s, strend, flags, &d);
1871 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1872 goto phooey; /* not present */
1877 const char * const s0 = UTF
1878 ? pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
1881 const int len0 = UTF ? (int)SvCUR(dsv0) : prog->prelen;
1882 const char * const s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60,
1883 UNI_DISPLAY_REGEX) : startpos;
1884 const int len1 = do_utf8 ? (int)SvCUR(dsv1) : strend - startpos;
1887 PerlIO_printf(Perl_debug_log,
1888 "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n",
1889 PL_colors[4], PL_colors[5], PL_colors[0],
1892 len0 > 60 ? "..." : "",
1894 (int)(len1 > 60 ? 60 : len1),
1896 (len1 > 60 ? "..." : "")
1900 /* Simplest case: anchored match need be tried only once. */
1901 /* [unless only anchor is BOL and multiline is set] */
1902 if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1903 if (s == startpos && regtry(®info, startpos))
1905 else if (multiline || (prog->reganch & ROPT_IMPLICIT)
1906 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1911 dontbother = minlen - 1;
1912 end = HOP3c(strend, -dontbother, strbeg) - 1;
1913 /* for multiline we only have to try after newlines */
1914 if (prog->check_substr || prog->check_utf8) {
1918 if (regtry(®info, s))
1923 if (prog->reganch & RE_USE_INTUIT) {
1924 s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1935 if (*s++ == '\n') { /* don't need PL_utf8skip here */
1936 if (regtry(®info, s))
1943 } else if (prog->reganch & ROPT_ANCH_GPOS) {
1944 if (regtry(®info, reginfo.ganch))
1949 /* Messy cases: unanchored match. */
1950 if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1951 /* we have /x+whatever/ */
1952 /* it must be a one character string (XXXX Except UTF?) */
1957 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1958 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1959 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1962 while (s < strend) {
1964 DEBUG_EXECUTE_r( did_match = 1 );
1965 if (regtry(®info, s)) goto got_it;
1967 while (s < strend && *s == ch)
1974 while (s < strend) {
1976 DEBUG_EXECUTE_r( did_match = 1 );
1977 if (regtry(®info, s)) goto got_it;
1979 while (s < strend && *s == ch)
1985 DEBUG_EXECUTE_r(if (!did_match)
1986 PerlIO_printf(Perl_debug_log,
1987 "Did not find anchored character...\n")
1990 else if (prog->anchored_substr != NULL
1991 || prog->anchored_utf8 != NULL
1992 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1993 && prog->float_max_offset < strend - s)) {
1998 char *last1; /* Last position checked before */
2002 if (prog->anchored_substr || prog->anchored_utf8) {
2003 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
2004 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2005 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
2006 back_max = back_min = prog->anchored_offset;
2008 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2009 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2010 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2011 back_max = prog->float_max_offset;
2012 back_min = prog->float_min_offset;
2014 if (must == &PL_sv_undef)
2015 /* could not downgrade utf8 check substring, so must fail */
2018 last = HOP3c(strend, /* Cannot start after this */
2019 -(I32)(CHR_SVLEN(must)
2020 - (SvTAIL(must) != 0) + back_min), strbeg);
2023 last1 = HOPc(s, -1);
2025 last1 = s - 1; /* bogus */
2027 /* XXXX check_substr already used to find "s", can optimize if
2028 check_substr==must. */
2030 dontbother = end_shift;
2031 strend = HOPc(strend, -dontbother);
2032 while ( (s <= last) &&
2033 ((flags & REXEC_SCREAM)
2034 ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
2035 end_shift, &scream_pos, 0))
2036 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
2037 (unsigned char*)strend, must,
2038 multiline ? FBMrf_MULTILINE : 0))) ) {
2039 /* we may be pointing at the wrong string */
2040 if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
2041 s = strbeg + (s - SvPVX_const(sv));
2042 DEBUG_EXECUTE_r( did_match = 1 );
2043 if (HOPc(s, -back_max) > last1) {
2044 last1 = HOPc(s, -back_min);
2045 s = HOPc(s, -back_max);
2048 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2050 last1 = HOPc(s, -back_min);
2054 while (s <= last1) {
2055 if (regtry(®info, s))
2061 while (s <= last1) {
2062 if (regtry(®info, s))
2068 DEBUG_EXECUTE_r(if (!did_match)
2069 PerlIO_printf(Perl_debug_log,
2070 "Did not find %s substr \"%s%.*s%s\"%s...\n",
2071 ((must == prog->anchored_substr || must == prog->anchored_utf8)
2072 ? "anchored" : "floating"),
2074 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
2076 PL_colors[1], (SvTAIL(must) ? "$" : ""))
2080 else if ((c = prog->regstclass)) {
2082 const OPCODE op = OP(prog->regstclass);
2083 /* don't bother with what can't match */
2084 if (PL_regkind[op] != EXACT && op != CANY && op != TRIE)
2085 strend = HOPc(strend, -(minlen - 1));
2088 SV * const prop = sv_newmortal();
2094 regprop(prog, prop, c);
2096 pv_uni_display(dsv0, (U8*)SvPVX_const(prop), SvCUR(prop), 60,
2097 UNI_DISPLAY_REGEX) :
2099 len0 = UTF ? SvCUR(dsv0) : SvCUR(prop);
2101 sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
2102 len1 = UTF ? (int)SvCUR(dsv1) : strend - s;
2103 PerlIO_printf(Perl_debug_log,
2104 "Matching stclass \"%*.*s\" against \"%*.*s\" (%d chars)\n",
2106 len1, len1, s1, (int)(strend - s));
2108 if (find_byclass(prog, c, s, strend, ®info))
2110 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2114 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2119 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2120 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2121 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2123 if (flags & REXEC_SCREAM) {
2124 last = screaminstr(sv, float_real, s - strbeg,
2125 end_shift, &scream_pos, 1); /* last one */
2127 last = scream_olds; /* Only one occurrence. */
2128 /* we may be pointing at the wrong string */
2129 else if (RX_MATCH_COPIED(prog))
2130 s = strbeg + (s - SvPVX_const(sv));
2134 const char * const little = SvPV_const(float_real, len);
2136 if (SvTAIL(float_real)) {
2137 if (memEQ(strend - len + 1, little, len - 1))
2138 last = strend - len + 1;
2139 else if (!multiline)
2140 last = memEQ(strend - len, little, len)
2141 ? strend - len : NULL;
2147 last = rninstr(s, strend, little, little + len);
2149 last = strend; /* matching "$" */
2153 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2154 "%sCan't trim the tail, match fails (should not happen)%s\n",
2155 PL_colors[4], PL_colors[5]));
2156 goto phooey; /* Should not happen! */
2158 dontbother = strend - last + prog->float_min_offset;
2160 if (minlen && (dontbother < minlen))
2161 dontbother = minlen - 1;
2162 strend -= dontbother; /* this one's always in bytes! */
2163 /* We don't know much -- general case. */
2166 if (regtry(®info, s))
2175 if (regtry(®info, s))
2177 } while (s++ < strend);
2185 RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2187 if (PL_reg_eval_set) {
2188 /* Preserve the current value of $^R */
2189 if (oreplsv != GvSV(PL_replgv))
2190 sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2191 restored, the value remains
2193 restore_pos(aTHX_ prog);
2196 /* make sure $`, $&, $', and $digit will work later */
2197 if ( !(flags & REXEC_NOT_FIRST) ) {
2198 RX_MATCH_COPY_FREE(prog);
2199 if (flags & REXEC_COPY_STR) {
2200 const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2201 #ifdef PERL_OLD_COPY_ON_WRITE
2203 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2205 PerlIO_printf(Perl_debug_log,
2206 "Copy on write: regexp capture, type %d\n",
2209 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2210 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2211 assert (SvPOKp(prog->saved_copy));
2215 RX_MATCH_COPIED_on(prog);
2216 s = savepvn(strbeg, i);
2222 prog->subbeg = strbeg;
2223 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2230 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2231 PL_colors[4], PL_colors[5]));
2232 if (PL_reg_eval_set)
2233 restore_pos(aTHX_ prog);
2238 - regtry - try match at specific point
2240 STATIC I32 /* 0 failure, 1 success */
2241 S_regtry(pTHX_ const regmatch_info *reginfo, char *startpos)
2247 regexp *prog = reginfo->prog;
2248 GET_RE_DEBUG_FLAGS_DECL;
2251 PL_regindent = 0; /* XXXX Not good when matches are reenterable... */
2253 if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2256 PL_reg_eval_set = RS_init;
2257 DEBUG_EXECUTE_r(DEBUG_s(
2258 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2259 (IV)(PL_stack_sp - PL_stack_base));
2261 SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2262 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2263 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2265 /* Apparently this is not needed, judging by wantarray. */
2266 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2267 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2270 /* Make $_ available to executed code. */
2271 if (reginfo->sv != DEFSV) {
2273 DEFSV = reginfo->sv;
2276 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2277 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2278 /* prepare for quick setting of pos */
2279 #ifdef PERL_OLD_COPY_ON_WRITE
2281 sv_force_normal_flags(sv, 0);
2283 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2284 &PL_vtbl_mglob, NULL, 0);
2288 PL_reg_oldpos = mg->mg_len;
2289 SAVEDESTRUCTOR_X(restore_pos, prog);
2291 if (!PL_reg_curpm) {
2292 Newxz(PL_reg_curpm, 1, PMOP);
2295 SV* const repointer = newSViv(0);
2296 /* so we know which PL_regex_padav element is PL_reg_curpm */
2297 SvFLAGS(repointer) |= SVf_BREAK;
2298 av_push(PL_regex_padav,repointer);
2299 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2300 PL_regex_pad = AvARRAY(PL_regex_padav);
2304 PM_SETRE(PL_reg_curpm, prog);
2305 PL_reg_oldcurpm = PL_curpm;
2306 PL_curpm = PL_reg_curpm;
2307 if (RX_MATCH_COPIED(prog)) {
2308 /* Here is a serious problem: we cannot rewrite subbeg,
2309 since it may be needed if this match fails. Thus
2310 $` inside (?{}) could fail... */
2311 PL_reg_oldsaved = prog->subbeg;
2312 PL_reg_oldsavedlen = prog->sublen;
2313 #ifdef PERL_OLD_COPY_ON_WRITE
2314 PL_nrs = prog->saved_copy;
2316 RX_MATCH_COPIED_off(prog);
2319 PL_reg_oldsaved = NULL;
2320 prog->subbeg = PL_bostr;
2321 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2323 prog->startp[0] = startpos - PL_bostr;
2324 PL_reginput = startpos;
2325 PL_regstartp = prog->startp;
2326 PL_regendp = prog->endp;
2327 PL_reglastparen = &prog->lastparen;
2328 PL_reglastcloseparen = &prog->lastcloseparen;
2329 prog->lastparen = 0;
2330 prog->lastcloseparen = 0;
2332 DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
2333 if (PL_reg_start_tmpl <= prog->nparens) {
2334 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2335 if(PL_reg_start_tmp)
2336 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2338 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2341 /* XXXX What this code is doing here?!!! There should be no need
2342 to do this again and again, PL_reglastparen should take care of
2345 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2346 * Actually, the code in regcppop() (which Ilya may be meaning by
2347 * PL_reglastparen), is not needed at all by the test suite
2348 * (op/regexp, op/pat, op/split), but that code is needed, oddly
2349 * enough, for building DynaLoader, or otherwise this
2350 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2351 * will happen. Meanwhile, this code *is* needed for the
2352 * above-mentioned test suite tests to succeed. The common theme
2353 * on those tests seems to be returning null fields from matches.
2358 if (prog->nparens) {
2360 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2367 if (regmatch(reginfo, prog->program + 1)) {
2368 prog->endp[0] = PL_reginput - PL_bostr;
2371 REGCP_UNWIND(lastcp);
2375 #define RE_UNWIND_BRANCH 1
2376 #define RE_UNWIND_BRANCHJ 2
2380 typedef struct { /* XX: makes sense to enlarge it... */
2384 } re_unwind_generic_t;
2398 } re_unwind_branch_t;
2400 typedef union re_unwind_t {
2402 re_unwind_generic_t generic;
2403 re_unwind_branch_t branch;
2406 #define sayYES goto yes
2407 #define sayNO goto no
2408 #define sayNO_ANYOF goto no_anyof
2409 #define sayYES_FINAL goto yes_final
2410 #define sayNO_FINAL goto no_final
2411 #define sayNO_SILENT goto do_no
2412 #define saySAME(x) if (x) goto yes; else goto no
2414 #define POSCACHE_SUCCESS 0 /* caching success rather than failure */
2415 #define POSCACHE_SEEN 1 /* we know what we're caching */
2416 #define POSCACHE_START 2 /* the real cache: this bit maps to pos 0 */
2418 #define CACHEsayYES STMT_START { \
2419 if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2420 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2421 PL_reg_poscache[0] |= (1<<POSCACHE_SUCCESS) | (1<<POSCACHE_SEEN); \
2422 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2424 else if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS)) { \
2425 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2428 /* cache records failure, but this is success */ \
2430 PerlIO_printf(Perl_debug_log, \
2431 "%*s (remove success from failure cache)\n", \
2432 REPORT_CODE_OFF+PL_regindent*2, "") \
2434 PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2440 #define CACHEsayNO STMT_START { \
2441 if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2442 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2443 PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2444 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2446 else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2447 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2450 /* cache records success, but this is failure */ \
2452 PerlIO_printf(Perl_debug_log, \
2453 "%*s (remove failure from success cache)\n", \
2454 REPORT_CODE_OFF+PL_regindent*2, "") \
2456 PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2462 /* this is used to determine how far from the left messages like
2463 'failed...' are printed. Currently 29 makes these messages line
2464 up with the opcode they refer to. Earlier perls used 25 which
2465 left these messages outdented making reviewing a debug output
2468 #define REPORT_CODE_OFF 29
2471 /* Make sure there is a test for this +1 options in re_tests */
2472 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2474 /* this value indiciates that the c1/c2 "next char" test should be skipped */
2475 #define CHRTEST_VOID -1000
2477 #define SLAB_FIRST(s) (&(s)->states[0])
2478 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2480 /* grab a new slab and return the first slot in it */
2482 STATIC regmatch_state *
2485 #if PERL_VERSION < 9
2488 regmatch_slab *s = PL_regmatch_slab->next;
2490 Newx(s, 1, regmatch_slab);
2491 s->prev = PL_regmatch_slab;
2493 PL_regmatch_slab->next = s;
2495 PL_regmatch_slab = s;
2496 return SLAB_FIRST(s);
2499 /* simulate a recursive call to regmatch */
2501 #define REGMATCH(ns, where) \
2504 st->resume_state = resume_##where; \
2505 goto start_recurse; \
2506 resume_point_##where:
2509 /* push a new regex state. Set newst to point to it */
2511 #define PUSH_STATE(newst, resume) \
2513 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "PUSH STATE(%d)\n", depth)); \
2517 st->locinput = locinput; \
2518 st->resume_state = resume; \
2520 if (newst > SLAB_LAST(PL_regmatch_slab)) \
2521 newst = S_push_slab(aTHX); \
2522 PL_regmatch_state = newst; \
2524 newst->minmod = 0; \
2526 newst->logical = 0; \
2527 newst->unwind = 0; \
2528 locinput = PL_reginput; \
2529 nextchr = UCHARAT(locinput);
2532 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth)); \
2535 if (st < SLAB_FIRST(PL_regmatch_slab)) { \
2536 PL_regmatch_slab = PL_regmatch_slab->prev; \
2537 st = SLAB_LAST(PL_regmatch_slab); \
2539 PL_regmatch_state = st; \
2543 locinput = st->locinput; \
2544 nextchr = UCHARAT(locinput);
2547 - regmatch - main matching routine
2549 * Conceptually the strategy is simple: check to see whether the current
2550 * node matches, call self recursively to see whether the rest matches,
2551 * and then act accordingly. In practice we make some effort to avoid
2552 * recursion, in particular by going through "ordinary" nodes (that don't
2553 * need to know whether the rest of the match failed) by a loop instead of
2556 /* [lwall] I've hoisted the register declarations to the outer block in order to
2557 * maybe save a little bit of pushing and popping on the stack. It also takes
2558 * advantage of machines that use a register save mask on subroutine entry.
2560 * This function used to be heavily recursive, but since this had the
2561 * effect of blowing the CPU stack on complex regexes, it has been
2562 * restructured to be iterative, and to save state onto the heap rather
2563 * than the stack. Essentially whereever regmatch() used to be called, it
2564 * pushes the current state, notes where to return, then jumps back into
2567 * Originally the structure of this function used to look something like
2572 while (scan != NULL) {
2573 a++; // do stuff with a and b
2579 if (regmatch(...)) // recurse
2589 * Now it looks something like this:
2597 regmatch_state *st = new();
2599 st->a++; // do stuff with a and b
2601 while (scan != NULL) {
2609 st->resume_state = resume_FOO;
2610 goto start_recurse; // recurse
2619 st = new(); push a new state
2620 st->a = 1; st->b = 2;
2627 switch (resume_state) {
2629 goto resume_point_FOO;
2636 * WARNING: this means that any line in this function that contains a
2637 * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2638 * regmatch() using gotos instead. Thus the values of any local variables
2639 * not saved in the regmatch_state structure will have been lost when
2640 * execution resumes on the next line .
2642 * States (ie the st pointer) are allocated in slabs of about 4K in size.
2643 * PL_regmatch_state always points to the currently active state, and
2644 * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2645 * The first time regmatch is called, the first slab is allocated, and is
2646 * never freed until interpreter desctruction. When the slab is full,
2647 * a new one is allocated chained to the end. At exit from regmatch, slabs
2648 * allocated since entry are freed.
2651 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2655 S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const bool do_utf8)
2657 const int docolor = *PL_colors[0];
2658 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2659 int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2660 /* The part of the string before starttry has one color
2661 (pref0_len chars), between starttry and current
2662 position another one (pref_len - pref0_len chars),
2663 after the current position the third one.
2664 We assume that pref0_len <= pref_len, otherwise we
2665 decrease pref0_len. */
2666 int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2667 ? (5 + taill) - l : locinput - PL_bostr;
2670 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2672 pref0_len = pref_len - (locinput - PL_reg_starttry);
2673 if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2674 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2675 ? (5 + taill) - pref_len : PL_regeol - locinput);
2676 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2680 if (pref0_len > pref_len)
2681 pref0_len = pref_len;
2683 const char * const s0 =
2684 do_utf8 && OP(scan) != CANY ?
2685 pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
2686 pref0_len, 60, UNI_DISPLAY_REGEX) :
2687 locinput - pref_len;
2688 const int len0 = do_utf8 ? (int)strlen(s0) : pref0_len;
2689 const char * const s1 = do_utf8 && OP(scan) != CANY ?
2690 pv_uni_display(PERL_DEBUG_PAD(1),
2691 (U8*)(locinput - pref_len + pref0_len),
2692 pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2693 locinput - pref_len + pref0_len;
2694 const int len1 = do_utf8 ? (int)strlen(s1) : pref_len - pref0_len;
2695 const char * const s2 = do_utf8 && OP(scan) != CANY ?
2696 pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
2697 PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2699 const int len2 = do_utf8 ? (int)strlen(s2) : l;
2700 PerlIO_printf(Perl_debug_log,
2701 "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|",
2702 (IV)(locinput - PL_bostr),
2709 (docolor ? "" : "> <"),
2713 15 - l - pref_len + 1,
2719 STATIC I32 /* 0 failure, 1 success */
2720 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2722 #if PERL_VERSION < 9
2726 register const bool do_utf8 = PL_reg_match_utf8;
2727 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2729 regexp *rex = reginfo->prog;
2731 regmatch_slab *orig_slab;
2732 regmatch_state *orig_state;
2734 /* the current state. This is a cached copy of PL_regmatch_state */
2735 register regmatch_state *st;
2737 /* cache heavy used fields of st in registers */
2738 register regnode *scan;
2739 register regnode *next;
2740 register I32 n = 0; /* initialize to shut up compiler warning */
2741 register char *locinput = PL_reginput;
2743 /* these variables are NOT saved during a recusive RFEGMATCH: */
2744 register I32 nextchr; /* is always set to UCHARAT(locinput) */
2745 bool result; /* return value of S_regmatch */
2746 regnode *inner; /* Next node in internal branch. */
2747 int depth = 0; /* depth of recursion */
2748 regmatch_state *newst; /* when pushing a state, this is the new one */
2749 regmatch_state *yes_state = NULL; /* state to pop to on success of
2753 SV *re_debug_flags = NULL;
2758 /* on first ever call to regmatch, allocate first slab */
2759 if (!PL_regmatch_slab) {
2760 Newx(PL_regmatch_slab, 1, regmatch_slab);
2761 PL_regmatch_slab->prev = NULL;
2762 PL_regmatch_slab->next = NULL;
2763 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2766 /* remember current high-water mark for exit */
2767 /* XXX this should be done with SAVE* instead */
2768 orig_slab = PL_regmatch_slab;
2769 orig_state = PL_regmatch_state;
2771 /* grab next free state slot */
2772 st = ++PL_regmatch_state;
2773 if (st > SLAB_LAST(PL_regmatch_slab))
2774 st = PL_regmatch_state = S_push_slab(aTHX);
2781 /* Note that nextchr is a byte even in UTF */
2782 nextchr = UCHARAT(locinput);
2784 while (scan != NULL) {
2787 SV * const prop = sv_newmortal();
2788 dump_exec_pos( locinput, scan, do_utf8 );
2789 regprop(rex, prop, scan);
2791 PerlIO_printf(Perl_debug_log,
2792 "%3"IVdf":%*s%s(%"IVdf")\n",
2793 (IV)(scan - rex->program), PL_regindent*2, "",
2795 PL_regkind[OP(scan)] == END ? 0 : (IV)(regnext(scan) - rex->program));
2798 next = scan + NEXT_OFF(scan);
2804 if (locinput == PL_bostr)
2806 /* reginfo->till = reginfo->bol; */
2811 if (locinput == PL_bostr ||
2812 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2818 if (locinput == PL_bostr)
2822 if (locinput == reginfo->ganch)
2828 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2833 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2835 if (PL_regeol - locinput > 1)
2839 if (PL_regeol != locinput)
2843 if (!nextchr && locinput >= PL_regeol)
2846 locinput += PL_utf8skip[nextchr];
2847 if (locinput > PL_regeol)
2849 nextchr = UCHARAT(locinput);
2852 nextchr = UCHARAT(++locinput);
2855 if (!nextchr && locinput >= PL_regeol)
2857 nextchr = UCHARAT(++locinput);
2860 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2863 locinput += PL_utf8skip[nextchr];
2864 if (locinput > PL_regeol)
2866 nextchr = UCHARAT(locinput);
2869 nextchr = UCHARAT(++locinput);
2873 /* what type of TRIE am I? (utf8 makes this contextual) */
2874 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2875 trie_type = do_utf8 ?
2876 (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2879 /* what trie are we using right now */
2880 reg_trie_data * const trie
2881 = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2882 U32 state = trie->startstate;
2884 if (trie->bitmap && trie_type != trie_utf8_fold &&
2885 !TRIE_BITMAP_TEST(trie,*locinput)
2887 if (trie->states[ state ].wordnum) {
2889 PerlIO_printf(Perl_debug_log,
2890 "%*s %smatched empty string...%s\n",
2891 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2896 PerlIO_printf(Perl_debug_log,
2897 "%*s %sfailed to match start class...%s\n",
2898 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2905 traverse the TRIE keeping track of all accepting states
2906 we transition through until we get to a failing node.
2909 U8 *uc = ( U8* )locinput;
2915 U8 *uscan = (U8*)NULL;
2917 SV *sv_accept_buff = NULL;
2919 st->u.trie.accepted = 0; /* how many accepting states we have seen */
2922 while ( state && uc <= (U8*)PL_regeol ) {
2924 if (trie->states[ state ].wordnum) {
2925 if (!st->u.trie.accepted ) {
2928 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2929 sv_accept_buff=newSV(bufflen *
2930 sizeof(reg_trie_accepted) - 1);
2931 SvCUR_set(sv_accept_buff,
2932 sizeof(reg_trie_accepted));
2933 SvPOK_on(sv_accept_buff);
2934 sv_2mortal(sv_accept_buff);
2935 st->u.trie.accept_buff =
2936 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2939 if (st->u.trie.accepted >= bufflen) {
2941 st->u.trie.accept_buff =(reg_trie_accepted*)
2942 SvGROW(sv_accept_buff,
2943 bufflen * sizeof(reg_trie_accepted));
2945 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2946 + sizeof(reg_trie_accepted));
2948 st->u.trie.accept_buff[st->u.trie.accepted].wordnum = trie->states[state].wordnum;
2949 st->u.trie.accept_buff[st->u.trie.accepted].endpos = uc;
2950 ++st->u.trie.accepted;
2953 base = trie->states[ state ].trans.base;
2955 DEBUG_TRIE_EXECUTE_r({
2956 dump_exec_pos( (char *)uc, scan, do_utf8 );
2957 PerlIO_printf( Perl_debug_log,
2958 "%*s %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2959 2+PL_regindent * 2, "", PL_colors[4],
2960 (UV)state, (UV)base, (UV)st->u.trie.accepted );
2964 switch (trie_type) {
2965 case trie_utf8_fold:
2967 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2972 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2973 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2974 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2975 foldlen -= UNISKIP( uvc );
2976 uscan = foldbuf + UNISKIP( uvc );
2980 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
2989 charid = trie->charmap[ uvc ];
2993 if (trie->widecharmap) {
2994 SV** const svpp = hv_fetch(trie->widecharmap,
2995 (char*)&uvc, sizeof(UV), 0);
2997 charid = (U16)SvIV(*svpp);
3002 (base + charid > trie->uniquecharcount )
3003 && (base + charid - 1 - trie->uniquecharcount
3005 && trie->trans[base + charid - 1 -
3006 trie->uniquecharcount].check == state)
3008 state = trie->trans[base + charid - 1 -
3009 trie->uniquecharcount ].next;
3020 DEBUG_TRIE_EXECUTE_r(
3021 PerlIO_printf( Perl_debug_log,
3022 "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
3023 charid, uvc, (UV)state, PL_colors[5] );
3026 if (!st->u.trie.accepted )
3030 There was at least one accepting state that we
3031 transitioned through. Presumably the number of accepting
3032 states is going to be low, typically one or two. So we
3033 simply scan through to find the one with lowest wordnum.
3034 Once we find it, we swap the last state into its place
3035 and decrement the size. We then try to match the rest of
3036 the pattern at the point where the word ends, if we
3037 succeed then we end the loop, otherwise the loop
3038 eventually terminates once all of the accepting states
3042 if ( st->u.trie.accepted == 1 ) {
3044 SV ** const tmp = RX_DEBUG(reginfo->prog)
3045 ? av_fetch( trie->words, st->u.trie.accept_buff[ 0 ].wordnum-1, 0 )
3047 PerlIO_printf( Perl_debug_log,
3048 "%*s %sonly one match : #%d <%s>%s\n",
3049 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
3050 st->u.trie.accept_buff[ 0 ].wordnum,
3051 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
3054 PL_reginput = (char *)st->u.trie.accept_buff[ 0 ].endpos;
3055 /* in this case we free tmps/leave before we call regmatch
3056 as we wont be using accept_buff again. */
3059 /* do we need this? why dont we just do a break? */
3060 REGMATCH(scan + NEXT_OFF(scan), TRIE1);
3061 /*** all unsaved local vars undefined at this point */
3064 PerlIO_printf( Perl_debug_log,"%*s %sgot %"IVdf" possible matches%s\n",
3065 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], (IV)st->u.trie.accepted,
3068 while ( !result && st->u.trie.accepted-- ) {
3071 for( cur = 1 ; cur <= st->u.trie.accepted ; cur++ ) {
3072 DEBUG_TRIE_EXECUTE_r(
3073 PerlIO_printf( Perl_debug_log,
3074 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3075 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
3076 (IV)best, st->u.trie.accept_buff[ best ].wordnum, (IV)cur,
3077 st->u.trie.accept_buff[ cur ].wordnum, PL_colors[5] );
3080 if (st->u.trie.accept_buff[cur].wordnum <
3081 st->u.trie.accept_buff[best].wordnum)
3085 reg_trie_data * const trie = (reg_trie_data*)
3086 rex->data->data[ARG(scan)];
3087 SV ** const tmp = RX_DEBUG(reginfo->prog)
3088 ? av_fetch( trie->words, st->u.trie.accept_buff[ best ].wordnum - 1, 0 )
3090 PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at node #%d %s\n",
3091 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
3092 st->u.trie.accept_buff[best].wordnum,
3093 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", REG_NODE_NUM(scan),
3096 if ( best<st->u.trie.accepted ) {
3097 reg_trie_accepted tmp = st->u.trie.accept_buff[ best ];
3098 st->u.trie.accept_buff[ best ] = st->u.trie.accept_buff[ st->u.trie.accepted ];
3099 st->u.trie.accept_buff[ st->u.trie.accepted ] = tmp;
3100 best = st->u.trie.accepted;
3102 PL_reginput = (char *)st->u.trie.accept_buff[ best ].endpos;
3105 as far as I can tell we only need the SAVETMPS/FREETMPS
3106 for re's with EVAL in them but I'm leaving them in for
3107 all until I can be sure.
3110 REGMATCH(scan + NEXT_OFF(scan), TRIE2);
3111 /*** all unsaved local vars undefined at this point */
3124 /* unreached codepoint */
3126 char *s = STRING(scan);
3127 st->ln = STR_LEN(scan);
3128 if (do_utf8 != UTF) {
3129 /* The target and the pattern have differing utf8ness. */
3131 const char * const e = s + st->ln;
3134 /* The target is utf8, the pattern is not utf8. */
3139 if (NATIVE_TO_UNI(*(U8*)s) !=
3140 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3148 /* The target is not utf8, the pattern is utf8. */
3153 if (NATIVE_TO_UNI(*((U8*)l)) !=
3154 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3162 nextchr = UCHARAT(locinput);
3165 /* The target and the pattern have the same utf8ness. */
3166 /* Inline the first character, for speed. */
3167 if (UCHARAT(s) != nextchr)
3169 if (PL_regeol - locinput < st->ln)
3171 if (st->ln > 1 && memNE(s, locinput, st->ln))
3174 nextchr = UCHARAT(locinput);
3178 PL_reg_flags |= RF_tainted;
3181 char * const s = STRING(scan);
3182 st->ln = STR_LEN(scan);
3184 if (do_utf8 || UTF) {
3185 /* Either target or the pattern are utf8. */
3186 const char * const l = locinput;
3187 char *e = PL_regeol;
3189 if (ibcmp_utf8(s, 0, st->ln, (bool)UTF,
3190 l, &e, 0, do_utf8)) {
3191 /* One more case for the sharp s:
3192 * pack("U0U*", 0xDF) =~ /ss/i,
3193 * the 0xC3 0x9F are the UTF-8
3194 * byte sequence for the U+00DF. */
3196 toLOWER(s[0]) == 's' &&
3198 toLOWER(s[1]) == 's' &&
3205 nextchr = UCHARAT(locinput);
3209 /* Neither the target and the pattern are utf8. */
3211 /* Inline the first character, for speed. */
3212 if (UCHARAT(s) != nextchr &&
3213 UCHARAT(s) != ((OP(scan) == EXACTF)
3214 ? PL_fold : PL_fold_locale)[nextchr])
3216 if (PL_regeol - locinput < st->ln)
3218 if (st->ln > 1 && (OP(scan) == EXACTF
3219 ? ibcmp(s, locinput, st->ln)
3220 : ibcmp_locale(s, locinput, st->ln)))
3223 nextchr = UCHARAT(locinput);
3228 STRLEN inclasslen = PL_regeol - locinput;
3230 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3232 if (locinput >= PL_regeol)
3234 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3235 nextchr = UCHARAT(locinput);
3240 nextchr = UCHARAT(locinput);
3241 if (!REGINCLASS(rex, scan, (U8*)locinput))
3243 if (!nextchr && locinput >= PL_regeol)
3245 nextchr = UCHARAT(++locinput);
3249 /* If we might have the case of the German sharp s
3250 * in a casefolding Unicode character class. */
3252 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3253 locinput += SHARP_S_SKIP;
3254 nextchr = UCHARAT(locinput);
3260 PL_reg_flags |= RF_tainted;
3266 LOAD_UTF8_CHARCLASS_ALNUM();
3267 if (!(OP(scan) == ALNUM
3268 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3269 : isALNUM_LC_utf8((U8*)locinput)))
3273 locinput += PL_utf8skip[nextchr];
3274 nextchr = UCHARAT(locinput);
3277 if (!(OP(scan) == ALNUM
3278 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3280 nextchr = UCHARAT(++locinput);
3283 PL_reg_flags |= RF_tainted;
3286 if (!nextchr && locinput >= PL_regeol)
3289 LOAD_UTF8_CHARCLASS_ALNUM();
3290 if (OP(scan) == NALNUM
3291 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3292 : isALNUM_LC_utf8((U8*)locinput))
3296 locinput += PL_utf8skip[nextchr];
3297 nextchr = UCHARAT(locinput);
3300 if (OP(scan) == NALNUM
3301 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3303 nextchr = UCHARAT(++locinput);
3307 PL_reg_flags |= RF_tainted;
3311 /* was last char in word? */
3313 if (locinput == PL_bostr)
3316 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3318 st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3320 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3321 st->ln = isALNUM_uni(st->ln);
3322 LOAD_UTF8_CHARCLASS_ALNUM();
3323 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3326 st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3327 n = isALNUM_LC_utf8((U8*)locinput);
3331 st->ln = (locinput != PL_bostr) ?
3332 UCHARAT(locinput - 1) : '\n';
3333 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3334 st->ln = isALNUM(st->ln);
3335 n = isALNUM(nextchr);
3338 st->ln = isALNUM_LC(st->ln);
3339 n = isALNUM_LC(nextchr);
3342 if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3343 OP(scan) == BOUNDL))
3347 PL_reg_flags |= RF_tainted;
3353 if (UTF8_IS_CONTINUED(nextchr)) {
3354 LOAD_UTF8_CHARCLASS_SPACE();
3355 if (!(OP(scan) == SPACE
3356 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3357 : isSPACE_LC_utf8((U8*)locinput)))
3361 locinput += PL_utf8skip[nextchr];
3362 nextchr = UCHARAT(locinput);
3365 if (!(OP(scan) == SPACE
3366 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3368 nextchr = UCHARAT(++locinput);
3371 if (!(OP(scan) == SPACE
3372 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3374 nextchr = UCHARAT(++locinput);
3378 PL_reg_flags |= RF_tainted;
3381 if (!nextchr && locinput >= PL_regeol)
3384 LOAD_UTF8_CHARCLASS_SPACE();
3385 if (OP(scan) == NSPACE
3386 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3387 : isSPACE_LC_utf8((U8*)locinput))
3391 locinput += PL_utf8skip[nextchr];
3392 nextchr = UCHARAT(locinput);
3395 if (OP(scan) == NSPACE
3396 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3398 nextchr = UCHARAT(++locinput);
3401 PL_reg_flags |= RF_tainted;
3407 LOAD_UTF8_CHARCLASS_DIGIT();
3408 if (!(OP(scan) == DIGIT
3409 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3410 : isDIGIT_LC_utf8((U8*)locinput)))
3414 locinput += PL_utf8skip[nextchr];
3415 nextchr = UCHARAT(locinput);
3418 if (!(OP(scan) == DIGIT
3419 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3421 nextchr = UCHARAT(++locinput);
3424 PL_reg_flags |= RF_tainted;
3427 if (!nextchr && locinput >= PL_regeol)
3430 LOAD_UTF8_CHARCLASS_DIGIT();
3431 if (OP(scan) == NDIGIT
3432 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3433 : isDIGIT_LC_utf8((U8*)locinput))
3437 locinput += PL_utf8skip[nextchr];
3438 nextchr = UCHARAT(locinput);
3441 if (OP(scan) == NDIGIT
3442 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3444 nextchr = UCHARAT(++locinput);
3447 if (locinput >= PL_regeol)
3450 LOAD_UTF8_CHARCLASS_MARK();
3451 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3453 locinput += PL_utf8skip[nextchr];
3454 while (locinput < PL_regeol &&
3455 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3456 locinput += UTF8SKIP(locinput);
3457 if (locinput > PL_regeol)
3462 nextchr = UCHARAT(locinput);
3465 PL_reg_flags |= RF_tainted;
3470 n = ARG(scan); /* which paren pair */
3471 st->ln = PL_regstartp[n];
3472 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3473 if ((I32)*PL_reglastparen < n || st->ln == -1)
3474 sayNO; /* Do not match unless seen CLOSEn. */
3475 if (st->ln == PL_regendp[n])
3478 s = PL_bostr + st->ln;
3479 if (do_utf8 && OP(scan) != REF) { /* REF can do byte comparison */
3481 const char *e = PL_bostr + PL_regendp[n];
3483 * Note that we can't do the "other character" lookup trick as
3484 * in the 8-bit case (no pun intended) because in Unicode we
3485 * have to map both upper and title case to lower case.
3487 if (OP(scan) == REFF) {
3489 STRLEN ulen1, ulen2;
3490 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3491 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3495 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3496 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3497 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3504 nextchr = UCHARAT(locinput);
3508 /* Inline the first character, for speed. */
3509 if (UCHARAT(s) != nextchr &&
3511 (UCHARAT(s) != ((OP(scan) == REFF
3512 ? PL_fold : PL_fold_locale)[nextchr]))))
3514 st->ln = PL_regendp[n] - st->ln;
3515 if (locinput + st->ln > PL_regeol)
3517 if (st->ln > 1 && (OP(scan) == REF
3518 ? memNE(s, locinput, st->ln)
3520 ? ibcmp(s, locinput, st->ln)
3521 : ibcmp_locale(s, locinput, st->ln))))
3524 nextchr = UCHARAT(locinput);
3537 /* execute the code in the {...} */
3539 SV ** const before = SP;
3540 OP_4tree * const oop = PL_op;
3541 COP * const ocurcop = PL_curcop;
3545 PL_op = (OP_4tree*)rex->data->data[n];
3546 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3547 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3548 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3550 CALLRUNOPS(aTHX); /* Scalar context. */
3553 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
3560 PAD_RESTORE_LOCAL(old_comppad);
3561 PL_curcop = ocurcop;
3564 sv_setsv(save_scalar(PL_replgv), ret);
3568 if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3571 /* extract RE object from returned value; compiling if
3576 if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3577 mg = mg_find(sv, PERL_MAGIC_qr);
3578 else if (SvSMAGICAL(ret)) {
3579 if (SvGMAGICAL(ret))
3580 sv_unmagic(ret, PERL_MAGIC_qr);
3582 mg = mg_find(ret, PERL_MAGIC_qr);
3586 re = (regexp *)mg->mg_obj;
3587 (void)ReREFCNT_inc(re);
3591 const char * const t = SvPV_const(ret, len);
3593 const I32 osize = PL_regsize;
3596 if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3597 re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3599 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3601 sv_magic(ret,(SV*)ReREFCNT_inc(re),
3607 /* run the pattern returned from (??{...}) */
3610 PerlIO_printf(Perl_debug_log,
3611 "Entering embedded \"%s%.60s%s%s\"\n",
3615 (strlen(re->precomp) > 60 ? "..." : ""))
3618 st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
3619 REGCP_SET(st->u.eval.lastcp);
3620 *PL_reglastparen = 0;
3621 *PL_reglastcloseparen = 0;
3622 PL_reginput = locinput;
3624 /* XXXX This is too dramatic a measure... */
3628 st->u.eval.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3629 ((re->reganch & ROPT_UTF8) != 0);
3630 if (st->u.eval.toggleutf) PL_reg_flags ^= RF_utf8;
3631 st->u.eval.prev_rex = rex;
3634 /* resume to current state on success */
3635 st->u.yes.prev_yes_state = yes_state;
3637 PUSH_STATE(newst, resume_EVAL);
3640 /* now continue from first node in postoned RE */
3641 next = re->program + 1;
3645 /* /(?(?{...})X|Y)/ */
3646 st->sw = SvTRUE(ret);
3651 n = ARG(scan); /* which paren pair */
3652 PL_reg_start_tmp[n] = locinput;
3657 n = ARG(scan); /* which paren pair */
3658 PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3659 PL_regendp[n] = locinput - PL_bostr;
3660 if (n > (I32)*PL_reglastparen)
3661 *PL_reglastparen = n;
3662 *PL_reglastcloseparen = n;
3665 n = ARG(scan); /* which paren pair */
3666 st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3669 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3671 next = NEXTOPER(NEXTOPER(scan));
3673 next = scan + ARG(scan);
3674 if (OP(next) == IFTHEN) /* Fake one. */
3675 next = NEXTOPER(NEXTOPER(next));
3679 st->logical = scan->flags;
3681 /*******************************************************************
3682 cc points to the regmatch_state associated with the most recent CURLYX.
3683 This struct contains info about the innermost (...)* loop (an
3684 "infoblock"), and a pointer to the next outer cc.
3686 Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3688 1) After matching Y, regnode for CURLYX is processed;
3690 2) This regnode populates cc, and calls regmatch() recursively
3691 with the starting point at WHILEM node;
3693 3) Each hit of WHILEM node tries to match A and Z (in the order
3694 depending on the current iteration, min/max of {min,max} and
3695 greediness). The information about where are nodes for "A"
3696 and "Z" is read from cc, as is info on how many times "A"
3697 was already matched, and greediness.
3699 4) After A matches, the same WHILEM node is hit again.
3701 5) Each time WHILEM is hit, cc is the infoblock created by CURLYX
3702 of the same pair. Thus when WHILEM tries to match Z, it temporarily
3703 resets cc, since this Y(A)*Z can be a part of some other loop:
3704 as in (Y(A)*Z)*. If Z matches, the automaton will hit the WHILEM node
3705 of the external loop.
3707 Currently present infoblocks form a tree with a stem formed by st->cc
3708 and whatever it mentions via ->next, and additional attached trees
3709 corresponding to temporarily unset infoblocks as in "5" above.
3711 In the following picture, infoblocks for outer loop of
3712 (Y(A)*?Z)*?T are denoted O, for inner I. NULL starting block
3713 is denoted by x. The matched string is YAAZYAZT. Temporarily postponed
3714 infoblocks are drawn below the "reset" infoblock.
3716 In fact in the picture below we do not show failed matches for Z and T
3717 by WHILEM blocks. [We illustrate minimal matches, since for them it is
3718 more obvious *why* one needs to *temporary* unset infoblocks.]
3720 Matched REx position InfoBlocks Comment
3724 Y A)*?Z)*?T x <- O <- I
3725 YA )*?Z)*?T x <- O <- I
3726 YA A)*?Z)*?T x <- O <- I
3727 YAA )*?Z)*?T x <- O <- I
3728 YAA Z)*?T x <- O # Temporary unset I
3731 YAAZ Y(A)*?Z)*?T x <- O
3734 YAAZY (A)*?Z)*?T x <- O
3737 YAAZY A)*?Z)*?T x <- O <- I
3740 YAAZYA )*?Z)*?T x <- O <- I
3743 YAAZYA Z)*?T x <- O # Temporary unset I
3749 YAAZYAZ T x # Temporary unset O
3756 *******************************************************************/
3759 /* No need to save/restore up to this paren */
3760 I32 parenfloor = scan->flags;
3764 CURLYX and WHILEM are always paired: they're the moral
3765 equivalent of pp_enteriter anbd pp_iter.
3767 The only time next could be null is if the node tree is
3768 corrupt. This was mentioned on p5p a few days ago.
3770 See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3771 So we'll assert that this is true:
3774 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3776 /* XXXX Probably it is better to teach regpush to support
3777 parenfloor > PL_regsize... */
3778 if (parenfloor > (I32)*PL_reglastparen)
3779 parenfloor = *PL_reglastparen; /* Pessimization... */
3781 st->u.curlyx.cp = PL_savestack_ix;
3782 st->u.curlyx.outercc = st->cc;
3784 /* these fields contain the state of the current curly.
3785 * they are accessed by subsequent WHILEMs;
3786 * cur and lastloc are also updated by WHILEM */
3787 st->u.curlyx.parenfloor = parenfloor;
3788 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3789 st->u.curlyx.min = ARG1(scan);
3790 st->u.curlyx.max = ARG2(scan);
3791 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3792 st->u.curlyx.lastloc = 0;
3793 /* st->next and st->minmod are also read by WHILEM */
3795 PL_reginput = locinput;
3796 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3797 /*** all unsaved local vars undefined at this point */
3798 regcpblow(st->u.curlyx.cp);
3799 st->cc = st->u.curlyx.outercc;
3805 * This is really hard to understand, because after we match
3806 * what we're trying to match, we must make sure the rest of
3807 * the REx is going to match for sure, and to do that we have
3808 * to go back UP the parse tree by recursing ever deeper. And
3809 * if it fails, we have to reset our parent's current state
3810 * that we can try again after backing off.
3815 st->cc gets initialised by CURLYX ready for use by WHILEM.
3816 So again, unless somethings been corrupted, st->cc cannot
3817 be null at that point in WHILEM.
3819 See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3820 So we'll assert that this is true:
3823 st->u.whilem.lastloc = st->cc->u.curlyx.lastloc; /* Detection of 0-len. */
3824 st->u.whilem.cache_offset = 0;
3825 st->u.whilem.cache_bit = 0;
3827 n = st->cc->u.curlyx.cur + 1; /* how many we know we matched */
3828 PL_reginput = locinput;
3831 PerlIO_printf(Perl_debug_log,
3832 "%*s %ld out of %ld..%ld cc=%"UVxf"\n",
3833 REPORT_CODE_OFF+PL_regindent*2, "",
3834 (long)n, (long)st->cc->u.curlyx.min,
3835 (long)st->cc->u.curlyx.max, PTR2UV(st->cc))
3838 /* If degenerate scan matches "", assume scan done. */
3840 if (locinput == st->cc->u.curlyx.lastloc && n >= st->cc->u.curlyx.min) {
3841 st->u.whilem.savecc = st->cc;
3842 st->cc = st->cc->u.curlyx.outercc;
3844 st->ln = st->cc->u.curlyx.cur;
3846 PerlIO_printf(Perl_debug_log,
3847 "%*s empty match detected, try continuation...\n",
3848 REPORT_CODE_OFF+PL_regindent*2, "")
3850 REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3851 /*** all unsaved local vars undefined at this point */
3852 st->cc = st->u.whilem.savecc;
3855 if (st->cc->u.curlyx.outercc)
3856 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3860 /* First just match a string of min scans. */
3862 if (n < st->cc->u.curlyx.min) {
3863 st->cc->u.curlyx.cur = n;
3864 st->cc->u.curlyx.lastloc = locinput;
3865 REGMATCH(st->cc->u.curlyx.scan, WHILEM2);
3866 /*** all unsaved local vars undefined at this point */
3869 st->cc->u.curlyx.cur = n - 1;
3870 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3875 /* Check whether we already were at this position.
3876 Postpone detection until we know the match is not
3877 *that* much linear. */
3878 if (!PL_reg_maxiter) {
3879 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3880 /* possible overflow for long strings and many CURLYX's */
3881 if (PL_reg_maxiter < 0)
3882 PL_reg_maxiter = I32_MAX;
3883 PL_reg_leftiter = PL_reg_maxiter;
3885 if (PL_reg_leftiter-- == 0) {
3886 const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8;
3887 if (PL_reg_poscache) {
3888 if ((I32)PL_reg_poscache_size < size) {
3889 Renew(PL_reg_poscache, size, char);
3890 PL_reg_poscache_size = size;
3892 Zero(PL_reg_poscache, size, char);
3895 PL_reg_poscache_size = size;
3896 Newxz(PL_reg_poscache, size, char);
3899 PerlIO_printf(Perl_debug_log,
3900 "%sDetected a super-linear match, switching on caching%s...\n",
3901 PL_colors[4], PL_colors[5])
3904 if (PL_reg_leftiter < 0) {
3905 st->u.whilem.cache_offset = locinput - PL_bostr;
3907 st->u.whilem.cache_offset = (scan->flags & 0xf) - 1 + POSCACHE_START
3908 + st->u.whilem.cache_offset * (scan->flags>>4);
3909 st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
3910 st->u.whilem.cache_offset /= 8;
3911 if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
3913 PerlIO_printf(Perl_debug_log,
3914 "%*s already tried at this position...\n",
3915 REPORT_CODE_OFF+PL_regindent*2, "")
3917 if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))
3918 /* cache records success */
3921 /* cache records failure */
3927 /* Prefer next over scan for minimal matching. */
3929 if (st->cc->minmod) {
3930 st->u.whilem.savecc = st->cc;
3931 st->cc = st->cc->u.curlyx.outercc;
3933 st->ln = st->cc->u.curlyx.cur;
3934 st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
3935 REGCP_SET(st->u.whilem.lastcp);
3936 REGMATCH(st->u.whilem.savecc->next, WHILEM3);
3937 /*** all unsaved local vars undefined at this point */
3938 st->cc = st->u.whilem.savecc;
3940 regcpblow(st->u.whilem.cp);
3941 CACHEsayYES; /* All done. */
3943 REGCP_UNWIND(st->u.whilem.lastcp);
3945 if (st->cc->u.curlyx.outercc)
3946 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3948 if (n >= st->cc->u.curlyx.max) { /* Maximum greed exceeded? */
3949 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3950 && !(PL_reg_flags & RF_warned)) {
3951 PL_reg_flags |= RF_warned;
3952 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3953 "Complex regular subexpression recursion",
3960 PerlIO_printf(Perl_debug_log,
3961 "%*s trying longer...\n",
3962 REPORT_CODE_OFF+PL_regindent*2, "")
3964 /* Try scanning more and see if it helps. */
3965 PL_reginput = locinput;
3966 st->cc->u.curlyx.cur = n;
3967 st->cc->u.curlyx.lastloc = locinput;
3968 st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3969 REGCP_SET(st->u.whilem.lastcp);
3970 REGMATCH(st->cc->u.curlyx.scan, WHILEM4);
3971 /*** all unsaved local vars undefined at this point */
3973 regcpblow(st->u.whilem.cp);
3976 REGCP_UNWIND(st->u.whilem.lastcp);
3978 st->cc->u.curlyx.cur = n - 1;
3979 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3983 /* Prefer scan over next for maximal matching. */
3985 if (n < st->cc->u.curlyx.max) { /* More greed allowed? */
3986 st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3987 st->cc->u.curlyx.cur = n;
3988 st->cc->u.curlyx.lastloc = locinput;
3989 REGCP_SET(st->u.whilem.lastcp);
3990 REGMATCH(st->cc->u.curlyx.scan, WHILEM5);
3991 /*** all unsaved local vars undefined at this point */
3993 regcpblow(st->u.whilem.cp);
3996 REGCP_UNWIND(st->u.whilem.lastcp);
3997 regcppop(rex); /* Restore some previous $<digit>s? */
3998 PL_reginput = locinput;
4000 PerlIO_printf(Perl_debug_log,
4001 "%*s failed, try continuation...\n",
4002 REPORT_CODE_OFF+PL_regindent*2, "")
4005 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
4006 && !(PL_reg_flags & RF_warned)) {
4007 PL_reg_flags |= RF_warned;
4008 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4009 "Complex regular subexpression recursion",
4013 /* Failed deeper matches of scan, so see if this one works. */
4014 st->u.whilem.savecc = st->cc;
4015 st->cc = st->cc->u.curlyx.outercc;
4017 st->ln = st->cc->u.curlyx.cur;
4018 REGMATCH(st->u.whilem.savecc->next, WHILEM6);
4019 /*** all unsaved local vars undefined at this point */
4020 st->cc = st->u.whilem.savecc;
4023 if (st->cc->u.curlyx.outercc)
4024 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
4025 st->cc->u.curlyx.cur = n - 1;
4026 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
4031 next = scan + ARG(scan);
4034 inner = NEXTOPER(NEXTOPER(scan));
4037 inner = NEXTOPER(scan);
4040 const I32 type = OP(scan);
4041 if (!next || OP(next) != type) /* No choice. */
4042 next = inner; /* Avoid recursion. */
4044 const I32 lastparen = *PL_reglastparen;
4045 /* Put unwinding data on stack */
4046 const I32 unwind1 = SSNEWt(1,re_unwind_branch_t);
4047 re_unwind_branch_t * const uw = SSPTRt(unwind1,re_unwind_branch_t);
4049 uw->prev = st->unwind;
4050 st->unwind = unwind1;
4051 uw->type = ((type == BRANCH)
4053 : RE_UNWIND_BRANCHJ);
4054 uw->lastparen = lastparen;
4056 uw->locinput = locinput;
4057 uw->nextchr = nextchr;
4058 uw->minmod = st->minmod;
4060 uw->regindent = ++PL_regindent;
4063 REGCP_SET(uw->lastcp);
4065 /* Now go into the first branch */
4075 st->u.curlym.l = st->u.curlym.matches = 0;
4077 /* We suppose that the next guy does not need
4078 backtracking: in particular, it is of constant non-zero length,
4079 and has no parenths to influence future backrefs. */
4080 st->ln = ARG1(scan); /* min to match */
4081 n = ARG2(scan); /* max to match */
4082 st->u.curlym.paren = scan->flags;
4083 if (st->u.curlym.paren) {
4084 if (st->u.curlym.paren > PL_regsize)
4085 PL_regsize = st->u.curlym.paren;
4086 if (st->u.curlym.paren > (I32)*PL_reglastparen)
4087 *PL_reglastparen = st->u.curlym.paren;
4089 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4090 if (st->u.curlym.paren)
4091 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4092 PL_reginput = locinput;
4093 st->u.curlym.maxwanted = st->minmod ? st->ln : n;
4094 while (PL_reginput < PL_regeol && st->u.curlym.matches < st->u.curlym.maxwanted) {
4095 /* resume to current state on success */
4096 st->u.yes.prev_yes_state = yes_state;
4098 REGMATCH(scan, CURLYM1);
4099 yes_state = st->u.yes.prev_yes_state;
4100 /*** all unsaved local vars undefined at this point */
4103 /* on first match, determine length, u.curlym.l */
4104 if (!st->u.curlym.matches++) {
4105 if (PL_reg_match_utf8) {
4107 while (s < PL_reginput) {
4113 st->u.curlym.l = PL_reginput - locinput;
4115 if (st->u.curlym.l == 0) {
4116 st->u.curlym.matches = st->u.curlym.maxwanted;
4120 locinput = PL_reginput;
4123 PL_reginput = locinput;
4124 if (st->u.curlym.matches < st->ln) {
4130 PerlIO_printf(Perl_debug_log,
4131 "%*s matched %"IVdf" times, len=%"IVdf"...\n",
4132 (int)(REPORT_CODE_OFF+PL_regindent*2), "",
4133 (IV) st->u.curlym.matches, (IV)st->u.curlym.l)
4136 /* calculate c1 and c1 for possible match of 1st char
4137 * following curly */
4138 st->u.curlym.c1 = st->u.curlym.c2 = CHRTEST_VOID;
4139 if (HAS_TEXT(next) || JUMPABLE(next)) {
4140 regnode *text_node = next;
4141 if (! HAS_TEXT(text_node))
4142 FIND_NEXT_IMPT(text_node);
4143 if (HAS_TEXT(text_node)
4144 && PL_regkind[OP(text_node)] != REF)
4146 st->u.curlym.c1 = (U8)*STRING(text_node);
4148 (OP(text_node) == EXACTF || OP(text_node) == REFF)
4149 ? PL_fold[st->u.curlym.c1]
4150 : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4151 ? PL_fold_locale[st->u.curlym.c1]
4156 REGCP_SET(st->u.curlym.lastcp);
4158 st->u.curlym.minmod = st->minmod;
4160 while (st->u.curlym.matches >= st->ln
4161 && (st->u.curlym.matches <= n
4162 /* for REG_INFTY, ln could overflow to negative */
4163 || (n == REG_INFTY && st->u.curlym.matches >= 0)))
4165 /* If it could work, try it. */
4166 if (st->u.curlym.c1 == CHRTEST_VOID ||
4167 UCHARAT(PL_reginput) == st->u.curlym.c1 ||
4168 UCHARAT(PL_reginput) == st->u.curlym.c2)
4171 PerlIO_printf(Perl_debug_log,
4172 "%*s trying tail with matches=%"IVdf"...\n",
4173 (int)(REPORT_CODE_OFF+PL_regindent*2),
4174 "", (IV)st->u.curlym.matches)
4176 if (st->u.curlym.paren) {
4177 if (st->u.curlym.matches) {
4178 PL_regstartp[st->u.curlym.paren]
4179 = HOPc(PL_reginput, -st->u.curlym.l) - PL_bostr;
4180 PL_regendp[st->u.curlym.paren] = PL_reginput - PL_bostr;
4183 PL_regendp[st->u.curlym.paren] = -1;
4185 /* resume to current state on success */
4186 st->u.yes.prev_yes_state = yes_state;
4188 REGMATCH(next, CURLYM2);
4189 yes_state = st->u.yes.prev_yes_state;
4190 /*** all unsaved local vars undefined at this point */
4192 /* XXX tmp sayYES; */
4194 REGCP_UNWIND(st->u.curlym.lastcp);
4196 /* Couldn't or didn't -- move forward/backward. */
4197 if (st->u.curlym.minmod) {
4198 PL_reginput = locinput;
4199 /* resume to current state on success */
4200 st->u.yes.prev_yes_state = yes_state;
4202 REGMATCH(scan, CURLYM3);
4203 yes_state = st->u.yes.prev_yes_state;
4204 /*** all unsaved local vars undefined at this point */
4206 st->u.curlym.matches++;
4207 locinput = PL_reginput;
4213 st->u.curlym.matches--;
4214 locinput = HOPc(locinput, -st->u.curlym.l);
4215 PL_reginput = locinput;
4223 st->u.plus.paren = scan->flags; /* Which paren to set */
4224 if (st->u.plus.paren > PL_regsize)
4225 PL_regsize = st->u.plus.paren;
4226 if (st->u.plus.paren > (I32)*PL_reglastparen)
4227 *PL_reglastparen = st->u.plus.paren;
4228 st->ln = ARG1(scan); /* min to match */
4229 n = ARG2(scan); /* max to match */
4230 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4233 st->u.plus.paren = 0;
4234 st->ln = ARG1(scan); /* min to match */
4235 n = ARG2(scan); /* max to match */
4236 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4241 scan = NEXTOPER(scan);
4242 st->u.plus.paren = 0;
4247 scan = NEXTOPER(scan);
4248 st->u.plus.paren = 0;
4251 * Lookahead to avoid useless match attempts
4252 * when we know what character comes next.
4256 * Used to only do .*x and .*?x, but now it allows
4257 * for )'s, ('s and (?{ ... })'s to be in the way
4258 * of the quantifier and the EXACT-like node. -- japhy
4261 if (HAS_TEXT(next) || JUMPABLE(next)) {
4263 regnode *text_node = next;
4265 if (! HAS_TEXT(text_node))
4266 FIND_NEXT_IMPT(text_node);
4268 if (! HAS_TEXT(text_node))
4269 st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4271 if (PL_regkind[OP(text_node)] == REF) {
4272 st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4273 goto assume_ok_easy;
4276 s = (U8*)STRING(text_node);
4279 st->u.plus.c2 = st->u.plus.c1 = *s;
4280 if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4281 st->u.plus.c2 = PL_fold[st->u.plus.c1];
4282 else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4283 st->u.plus.c2 = PL_fold_locale[st->u.plus.c1];
4286 if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4287 STRLEN ulen1, ulen2;
4288 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4289 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4291 to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4292 to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4294 st->u.plus.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4296 st->u.plus.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4300 st->u.plus.c2 = st->u.plus.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4307 st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4309 PL_reginput = locinput;
4312 if (st->ln && regrepeat(rex, scan, st->ln) < st->ln)
4314 locinput = PL_reginput;
4315 REGCP_SET(st->u.plus.lastcp);
4316 if (st->u.plus.c1 != CHRTEST_VOID) {
4317 st->u.plus.old = locinput;
4318 st->u.plus.count = 0;
4320 if (n == REG_INFTY) {
4321 st->u.plus.e = PL_regeol - 1;
4323 while (UTF8_IS_CONTINUATION(*(U8*)st->u.plus.e))
4328 for (st->u.plus.e = locinput;
4329 m >0 && st->u.plus.e + UTF8SKIP(st->u.plus.e) <= PL_regeol; m--)
4330 st->u.plus.e += UTF8SKIP(st->u.plus.e);
4333 st->u.plus.e = locinput + n - st->ln;
4334 if (st->u.plus.e >= PL_regeol)
4335 st->u.plus.e = PL_regeol - 1;
4338 /* Find place 'next' could work */
4340 if (st->u.plus.c1 == st->u.plus.c2) {
4341 while (locinput <= st->u.plus.e &&
4342 UCHARAT(locinput) != st->u.plus.c1)
4345 while (locinput <= st->u.plus.e
4346 && UCHARAT(locinput) != st->u.plus.c1
4347 && UCHARAT(locinput) != st->u.plus.c2)
4350 st->u.plus.count = locinput - st->u.plus.old;
4353 if (st->u.plus.c1 == st->u.plus.c2) {
4355 /* count initialised to
4356 * utf8_distance(old, locinput) */
4357 while (locinput <= st->u.plus.e &&
4358 utf8n_to_uvchr((U8*)locinput,
4359 UTF8_MAXBYTES, &len,
4360 uniflags) != (UV)st->u.plus.c1) {
4365 /* count initialised to
4366 * utf8_distance(old, locinput) */
4367 while (locinput <= st->u.plus.e) {
4369 const UV c = utf8n_to_uvchr((U8*)locinput,
4370 UTF8_MAXBYTES, &len,
4372 if (c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4379 if (locinput > st->u.plus.e)
4381 /* PL_reginput == old now */
4382 if (locinput != st->u.plus.old) {
4383 st->ln = 1; /* Did some */
4384 if (regrepeat(rex, scan, st->u.plus.count) < st->u.plus.count)
4387 /* PL_reginput == locinput now */
4388 TRYPAREN(st->u.plus.paren, st->ln, locinput, PLUS1);
4389 /*** all unsaved local vars undefined at this point */
4390 PL_reginput = locinput; /* Could be reset... */
4391 REGCP_UNWIND(st->u.plus.lastcp);
4392 /* Couldn't or didn't -- move forward. */
4393 st->u.plus.old = locinput;
4395 locinput += UTF8SKIP(locinput);
4398 st->u.plus.count = 1;
4402 while (n >= st->ln || (n == REG_INFTY && st->ln > 0)) { /* ln overflow ? */
4404 if (st->u.plus.c1 != CHRTEST_VOID) {
4406 c = utf8n_to_uvchr((U8*)PL_reginput,
4410 c = UCHARAT(PL_reginput);
4411 /* If it could work, try it. */
4412 if (c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2) {
4413 TRYPAREN(st->u.plus.paren, st->ln, PL_reginput, PLUS2);
4414 /*** all unsaved local vars undefined at this point */
4415 REGCP_UNWIND(st->u.plus.lastcp);
4418 /* If it could work, try it. */
4419 else if (st->u.plus.c1 == CHRTEST_VOID) {
4420 TRYPAREN(st->u.plus.paren, st->ln, PL_reginput, PLUS3);
4421 /*** all unsaved local vars undefined at this point */
4422 REGCP_UNWIND(st->u.plus.lastcp);
4424 /* Couldn't or didn't -- move forward. */
4425 PL_reginput = locinput;
4426 if (regrepeat(rex, scan, 1)) {
4428 locinput = PL_reginput;
4435 n = regrepeat(rex, scan, n);
4436 locinput = PL_reginput;
4437 if ((st->ln < n) && (PL_regkind[OP(next)] == EOL) &&
4438 (OP(next) != MEOL || OP(next) == SEOL || OP(next) == EOS))
4440 st->ln = n; /* why back off? */
4441 /* ...because $ and \Z can match before *and* after
4442 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
4443 We should back off by one in this case. */
4444 if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
4447 REGCP_SET(st->u.plus.lastcp);
4449 while (n >= st->ln) {
4451 if (st->u.plus.c1 != CHRTEST_VOID) {
4453 c = utf8n_to_uvchr((U8*)PL_reginput,
4457 c = UCHARAT(PL_reginput);
4459 /* If it could work, try it. */
4460 if (st->u.plus.c1 == CHRTEST_VOID || c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2) {
4461 TRYPAREN(st->u.plus.paren, n, PL_reginput, PLUS4);
4462 /*** all unsaved local vars undefined at this point */
4463 REGCP_UNWIND(st->u.plus.lastcp);
4465 /* Couldn't or didn't -- back up. */
4467 PL_reginput = locinput = HOPc(locinput, -1);
4474 if (locinput < reginfo->till) {
4475 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4476 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4478 (long)(locinput - PL_reg_starttry),
4479 (long)(reginfo->till - PL_reg_starttry),
4481 sayNO_FINAL; /* Cannot match: too short. */
4483 PL_reginput = locinput; /* put where regtry can find it */
4484 sayYES_FINAL; /* Success! */
4486 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4488 PerlIO_printf(Perl_debug_log,
4489 "%*s %ssubpattern success...%s\n",
4490 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5]));
4491 PL_reginput = locinput; /* put where regtry can find it */
4492 sayYES_FINAL; /* Success! */
4494 case SUSPEND: /* (?>FOO) */
4495 st->u.ifmatch.wanted = 1;
4496 PL_reginput = locinput;
4499 case UNLESSM: /* -ve lookaround: (?!FOO), or with flags, (?<!foo) */
4500 st->u.ifmatch.wanted = 0;
4501 goto ifmatch_trivial_fail_test;
4503 case IFMATCH: /* +ve lookaround: (?=FOO), or with flags, (?<=foo) */
4504 st->u.ifmatch.wanted = 1;
4505 ifmatch_trivial_fail_test:
4507 char * const s = HOPBACKc(locinput, scan->flags);
4512 st->sw = 1 - (bool)st->u.ifmatch.wanted;
4514 else if (st->u.ifmatch.wanted)
4516 next = scan + ARG(scan);
4524 PL_reginput = locinput;
4527 /* resume to current state on success */
4528 st->u.yes.prev_yes_state = yes_state;
4530 PUSH_STATE(newst, resume_IFMATCH);
4532 next = NEXTOPER(NEXTOPER(scan));
4536 next = scan + ARG(scan);
4541 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4542 PTR2UV(scan), OP(scan));
4543 Perl_croak(aTHX_ "regexp memory corruption");
4551 /* simulate recursively calling regmatch(), but without actually
4552 * recursing - ie save the current state on the heap rather than on
4553 * the stack, then re-enter the loop. This avoids complex regexes
4554 * blowing the processor stack */
4558 /* push new state */
4559 regmatch_state *oldst = st;
4563 /* grab the next free state slot */
4565 if (st > SLAB_LAST(PL_regmatch_slab))
4566 st = S_push_slab(aTHX);
4567 PL_regmatch_state = st;
4571 oldst->locinput = locinput;
4574 locinput = PL_reginput;
4575 nextchr = UCHARAT(locinput);
4589 * We get here only if there's trouble -- normally "case END" is
4590 * the terminating point.
4592 Perl_croak(aTHX_ "corrupted regexp pointers");
4599 /* we have successfully completed a subexpression, but we must now
4600 * pop to the state marked by yes_state and continue from there */
4602 /*XXX tmp for CURLYM*/
4603 regmatch_slab * const oslab = PL_regmatch_slab;
4604 regmatch_state * const ost = st;
4605 regmatch_state * const oys = yes_state;
4608 assert(st != yes_state);
4609 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
4610 || yes_state > SLAB_LAST(PL_regmatch_slab))
4612 /* not in this slab, pop slab */
4613 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
4614 PL_regmatch_slab = PL_regmatch_slab->prev;
4615 st = SLAB_LAST(PL_regmatch_slab);
4617 depth -= (st - yes_state);
4618 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE TO (%d)\n", depth));
4620 yes_state = st->u.yes.prev_yes_state;
4621 PL_regmatch_state = st;
4623 switch (st->resume_state) {
4625 if (st->u.eval.toggleutf)
4626 PL_reg_flags ^= RF_utf8;
4628 rex = st->u.eval.prev_rex;
4629 /* XXXX This is too dramatic a measure... */
4631 /* Restore parens of the caller without popping the
4634 const I32 tmp = PL_savestack_ix;
4635 PL_savestack_ix = st->u.eval.lastcp;
4637 PL_savestack_ix = tmp;
4639 PL_reginput = locinput;
4640 /* continue at the node following the (??{...}) */
4644 case resume_IFMATCH:
4647 st->sw = (bool)st->u.ifmatch.wanted;
4649 else if (!st->u.ifmatch.wanted)
4652 if (OP(st->scan) == SUSPEND)
4653 locinput = PL_reginput;
4655 locinput = PL_reginput = st->locinput;
4656 nextchr = UCHARAT(locinput);
4658 next = st->scan + ARG(st->scan);
4659 if (next == st->scan)
4663 /* XXX tmp don't handle yes_state yet */
4664 case resume_CURLYM1:
4665 case resume_CURLYM2:
4666 case resume_CURLYM3:
4667 PL_regmatch_slab =oslab;
4669 PL_regmatch_state = st;
4672 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "XXX revering a CURLYM\n"));
4676 Perl_croak(aTHX_ "unexpected yes reume state");
4680 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4681 PL_colors[4], PL_colors[5]));
4688 /* XXX this is duplicate(ish) code to that in the do_no section.
4689 * eventually a yes should just pop the stack back to the current
4692 /* restore previous state and re-enter */
4695 switch (st->resume_state) {
4697 goto resume_point_TRIE1;
4699 goto resume_point_TRIE2;
4701 goto resume_point_CURLYX;
4702 case resume_WHILEM1:
4703 goto resume_point_WHILEM1;
4704 case resume_WHILEM2:
4705 goto resume_point_WHILEM2;
4706 case resume_WHILEM3:
4707 goto resume_point_WHILEM3;
4708 case resume_WHILEM4:
4709 goto resume_point_WHILEM4;
4710 case resume_WHILEM5:
4711 goto resume_point_WHILEM5;
4712 case resume_WHILEM6:
4713 goto resume_point_WHILEM6;
4714 case resume_CURLYM1:
4715 goto resume_point_CURLYM1;
4716 case resume_CURLYM2:
4717 goto resume_point_CURLYM2;
4718 case resume_CURLYM3:
4719 goto resume_point_CURLYM3;
4721 goto resume_point_PLUS1;
4723 goto resume_point_PLUS2;
4725 goto resume_point_PLUS3;
4727 goto resume_point_PLUS4;
4729 case resume_IFMATCH:
4732 Perl_croak(aTHX_ "regexp resume memory corruption");
4739 PerlIO_printf(Perl_debug_log,
4740 "%*s %sfailed...%s\n",
4741 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4747 re_unwind_t * const uw = SSPTRt(st->unwind,re_unwind_t);
4750 case RE_UNWIND_BRANCH:
4751 case RE_UNWIND_BRANCHJ:
4753 re_unwind_branch_t * const uwb = &(uw->branch);
4754 const I32 lastparen = uwb->lastparen;
4756 REGCP_UNWIND(uwb->lastcp);
4757 for (n = *PL_reglastparen; n > lastparen; n--)
4759 *PL_reglastparen = n;
4760 scan = next = uwb->next;
4761 st->minmod = uwb->minmod;
4763 OP(scan) != (uwb->type == RE_UNWIND_BRANCH
4764 ? BRANCH : BRANCHJ) ) { /* Failure */
4765 st->unwind = uwb->prev;
4771 /* Have more choice yet. Reuse the same uwb. */
4772 if ((n = (uwb->type == RE_UNWIND_BRANCH
4773 ? NEXT_OFF(next) : ARG(next))))
4776 next = NULL; /* XXXX Needn't unwinding in this case... */
4778 next = NEXTOPER(scan);
4779 if (uwb->type == RE_UNWIND_BRANCHJ)
4780 next = NEXTOPER(next);
4781 locinput = uwb->locinput;
4782 nextchr = uwb->nextchr;
4784 PL_regindent = uwb->regindent;
4791 Perl_croak(aTHX_ "regexp unwind memory corruption");
4802 /* there's a previous state to backtrack to */
4804 switch (st->resume_state) {
4806 goto resume_point_TRIE1;
4808 goto resume_point_TRIE2;
4810 /* we have failed an (??{...}). Restore state to the outer re
4811 * then re-throw the failure */
4812 if (st->u.eval.toggleutf)
4813 PL_reg_flags ^= RF_utf8;
4815 rex = st->u.eval.prev_rex;
4816 yes_state = st->u.yes.prev_yes_state;
4818 /* XXXX This is too dramatic a measure... */
4821 PL_reginput = locinput;
4822 REGCP_UNWIND(st->u.eval.lastcp);
4827 goto resume_point_CURLYX;
4828 case resume_WHILEM1:
4829 goto resume_point_WHILEM1;
4830 case resume_WHILEM2:
4831 goto resume_point_WHILEM2;
4832 case resume_WHILEM3:
4833 goto resume_point_WHILEM3;
4834 case resume_WHILEM4:
4835 goto resume_point_WHILEM4;
4836 case resume_WHILEM5:
4837 goto resume_point_WHILEM5;
4838 case resume_WHILEM6:
4839 goto resume_point_WHILEM6;
4840 case resume_CURLYM1:
4841 goto resume_point_CURLYM1;
4842 case resume_CURLYM2:
4843 goto resume_point_CURLYM2;
4844 case resume_CURLYM3:
4845 goto resume_point_CURLYM3;
4846 case resume_IFMATCH:
4847 yes_state = st->u.yes.prev_yes_state;
4850 st->sw = !st->u.ifmatch.wanted;
4852 else if (st->u.ifmatch.wanted)
4855 assert(OP(scan) != SUSPEND); /* XXX DAPM tmp */
4856 locinput = PL_reginput = st->locinput;
4857 nextchr = UCHARAT(locinput);
4858 next = scan + ARG(scan);
4864 goto resume_point_PLUS1;
4866 goto resume_point_PLUS2;
4868 goto resume_point_PLUS3;
4870 goto resume_point_PLUS4;
4872 Perl_croak(aTHX_ "regexp resume memory corruption");
4878 /* restore original high-water mark */
4879 PL_regmatch_slab = orig_slab;
4880 PL_regmatch_state = orig_state;
4882 /* free all slabs above current one */
4883 if (orig_slab->next) {
4884 regmatch_slab *sl = orig_slab->next;
4885 orig_slab->next = NULL;
4887 regmatch_slab * const osl = sl;
4898 - regrepeat - repeatedly match something simple, report how many
4901 * [This routine now assumes that it will only match on things of length 1.
4902 * That was true before, but now we assume scan - reginput is the count,
4903 * rather than incrementing count on every character. [Er, except utf8.]]
4906 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max)
4909 register char *scan;
4911 register char *loceol = PL_regeol;
4912 register I32 hardcount = 0;
4913 register bool do_utf8 = PL_reg_match_utf8;
4916 if (max == REG_INFTY)
4918 else if (max < loceol - scan)
4919 loceol = scan + max;
4924 while (scan < loceol && hardcount < max && *scan != '\n') {
4925 scan += UTF8SKIP(scan);
4929 while (scan < loceol && *scan != '\n')
4936 while (scan < loceol && hardcount < max) {
4937 scan += UTF8SKIP(scan);
4947 case EXACT: /* length of string is 1 */
4949 while (scan < loceol && UCHARAT(scan) == c)
4952 case EXACTF: /* length of string is 1 */
4954 while (scan < loceol &&
4955 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4958 case EXACTFL: /* length of string is 1 */
4959 PL_reg_flags |= RF_tainted;
4961 while (scan < loceol &&
4962 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4968 while (hardcount < max && scan < loceol &&
4969 reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
4970 scan += UTF8SKIP(scan);
4974 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
4981 LOAD_UTF8_CHARCLASS_ALNUM();
4982 while (hardcount < max && scan < loceol &&
4983 swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4984 scan += UTF8SKIP(scan);
4988 while (scan < loceol && isALNUM(*scan))
4993 PL_reg_flags |= RF_tainted;
4996 while (hardcount < max && scan < loceol &&
4997 isALNUM_LC_utf8((U8*)scan)) {
4998 scan += UTF8SKIP(scan);
5002 while (scan < loceol && isALNUM_LC(*scan))
5009 LOAD_UTF8_CHARCLASS_ALNUM();
5010 while (hardcount < max && scan < loceol &&
5011 !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5012 scan += UTF8SKIP(scan);
5016 while (scan < loceol && !isALNUM(*scan))
5021 PL_reg_flags |= RF_tainted;
5024 while (hardcount < max && scan < loceol &&
5025 !isALNUM_LC_utf8((U8*)scan)) {
5026 scan += UTF8SKIP(scan);
5030 while (scan < loceol && !isALNUM_LC(*scan))
5037 LOAD_UTF8_CHARCLASS_SPACE();
5038 while (hardcount < max && scan < loceol &&
5040 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5041 scan += UTF8SKIP(scan);
5045 while (scan < loceol && isSPACE(*scan))
5050 PL_reg_flags |= RF_tainted;
5053 while (hardcount < max && scan < loceol &&
5054 (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5055 scan += UTF8SKIP(scan);
5059 while (scan < loceol && isSPACE_LC(*scan))
5066 LOAD_UTF8_CHARCLASS_SPACE();
5067 while (hardcount < max && scan < loceol &&
5069 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5070 scan += UTF8SKIP(scan);
5074 while (scan < loceol && !isSPACE(*scan))
5079 PL_reg_flags |= RF_tainted;
5082 while (hardcount < max && scan < loceol &&
5083 !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5084 scan += UTF8SKIP(scan);
5088 while (scan < loceol && !isSPACE_LC(*scan))
5095 LOAD_UTF8_CHARCLASS_DIGIT();
5096 while (hardcount < max && scan < loceol &&
5097 swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5098 scan += UTF8SKIP(scan);
5102 while (scan < loceol && isDIGIT(*scan))
5109 LOAD_UTF8_CHARCLASS_DIGIT();
5110 while (hardcount < max && scan < loceol &&
5111 !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5112 scan += UTF8SKIP(scan);
5116 while (scan < loceol && !isDIGIT(*scan))
5120 default: /* Called on something of 0 width. */
5121 break; /* So match right here or not at all. */
5127 c = scan - PL_reginput;
5131 SV *re_debug_flags = NULL;
5132 SV * const prop = sv_newmortal();
5135 regprop(prog, prop, p);
5136 PerlIO_printf(Perl_debug_log,
5137 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
5138 REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
5146 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5148 - regclass_swash - prepare the utf8 swash
5152 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5158 const struct reg_data * const data = prog ? prog->data : NULL;
5160 if (data && data->count) {
5161 const U32 n = ARG(node);
5163 if (data->what[n] == 's') {
5164 SV * const rv = (SV*)data->data[n];
5165 AV * const av = (AV*)SvRV((SV*)rv);
5166 SV **const ary = AvARRAY(av);
5169 /* See the end of regcomp.c:S_regclass() for
5170 * documentation of these array elements. */
5173 a = SvROK(ary[1]) ? &ary[1] : 0;
5174 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
5178 else if (si && doinit) {
5179 sw = swash_init("utf8", "", si, 1, 0);
5180 (void)av_store(av, 1, sw);
5197 - reginclass - determine if a character falls into a character class
5199 The n is the ANYOF regnode, the p is the target string, lenp
5200 is pointer to the maximum length of how far to go in the p
5201 (if the lenp is zero, UTF8SKIP(p) is used),
5202 do_utf8 tells whether the target string is in UTF-8.
5207 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5210 const char flags = ANYOF_FLAGS(n);
5216 if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5217 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5218 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5219 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5220 if (len == (STRLEN)-1)
5221 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5224 plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5225 if (do_utf8 || (flags & ANYOF_UNICODE)) {
5228 if (do_utf8 && !ANYOF_RUNTIME(n)) {
5229 if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5232 if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5236 SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5239 if (swash_fetch(sw, p, do_utf8))
5241 else if (flags & ANYOF_FOLD) {
5242 if (!match && lenp && av) {
5244 for (i = 0; i <= av_len(av); i++) {
5245 SV* const sv = *av_fetch(av, i, FALSE);
5247 const char * const s = SvPV_const(sv, len);
5249 if (len <= plen && memEQ(s, (char*)p, len)) {
5257 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5260 to_utf8_fold(p, tmpbuf, &tmplen);
5261 if (swash_fetch(sw, tmpbuf, do_utf8))
5267 if (match && lenp && *lenp == 0)
5268 *lenp = UNISKIP(NATIVE_TO_UNI(c));
5270 if (!match && c < 256) {
5271 if (ANYOF_BITMAP_TEST(n, c))
5273 else if (flags & ANYOF_FOLD) {
5276 if (flags & ANYOF_LOCALE) {
5277 PL_reg_flags |= RF_tainted;
5278 f = PL_fold_locale[c];
5282 if (f != c && ANYOF_BITMAP_TEST(n, f))
5286 if (!match && (flags & ANYOF_CLASS)) {
5287 PL_reg_flags |= RF_tainted;
5289 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
5290 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
5291 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
5292 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
5293 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
5294 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
5295 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
5296 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5297 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
5298 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
5299 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
5300 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
5301 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
5302 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
5303 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
5304 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
5305 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
5306 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
5307 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
5308 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
5309 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
5310 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
5311 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
5312 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
5313 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
5314 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
5315 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
5316 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
5317 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
5318 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
5319 ) /* How's that for a conditional? */
5326 return (flags & ANYOF_INVERT) ? !match : match;
5330 S_reghop3(U8 *s, I32 off, const U8* lim)
5334 while (off-- && s < lim) {
5335 /* XXX could check well-formedness here */
5343 if (UTF8_IS_CONTINUED(*s)) {
5344 while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5347 /* XXX could check well-formedness here */
5355 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5359 while (off-- && s < lim) {
5360 /* XXX could check well-formedness here */
5370 if (UTF8_IS_CONTINUED(*s)) {
5371 while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5374 /* XXX could check well-formedness here */
5386 restore_pos(pTHX_ void *arg)
5389 regexp * const rex = (regexp *)arg;
5390 if (PL_reg_eval_set) {
5391 if (PL_reg_oldsaved) {
5392 rex->subbeg = PL_reg_oldsaved;
5393 rex->sublen = PL_reg_oldsavedlen;
5394 #ifdef PERL_OLD_COPY_ON_WRITE
5395 rex->saved_copy = PL_nrs;
5397 RX_MATCH_COPIED_on(rex);
5399 PL_reg_magic->mg_len = PL_reg_oldpos;
5400 PL_reg_eval_set = 0;
5401 PL_curpm = PL_reg_oldcurpm;
5406 S_to_utf8_substr(pTHX_ register regexp *prog)
5408 if (prog->float_substr && !prog->float_utf8) {
5409 SV* const sv = newSVsv(prog->float_substr);
5410 prog->float_utf8 = sv;
5411 sv_utf8_upgrade(sv);
5412 if (SvTAIL(prog->float_substr))
5414 if (prog->float_substr == prog->check_substr)
5415 prog->check_utf8 = sv;
5417 if (prog->anchored_substr && !prog->anchored_utf8) {
5418 SV* const sv = newSVsv(prog->anchored_substr);
5419 prog->anchored_utf8 = sv;
5420 sv_utf8_upgrade(sv);
5421 if (SvTAIL(prog->anchored_substr))
5423 if (prog->anchored_substr == prog->check_substr)
5424 prog->check_utf8 = sv;
5429 S_to_byte_substr(pTHX_ register regexp *prog)
5432 if (prog->float_utf8 && !prog->float_substr) {
5433 SV* sv = newSVsv(prog->float_utf8);
5434 prog->float_substr = sv;
5435 if (sv_utf8_downgrade(sv, TRUE)) {
5436 if (SvTAIL(prog->float_utf8))
5440 prog->float_substr = sv = &PL_sv_undef;
5442 if (prog->float_utf8 == prog->check_utf8)
5443 prog->check_substr = sv;
5445 if (prog->anchored_utf8 && !prog->anchored_substr) {
5446 SV* sv = newSVsv(prog->anchored_utf8);
5447 prog->anchored_substr = sv;
5448 if (sv_utf8_downgrade(sv, TRUE)) {
5449 if (SvTAIL(prog->anchored_utf8))
5453 prog->anchored_substr = sv = &PL_sv_undef;
5455 if (prog->anchored_utf8 == prog->check_utf8)
5456 prog->check_substr = sv;
5462 * c-indentation-style: bsd
5464 * indent-tabs-mode: t
5467 * ex: set ts=8 sts=4 sw=4 noet: