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;
164 GET_RE_DEBUG_FLAGS_DECL;
166 if (paren_elems_to_push < 0)
167 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
169 #define REGCP_OTHER_ELEMS 6
170 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
171 for (p = PL_regsize; p > parenfloor; p--) {
172 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
173 SSPUSHINT(PL_regendp[p]);
174 SSPUSHINT(PL_regstartp[p]);
175 SSPUSHPTR(PL_reg_start_tmp[p]);
177 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
178 " saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
179 (UV)p, (IV)PL_regstartp[p],
180 (IV)(PL_reg_start_tmp[p] - PL_bostr),
184 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
185 SSPUSHINT(PL_regsize);
186 SSPUSHINT(*PL_reglastparen);
187 SSPUSHINT(*PL_reglastcloseparen);
188 SSPUSHPTR(PL_reginput);
189 #define REGCP_FRAME_ELEMS 2
190 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
191 * are needed for the regexp context stack bookkeeping. */
192 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
193 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
198 /* These are needed since we do not localize EVAL nodes: */
199 # define REGCP_SET(cp) DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, \
200 " Setting an EVAL scope, savestack=%"IVdf"\n", \
201 (IV)PL_savestack_ix)); cp = PL_savestack_ix
203 # define REGCP_UNWIND(cp) DEBUG_EXECUTE_r(cp != PL_savestack_ix ? \
204 PerlIO_printf(Perl_debug_log, \
205 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
206 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
209 S_regcppop(pTHX_ const regexp *rex)
215 GET_RE_DEBUG_FLAGS_DECL;
217 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
219 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
220 i = SSPOPINT; /* Parentheses elements to pop. */
221 input = (char *) SSPOPPTR;
222 *PL_reglastcloseparen = SSPOPINT;
223 *PL_reglastparen = SSPOPINT;
224 PL_regsize = SSPOPINT;
226 /* Now restore the parentheses context. */
227 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
228 i > 0; i -= REGCP_PAREN_ELEMS) {
230 U32 paren = (U32)SSPOPINT;
231 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
232 PL_regstartp[paren] = SSPOPINT;
234 if (paren <= *PL_reglastparen)
235 PL_regendp[paren] = tmps;
237 PerlIO_printf(Perl_debug_log,
238 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
239 (UV)paren, (IV)PL_regstartp[paren],
240 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
241 (IV)PL_regendp[paren],
242 (paren > *PL_reglastparen ? "(no)" : ""));
246 if (*PL_reglastparen + 1 <= rex->nparens) {
247 PerlIO_printf(Perl_debug_log,
248 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
249 (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
253 /* It would seem that the similar code in regtry()
254 * already takes care of this, and in fact it is in
255 * a better location to since this code can #if 0-ed out
256 * but the code in regtry() is needed or otherwise tests
257 * requiring null fields (pat.t#187 and split.t#{13,14}
258 * (as of patchlevel 7877) will fail. Then again,
259 * this code seems to be necessary or otherwise
260 * building DynaLoader will fail:
261 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
263 for (i = *PL_reglastparen + 1; (U32)i <= rex->nparens; i++) {
265 PL_regstartp[i] = -1;
272 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
275 * pregexec and friends
278 #ifndef PERL_IN_XSUB_RE
280 - pregexec - match a regexp against a string
283 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
284 char *strbeg, I32 minend, SV *screamer, U32 nosave)
285 /* strend: pointer to null at end of string */
286 /* strbeg: real beginning of string */
287 /* minend: end of match must be >=minend after stringarg. */
288 /* nosave: For optimizations. */
291 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
292 nosave ? 0 : REXEC_COPY_STR);
297 * Need to implement the following flags for reg_anch:
299 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
301 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
302 * INTUIT_AUTORITATIVE_ML
303 * INTUIT_ONCE_NOML - Intuit can match in one location only.
306 * Another flag for this function: SECOND_TIME (so that float substrs
307 * with giant delta may be not rechecked).
310 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
312 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
313 Otherwise, only SvCUR(sv) is used to get strbeg. */
315 /* XXXX We assume that strpos is strbeg unless sv. */
317 /* XXXX Some places assume that there is a fixed substring.
318 An update may be needed if optimizer marks as "INTUITable"
319 RExen without fixed substrings. Similarly, it is assumed that
320 lengths of all the strings are no more than minlen, thus they
321 cannot come from lookahead.
322 (Or minlen should take into account lookahead.) */
324 /* A failure to find a constant substring means that there is no need to make
325 an expensive call to REx engine, thus we celebrate a failure. Similarly,
326 finding a substring too deep into the string means that less calls to
327 regtry() should be needed.
329 REx compiler's optimizer found 4 possible hints:
330 a) Anchored substring;
332 c) Whether we are anchored (beginning-of-line or \G);
333 d) First node (of those at offset 0) which may distingush positions;
334 We use a)b)d) and multiline-part of c), and try to find a position in the
335 string which does not contradict any of them.
338 /* Most of decisions we do here should have been done at compile time.
339 The nodes of the REx which we used for the search should have been
340 deleted from the finite automaton. */
343 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
344 char *strend, U32 flags, re_scream_pos_data *data)
347 register I32 start_shift = 0;
348 /* Should be nonnegative! */
349 register I32 end_shift = 0;
354 const int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */
356 register char *other_last = NULL; /* other substr checked before this */
357 char *check_at = NULL; /* check substr found at this pos */
358 const I32 multiline = prog->reganch & PMf_MULTILINE;
360 const char * const i_strpos = strpos;
361 SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
364 GET_RE_DEBUG_FLAGS_DECL;
366 RX_MATCH_UTF8_set(prog,do_utf8);
368 if (prog->reganch & ROPT_UTF8) {
369 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
370 "UTF-8 regex...\n"));
371 PL_reg_flags |= RF_utf8;
375 const char *s = PL_reg_match_utf8 ?
376 sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
378 const int len = PL_reg_match_utf8 ?
379 (int)strlen(s) : strend - strpos;
382 if (PL_reg_match_utf8)
383 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
384 "UTF-8 target...\n"));
385 PerlIO_printf(Perl_debug_log,
386 "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n",
387 PL_colors[4], PL_colors[5], PL_colors[0],
390 (strlen(prog->precomp) > 60 ? "..." : ""),
392 (int)(len > 60 ? 60 : len),
394 (len > 60 ? "..." : "")
398 /* CHR_DIST() would be more correct here but it makes things slow. */
399 if (prog->minlen > strend - strpos) {
400 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
401 "String too short... [re_intuit_start]\n"));
404 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
407 if (!prog->check_utf8 && prog->check_substr)
408 to_utf8_substr(prog);
409 check = prog->check_utf8;
411 if (!prog->check_substr && prog->check_utf8)
412 to_byte_substr(prog);
413 check = prog->check_substr;
415 if (check == &PL_sv_undef) {
416 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
417 "Non-utf string cannot match utf check string\n"));
420 if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
421 ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
422 || ( (prog->reganch & ROPT_ANCH_BOL)
423 && !multiline ) ); /* Check after \n? */
426 if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
427 | ROPT_IMPLICIT)) /* not a real BOL */
428 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
430 && (strpos != strbeg)) {
431 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
434 if (prog->check_offset_min == prog->check_offset_max &&
435 !(prog->reganch & ROPT_CANY_SEEN)) {
436 /* Substring at constant offset from beg-of-str... */
439 s = HOP3c(strpos, prog->check_offset_min, strend);
441 slen = SvCUR(check); /* >= 1 */
443 if ( strend - s > slen || strend - s < slen - 1
444 || (strend - s == slen && strend[-1] != '\n')) {
445 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
448 /* Now should match s[0..slen-2] */
450 if (slen && (*SvPVX_const(check) != *s
452 && memNE(SvPVX_const(check), s, slen)))) {
454 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
458 else if (*SvPVX_const(check) != *s
459 || ((slen = SvCUR(check)) > 1
460 && memNE(SvPVX_const(check), s, slen)))
463 goto success_at_start;
466 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
468 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
469 end_shift = prog->minlen - start_shift -
470 CHR_SVLEN(check) + (SvTAIL(check) != 0);
472 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
473 - (SvTAIL(check) != 0);
474 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
476 if (end_shift < eshift)
480 else { /* Can match at random position */
483 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
484 /* Should be nonnegative! */
485 end_shift = prog->minlen - start_shift -
486 CHR_SVLEN(check) + (SvTAIL(check) != 0);
489 #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
491 Perl_croak(aTHX_ "panic: end_shift");
495 /* Find a possible match in the region s..strend by looking for
496 the "check" substring in the region corrected by start/end_shift. */
497 if (flags & REXEC_SCREAM) {
498 I32 p = -1; /* Internal iterator of scream. */
499 I32 * const pp = data ? data->scream_pos : &p;
501 if (PL_screamfirst[BmRARE(check)] >= 0
502 || ( BmRARE(check) == '\n'
503 && (BmPREVIOUS(check) == SvCUR(check) - 1)
505 s = screaminstr(sv, check,
506 start_shift + (s - strbeg), end_shift, pp, 0);
509 /* we may be pointing at the wrong string */
510 if (s && RX_MATCH_COPIED(prog))
511 s = strbeg + (s - SvPVX_const(sv));
513 *data->scream_olds = s;
515 else if (prog->reganch & ROPT_CANY_SEEN)
516 s = fbm_instr((U8*)(s + start_shift),
517 (U8*)(strend - end_shift),
518 check, multiline ? FBMrf_MULTILINE : 0);
520 s = fbm_instr(HOP3(s, start_shift, strend),
521 HOP3(strend, -end_shift, strbeg),
522 check, multiline ? FBMrf_MULTILINE : 0);
524 /* Update the count-of-usability, remove useless subpatterns,
527 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s",
528 (s ? "Found" : "Did not find"),
529 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
531 (int)(SvCUR(check) - (SvTAIL(check)!=0)),
533 PL_colors[1], (SvTAIL(check) ? "$" : ""),
534 (s ? " at offset " : "...\n") ) );
541 /* Finish the diagnostic message */
542 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
544 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
545 Start with the other substr.
546 XXXX no SCREAM optimization yet - and a very coarse implementation
547 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
548 *always* match. Probably should be marked during compile...
549 Probably it is right to do no SCREAM here...
552 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
553 /* Take into account the "other" substring. */
554 /* XXXX May be hopelessly wrong for UTF... */
557 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
560 char * const last = HOP3c(s, -start_shift, strbeg);
562 char * const saved_s = s;
565 t = s - prog->check_offset_max;
566 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
568 || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
573 t = HOP3c(t, prog->anchored_offset, strend);
574 if (t < other_last) /* These positions already checked */
576 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
579 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
580 /* On end-of-str: see comment below. */
581 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
582 if (must == &PL_sv_undef) {
584 DEBUG_EXECUTE_r(must = prog->anchored_utf8); /* for debug */
589 HOP3(HOP3(last1, prog->anchored_offset, strend)
590 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
592 multiline ? FBMrf_MULTILINE : 0
594 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
595 "%s anchored substr \"%s%.*s%s\"%s",
596 (s ? "Found" : "Contradicts"),
599 - (SvTAIL(must)!=0)),
601 PL_colors[1], (SvTAIL(must) ? "$" : "")));
603 if (last1 >= last2) {
604 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
605 ", giving up...\n"));
608 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
609 ", trying floating at offset %ld...\n",
610 (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
611 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
612 s = HOP3c(last, 1, strend);
616 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
617 (long)(s - i_strpos)));
618 t = HOP3c(s, -prog->anchored_offset, strbeg);
619 other_last = HOP3c(s, 1, strend);
627 else { /* Take into account the floating substring. */
629 char * const saved_s = s;
632 t = HOP3c(s, -start_shift, strbeg);
634 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
635 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
636 last = HOP3c(t, prog->float_max_offset, strend);
637 s = HOP3c(t, prog->float_min_offset, strend);
640 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
641 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
642 /* fbm_instr() takes into account exact value of end-of-str
643 if the check is SvTAIL(ed). Since false positives are OK,
644 and end-of-str is not later than strend we are OK. */
645 if (must == &PL_sv_undef) {
647 DEBUG_EXECUTE_r(must = prog->float_utf8); /* for debug message */
650 s = fbm_instr((unsigned char*)s,
651 (unsigned char*)last + SvCUR(must)
653 must, multiline ? FBMrf_MULTILINE : 0);
654 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
655 (s ? "Found" : "Contradicts"),
657 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
659 PL_colors[1], (SvTAIL(must) ? "$" : "")));
662 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
663 ", giving up...\n"));
666 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
667 ", trying anchored starting at offset %ld...\n",
668 (long)(saved_s + 1 - i_strpos)));
670 s = HOP3c(t, 1, strend);
674 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
675 (long)(s - i_strpos)));
676 other_last = s; /* Fix this later. --Hugo */
685 t = s - prog->check_offset_max;
686 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
688 || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*)strpos))
690 /* Fixed substring is found far enough so that the match
691 cannot start at strpos. */
693 if (ml_anch && t[-1] != '\n') {
694 /* Eventually fbm_*() should handle this, but often
695 anchored_offset is not 0, so this check will not be wasted. */
696 /* XXXX In the code below we prefer to look for "^" even in
697 presence of anchored substrings. And we search even
698 beyond the found float position. These pessimizations
699 are historical artefacts only. */
701 while (t < strend - prog->minlen) {
703 if (t < check_at - prog->check_offset_min) {
704 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
705 /* Since we moved from the found position,
706 we definitely contradict the found anchored
707 substr. Due to the above check we do not
708 contradict "check" substr.
709 Thus we can arrive here only if check substr
710 is float. Redo checking for "other"=="fixed".
713 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
714 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
715 goto do_other_anchored;
717 /* We don't contradict the found floating substring. */
718 /* XXXX Why not check for STCLASS? */
720 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
721 PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
724 /* Position contradicts check-string */
725 /* XXXX probably better to look for check-string
726 than for "\n", so one should lower the limit for t? */
727 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
728 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
729 other_last = strpos = s = t + 1;
734 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
735 PL_colors[0], PL_colors[1]));
739 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
740 PL_colors[0], PL_colors[1]));
744 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
747 /* The found string does not prohibit matching at strpos,
748 - no optimization of calling REx engine can be performed,
749 unless it was an MBOL and we are not after MBOL,
750 or a future STCLASS check will fail this. */
752 /* Even in this situation we may use MBOL flag if strpos is offset
753 wrt the start of the string. */
754 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
755 && (strpos != strbeg) && strpos[-1] != '\n'
756 /* May be due to an implicit anchor of m{.*foo} */
757 && !(prog->reganch & ROPT_IMPLICIT))
762 DEBUG_EXECUTE_r( if (ml_anch)
763 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
764 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
767 if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
769 prog->check_utf8 /* Could be deleted already */
770 && --BmUSEFUL(prog->check_utf8) < 0
771 && (prog->check_utf8 == prog->float_utf8)
773 prog->check_substr /* Could be deleted already */
774 && --BmUSEFUL(prog->check_substr) < 0
775 && (prog->check_substr == prog->float_substr)
778 /* If flags & SOMETHING - do not do it many times on the same match */
779 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
780 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
781 if (do_utf8 ? prog->check_substr : prog->check_utf8)
782 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
783 prog->check_substr = prog->check_utf8 = NULL; /* disable */
784 prog->float_substr = prog->float_utf8 = NULL; /* clear */
785 check = NULL; /* abort */
787 /* XXXX This is a remnant of the old implementation. It
788 looks wasteful, since now INTUIT can use many
790 prog->reganch &= ~RE_USE_INTUIT;
797 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
798 if (prog->regstclass && OP(prog->regstclass)!=TRIE) {
799 /* minlen == 0 is possible if regstclass is \b or \B,
800 and the fixed substr is ''$.
801 Since minlen is already taken into account, s+1 is before strend;
802 accidentally, minlen >= 1 guaranties no false positives at s + 1
803 even for \b or \B. But (minlen? 1 : 0) below assumes that
804 regstclass does not come from lookahead... */
805 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
806 This leaves EXACTF only, which is dealt with in find_byclass(). */
807 const U8* const str = (U8*)STRING(prog->regstclass);
808 const int cl_l = (PL_regkind[OP(prog->regstclass)] == EXACT
809 ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
811 const char * endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
812 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
813 : (prog->float_substr || prog->float_utf8
814 ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
817 /*if (OP(prog->regstclass) == TRIE)
820 s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
823 const char *what = NULL;
825 if (endpos == strend) {
826 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
827 "Could not match STCLASS...\n") );
830 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
831 "This position contradicts STCLASS...\n") );
832 if ((prog->reganch & ROPT_ANCH) && !ml_anch)
834 /* Contradict one of substrings */
835 if (prog->anchored_substr || prog->anchored_utf8) {
836 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
837 DEBUG_EXECUTE_r( what = "anchored" );
839 s = HOP3c(t, 1, strend);
840 if (s + start_shift + end_shift > strend) {
841 /* XXXX Should be taken into account earlier? */
842 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
843 "Could not match STCLASS...\n") );
848 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
849 "Looking for %s substr starting at offset %ld...\n",
850 what, (long)(s + start_shift - i_strpos)) );
853 /* Have both, check_string is floating */
854 if (t + start_shift >= check_at) /* Contradicts floating=check */
855 goto retry_floating_check;
856 /* Recheck anchored substring, but not floating... */
860 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
861 "Looking for anchored substr starting at offset %ld...\n",
862 (long)(other_last - i_strpos)) );
863 goto do_other_anchored;
865 /* Another way we could have checked stclass at the
866 current position only: */
871 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
872 "Looking for /%s^%s/m starting at offset %ld...\n",
873 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
876 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
878 /* Check is floating subtring. */
879 retry_floating_check:
880 t = check_at - start_shift;
881 DEBUG_EXECUTE_r( what = "floating" );
882 goto hop_and_restart;
885 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
886 "By STCLASS: moving %ld --> %ld\n",
887 (long)(t - i_strpos), (long)(s - i_strpos))
891 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
892 "Does not contradict STCLASS...\n");
897 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
898 PL_colors[4], (check ? "Guessed" : "Giving up"),
899 PL_colors[5], (long)(s - i_strpos)) );
902 fail_finish: /* Substring not found */
903 if (prog->check_substr || prog->check_utf8) /* could be removed already */
904 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
906 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
907 PL_colors[4], PL_colors[5]));
911 /* We know what class REx starts with. Try to find this position... */
912 /* if reginfo is NULL, its a dryrun */
913 /* annoyingly all the vars in this routine have different names from their counterparts
914 in regmatch. /grrr */
917 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
918 const char *strend, const regmatch_info *reginfo)
921 const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
925 register STRLEN uskip;
929 register I32 tmp = 1; /* Scratch variable? */
930 register const bool do_utf8 = PL_reg_match_utf8;
932 /* We know what class it must start with. */
936 while (s + (uskip = UTF8SKIP(s)) <= strend) {
937 if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
938 !UTF8_IS_INVARIANT((U8)s[0]) ?
939 reginclass(prog, c, (U8*)s, 0, do_utf8) :
940 REGINCLASS(prog, c, (U8*)s)) {
941 if (tmp && (!reginfo || regtry(reginfo, s)))
955 if (REGINCLASS(prog, c, (U8*)s) ||
956 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
957 /* The assignment of 2 is intentional:
958 * for the folded sharp s, the skip is 2. */
959 (skip = SHARP_S_SKIP))) {
960 if (tmp && (!reginfo || regtry(reginfo, s)))
973 if (tmp && (!reginfo || regtry(reginfo, s)))
982 ln = STR_LEN(c); /* length to match in octets/bytes */
983 lnc = (I32) ln; /* length to match in characters */
987 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
988 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
989 const U32 uniflags = UTF8_ALLOW_DEFAULT;
991 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
992 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
994 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
996 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
999 while (sm < ((U8 *) m + ln)) {
1014 c2 = PL_fold_locale[c1];
1016 e = HOP3c(strend, -((I32)lnc), s);
1018 if (!reginfo && e < s)
1019 e = s; /* Due to minlen logic of intuit() */
1021 /* The idea in the EXACTF* cases is to first find the
1022 * first character of the EXACTF* node and then, if
1023 * necessary, case-insensitively compare the full
1024 * text of the node. The c1 and c2 are the first
1025 * characters (though in Unicode it gets a bit
1026 * more complicated because there are more cases
1027 * than just upper and lower: one needs to use
1028 * the so-called folding case for case-insensitive
1029 * matching (called "loose matching" in Unicode).
1030 * ibcmp_utf8() will do just that. */
1034 U8 tmpbuf [UTF8_MAXBYTES+1];
1035 STRLEN len, foldlen;
1036 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1038 /* Upper and lower of 1st char are equal -
1039 * probably not a "letter". */
1041 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1045 ibcmp_utf8(s, NULL, 0, do_utf8,
1046 m, NULL, ln, (bool)UTF))
1047 && (!reginfo || regtry(reginfo, s)) )
1050 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1051 uvchr_to_utf8(tmpbuf, c);
1052 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1054 && (f == c1 || f == c2)
1055 && (ln == foldlen ||
1056 !ibcmp_utf8((char *) foldbuf,
1057 NULL, foldlen, do_utf8,
1059 NULL, ln, (bool)UTF))
1060 && (!reginfo || regtry(reginfo, s)) )
1068 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1071 /* Handle some of the three Greek sigmas cases.
1072 * Note that not all the possible combinations
1073 * are handled here: some of them are handled
1074 * by the standard folding rules, and some of
1075 * them (the character class or ANYOF cases)
1076 * are handled during compiletime in
1077 * regexec.c:S_regclass(). */
1078 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1079 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1080 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1082 if ( (c == c1 || c == c2)
1084 ibcmp_utf8(s, NULL, 0, do_utf8,
1085 m, NULL, ln, (bool)UTF))
1086 && (!reginfo || regtry(reginfo, s)) )
1089 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1090 uvchr_to_utf8(tmpbuf, c);
1091 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1093 && (f == c1 || f == c2)
1094 && (ln == foldlen ||
1095 !ibcmp_utf8((char *) foldbuf,
1096 NULL, foldlen, do_utf8,
1098 NULL, ln, (bool)UTF))
1099 && (!reginfo || regtry(reginfo, s)) )
1110 && (ln == 1 || !(OP(c) == EXACTF
1112 : ibcmp_locale(s, m, ln)))
1113 && (!reginfo || regtry(reginfo, s)) )
1119 if ( (*(U8*)s == c1 || *(U8*)s == c2)
1120 && (ln == 1 || !(OP(c) == EXACTF
1122 : ibcmp_locale(s, m, ln)))
1123 && (!reginfo || regtry(reginfo, s)) )
1130 PL_reg_flags |= RF_tainted;
1137 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1138 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1140 tmp = ((OP(c) == BOUND ?
1141 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1142 LOAD_UTF8_CHARCLASS_ALNUM();
1143 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1144 if (tmp == !(OP(c) == BOUND ?
1145 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1146 isALNUM_LC_utf8((U8*)s)))
1149 if ((!reginfo || regtry(reginfo, s)))
1156 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1157 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1158 while (s < strend) {
1160 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1162 if ((!reginfo || regtry(reginfo, s)))
1168 if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, s)))
1172 PL_reg_flags |= RF_tainted;
1179 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1180 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1182 tmp = ((OP(c) == NBOUND ?
1183 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1184 LOAD_UTF8_CHARCLASS_ALNUM();
1185 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1186 if (tmp == !(OP(c) == NBOUND ?
1187 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1188 isALNUM_LC_utf8((U8*)s)))
1190 else if ((!reginfo || regtry(reginfo, s)))
1196 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1197 tmp = ((OP(c) == NBOUND ?
1198 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1199 while (s < strend) {
1201 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1203 else if ((!reginfo || regtry(reginfo, s)))
1208 if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, s)))
1213 LOAD_UTF8_CHARCLASS_ALNUM();
1214 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1215 if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1216 if (tmp && (!reginfo || regtry(reginfo, s)))
1227 while (s < strend) {
1229 if (tmp && (!reginfo || regtry(reginfo, s)))
1241 PL_reg_flags |= RF_tainted;
1243 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1244 if (isALNUM_LC_utf8((U8*)s)) {
1245 if (tmp && (!reginfo || regtry(reginfo, s)))
1256 while (s < strend) {
1257 if (isALNUM_LC(*s)) {
1258 if (tmp && (!reginfo || regtry(reginfo, s)))
1271 LOAD_UTF8_CHARCLASS_ALNUM();
1272 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1273 if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1274 if (tmp && (!reginfo || regtry(reginfo, s)))
1285 while (s < strend) {
1287 if (tmp && (!reginfo || regtry(reginfo, s)))
1299 PL_reg_flags |= RF_tainted;
1301 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1302 if (!isALNUM_LC_utf8((U8*)s)) {
1303 if (tmp && (!reginfo || regtry(reginfo, s)))
1314 while (s < strend) {
1315 if (!isALNUM_LC(*s)) {
1316 if (tmp && (!reginfo || regtry(reginfo, s)))
1329 LOAD_UTF8_CHARCLASS_SPACE();
1330 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1331 if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1332 if (tmp && (!reginfo || regtry(reginfo, s)))
1343 while (s < strend) {
1345 if (tmp && (!reginfo || regtry(reginfo, s)))
1357 PL_reg_flags |= RF_tainted;
1359 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1360 if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1361 if (tmp && (!reginfo || regtry(reginfo, s)))
1372 while (s < strend) {
1373 if (isSPACE_LC(*s)) {
1374 if (tmp && (!reginfo || regtry(reginfo, s)))
1387 LOAD_UTF8_CHARCLASS_SPACE();
1388 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1389 if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1390 if (tmp && (!reginfo || regtry(reginfo, s)))
1401 while (s < strend) {
1403 if (tmp && (!reginfo || regtry(reginfo, s)))
1415 PL_reg_flags |= RF_tainted;
1417 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1418 if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1419 if (tmp && (!reginfo || regtry(reginfo, s)))
1430 while (s < strend) {
1431 if (!isSPACE_LC(*s)) {
1432 if (tmp && (!reginfo || regtry(reginfo, s)))
1445 LOAD_UTF8_CHARCLASS_DIGIT();
1446 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1447 if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1448 if (tmp && (!reginfo || regtry(reginfo, s)))
1459 while (s < strend) {
1461 if (tmp && (!reginfo || regtry(reginfo, s)))
1473 PL_reg_flags |= RF_tainted;
1475 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1476 if (isDIGIT_LC_utf8((U8*)s)) {
1477 if (tmp && (!reginfo || regtry(reginfo, s)))
1488 while (s < strend) {
1489 if (isDIGIT_LC(*s)) {
1490 if (tmp && (!reginfo || regtry(reginfo, s)))
1503 LOAD_UTF8_CHARCLASS_DIGIT();
1504 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1505 if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1506 if (tmp && (!reginfo || regtry(reginfo, s)))
1517 while (s < strend) {
1519 if (tmp && (!reginfo || regtry(reginfo, s)))
1531 PL_reg_flags |= RF_tainted;
1533 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1534 if (!isDIGIT_LC_utf8((U8*)s)) {
1535 if (tmp && (!reginfo || regtry(reginfo, s)))
1546 while (s < strend) {
1547 if (!isDIGIT_LC(*s)) {
1548 if (tmp && (!reginfo || regtry(reginfo, s)))
1560 /*Perl_croak(aTHX_ "panic: unknown regstclass TRIE");*/
1562 const enum { trie_plain, trie_utf8, trie_utf8_fold }
1563 trie_type = do_utf8 ?
1564 (c->flags == EXACT ? trie_utf8 : trie_utf8_fold)
1566 /* what trie are we using right now */
1568 = (reg_ac_data*)prog->data->data[ ARG( c ) ];
1569 reg_trie_data *trie=aho->trie;
1571 const char *last_start = strend - trie->minlen;
1572 const char *real_start = s;
1573 STRLEN maxlen = trie->maxlen;
1575 U8 **points; /* map of where we were in the input string
1576 when reading a given string. For ASCII this
1577 is unnecessary overhead as the relationship
1578 is always 1:1, but for unicode, especially
1579 case folded unicode this is not true. */
1580 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1582 GET_RE_DEBUG_FLAGS_DECL;
1584 /* We can't just allocate points here. We need to wrap it in
1585 * an SV so it gets freed properly if there is a croak while
1586 * running the match */
1589 sv_points=newSV(maxlen * sizeof(U8 *));
1590 SvCUR_set(sv_points,
1591 maxlen * sizeof(U8 *));
1592 SvPOK_on(sv_points);
1593 sv_2mortal(sv_points);
1594 points=(U8**)SvPV_nolen(sv_points );
1596 if (trie->bitmap && trie_type != trie_utf8_fold) {
1597 while (s <= last_start && !TRIE_BITMAP_TEST(trie,*s) ) {
1602 while (s <= last_start) {
1603 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1611 U8 *uscan = (U8*)NULL;
1612 U8 *leftmost = NULL;
1616 while ( state && uc <= (U8*)strend ) {
1618 if (aho->states[ state ].wordnum) {
1619 U8 *lpos= points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1] ) % maxlen ];
1620 if (!leftmost || lpos < leftmost)
1624 points[pointpos++ % maxlen]= uc;
1625 switch (trie_type) {
1626 case trie_utf8_fold:
1628 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
1633 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
1634 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
1635 foldlen -= UNISKIP( uvc );
1636 uscan = foldbuf + UNISKIP( uvc );
1640 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
1649 charid = trie->charmap[ uvc ];
1653 if (trie->widecharmap) {
1654 SV** const svpp = hv_fetch(trie->widecharmap,
1655 (char*)&uvc, sizeof(UV), 0);
1657 charid = (U16)SvIV(*svpp);
1660 DEBUG_TRIE_EXECUTE_r(
1661 PerlIO_printf(Perl_debug_log,
1662 "Pos: %d Charid:%3x CV:%4"UVxf" ",
1663 (int)((const char*)uc - real_start), charid, uvc)
1668 U32 word = aho->states[ state ].wordnum;
1669 base = aho->states[ state ].trans.base;
1671 DEBUG_TRIE_EXECUTE_r(
1672 PerlIO_printf( Perl_debug_log,
1673 "%sState: %4"UVxf", Base: 0x%-4"UVxf" uvc=%"UVxf" word=%"UVxf"\n",
1674 failed ? "Fail transition to " : "",
1675 state, base, uvc, word)
1680 (base + charid > trie->uniquecharcount )
1681 && (base + charid - 1 - trie->uniquecharcount
1683 && trie->trans[base + charid - 1 -
1684 trie->uniquecharcount].check == state
1685 && (tmp=trie->trans[base + charid - 1 -
1686 trie->uniquecharcount ].next))
1696 state = aho->fail[state];
1700 /* we must be accepting here */
1708 else if (!charid && trie->bitmap && trie_type != trie_utf8_fold) {
1709 while ( uc <= (U8*)last_start && !TRIE_BITMAP_TEST(trie,*uc) ) {
1715 if ( aho->states[ state ].wordnum ) {
1716 U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1717 if (!leftmost || lpos < leftmost)
1720 DEBUG_TRIE_EXECUTE_r(
1721 PerlIO_printf( Perl_debug_log,
1722 "%sState: %4"UVxf", Base: 0x%-4"UVxf" uvc=%"UVxf"\n",
1727 s = (char*)leftmost;
1728 if (!reginfo || regtry(reginfo, s)) {
1743 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1752 - regexec_flags - match a regexp against a string
1755 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1756 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1757 /* strend: pointer to null at end of string */
1758 /* strbeg: real beginning of string */
1759 /* minend: end of match must be >=minend after stringarg. */
1760 /* data: May be used for some additional optimizations. */
1761 /* nosave: For optimizations. */
1765 register regnode *c;
1766 register char *startpos = stringarg;
1767 I32 minlen; /* must match at least this many chars */
1768 I32 dontbother = 0; /* how many characters not to try at end */
1769 I32 end_shift = 0; /* Same for the end. */ /* CC */
1770 I32 scream_pos = -1; /* Internal iterator of scream. */
1771 char *scream_olds = NULL;
1772 SV* const oreplsv = GvSV(PL_replgv);
1773 const bool do_utf8 = DO_UTF8(sv);
1779 regmatch_info reginfo; /* create some info to pass to regtry etc */
1781 GET_RE_DEBUG_FLAGS_DECL;
1783 PERL_UNUSED_ARG(data);
1785 /* Be paranoid... */
1786 if (prog == NULL || startpos == NULL) {
1787 Perl_croak(aTHX_ "NULL regexp parameter");
1791 multiline = prog->reganch & PMf_MULTILINE;
1792 reginfo.prog = prog;
1795 dsv0 = PERL_DEBUG_PAD_ZERO(0);
1796 dsv1 = PERL_DEBUG_PAD_ZERO(1);
1799 RX_MATCH_UTF8_set(prog, do_utf8);
1801 minlen = prog->minlen;
1802 if (strend - startpos < minlen) {
1803 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1804 "String too short [regexec_flags]...\n"));
1808 /* Check validity of program. */
1809 if (UCHARAT(prog->program) != REG_MAGIC) {
1810 Perl_croak(aTHX_ "corrupted regexp program");
1814 PL_reg_eval_set = 0;
1817 if (prog->reganch & ROPT_UTF8)
1818 PL_reg_flags |= RF_utf8;
1820 /* Mark beginning of line for ^ and lookbehind. */
1821 reginfo.bol = startpos; /* XXX not used ??? */
1825 /* Mark end of line for $ (and such) */
1828 /* see how far we have to get to not match where we matched before */
1829 reginfo.till = startpos+minend;
1831 /* If there is a "must appear" string, look for it. */
1834 if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to set reginfo->ganch */
1837 if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
1838 reginfo.ganch = startpos;
1839 else if (sv && SvTYPE(sv) >= SVt_PVMG
1841 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1842 && mg->mg_len >= 0) {
1843 reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
1844 if (prog->reganch & ROPT_ANCH_GPOS) {
1845 if (s > reginfo.ganch)
1850 else /* pos() not defined */
1851 reginfo.ganch = strbeg;
1854 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1855 re_scream_pos_data d;
1857 d.scream_olds = &scream_olds;
1858 d.scream_pos = &scream_pos;
1859 s = re_intuit_start(prog, sv, s, strend, flags, &d);
1861 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1862 goto phooey; /* not present */
1867 const char * const s0 = UTF
1868 ? pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
1871 const int len0 = UTF ? (int)SvCUR(dsv0) : prog->prelen;
1872 const char * const s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60,
1873 UNI_DISPLAY_REGEX) : startpos;
1874 const int len1 = do_utf8 ? (int)SvCUR(dsv1) : strend - startpos;
1877 PerlIO_printf(Perl_debug_log,
1878 "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n",
1879 PL_colors[4], PL_colors[5], PL_colors[0],
1882 len0 > 60 ? "..." : "",
1884 (int)(len1 > 60 ? 60 : len1),
1886 (len1 > 60 ? "..." : "")
1890 /* Simplest case: anchored match need be tried only once. */
1891 /* [unless only anchor is BOL and multiline is set] */
1892 if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1893 if (s == startpos && regtry(®info, startpos))
1895 else if (multiline || (prog->reganch & ROPT_IMPLICIT)
1896 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1901 dontbother = minlen - 1;
1902 end = HOP3c(strend, -dontbother, strbeg) - 1;
1903 /* for multiline we only have to try after newlines */
1904 if (prog->check_substr || prog->check_utf8) {
1908 if (regtry(®info, s))
1913 if (prog->reganch & RE_USE_INTUIT) {
1914 s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1925 if (*s++ == '\n') { /* don't need PL_utf8skip here */
1926 if (regtry(®info, s))
1933 } else if (prog->reganch & ROPT_ANCH_GPOS) {
1934 if (regtry(®info, reginfo.ganch))
1939 /* Messy cases: unanchored match. */
1940 if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1941 /* we have /x+whatever/ */
1942 /* it must be a one character string (XXXX Except UTF?) */
1947 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1948 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1949 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1952 while (s < strend) {
1954 DEBUG_EXECUTE_r( did_match = 1 );
1955 if (regtry(®info, s)) goto got_it;
1957 while (s < strend && *s == ch)
1964 while (s < strend) {
1966 DEBUG_EXECUTE_r( did_match = 1 );
1967 if (regtry(®info, s)) goto got_it;
1969 while (s < strend && *s == ch)
1975 DEBUG_EXECUTE_r(if (!did_match)
1976 PerlIO_printf(Perl_debug_log,
1977 "Did not find anchored character...\n")
1980 else if (prog->anchored_substr != NULL
1981 || prog->anchored_utf8 != NULL
1982 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1983 && prog->float_max_offset < strend - s)) {
1988 char *last1; /* Last position checked before */
1992 if (prog->anchored_substr || prog->anchored_utf8) {
1993 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1994 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1995 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1996 back_max = back_min = prog->anchored_offset;
1998 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1999 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2000 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
2001 back_max = prog->float_max_offset;
2002 back_min = prog->float_min_offset;
2004 if (must == &PL_sv_undef)
2005 /* could not downgrade utf8 check substring, so must fail */
2008 last = HOP3c(strend, /* Cannot start after this */
2009 -(I32)(CHR_SVLEN(must)
2010 - (SvTAIL(must) != 0) + back_min), strbeg);
2013 last1 = HOPc(s, -1);
2015 last1 = s - 1; /* bogus */
2017 /* XXXX check_substr already used to find "s", can optimize if
2018 check_substr==must. */
2020 dontbother = end_shift;
2021 strend = HOPc(strend, -dontbother);
2022 while ( (s <= last) &&
2023 ((flags & REXEC_SCREAM)
2024 ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
2025 end_shift, &scream_pos, 0))
2026 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
2027 (unsigned char*)strend, must,
2028 multiline ? FBMrf_MULTILINE : 0))) ) {
2029 /* we may be pointing at the wrong string */
2030 if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
2031 s = strbeg + (s - SvPVX_const(sv));
2032 DEBUG_EXECUTE_r( did_match = 1 );
2033 if (HOPc(s, -back_max) > last1) {
2034 last1 = HOPc(s, -back_min);
2035 s = HOPc(s, -back_max);
2038 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2040 last1 = HOPc(s, -back_min);
2044 while (s <= last1) {
2045 if (regtry(®info, s))
2051 while (s <= last1) {
2052 if (regtry(®info, s))
2058 DEBUG_EXECUTE_r(if (!did_match)
2059 PerlIO_printf(Perl_debug_log,
2060 "Did not find %s substr \"%s%.*s%s\"%s...\n",
2061 ((must == prog->anchored_substr || must == prog->anchored_utf8)
2062 ? "anchored" : "floating"),
2064 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
2066 PL_colors[1], (SvTAIL(must) ? "$" : ""))
2070 else if ((c = prog->regstclass)) {
2072 const OPCODE op = OP(prog->regstclass);
2073 /* don't bother with what can't match */
2074 if (PL_regkind[op] != EXACT && op != CANY && op != TRIE)
2075 strend = HOPc(strend, -(minlen - 1));
2078 SV * const prop = sv_newmortal();
2084 regprop(prog, prop, c);
2086 pv_uni_display(dsv0, (U8*)SvPVX_const(prop), SvCUR(prop), 60,
2087 UNI_DISPLAY_REGEX) :
2089 len0 = UTF ? SvCUR(dsv0) : SvCUR(prop);
2091 sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
2092 len1 = UTF ? (int)SvCUR(dsv1) : strend - s;
2093 PerlIO_printf(Perl_debug_log,
2094 "Matching stclass \"%*.*s\" against \"%*.*s\" (%d chars)\n",
2096 len1, len1, s1, (int)(strend - s));
2098 if (find_byclass(prog, c, s, strend, ®info))
2100 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2104 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2109 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2110 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2111 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2113 if (flags & REXEC_SCREAM) {
2114 last = screaminstr(sv, float_real, s - strbeg,
2115 end_shift, &scream_pos, 1); /* last one */
2117 last = scream_olds; /* Only one occurrence. */
2118 /* we may be pointing at the wrong string */
2119 else if (RX_MATCH_COPIED(prog))
2120 s = strbeg + (s - SvPVX_const(sv));
2124 const char * const little = SvPV_const(float_real, len);
2126 if (SvTAIL(float_real)) {
2127 if (memEQ(strend - len + 1, little, len - 1))
2128 last = strend - len + 1;
2129 else if (!multiline)
2130 last = memEQ(strend - len, little, len)
2131 ? strend - len : NULL;
2137 last = rninstr(s, strend, little, little + len);
2139 last = strend; /* matching "$" */
2143 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
2144 "%sCan't trim the tail, match fails (should not happen)%s\n",
2145 PL_colors[4], PL_colors[5]));
2146 goto phooey; /* Should not happen! */
2148 dontbother = strend - last + prog->float_min_offset;
2150 if (minlen && (dontbother < minlen))
2151 dontbother = minlen - 1;
2152 strend -= dontbother; /* this one's always in bytes! */
2153 /* We don't know much -- general case. */
2156 if (regtry(®info, s))
2165 if (regtry(®info, s))
2167 } while (s++ < strend);
2175 RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2177 if (PL_reg_eval_set) {
2178 /* Preserve the current value of $^R */
2179 if (oreplsv != GvSV(PL_replgv))
2180 sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2181 restored, the value remains
2183 restore_pos(aTHX_ prog);
2186 /* make sure $`, $&, $', and $digit will work later */
2187 if ( !(flags & REXEC_NOT_FIRST) ) {
2188 RX_MATCH_COPY_FREE(prog);
2189 if (flags & REXEC_COPY_STR) {
2190 const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2191 #ifdef PERL_OLD_COPY_ON_WRITE
2193 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2195 PerlIO_printf(Perl_debug_log,
2196 "Copy on write: regexp capture, type %d\n",
2199 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2200 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2201 assert (SvPOKp(prog->saved_copy));
2205 RX_MATCH_COPIED_on(prog);
2206 s = savepvn(strbeg, i);
2212 prog->subbeg = strbeg;
2213 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2220 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2221 PL_colors[4], PL_colors[5]));
2222 if (PL_reg_eval_set)
2223 restore_pos(aTHX_ prog);
2228 - regtry - try match at specific point
2230 STATIC I32 /* 0 failure, 1 success */
2231 S_regtry(pTHX_ const regmatch_info *reginfo, char *startpos)
2237 regexp *prog = reginfo->prog;
2238 GET_RE_DEBUG_FLAGS_DECL;
2241 PL_regindent = 0; /* XXXX Not good when matches are reenterable... */
2243 if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2246 PL_reg_eval_set = RS_init;
2247 DEBUG_EXECUTE_r(DEBUG_s(
2248 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2249 (IV)(PL_stack_sp - PL_stack_base));
2251 SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2252 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2253 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2255 /* Apparently this is not needed, judging by wantarray. */
2256 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2257 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2260 /* Make $_ available to executed code. */
2261 if (reginfo->sv != DEFSV) {
2263 DEFSV = reginfo->sv;
2266 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2267 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2268 /* prepare for quick setting of pos */
2269 #ifdef PERL_OLD_COPY_ON_WRITE
2271 sv_force_normal_flags(sv, 0);
2273 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2274 &PL_vtbl_mglob, NULL, 0);
2278 PL_reg_oldpos = mg->mg_len;
2279 SAVEDESTRUCTOR_X(restore_pos, prog);
2281 if (!PL_reg_curpm) {
2282 Newxz(PL_reg_curpm, 1, PMOP);
2285 SV* const repointer = newSViv(0);
2286 /* so we know which PL_regex_padav element is PL_reg_curpm */
2287 SvFLAGS(repointer) |= SVf_BREAK;
2288 av_push(PL_regex_padav,repointer);
2289 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2290 PL_regex_pad = AvARRAY(PL_regex_padav);
2294 PM_SETRE(PL_reg_curpm, prog);
2295 PL_reg_oldcurpm = PL_curpm;
2296 PL_curpm = PL_reg_curpm;
2297 if (RX_MATCH_COPIED(prog)) {
2298 /* Here is a serious problem: we cannot rewrite subbeg,
2299 since it may be needed if this match fails. Thus
2300 $` inside (?{}) could fail... */
2301 PL_reg_oldsaved = prog->subbeg;
2302 PL_reg_oldsavedlen = prog->sublen;
2303 #ifdef PERL_OLD_COPY_ON_WRITE
2304 PL_nrs = prog->saved_copy;
2306 RX_MATCH_COPIED_off(prog);
2309 PL_reg_oldsaved = NULL;
2310 prog->subbeg = PL_bostr;
2311 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2313 prog->startp[0] = startpos - PL_bostr;
2314 PL_reginput = startpos;
2315 PL_regstartp = prog->startp;
2316 PL_regendp = prog->endp;
2317 PL_reglastparen = &prog->lastparen;
2318 PL_reglastcloseparen = &prog->lastcloseparen;
2319 prog->lastparen = 0;
2320 prog->lastcloseparen = 0;
2322 DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
2323 if (PL_reg_start_tmpl <= prog->nparens) {
2324 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2325 if(PL_reg_start_tmp)
2326 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2328 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2331 /* XXXX What this code is doing here?!!! There should be no need
2332 to do this again and again, PL_reglastparen should take care of
2335 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2336 * Actually, the code in regcppop() (which Ilya may be meaning by
2337 * PL_reglastparen), is not needed at all by the test suite
2338 * (op/regexp, op/pat, op/split), but that code is needed, oddly
2339 * enough, for building DynaLoader, or otherwise this
2340 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2341 * will happen. Meanwhile, this code *is* needed for the
2342 * above-mentioned test suite tests to succeed. The common theme
2343 * on those tests seems to be returning null fields from matches.
2348 if (prog->nparens) {
2350 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2357 if (regmatch(reginfo, prog->program + 1)) {
2358 prog->endp[0] = PL_reginput - PL_bostr;
2361 REGCP_UNWIND(lastcp);
2366 #define sayYES goto yes
2367 #define sayNO goto no
2368 #define sayNO_ANYOF goto no_anyof
2369 #define sayYES_FINAL goto yes_final
2370 #define sayNO_FINAL goto no_final
2371 #define sayNO_SILENT goto do_no
2372 #define saySAME(x) if (x) goto yes; else goto no
2374 #define POSCACHE_SUCCESS 0 /* caching success rather than failure */
2375 #define POSCACHE_SEEN 1 /* we know what we're caching */
2376 #define POSCACHE_START 2 /* the real cache: this bit maps to pos 0 */
2378 #define CACHEsayYES STMT_START { \
2379 if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2380 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2381 PL_reg_poscache[0] |= (1<<POSCACHE_SUCCESS) | (1<<POSCACHE_SEEN); \
2382 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2384 else if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS)) { \
2385 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2388 /* cache records failure, but this is success */ \
2390 PerlIO_printf(Perl_debug_log, \
2391 "%*s (remove success from failure cache)\n", \
2392 REPORT_CODE_OFF+PL_regindent*2, "") \
2394 PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2400 #define CACHEsayNO STMT_START { \
2401 if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2402 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2403 PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2404 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2406 else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2407 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2410 /* cache records success, but this is failure */ \
2412 PerlIO_printf(Perl_debug_log, \
2413 "%*s (remove failure from success cache)\n", \
2414 REPORT_CODE_OFF+PL_regindent*2, "") \
2416 PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2422 /* this is used to determine how far from the left messages like
2423 'failed...' are printed. Currently 29 makes these messages line
2424 up with the opcode they refer to. Earlier perls used 25 which
2425 left these messages outdented making reviewing a debug output
2428 #define REPORT_CODE_OFF 29
2431 /* Make sure there is a test for this +1 options in re_tests */
2432 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2434 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2435 #define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
2437 #define SLAB_FIRST(s) (&(s)->states[0])
2438 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2440 /* grab a new slab and return the first slot in it */
2442 STATIC regmatch_state *
2445 #if PERL_VERSION < 9
2448 regmatch_slab *s = PL_regmatch_slab->next;
2450 Newx(s, 1, regmatch_slab);
2451 s->prev = PL_regmatch_slab;
2453 PL_regmatch_slab->next = s;
2455 PL_regmatch_slab = s;
2456 return SLAB_FIRST(s);
2459 /* simulate a recursive call to regmatch */
2461 #define REGMATCH(ns, where) \
2464 st->resume_state = resume_##where; \
2465 goto start_recurse; \
2466 resume_point_##where:
2468 /* push a new state then goto it */
2470 #define PUSH_STATE_GOTO(state, node) \
2472 st->resume_state = state; \
2475 /* push a new state with success backtracking, then goto it */
2477 #define PUSH_YES_STATE_GOTO(state, node) \
2479 st->resume_state = state; \
2480 goto push_yes_state;
2485 - regmatch - main matching routine
2487 * Conceptually the strategy is simple: check to see whether the current
2488 * node matches, call self recursively to see whether the rest matches,
2489 * and then act accordingly. In practice we make some effort to avoid
2490 * recursion, in particular by going through "ordinary" nodes (that don't
2491 * need to know whether the rest of the match failed) by a loop instead of
2494 /* [lwall] I've hoisted the register declarations to the outer block in order to
2495 * maybe save a little bit of pushing and popping on the stack. It also takes
2496 * advantage of machines that use a register save mask on subroutine entry.
2498 * This function used to be heavily recursive, but since this had the
2499 * effect of blowing the CPU stack on complex regexes, it has been
2500 * restructured to be iterative, and to save state onto the heap rather
2501 * than the stack. Essentially whereever regmatch() used to be called, it
2502 * pushes the current state, notes where to return, then jumps back into
2505 * Originally the structure of this function used to look something like
2510 while (scan != NULL) {
2511 a++; // do stuff with a and b
2517 if (regmatch(...)) // recurse
2527 * Now it looks something like this:
2535 regmatch_state *st = new();
2537 st->a++; // do stuff with a and b
2539 while (scan != NULL) {
2547 st->resume_state = resume_FOO;
2548 goto start_recurse; // recurse
2557 st = new(); push a new state
2558 st->a = 1; st->b = 2;
2565 switch (resume_state) {
2567 goto resume_point_FOO;
2574 * WARNING: this means that any line in this function that contains a
2575 * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2576 * regmatch() using gotos instead. Thus the values of any local variables
2577 * not saved in the regmatch_state structure will have been lost when
2578 * execution resumes on the next line .
2580 * States (ie the st pointer) are allocated in slabs of about 4K in size.
2581 * PL_regmatch_state always points to the currently active state, and
2582 * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2583 * The first time regmatch is called, the first slab is allocated, and is
2584 * never freed until interpreter desctruction. When the slab is full,
2585 * a new one is allocated chained to the end. At exit from regmatch, slabs
2586 * allocated since entry are freed.
2589 /* *** every FOO_fail should = FOO+1 */
2590 #define TRIE_next (REGNODE_MAX+1)
2591 #define TRIE_next_fail (REGNODE_MAX+2)
2592 #define EVAL_A (REGNODE_MAX+3)
2593 #define EVAL_A_fail (REGNODE_MAX+4)
2594 #define resume_CURLYX (REGNODE_MAX+5)
2595 #define resume_WHILEM1 (REGNODE_MAX+6)
2596 #define resume_WHILEM2 (REGNODE_MAX+7)
2597 #define resume_WHILEM3 (REGNODE_MAX+8)
2598 #define resume_WHILEM4 (REGNODE_MAX+9)
2599 #define resume_WHILEM5 (REGNODE_MAX+10)
2600 #define resume_WHILEM6 (REGNODE_MAX+11)
2601 #define BRANCH_next (REGNODE_MAX+12)
2602 #define BRANCH_next_fail (REGNODE_MAX+13)
2603 #define CURLYM_A (REGNODE_MAX+14)
2604 #define CURLYM_A_fail (REGNODE_MAX+15)
2605 #define CURLYM_B (REGNODE_MAX+16)
2606 #define CURLYM_B_fail (REGNODE_MAX+17)
2607 #define IFMATCH_A (REGNODE_MAX+18)
2608 #define IFMATCH_A_fail (REGNODE_MAX+19)
2609 #define CURLY_B_min_known (REGNODE_MAX+20)
2610 #define CURLY_B_min_known_fail (REGNODE_MAX+21)
2611 #define CURLY_B_min (REGNODE_MAX+22)
2612 #define CURLY_B_min_fail (REGNODE_MAX+23)
2613 #define CURLY_B_max (REGNODE_MAX+24)
2614 #define CURLY_B_max_fail (REGNODE_MAX+25)
2617 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2621 S_dump_exec_pos(pTHX_ const char *locinput, const regnode *scan, const bool do_utf8)
2623 const int docolor = *PL_colors[0];
2624 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2625 int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2626 /* The part of the string before starttry has one color
2627 (pref0_len chars), between starttry and current
2628 position another one (pref_len - pref0_len chars),
2629 after the current position the third one.
2630 We assume that pref0_len <= pref_len, otherwise we
2631 decrease pref0_len. */
2632 int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2633 ? (5 + taill) - l : locinput - PL_bostr;
2636 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2638 pref0_len = pref_len - (locinput - PL_reg_starttry);
2639 if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2640 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2641 ? (5 + taill) - pref_len : PL_regeol - locinput);
2642 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2646 if (pref0_len > pref_len)
2647 pref0_len = pref_len;
2649 const char * const s0 =
2650 do_utf8 && OP(scan) != CANY ?
2651 pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
2652 pref0_len, 60, UNI_DISPLAY_REGEX) :
2653 locinput - pref_len;
2654 const int len0 = do_utf8 ? (int)strlen(s0) : pref0_len;
2655 const char * const s1 = do_utf8 && OP(scan) != CANY ?
2656 pv_uni_display(PERL_DEBUG_PAD(1),
2657 (U8*)(locinput - pref_len + pref0_len),
2658 pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2659 locinput - pref_len + pref0_len;
2660 const int len1 = do_utf8 ? (int)strlen(s1) : pref_len - pref0_len;
2661 const char * const s2 = do_utf8 && OP(scan) != CANY ?
2662 pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
2663 PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2665 const int len2 = do_utf8 ? (int)strlen(s2) : l;
2666 PerlIO_printf(Perl_debug_log,
2667 "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|",
2668 (IV)(locinput - PL_bostr),
2675 (docolor ? "" : "> <"),
2679 15 - l - pref_len + 1,
2685 STATIC I32 /* 0 failure, 1 success */
2686 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2688 #if PERL_VERSION < 9
2692 register const bool do_utf8 = PL_reg_match_utf8;
2693 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2695 regexp *rex = reginfo->prog;
2697 regmatch_slab *orig_slab;
2698 regmatch_state *orig_state;
2700 /* the current state. This is a cached copy of PL_regmatch_state */
2701 register regmatch_state *st;
2703 /* cache heavy used fields of st in registers */
2704 register regnode *scan;
2705 register regnode *next;
2706 register I32 n = 0; /* initialize to shut up compiler warning */
2707 register char *locinput = PL_reginput;
2709 /* these variables are NOT saved during a recusive RFEGMATCH: */
2710 register I32 nextchr; /* is always set to UCHARAT(locinput) */
2711 bool result; /* return value of S_regmatch */
2712 int depth = 0; /* depth of recursion */
2713 regmatch_state *yes_state = NULL; /* state to pop to on success of
2718 GET_RE_DEBUG_FLAGS_DECL;
2722 /* on first ever call to regmatch, allocate first slab */
2723 if (!PL_regmatch_slab) {
2724 Newx(PL_regmatch_slab, 1, regmatch_slab);
2725 PL_regmatch_slab->prev = NULL;
2726 PL_regmatch_slab->next = NULL;
2727 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2730 /* remember current high-water mark for exit */
2731 /* XXX this should be done with SAVE* instead */
2732 orig_slab = PL_regmatch_slab;
2733 orig_state = PL_regmatch_state;
2735 /* grab next free state slot */
2736 st = ++PL_regmatch_state;
2737 if (st > SLAB_LAST(PL_regmatch_slab))
2738 st = PL_regmatch_state = S_push_slab(aTHX);
2744 /* Note that nextchr is a byte even in UTF */
2745 nextchr = UCHARAT(locinput);
2747 while (scan != NULL) {
2750 SV * const prop = sv_newmortal();
2751 dump_exec_pos( locinput, scan, do_utf8 );
2752 regprop(rex, prop, scan);
2754 PerlIO_printf(Perl_debug_log,
2755 "%3"IVdf":%*s%s(%"IVdf")\n",
2756 (IV)(scan - rex->program), PL_regindent*2, "",
2758 PL_regkind[OP(scan)] == END ? 0 : (IV)(regnext(scan) - rex->program));
2761 next = scan + NEXT_OFF(scan);
2764 state_num = OP(scan);
2767 switch (state_num) {
2769 if (locinput == PL_bostr)
2771 /* reginfo->till = reginfo->bol; */
2776 if (locinput == PL_bostr ||
2777 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2783 if (locinput == PL_bostr)
2787 if (locinput == reginfo->ganch)
2793 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2798 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2800 if (PL_regeol - locinput > 1)
2804 if (PL_regeol != locinput)
2808 if (!nextchr && locinput >= PL_regeol)
2811 locinput += PL_utf8skip[nextchr];
2812 if (locinput > PL_regeol)
2814 nextchr = UCHARAT(locinput);
2817 nextchr = UCHARAT(++locinput);
2820 if (!nextchr && locinput >= PL_regeol)
2822 nextchr = UCHARAT(++locinput);
2825 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2828 locinput += PL_utf8skip[nextchr];
2829 if (locinput > PL_regeol)
2831 nextchr = UCHARAT(locinput);
2834 nextchr = UCHARAT(++locinput);
2838 #define ST st->u.trie
2842 /* what type of TRIE am I? (utf8 makes this contextual) */
2843 const enum { trie_plain, trie_utf8, trie_utf8_fold }
2844 trie_type = do_utf8 ?
2845 (scan->flags == EXACT ? trie_utf8 : trie_utf8_fold)
2848 /* what trie are we using right now */
2849 reg_trie_data * const trie
2850 = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2851 U32 state = trie->startstate;
2853 U8 *uc = ( U8* )locinput;
2859 U8 *uscan = (U8*)NULL;
2861 SV *sv_accept_buff = NULL;
2862 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2864 ST.accepted = 0; /* how many accepting states we have seen */
2870 if (trie->bitmap && trie_type != trie_utf8_fold &&
2871 !TRIE_BITMAP_TEST(trie,*locinput)
2873 if (trie->states[ state ].wordnum) {
2875 PerlIO_printf(Perl_debug_log,
2876 "%*s %smatched empty string...%s\n",
2877 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2882 PerlIO_printf(Perl_debug_log,
2883 "%*s %sfailed to match start class...%s\n",
2884 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
2891 traverse the TRIE keeping track of all accepting states
2892 we transition through until we get to a failing node.
2895 while ( state && uc <= (U8*)PL_regeol ) {
2897 if (trie->states[ state ].wordnum) {
2898 if (!ST.accepted ) {
2901 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2902 sv_accept_buff=newSV(bufflen *
2903 sizeof(reg_trie_accepted) - 1);
2904 SvCUR_set(sv_accept_buff,
2905 sizeof(reg_trie_accepted));
2906 SvPOK_on(sv_accept_buff);
2907 sv_2mortal(sv_accept_buff);
2910 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2913 if (ST.accepted >= bufflen) {
2915 ST.accept_buff =(reg_trie_accepted*)
2916 SvGROW(sv_accept_buff,
2917 bufflen * sizeof(reg_trie_accepted));
2919 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2920 + sizeof(reg_trie_accepted));
2922 ST.accept_buff[ST.accepted].wordnum = trie->states[state].wordnum;
2923 ST.accept_buff[ST.accepted].endpos = uc;
2927 base = trie->states[ state ].trans.base;
2929 DEBUG_TRIE_EXECUTE_r({
2930 dump_exec_pos( (char *)uc, scan, do_utf8 );
2931 PerlIO_printf( Perl_debug_log,
2932 "%*s %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2933 2+PL_regindent * 2, "", PL_colors[4],
2934 (UV)state, (UV)base, (UV)ST.accepted );
2938 switch (trie_type) {
2939 case trie_utf8_fold:
2941 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2946 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2947 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2948 foldlen -= UNISKIP( uvc );
2949 uscan = foldbuf + UNISKIP( uvc );
2953 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
2962 charid = trie->charmap[ uvc ];
2966 if (trie->widecharmap) {
2967 SV** const svpp = hv_fetch(trie->widecharmap,
2968 (char*)&uvc, sizeof(UV), 0);
2970 charid = (U16)SvIV(*svpp);
2975 (base + charid > trie->uniquecharcount )
2976 && (base + charid - 1 - trie->uniquecharcount
2978 && trie->trans[base + charid - 1 -
2979 trie->uniquecharcount].check == state)
2981 state = trie->trans[base + charid - 1 -
2982 trie->uniquecharcount ].next;
2993 DEBUG_TRIE_EXECUTE_r(
2994 PerlIO_printf( Perl_debug_log,
2995 "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
2996 charid, uvc, (UV)state, PL_colors[5] );
3003 PerlIO_printf( Perl_debug_log,
3004 "%*s %sgot %"IVdf" possible matches%s\n",
3005 REPORT_CODE_OFF + PL_regindent * 2, "",
3006 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3012 case TRIE_next_fail: /* we failed - try next alterative */
3014 if ( ST.accepted == 1 ) {
3015 /* only one choice left - just continue */
3017 reg_trie_data * const trie
3018 = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
3019 SV ** const tmp = RX_DEBUG(reginfo->prog)
3020 ? av_fetch( trie->words, ST.accept_buff[ 0 ].wordnum-1, 0 )
3022 PerlIO_printf( Perl_debug_log,
3023 "%*s %sonly one match left: #%d <%s>%s\n",
3024 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
3025 ST.accept_buff[ 0 ].wordnum,
3026 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
3029 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3030 /* in this case we free tmps/leave before we call regmatch
3031 as we wont be using accept_buff again. */
3034 locinput = PL_reginput;
3035 nextchr = UCHARAT(locinput);
3037 continue; /* execute rest of RE */
3040 if (!ST.accepted-- ) {
3047 There are at least two accepting states left. Presumably
3048 the number of accepting states is going to be low,
3049 typically two. So we simply scan through to find the one
3050 with lowest wordnum. Once we find it, we swap the last
3051 state into its place and decrement the size. We then try to
3052 match the rest of the pattern at the point where the word
3053 ends. If we succeed, control just continues along the
3054 regex; if we fail we return here to try the next accepting
3061 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3062 DEBUG_TRIE_EXECUTE_r(
3063 PerlIO_printf( Perl_debug_log,
3064 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3065 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
3066 (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3067 ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3070 if (ST.accept_buff[cur].wordnum <
3071 ST.accept_buff[best].wordnum)
3076 reg_trie_data * const trie
3077 = (reg_trie_data*)rex->data->data[ ARG(ST.me) ];
3078 SV ** const tmp = RX_DEBUG(reginfo->prog)
3079 ? av_fetch( trie->words, ST.accept_buff[ best ].wordnum - 1, 0 )
3081 PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at node #%d %s\n",
3082 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
3083 ST.accept_buff[best].wordnum,
3084 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr", REG_NODE_NUM(scan),
3088 if ( best<ST.accepted ) {
3089 reg_trie_accepted tmp = ST.accept_buff[ best ];
3090 ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3091 ST.accept_buff[ ST.accepted ] = tmp;
3094 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3096 PUSH_STATE_GOTO(TRIE_next, ST.B);
3102 char *s = STRING(scan);
3103 st->ln = STR_LEN(scan);
3104 if (do_utf8 != UTF) {
3105 /* The target and the pattern have differing utf8ness. */
3107 const char * const e = s + st->ln;
3110 /* The target is utf8, the pattern is not utf8. */
3115 if (NATIVE_TO_UNI(*(U8*)s) !=
3116 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3124 /* The target is not utf8, the pattern is utf8. */
3129 if (NATIVE_TO_UNI(*((U8*)l)) !=
3130 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3138 nextchr = UCHARAT(locinput);
3141 /* The target and the pattern have the same utf8ness. */
3142 /* Inline the first character, for speed. */
3143 if (UCHARAT(s) != nextchr)
3145 if (PL_regeol - locinput < st->ln)
3147 if (st->ln > 1 && memNE(s, locinput, st->ln))
3150 nextchr = UCHARAT(locinput);
3154 PL_reg_flags |= RF_tainted;
3157 char * const s = STRING(scan);
3158 st->ln = STR_LEN(scan);
3160 if (do_utf8 || UTF) {
3161 /* Either target or the pattern are utf8. */
3162 const char * const l = locinput;
3163 char *e = PL_regeol;
3165 if (ibcmp_utf8(s, 0, st->ln, (bool)UTF,
3166 l, &e, 0, do_utf8)) {
3167 /* One more case for the sharp s:
3168 * pack("U0U*", 0xDF) =~ /ss/i,
3169 * the 0xC3 0x9F are the UTF-8
3170 * byte sequence for the U+00DF. */
3172 toLOWER(s[0]) == 's' &&
3174 toLOWER(s[1]) == 's' &&
3181 nextchr = UCHARAT(locinput);
3185 /* Neither the target and the pattern are utf8. */
3187 /* Inline the first character, for speed. */
3188 if (UCHARAT(s) != nextchr &&
3189 UCHARAT(s) != ((OP(scan) == EXACTF)
3190 ? PL_fold : PL_fold_locale)[nextchr])
3192 if (PL_regeol - locinput < st->ln)
3194 if (st->ln > 1 && (OP(scan) == EXACTF
3195 ? ibcmp(s, locinput, st->ln)
3196 : ibcmp_locale(s, locinput, st->ln)))
3199 nextchr = UCHARAT(locinput);
3204 STRLEN inclasslen = PL_regeol - locinput;
3206 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3208 if (locinput >= PL_regeol)
3210 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3211 nextchr = UCHARAT(locinput);
3216 nextchr = UCHARAT(locinput);
3217 if (!REGINCLASS(rex, scan, (U8*)locinput))
3219 if (!nextchr && locinput >= PL_regeol)
3221 nextchr = UCHARAT(++locinput);
3225 /* If we might have the case of the German sharp s
3226 * in a casefolding Unicode character class. */
3228 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3229 locinput += SHARP_S_SKIP;
3230 nextchr = UCHARAT(locinput);
3236 PL_reg_flags |= RF_tainted;
3242 LOAD_UTF8_CHARCLASS_ALNUM();
3243 if (!(OP(scan) == ALNUM
3244 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3245 : isALNUM_LC_utf8((U8*)locinput)))
3249 locinput += PL_utf8skip[nextchr];
3250 nextchr = UCHARAT(locinput);
3253 if (!(OP(scan) == ALNUM
3254 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3256 nextchr = UCHARAT(++locinput);
3259 PL_reg_flags |= RF_tainted;
3262 if (!nextchr && locinput >= PL_regeol)
3265 LOAD_UTF8_CHARCLASS_ALNUM();
3266 if (OP(scan) == NALNUM
3267 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3268 : isALNUM_LC_utf8((U8*)locinput))
3272 locinput += PL_utf8skip[nextchr];
3273 nextchr = UCHARAT(locinput);
3276 if (OP(scan) == NALNUM
3277 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3279 nextchr = UCHARAT(++locinput);
3283 PL_reg_flags |= RF_tainted;
3287 /* was last char in word? */
3289 if (locinput == PL_bostr)
3292 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3294 st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3296 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3297 st->ln = isALNUM_uni(st->ln);
3298 LOAD_UTF8_CHARCLASS_ALNUM();
3299 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3302 st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3303 n = isALNUM_LC_utf8((U8*)locinput);
3307 st->ln = (locinput != PL_bostr) ?
3308 UCHARAT(locinput - 1) : '\n';
3309 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3310 st->ln = isALNUM(st->ln);
3311 n = isALNUM(nextchr);
3314 st->ln = isALNUM_LC(st->ln);
3315 n = isALNUM_LC(nextchr);
3318 if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3319 OP(scan) == BOUNDL))
3323 PL_reg_flags |= RF_tainted;
3329 if (UTF8_IS_CONTINUED(nextchr)) {
3330 LOAD_UTF8_CHARCLASS_SPACE();
3331 if (!(OP(scan) == SPACE
3332 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3333 : isSPACE_LC_utf8((U8*)locinput)))
3337 locinput += PL_utf8skip[nextchr];
3338 nextchr = UCHARAT(locinput);
3341 if (!(OP(scan) == SPACE
3342 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3344 nextchr = UCHARAT(++locinput);
3347 if (!(OP(scan) == SPACE
3348 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3350 nextchr = UCHARAT(++locinput);
3354 PL_reg_flags |= RF_tainted;
3357 if (!nextchr && locinput >= PL_regeol)
3360 LOAD_UTF8_CHARCLASS_SPACE();
3361 if (OP(scan) == NSPACE
3362 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3363 : isSPACE_LC_utf8((U8*)locinput))
3367 locinput += PL_utf8skip[nextchr];
3368 nextchr = UCHARAT(locinput);
3371 if (OP(scan) == NSPACE
3372 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3374 nextchr = UCHARAT(++locinput);
3377 PL_reg_flags |= RF_tainted;
3383 LOAD_UTF8_CHARCLASS_DIGIT();
3384 if (!(OP(scan) == DIGIT
3385 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3386 : isDIGIT_LC_utf8((U8*)locinput)))
3390 locinput += PL_utf8skip[nextchr];
3391 nextchr = UCHARAT(locinput);
3394 if (!(OP(scan) == DIGIT
3395 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3397 nextchr = UCHARAT(++locinput);
3400 PL_reg_flags |= RF_tainted;
3403 if (!nextchr && locinput >= PL_regeol)
3406 LOAD_UTF8_CHARCLASS_DIGIT();
3407 if (OP(scan) == NDIGIT
3408 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3409 : isDIGIT_LC_utf8((U8*)locinput))
3413 locinput += PL_utf8skip[nextchr];
3414 nextchr = UCHARAT(locinput);
3417 if (OP(scan) == NDIGIT
3418 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3420 nextchr = UCHARAT(++locinput);
3423 if (locinput >= PL_regeol)
3426 LOAD_UTF8_CHARCLASS_MARK();
3427 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3429 locinput += PL_utf8skip[nextchr];
3430 while (locinput < PL_regeol &&
3431 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3432 locinput += UTF8SKIP(locinput);
3433 if (locinput > PL_regeol)
3438 nextchr = UCHARAT(locinput);
3441 PL_reg_flags |= RF_tainted;
3446 n = ARG(scan); /* which paren pair */
3447 st->ln = PL_regstartp[n];
3448 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3449 if ((I32)*PL_reglastparen < n || st->ln == -1)
3450 sayNO; /* Do not match unless seen CLOSEn. */
3451 if (st->ln == PL_regendp[n])
3454 s = PL_bostr + st->ln;
3455 if (do_utf8 && OP(scan) != REF) { /* REF can do byte comparison */
3457 const char *e = PL_bostr + PL_regendp[n];
3459 * Note that we can't do the "other character" lookup trick as
3460 * in the 8-bit case (no pun intended) because in Unicode we
3461 * have to map both upper and title case to lower case.
3463 if (OP(scan) == REFF) {
3465 STRLEN ulen1, ulen2;
3466 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3467 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3471 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3472 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3473 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3480 nextchr = UCHARAT(locinput);
3484 /* Inline the first character, for speed. */
3485 if (UCHARAT(s) != nextchr &&
3487 (UCHARAT(s) != ((OP(scan) == REFF
3488 ? PL_fold : PL_fold_locale)[nextchr]))))
3490 st->ln = PL_regendp[n] - st->ln;
3491 if (locinput + st->ln > PL_regeol)
3493 if (st->ln > 1 && (OP(scan) == REF
3494 ? memNE(s, locinput, st->ln)
3496 ? ibcmp(s, locinput, st->ln)
3497 : ibcmp_locale(s, locinput, st->ln))))
3500 nextchr = UCHARAT(locinput);
3511 #define ST st->u.eval
3513 case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
3517 /* execute the code in the {...} */
3519 SV ** const before = SP;
3520 OP_4tree * const oop = PL_op;
3521 COP * const ocurcop = PL_curcop;
3525 PL_op = (OP_4tree*)rex->data->data[n];
3526 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3527 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3528 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3530 CALLRUNOPS(aTHX); /* Scalar context. */
3533 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
3540 PAD_RESTORE_LOCAL(old_comppad);
3541 PL_curcop = ocurcop;
3544 sv_setsv(save_scalar(PL_replgv), ret);
3548 if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3551 /* extract RE object from returned value; compiling if
3556 if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3557 mg = mg_find(sv, PERL_MAGIC_qr);
3558 else if (SvSMAGICAL(ret)) {
3559 if (SvGMAGICAL(ret))
3560 sv_unmagic(ret, PERL_MAGIC_qr);
3562 mg = mg_find(ret, PERL_MAGIC_qr);
3566 re = (regexp *)mg->mg_obj;
3567 (void)ReREFCNT_inc(re);
3571 const char * const t = SvPV_const(ret, len);
3573 const I32 osize = PL_regsize;
3576 if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3577 re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3579 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3581 sv_magic(ret,(SV*)ReREFCNT_inc(re),
3587 /* run the pattern returned from (??{...}) */
3590 PerlIO_printf(Perl_debug_log,
3591 "Entering embedded \"%s%.60s%s%s\"\n",
3595 (strlen(re->precomp) > 60 ? "..." : ""))
3598 ST.cp = regcppush(0); /* Save *all* the positions. */
3599 REGCP_SET(ST.lastcp);
3600 *PL_reglastparen = 0;
3601 *PL_reglastcloseparen = 0;
3602 PL_reginput = locinput;
3604 /* XXXX This is too dramatic a measure... */
3608 ST.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3609 ((re->reganch & ROPT_UTF8) != 0);
3610 if (ST.toggleutf) PL_reg_flags ^= RF_utf8;
3615 /* now continue from first node in postoned RE */
3616 PUSH_YES_STATE_GOTO(EVAL_A, re->program + 1);
3619 /* /(?(?{...})X|Y)/ */
3620 st->sw = SvTRUE(ret);
3625 case EVAL_A: /* successfully ran inner rex (??{rex}) */
3627 PL_reg_flags ^= RF_utf8;
3630 /* XXXX This is too dramatic a measure... */
3632 /* Restore parens of the caller without popping the
3635 const I32 tmp = PL_savestack_ix;
3636 PL_savestack_ix = ST.lastcp;
3638 PL_savestack_ix = tmp;
3640 PL_reginput = locinput;
3641 /* continue at the node following the (??{...}) */
3645 case EVAL_A_fail: /* unsuccessfully ran inner rex (??{rex}) */
3646 /* Restore state to the outer re then re-throw the failure */
3648 PL_reg_flags ^= RF_utf8;
3652 /* XXXX This is too dramatic a measure... */
3655 PL_reginput = locinput;
3656 REGCP_UNWIND(ST.lastcp);
3663 n = ARG(scan); /* which paren pair */
3664 PL_reg_start_tmp[n] = locinput;
3669 n = ARG(scan); /* which paren pair */
3670 PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3671 PL_regendp[n] = locinput - PL_bostr;
3672 if (n > (I32)*PL_reglastparen)
3673 *PL_reglastparen = n;
3674 *PL_reglastcloseparen = n;
3677 n = ARG(scan); /* which paren pair */
3678 st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3681 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3683 next = NEXTOPER(NEXTOPER(scan));
3685 next = scan + ARG(scan);
3686 if (OP(next) == IFTHEN) /* Fake one. */
3687 next = NEXTOPER(NEXTOPER(next));
3691 st->logical = scan->flags;
3693 /*******************************************************************
3694 cc points to the regmatch_state associated with the most recent CURLYX.
3695 This struct contains info about the innermost (...)* loop (an
3696 "infoblock"), and a pointer to the next outer cc.
3698 Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3700 1) After matching Y, regnode for CURLYX is processed;
3702 2) This regnode populates cc, and calls regmatch() recursively
3703 with the starting point at WHILEM node;
3705 3) Each hit of WHILEM node tries to match A and Z (in the order
3706 depending on the current iteration, min/max of {min,max} and
3707 greediness). The information about where are nodes for "A"
3708 and "Z" is read from cc, as is info on how many times "A"
3709 was already matched, and greediness.
3711 4) After A matches, the same WHILEM node is hit again.
3713 5) Each time WHILEM is hit, cc is the infoblock created by CURLYX
3714 of the same pair. Thus when WHILEM tries to match Z, it temporarily
3715 resets cc, since this Y(A)*Z can be a part of some other loop:
3716 as in (Y(A)*Z)*. If Z matches, the automaton will hit the WHILEM node
3717 of the external loop.
3719 Currently present infoblocks form a tree with a stem formed by st->cc
3720 and whatever it mentions via ->next, and additional attached trees
3721 corresponding to temporarily unset infoblocks as in "5" above.
3723 In the following picture, infoblocks for outer loop of
3724 (Y(A)*?Z)*?T are denoted O, for inner I. NULL starting block
3725 is denoted by x. The matched string is YAAZYAZT. Temporarily postponed
3726 infoblocks are drawn below the "reset" infoblock.
3728 In fact in the picture below we do not show failed matches for Z and T
3729 by WHILEM blocks. [We illustrate minimal matches, since for them it is
3730 more obvious *why* one needs to *temporary* unset infoblocks.]
3732 Matched REx position InfoBlocks Comment
3736 Y A)*?Z)*?T x <- O <- I
3737 YA )*?Z)*?T x <- O <- I
3738 YA A)*?Z)*?T x <- O <- I
3739 YAA )*?Z)*?T x <- O <- I
3740 YAA Z)*?T x <- O # Temporary unset I
3743 YAAZ Y(A)*?Z)*?T x <- O
3746 YAAZY (A)*?Z)*?T x <- O
3749 YAAZY A)*?Z)*?T x <- O <- I
3752 YAAZYA )*?Z)*?T x <- O <- I
3755 YAAZYA Z)*?T x <- O # Temporary unset I
3761 YAAZYAZ T x # Temporary unset O
3768 *******************************************************************/
3771 /* No need to save/restore up to this paren */
3772 I32 parenfloor = scan->flags;
3776 CURLYX and WHILEM are always paired: they're the moral
3777 equivalent of pp_enteriter anbd pp_iter.
3779 The only time next could be null is if the node tree is
3780 corrupt. This was mentioned on p5p a few days ago.
3782 See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3783 So we'll assert that this is true:
3786 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3788 /* XXXX Probably it is better to teach regpush to support
3789 parenfloor > PL_regsize... */
3790 if (parenfloor > (I32)*PL_reglastparen)
3791 parenfloor = *PL_reglastparen; /* Pessimization... */
3793 st->u.curlyx.cp = PL_savestack_ix;
3794 st->u.curlyx.outercc = st->cc;
3796 /* these fields contain the state of the current curly.
3797 * they are accessed by subsequent WHILEMs;
3798 * cur and lastloc are also updated by WHILEM */
3799 st->u.curlyx.parenfloor = parenfloor;
3800 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3801 st->u.curlyx.min = ARG1(scan);
3802 st->u.curlyx.max = ARG2(scan);
3803 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3804 st->u.curlyx.lastloc = 0;
3805 /* st->next and st->minmod are also read by WHILEM */
3807 PL_reginput = locinput;
3808 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3809 /*** all unsaved local vars undefined at this point */
3810 regcpblow(st->u.curlyx.cp);
3811 st->cc = st->u.curlyx.outercc;
3817 * This is really hard to understand, because after we match
3818 * what we're trying to match, we must make sure the rest of
3819 * the REx is going to match for sure, and to do that we have
3820 * to go back UP the parse tree by recursing ever deeper. And
3821 * if it fails, we have to reset our parent's current state
3822 * that we can try again after backing off.
3827 st->cc gets initialised by CURLYX ready for use by WHILEM.
3828 So again, unless somethings been corrupted, st->cc cannot
3829 be null at that point in WHILEM.
3831 See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3832 So we'll assert that this is true:
3835 st->u.whilem.lastloc = st->cc->u.curlyx.lastloc; /* Detection of 0-len. */
3836 st->u.whilem.cache_offset = 0;
3837 st->u.whilem.cache_bit = 0;
3839 n = st->cc->u.curlyx.cur + 1; /* how many we know we matched */
3840 PL_reginput = locinput;
3843 PerlIO_printf(Perl_debug_log,
3844 "%*s %ld out of %ld..%ld cc=%"UVxf"\n",
3845 REPORT_CODE_OFF+PL_regindent*2, "",
3846 (long)n, (long)st->cc->u.curlyx.min,
3847 (long)st->cc->u.curlyx.max, PTR2UV(st->cc))
3850 /* If degenerate scan matches "", assume scan done. */
3852 if (locinput == st->cc->u.curlyx.lastloc && n >= st->cc->u.curlyx.min) {
3853 st->u.whilem.savecc = st->cc;
3854 st->cc = st->cc->u.curlyx.outercc;
3856 st->ln = st->cc->u.curlyx.cur;
3858 PerlIO_printf(Perl_debug_log,
3859 "%*s empty match detected, try continuation...\n",
3860 REPORT_CODE_OFF+PL_regindent*2, "")
3862 REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3863 /*** all unsaved local vars undefined at this point */
3864 st->cc = st->u.whilem.savecc;
3867 if (st->cc->u.curlyx.outercc)
3868 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3872 /* First just match a string of min scans. */
3874 if (n < st->cc->u.curlyx.min) {
3875 st->cc->u.curlyx.cur = n;
3876 st->cc->u.curlyx.lastloc = locinput;
3877 REGMATCH(st->cc->u.curlyx.scan, WHILEM2);
3878 /*** all unsaved local vars undefined at this point */
3881 st->cc->u.curlyx.cur = n - 1;
3882 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3887 /* Check whether we already were at this position.
3888 Postpone detection until we know the match is not
3889 *that* much linear. */
3890 if (!PL_reg_maxiter) {
3891 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3892 /* possible overflow for long strings and many CURLYX's */
3893 if (PL_reg_maxiter < 0)
3894 PL_reg_maxiter = I32_MAX;
3895 PL_reg_leftiter = PL_reg_maxiter;
3897 if (PL_reg_leftiter-- == 0) {
3898 const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8;
3899 if (PL_reg_poscache) {
3900 if ((I32)PL_reg_poscache_size < size) {
3901 Renew(PL_reg_poscache, size, char);
3902 PL_reg_poscache_size = size;
3904 Zero(PL_reg_poscache, size, char);
3907 PL_reg_poscache_size = size;
3908 Newxz(PL_reg_poscache, size, char);
3911 PerlIO_printf(Perl_debug_log,
3912 "%sDetected a super-linear match, switching on caching%s...\n",
3913 PL_colors[4], PL_colors[5])
3916 if (PL_reg_leftiter < 0) {
3917 st->u.whilem.cache_offset = locinput - PL_bostr;
3919 st->u.whilem.cache_offset = (scan->flags & 0xf) - 1 + POSCACHE_START
3920 + st->u.whilem.cache_offset * (scan->flags>>4);
3921 st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
3922 st->u.whilem.cache_offset /= 8;
3923 if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
3925 PerlIO_printf(Perl_debug_log,
3926 "%*s already tried at this position...\n",
3927 REPORT_CODE_OFF+PL_regindent*2, "")
3929 if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))
3930 /* cache records success */
3933 /* cache records failure */
3939 /* Prefer next over scan for minimal matching. */
3941 if (st->cc->minmod) {
3942 st->u.whilem.savecc = st->cc;
3943 st->cc = st->cc->u.curlyx.outercc;
3945 st->ln = st->cc->u.curlyx.cur;
3946 st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
3947 REGCP_SET(st->u.whilem.lastcp);
3948 REGMATCH(st->u.whilem.savecc->next, WHILEM3);
3949 /*** all unsaved local vars undefined at this point */
3950 st->cc = st->u.whilem.savecc;
3952 regcpblow(st->u.whilem.cp);
3953 CACHEsayYES; /* All done. */
3955 REGCP_UNWIND(st->u.whilem.lastcp);
3957 if (st->cc->u.curlyx.outercc)
3958 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3960 if (n >= st->cc->u.curlyx.max) { /* Maximum greed exceeded? */
3961 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3962 && !(PL_reg_flags & RF_warned)) {
3963 PL_reg_flags |= RF_warned;
3964 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3965 "Complex regular subexpression recursion",
3972 PerlIO_printf(Perl_debug_log,
3973 "%*s trying longer...\n",
3974 REPORT_CODE_OFF+PL_regindent*2, "")
3976 /* Try scanning more and see if it helps. */
3977 PL_reginput = locinput;
3978 st->cc->u.curlyx.cur = n;
3979 st->cc->u.curlyx.lastloc = locinput;
3980 st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3981 REGCP_SET(st->u.whilem.lastcp);
3982 REGMATCH(st->cc->u.curlyx.scan, WHILEM4);
3983 /*** all unsaved local vars undefined at this point */
3985 regcpblow(st->u.whilem.cp);
3988 REGCP_UNWIND(st->u.whilem.lastcp);
3990 st->cc->u.curlyx.cur = n - 1;
3991 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3995 /* Prefer scan over next for maximal matching. */
3997 if (n < st->cc->u.curlyx.max) { /* More greed allowed? */
3998 st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3999 st->cc->u.curlyx.cur = n;
4000 st->cc->u.curlyx.lastloc = locinput;
4001 REGCP_SET(st->u.whilem.lastcp);
4002 REGMATCH(st->cc->u.curlyx.scan, WHILEM5);
4003 /*** all unsaved local vars undefined at this point */
4005 regcpblow(st->u.whilem.cp);
4008 REGCP_UNWIND(st->u.whilem.lastcp);
4009 regcppop(rex); /* Restore some previous $<digit>s? */
4010 PL_reginput = locinput;
4012 PerlIO_printf(Perl_debug_log,
4013 "%*s failed, try continuation...\n",
4014 REPORT_CODE_OFF+PL_regindent*2, "")
4017 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
4018 && !(PL_reg_flags & RF_warned)) {
4019 PL_reg_flags |= RF_warned;
4020 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4021 "Complex regular subexpression recursion",
4025 /* Failed deeper matches of scan, so see if this one works. */
4026 st->u.whilem.savecc = st->cc;
4027 st->cc = st->cc->u.curlyx.outercc;
4029 st->ln = st->cc->u.curlyx.cur;
4030 REGMATCH(st->u.whilem.savecc->next, WHILEM6);
4031 /*** all unsaved local vars undefined at this point */
4032 st->cc = st->u.whilem.savecc;
4035 if (st->cc->u.curlyx.outercc)
4036 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
4037 st->cc->u.curlyx.cur = n - 1;
4038 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
4044 #define ST st->u.branch
4046 case BRANCHJ: /* /(...|A|...)/ with long next pointer */
4047 next = scan + ARG(scan);
4050 scan = NEXTOPER(scan);
4053 case BRANCH: /* /(...|A|...)/ */
4054 scan = NEXTOPER(scan); /* scan now points to inner node */
4055 if (!next || (OP(next) != BRANCH && OP(next) != BRANCHJ))
4056 /* last branch; skip state push and jump direct to node */
4058 ST.lastparen = *PL_reglastparen;
4059 ST.next_branch = next;
4061 PL_reginput = locinput;
4063 /* Now go into the branch */
4064 PUSH_STATE_GOTO(BRANCH_next, scan);
4067 case BRANCH_next_fail: /* that branch failed; try the next, if any */
4068 REGCP_UNWIND(ST.cp);
4069 for (n = *PL_reglastparen; n > ST.lastparen; n--)
4071 *PL_reglastparen = n;
4072 scan = ST.next_branch;
4073 /* no more branches? */
4074 if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ))
4076 continue; /* execute next BRANCH[J] op */
4084 #define ST st->u.curlym
4086 case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4088 /* This is an optimisation of CURLYX that enables us to push
4089 * only a single backtracking state, no matter now many matches
4090 * there are in {m,n}. It relies on the pattern being constant
4091 * length, with no parens to influence future backrefs
4095 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4097 /* if paren positive, emulate an OPEN/CLOSE around A */
4099 I32 paren = ST.me->flags;
4100 if (paren > PL_regsize)
4102 if (paren > (I32)*PL_reglastparen)
4103 *PL_reglastparen = paren;
4104 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4110 ST.minmod = st->minmod;
4112 ST.c1 = CHRTEST_UNINIT;
4115 if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4118 curlym_do_A: /* execute the A in /A{m,n}B/ */
4119 PL_reginput = locinput;
4120 PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4123 case CURLYM_A: /* we've just matched an A */
4124 locinput = st->locinput;
4125 nextchr = UCHARAT(locinput);
4128 /* after first match, determine A's length: u.curlym.alen */
4129 if (ST.count == 1) {
4130 if (PL_reg_match_utf8) {
4132 while (s < PL_reginput) {
4138 ST.alen = PL_reginput - locinput;
4141 ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4144 PerlIO_printf(Perl_debug_log,
4145 "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4146 (int)(REPORT_CODE_OFF+PL_regindent*2), "",
4147 (IV) ST.count, (IV)ST.alen)
4150 locinput = PL_reginput;
4151 if (ST.count < (ST.minmod ? ARG1(ST.me) : ARG2(ST.me)))
4152 goto curlym_do_A; /* try to match another A */
4153 goto curlym_do_B; /* try to match B */
4155 case CURLYM_A_fail: /* just failed to match an A */
4156 REGCP_UNWIND(ST.cp);
4157 if (ST.minmod || ST.count < ARG1(ST.me) /* min*/ )
4160 curlym_do_B: /* execute the B in /A{m,n}B/ */
4161 PL_reginput = locinput;
4162 if (ST.c1 == CHRTEST_UNINIT) {
4163 /* calculate c1 and c2 for possible match of 1st char
4164 * following curly */
4165 ST.c1 = ST.c2 = CHRTEST_VOID;
4166 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4167 regnode *text_node = ST.B;
4168 if (! HAS_TEXT(text_node))
4169 FIND_NEXT_IMPT(text_node);
4170 if (HAS_TEXT(text_node)
4171 && PL_regkind[OP(text_node)] != REF)
4173 ST.c1 = (U8)*STRING(text_node);
4175 (OP(text_node) == EXACTF || OP(text_node) == REFF)
4177 : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4178 ? PL_fold_locale[ST.c1]
4185 PerlIO_printf(Perl_debug_log,
4186 "%*s CURLYM trying tail with matches=%"IVdf"...\n",
4187 (int)(REPORT_CODE_OFF+PL_regindent*2),
4190 if (ST.c1 != CHRTEST_VOID
4191 && UCHARAT(PL_reginput) != ST.c1
4192 && UCHARAT(PL_reginput) != ST.c2)
4194 /* simulate B failing */
4195 state_num = CURLYM_B_fail;
4196 goto reenter_switch;
4200 /* mark current A as captured */
4201 I32 paren = ST.me->flags;
4204 = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4205 PL_regendp[paren] = PL_reginput - PL_bostr;
4208 PL_regendp[paren] = -1;
4210 PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4213 case CURLYM_B_fail: /* just failed to match a B */
4214 REGCP_UNWIND(ST.cp);
4216 if (ST.count == ARG2(ST.me) /* max */)
4218 goto curlym_do_A; /* try to match a further A */
4220 /* backtrack one A */
4221 if (ST.count == ARG1(ST.me) /* min */)
4224 locinput = HOPc(locinput, -ST.alen);
4225 goto curlym_do_B; /* try to match B */
4228 #define ST st->u.curly
4230 #define CURLY_SETPAREN(paren, success) \
4233 PL_regstartp[paren] = HOPc(locinput, -1) - PL_bostr; \
4234 PL_regendp[paren] = locinput - PL_bostr; \
4237 PL_regendp[paren] = -1; \
4240 case STAR: /* /A*B/ where A is width 1 */
4244 scan = NEXTOPER(scan);
4246 case PLUS: /* /A+B/ where A is width 1 */
4250 scan = NEXTOPER(scan);
4252 case CURLYN: /* /(A){m,n}B/ where A is width 1 */
4253 ST.paren = scan->flags; /* Which paren to set */
4254 if (ST.paren > PL_regsize)
4255 PL_regsize = ST.paren;
4256 if (ST.paren > (I32)*PL_reglastparen)
4257 *PL_reglastparen = ST.paren;
4258 ST.min = ARG1(scan); /* min to match */
4259 ST.max = ARG2(scan); /* max to match */
4260 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4262 case CURLY: /* /A{m,n}B/ where A is width 1 */
4264 ST.min = ARG1(scan); /* min to match */
4265 ST.max = ARG2(scan); /* max to match */
4266 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4269 * Lookahead to avoid useless match attempts
4270 * when we know what character comes next.
4272 * Used to only do .*x and .*?x, but now it allows
4273 * for )'s, ('s and (?{ ... })'s to be in the way
4274 * of the quantifier and the EXACT-like node. -- japhy
4277 if (ST.min > ST.max) /* XXX make this a compile-time check? */
4279 if (HAS_TEXT(next) || JUMPABLE(next)) {
4281 regnode *text_node = next;
4283 if (! HAS_TEXT(text_node))
4284 FIND_NEXT_IMPT(text_node);
4286 if (! HAS_TEXT(text_node))
4287 ST.c1 = ST.c2 = CHRTEST_VOID;
4289 if (PL_regkind[OP(text_node)] == REF) {
4290 ST.c1 = ST.c2 = CHRTEST_VOID;
4291 goto assume_ok_easy;
4294 s = (U8*)STRING(text_node);
4298 if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4299 ST.c2 = PL_fold[ST.c1];
4300 else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4301 ST.c2 = PL_fold_locale[ST.c1];
4304 if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4305 STRLEN ulen1, ulen2;
4306 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4307 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4309 to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4310 to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4312 ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4314 ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4318 ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4325 ST.c1 = ST.c2 = CHRTEST_VOID;
4330 PL_reginput = locinput;
4333 if (ST.min && regrepeat(rex, ST.A, ST.min) < ST.min)
4336 locinput = PL_reginput;
4338 if (ST.c1 == CHRTEST_VOID)
4339 goto curly_try_B_min;
4341 ST.oldloc = locinput;
4343 /* set ST.maxpos to the furthest point along the
4344 * string that could possibly match */
4345 if (ST.max == REG_INFTY) {
4346 ST.maxpos = PL_regeol - 1;
4348 while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4352 int m = ST.max - ST.min;
4353 for (ST.maxpos = locinput;
4354 m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4355 ST.maxpos += UTF8SKIP(ST.maxpos);
4358 ST.maxpos = locinput + ST.max - ST.min;
4359 if (ST.maxpos >= PL_regeol)
4360 ST.maxpos = PL_regeol - 1;
4362 goto curly_try_B_min_known;
4366 ST.count = regrepeat(rex, ST.A, ST.max);
4367 locinput = PL_reginput;
4368 if (ST.count < ST.min)
4370 if ((ST.count > ST.min)
4371 && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4373 /* A{m,n} must come at the end of the string, there's
4374 * no point in backing off ... */
4376 /* ...except that $ and \Z can match before *and* after
4377 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
4378 We may back off by one in this case. */
4379 if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4383 goto curly_try_B_max;
4388 case CURLY_B_min_known_fail:
4389 /* failed to find B in a non-greedy match where c1,c2 valid */
4390 if (ST.paren && ST.count)
4391 PL_regendp[ST.paren] = -1;
4393 PL_reginput = locinput; /* Could be reset... */
4394 REGCP_UNWIND(ST.cp);
4395 /* Couldn't or didn't -- move forward. */
4396 ST.oldloc = locinput;
4398 locinput += UTF8SKIP(locinput);
4402 curly_try_B_min_known:
4403 /* find the next place where 'B' could work, then call B */
4407 n = (ST.oldloc == locinput) ? 0 : 1;
4408 if (ST.c1 == ST.c2) {
4410 /* set n to utf8_distance(oldloc, locinput) */
4411 while (locinput <= ST.maxpos &&
4412 utf8n_to_uvchr((U8*)locinput,
4413 UTF8_MAXBYTES, &len,
4414 uniflags) != (UV)ST.c1) {
4420 /* set n to utf8_distance(oldloc, locinput) */
4421 while (locinput <= ST.maxpos) {
4423 const UV c = utf8n_to_uvchr((U8*)locinput,
4424 UTF8_MAXBYTES, &len,
4426 if (c == (UV)ST.c1 || c == (UV)ST.c2)
4434 if (ST.c1 == ST.c2) {
4435 while (locinput <= ST.maxpos &&
4436 UCHARAT(locinput) != ST.c1)
4440 while (locinput <= ST.maxpos
4441 && UCHARAT(locinput) != ST.c1
4442 && UCHARAT(locinput) != ST.c2)
4445 n = locinput - ST.oldloc;
4447 if (locinput > ST.maxpos)
4449 /* PL_reginput == oldloc now */
4452 if (regrepeat(rex, ST.A, n) < n)
4455 PL_reginput = locinput;
4456 CURLY_SETPAREN(ST.paren, ST.count);
4457 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
4462 case CURLY_B_min_fail:
4463 /* failed to find B in a non-greedy match where c1,c2 invalid */
4464 if (ST.paren && ST.count)
4465 PL_regendp[ST.paren] = -1;
4467 REGCP_UNWIND(ST.cp);
4468 /* failed -- move forward one */
4469 PL_reginput = locinput;
4470 if (regrepeat(rex, ST.A, 1)) {
4472 locinput = PL_reginput;
4473 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
4474 ST.count > 0)) /* count overflow ? */
4477 CURLY_SETPAREN(ST.paren, ST.count);
4478 PUSH_STATE_GOTO(CURLY_B_min, ST.B);
4486 /* a successful greedy match: now try to match B */
4489 if (ST.c1 != CHRTEST_VOID)
4490 c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
4491 UTF8_MAXBYTES, 0, uniflags)
4492 : UCHARAT(PL_reginput);
4493 /* If it could work, try it. */
4494 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
4495 CURLY_SETPAREN(ST.paren, ST.count);
4496 PUSH_STATE_GOTO(CURLY_B_max, ST.B);
4501 case CURLY_B_max_fail:
4502 /* failed to find B in a greedy match */
4503 if (ST.paren && ST.count)
4504 PL_regendp[ST.paren] = -1;
4506 REGCP_UNWIND(ST.cp);
4508 if (--ST.count < ST.min)
4510 PL_reginput = locinput = HOPc(locinput, -1);
4511 goto curly_try_B_max;
4517 if (locinput < reginfo->till) {
4518 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4519 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4521 (long)(locinput - PL_reg_starttry),
4522 (long)(reginfo->till - PL_reg_starttry),
4524 sayNO_FINAL; /* Cannot match: too short. */
4526 PL_reginput = locinput; /* put where regtry can find it */
4527 sayYES_FINAL; /* Success! */
4529 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4531 PerlIO_printf(Perl_debug_log,
4532 "%*s %ssubpattern success...%s\n",
4533 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5]));
4534 PL_reginput = locinput; /* put where regtry can find it */
4535 sayYES_FINAL; /* Success! */
4538 #define ST st->u.ifmatch
4540 case SUSPEND: /* (?>A) */
4542 PL_reginput = locinput;
4545 case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
4547 goto ifmatch_trivial_fail_test;
4549 case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
4551 ifmatch_trivial_fail_test:
4553 char * const s = HOPBACKc(locinput, scan->flags);
4558 st->sw = 1 - (bool)ST.wanted;
4562 next = scan + ARG(scan);
4570 PL_reginput = locinput;
4574 /* execute body of (?...A) */
4575 PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
4578 case IFMATCH_A_fail: /* body of (?...A) failed */
4579 ST.wanted = !ST.wanted;
4582 case IFMATCH_A: /* body of (?...A) succeeded */
4585 st->sw = (bool)ST.wanted;
4587 else if (!ST.wanted)
4590 if (OP(ST.me) == SUSPEND)
4591 locinput = PL_reginput;
4593 locinput = PL_reginput = st->locinput;
4594 nextchr = UCHARAT(locinput);
4596 scan = ST.me + ARG(ST.me);
4599 continue; /* execute B */
4604 next = scan + ARG(scan);
4609 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4610 PTR2UV(scan), OP(scan));
4611 Perl_croak(aTHX_ "regexp memory corruption");
4619 /* push a state that backtracks on success */
4620 st->u.yes.prev_yes_state = yes_state;
4624 /* push a new regex state, then continue at scan */
4626 regmatch_state *newst;
4629 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4630 "PUSH STATE(%d)\n", depth));
4631 st->locinput = locinput;
4633 if (newst > SLAB_LAST(PL_regmatch_slab))
4634 newst = S_push_slab(aTHX);
4635 PL_regmatch_state = newst;
4637 /* XXX probably don't need to initialise these */
4642 locinput = PL_reginput;
4643 nextchr = UCHARAT(locinput);
4649 /* simulate recursively calling regmatch(), but without actually
4650 * recursing - ie save the current state on the heap rather than on
4651 * the stack, then re-enter the loop. This avoids complex regexes
4652 * blowing the processor stack */
4656 /* push new state */
4657 regmatch_state *oldst = st;
4660 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "PUSH RECURSE STATE(%d)\n", depth));
4662 /* grab the next free state slot */
4664 if (st > SLAB_LAST(PL_regmatch_slab))
4665 st = S_push_slab(aTHX);
4666 PL_regmatch_state = st;
4670 oldst->locinput = locinput;
4673 locinput = PL_reginput;
4674 nextchr = UCHARAT(locinput);
4687 * We get here only if there's trouble -- normally "case END" is
4688 * the terminating point.
4690 Perl_croak(aTHX_ "corrupted regexp pointers");
4697 /* we have successfully completed a subexpression, but we must now
4698 * pop to the state marked by yes_state and continue from there */
4700 assert(st != yes_state);
4701 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
4702 || yes_state > SLAB_LAST(PL_regmatch_slab))
4704 /* not in this slab, pop slab */
4705 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
4706 PL_regmatch_slab = PL_regmatch_slab->prev;
4707 st = SLAB_LAST(PL_regmatch_slab);
4709 depth -= (st - yes_state);
4710 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATES (%d..%d)\n",
4711 depth+1, depth+(st - yes_state)));
4713 yes_state = st->u.yes.prev_yes_state;
4714 PL_regmatch_state = st;
4716 switch (st->resume_state) {
4720 state_num = st->resume_state;
4721 goto reenter_switch;
4728 Perl_croak(aTHX_ "unexpected yes resume state");
4732 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4733 PL_colors[4], PL_colors[5]));
4740 /* XXX this is duplicate(ish) code to that in the do_no section.
4741 * will disappear when REGFMATCH goes */
4743 /* restore previous state and re-enter */
4744 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
4747 if (st < SLAB_FIRST(PL_regmatch_slab)) {
4748 PL_regmatch_slab = PL_regmatch_slab->prev;
4749 st = SLAB_LAST(PL_regmatch_slab);
4751 PL_regmatch_state = st;
4755 locinput= st->locinput;
4756 nextchr = UCHARAT(locinput);
4758 switch (st->resume_state) {
4760 goto resume_point_CURLYX;
4761 case resume_WHILEM1:
4762 goto resume_point_WHILEM1;
4763 case resume_WHILEM2:
4764 goto resume_point_WHILEM2;
4765 case resume_WHILEM3:
4766 goto resume_point_WHILEM3;
4767 case resume_WHILEM4:
4768 goto resume_point_WHILEM4;
4769 case resume_WHILEM5:
4770 goto resume_point_WHILEM5;
4771 case resume_WHILEM6:
4772 goto resume_point_WHILEM6;
4782 case CURLY_B_min_known:
4786 Perl_croak(aTHX_ "regexp resume memory corruption");
4793 PerlIO_printf(Perl_debug_log,
4794 "%*s %sfailed...%s\n",
4795 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4806 /* there's a previous state to backtrack to */
4807 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth));
4810 if (st < SLAB_FIRST(PL_regmatch_slab)) {
4811 PL_regmatch_slab = PL_regmatch_slab->prev;
4812 st = SLAB_LAST(PL_regmatch_slab);
4814 PL_regmatch_state = st;
4818 locinput= st->locinput;
4819 nextchr = UCHARAT(locinput);
4821 switch (st->resume_state) {
4823 goto resume_point_CURLYX;
4824 case resume_WHILEM1:
4825 goto resume_point_WHILEM1;
4826 case resume_WHILEM2:
4827 goto resume_point_WHILEM2;
4828 case resume_WHILEM3:
4829 goto resume_point_WHILEM3;
4830 case resume_WHILEM4:
4831 goto resume_point_WHILEM4;
4832 case resume_WHILEM5:
4833 goto resume_point_WHILEM5;
4834 case resume_WHILEM6:
4835 goto resume_point_WHILEM6;
4845 case CURLY_B_min_known:
4846 if (yes_state == st)
4847 yes_state = st->u.yes.prev_yes_state;
4848 state_num = st->resume_state + 1; /* failure = success + 1 */
4849 goto reenter_switch;
4852 Perl_croak(aTHX_ "regexp resume memory corruption");
4858 /* restore original high-water mark */
4859 PL_regmatch_slab = orig_slab;
4860 PL_regmatch_state = orig_state;
4862 /* free all slabs above current one */
4863 if (orig_slab->next) {
4864 regmatch_slab *sl = orig_slab->next;
4865 orig_slab->next = NULL;
4867 regmatch_slab * const osl = sl;
4878 - regrepeat - repeatedly match something simple, report how many
4881 * [This routine now assumes that it will only match on things of length 1.
4882 * That was true before, but now we assume scan - reginput is the count,
4883 * rather than incrementing count on every character. [Er, except utf8.]]
4886 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max)
4889 register char *scan;
4891 register char *loceol = PL_regeol;
4892 register I32 hardcount = 0;
4893 register bool do_utf8 = PL_reg_match_utf8;
4896 if (max == REG_INFTY)
4898 else if (max < loceol - scan)
4899 loceol = scan + max;
4904 while (scan < loceol && hardcount < max && *scan != '\n') {
4905 scan += UTF8SKIP(scan);
4909 while (scan < loceol && *scan != '\n')
4916 while (scan < loceol && hardcount < max) {
4917 scan += UTF8SKIP(scan);
4927 case EXACT: /* length of string is 1 */
4929 while (scan < loceol && UCHARAT(scan) == c)
4932 case EXACTF: /* length of string is 1 */
4934 while (scan < loceol &&
4935 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4938 case EXACTFL: /* length of string is 1 */
4939 PL_reg_flags |= RF_tainted;
4941 while (scan < loceol &&
4942 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4948 while (hardcount < max && scan < loceol &&
4949 reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
4950 scan += UTF8SKIP(scan);
4954 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
4961 LOAD_UTF8_CHARCLASS_ALNUM();
4962 while (hardcount < max && scan < loceol &&
4963 swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4964 scan += UTF8SKIP(scan);
4968 while (scan < loceol && isALNUM(*scan))
4973 PL_reg_flags |= RF_tainted;
4976 while (hardcount < max && scan < loceol &&
4977 isALNUM_LC_utf8((U8*)scan)) {
4978 scan += UTF8SKIP(scan);
4982 while (scan < loceol && isALNUM_LC(*scan))
4989 LOAD_UTF8_CHARCLASS_ALNUM();
4990 while (hardcount < max && scan < loceol &&
4991 !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4992 scan += UTF8SKIP(scan);
4996 while (scan < loceol && !isALNUM(*scan))
5001 PL_reg_flags |= RF_tainted;
5004 while (hardcount < max && scan < loceol &&
5005 !isALNUM_LC_utf8((U8*)scan)) {
5006 scan += UTF8SKIP(scan);
5010 while (scan < loceol && !isALNUM_LC(*scan))
5017 LOAD_UTF8_CHARCLASS_SPACE();
5018 while (hardcount < max && scan < loceol &&
5020 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5021 scan += UTF8SKIP(scan);
5025 while (scan < loceol && isSPACE(*scan))
5030 PL_reg_flags |= RF_tainted;
5033 while (hardcount < max && scan < loceol &&
5034 (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5035 scan += UTF8SKIP(scan);
5039 while (scan < loceol && isSPACE_LC(*scan))
5046 LOAD_UTF8_CHARCLASS_SPACE();
5047 while (hardcount < max && scan < loceol &&
5049 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5050 scan += UTF8SKIP(scan);
5054 while (scan < loceol && !isSPACE(*scan))
5059 PL_reg_flags |= RF_tainted;
5062 while (hardcount < max && scan < loceol &&
5063 !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5064 scan += UTF8SKIP(scan);
5068 while (scan < loceol && !isSPACE_LC(*scan))
5075 LOAD_UTF8_CHARCLASS_DIGIT();
5076 while (hardcount < max && scan < loceol &&
5077 swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5078 scan += UTF8SKIP(scan);
5082 while (scan < loceol && isDIGIT(*scan))
5089 LOAD_UTF8_CHARCLASS_DIGIT();
5090 while (hardcount < max && scan < loceol &&
5091 !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5092 scan += UTF8SKIP(scan);
5096 while (scan < loceol && !isDIGIT(*scan))
5100 default: /* Called on something of 0 width. */
5101 break; /* So match right here or not at all. */
5107 c = scan - PL_reginput;
5111 GET_RE_DEBUG_FLAGS_DECL;
5113 SV * const prop = sv_newmortal();
5114 regprop(prog, prop, p);
5115 PerlIO_printf(Perl_debug_log,
5116 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
5117 REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
5125 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5127 - regclass_swash - prepare the utf8 swash
5131 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5137 const struct reg_data * const data = prog ? prog->data : NULL;
5139 if (data && data->count) {
5140 const U32 n = ARG(node);
5142 if (data->what[n] == 's') {
5143 SV * const rv = (SV*)data->data[n];
5144 AV * const av = (AV*)SvRV((SV*)rv);
5145 SV **const ary = AvARRAY(av);
5148 /* See the end of regcomp.c:S_regclass() for
5149 * documentation of these array elements. */
5152 a = SvROK(ary[1]) ? &ary[1] : 0;
5153 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
5157 else if (si && doinit) {
5158 sw = swash_init("utf8", "", si, 1, 0);
5159 (void)av_store(av, 1, sw);
5176 - reginclass - determine if a character falls into a character class
5178 The n is the ANYOF regnode, the p is the target string, lenp
5179 is pointer to the maximum length of how far to go in the p
5180 (if the lenp is zero, UTF8SKIP(p) is used),
5181 do_utf8 tells whether the target string is in UTF-8.
5186 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5189 const char flags = ANYOF_FLAGS(n);
5195 if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5196 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5197 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5198 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5199 if (len == (STRLEN)-1)
5200 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5203 plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5204 if (do_utf8 || (flags & ANYOF_UNICODE)) {
5207 if (do_utf8 && !ANYOF_RUNTIME(n)) {
5208 if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5211 if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5215 SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5218 if (swash_fetch(sw, p, do_utf8))
5220 else if (flags & ANYOF_FOLD) {
5221 if (!match && lenp && av) {
5223 for (i = 0; i <= av_len(av); i++) {
5224 SV* const sv = *av_fetch(av, i, FALSE);
5226 const char * const s = SvPV_const(sv, len);
5228 if (len <= plen && memEQ(s, (char*)p, len)) {
5236 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5239 to_utf8_fold(p, tmpbuf, &tmplen);
5240 if (swash_fetch(sw, tmpbuf, do_utf8))
5246 if (match && lenp && *lenp == 0)
5247 *lenp = UNISKIP(NATIVE_TO_UNI(c));
5249 if (!match && c < 256) {
5250 if (ANYOF_BITMAP_TEST(n, c))
5252 else if (flags & ANYOF_FOLD) {
5255 if (flags & ANYOF_LOCALE) {
5256 PL_reg_flags |= RF_tainted;
5257 f = PL_fold_locale[c];
5261 if (f != c && ANYOF_BITMAP_TEST(n, f))
5265 if (!match && (flags & ANYOF_CLASS)) {
5266 PL_reg_flags |= RF_tainted;
5268 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
5269 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
5270 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
5271 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
5272 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
5273 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
5274 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
5275 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5276 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
5277 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
5278 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
5279 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
5280 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
5281 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
5282 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
5283 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
5284 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
5285 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
5286 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
5287 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
5288 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
5289 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
5290 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
5291 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
5292 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
5293 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
5294 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
5295 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
5296 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
5297 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
5298 ) /* How's that for a conditional? */
5305 return (flags & ANYOF_INVERT) ? !match : match;
5309 S_reghop3(U8 *s, I32 off, const U8* lim)
5313 while (off-- && s < lim) {
5314 /* XXX could check well-formedness here */
5322 if (UTF8_IS_CONTINUED(*s)) {
5323 while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5326 /* XXX could check well-formedness here */
5334 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5338 while (off-- && s < lim) {
5339 /* XXX could check well-formedness here */
5349 if (UTF8_IS_CONTINUED(*s)) {
5350 while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5353 /* XXX could check well-formedness here */
5365 restore_pos(pTHX_ void *arg)
5368 regexp * const rex = (regexp *)arg;
5369 if (PL_reg_eval_set) {
5370 if (PL_reg_oldsaved) {
5371 rex->subbeg = PL_reg_oldsaved;
5372 rex->sublen = PL_reg_oldsavedlen;
5373 #ifdef PERL_OLD_COPY_ON_WRITE
5374 rex->saved_copy = PL_nrs;
5376 RX_MATCH_COPIED_on(rex);
5378 PL_reg_magic->mg_len = PL_reg_oldpos;
5379 PL_reg_eval_set = 0;
5380 PL_curpm = PL_reg_oldcurpm;
5385 S_to_utf8_substr(pTHX_ register regexp *prog)
5387 if (prog->float_substr && !prog->float_utf8) {
5388 SV* const sv = newSVsv(prog->float_substr);
5389 prog->float_utf8 = sv;
5390 sv_utf8_upgrade(sv);
5391 if (SvTAIL(prog->float_substr))
5393 if (prog->float_substr == prog->check_substr)
5394 prog->check_utf8 = sv;
5396 if (prog->anchored_substr && !prog->anchored_utf8) {
5397 SV* const sv = newSVsv(prog->anchored_substr);
5398 prog->anchored_utf8 = sv;
5399 sv_utf8_upgrade(sv);
5400 if (SvTAIL(prog->anchored_substr))
5402 if (prog->anchored_substr == prog->check_substr)
5403 prog->check_utf8 = sv;
5408 S_to_byte_substr(pTHX_ register regexp *prog)
5411 if (prog->float_utf8 && !prog->float_substr) {
5412 SV* sv = newSVsv(prog->float_utf8);
5413 prog->float_substr = sv;
5414 if (sv_utf8_downgrade(sv, TRUE)) {
5415 if (SvTAIL(prog->float_utf8))
5419 prog->float_substr = sv = &PL_sv_undef;
5421 if (prog->float_utf8 == prog->check_utf8)
5422 prog->check_substr = sv;
5424 if (prog->anchored_utf8 && !prog->anchored_substr) {
5425 SV* sv = newSVsv(prog->anchored_utf8);
5426 prog->anchored_substr = sv;
5427 if (sv_utf8_downgrade(sv, TRUE)) {
5428 if (SvTAIL(prog->anchored_utf8))
5432 prog->anchored_substr = sv = &PL_sv_undef;
5434 if (prog->anchored_utf8 == prog->check_utf8)
5435 prog->check_substr = sv;
5441 * c-indentation-style: bsd
5443 * indent-tabs-mode: t
5446 * ex: set ts=8 sts=4 sw=4 noet: