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
34 /* need to replace pregcomp et al, so enable that */
35 # ifndef PERL_IN_XSUB_RE
36 # define PERL_IN_XSUB_RE
38 /* need access to debugger hooks */
39 # if defined(PERL_EXT_RE_DEBUG) && !defined(DEBUGGING)
44 #ifdef PERL_IN_XSUB_RE
45 /* We *really* need to overwrite these symbols: */
46 # define Perl_regexec_flags my_regexec
47 # define Perl_regdump my_regdump
48 # define Perl_regprop my_regprop
49 # define Perl_re_intuit_start my_re_intuit_start
51 # define PERL_NO_GET_CONTEXT
55 * pregcomp and pregexec -- regsub and regerror are not used in perl
57 * Copyright (c) 1986 by University of Toronto.
58 * Written by Henry Spencer. Not derived from licensed software.
60 * Permission is granted to anyone to use this software for any
61 * purpose on any computer system, and to redistribute it freely,
62 * subject to the following restrictions:
64 * 1. The author is not responsible for the consequences of use of
65 * this software, no matter how awful, even if they arise
68 * 2. The origin of this software must not be misrepresented, either
69 * by explicit claim or by omission.
71 * 3. Altered versions must be plainly marked as such, and must not
72 * be misrepresented as being the original software.
74 **** Alterations to Henry's code are...
76 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
77 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
79 **** You may distribute under the terms of either the GNU General Public
80 **** License or the Artistic License, as specified in the README file.
82 * Beware that some of this code is subtly aware of the way operator
83 * precedence is structured in regular expressions. Serious changes in
84 * regular-expression syntax might require a total rethink.
87 #define PERL_IN_REGEXEC_C
92 #define RF_tainted 1 /* tainted information used? */
93 #define RF_warned 2 /* warned about big count? */
94 #define RF_evaled 4 /* Did an EVAL with setting? */
95 #define RF_utf8 8 /* String contains multibyte chars? */
97 #define UTF ((PL_reg_flags & RF_utf8) != 0)
99 #define RS_init 1 /* eval environment created */
100 #define RS_set 2 /* replsv value is set */
103 #define STATIC static
106 #define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
112 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
113 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
115 #define HOPc(pos,off) ((char *)(PL_reg_match_utf8 \
116 ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
118 #define HOPBACKc(pos, off) ((char*) \
119 ((PL_reg_match_utf8) \
120 ? reghopmaybe3((U8*)pos, -off, ((U8*)(off < 0 ? PL_regeol : PL_bostr))) \
121 : (pos - off >= PL_bostr) \
126 #define reghopmaybe3_c(pos,off,lim) ((char*)reghopmaybe3((U8*)pos, off, (U8*)lim))
127 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)pos, off, (U8*)lim) : (U8*)(pos + off))
128 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
130 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
131 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
132 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
133 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
134 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
135 #define LOAD_UTF8_CHARCLASS_MARK() LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
137 /* for use after a quantifier and before an EXACT-like node -- japhy */
138 #define JUMPABLE(rn) ( \
139 OP(rn) == OPEN || OP(rn) == CLOSE || OP(rn) == EVAL || \
140 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
141 OP(rn) == PLUS || OP(rn) == MINMOD || \
142 (PL_regkind[(U8)OP(rn)] == CURLY && ARG1(rn) > 0) \
145 #define HAS_TEXT(rn) ( \
146 PL_regkind[(U8)OP(rn)] == EXACT || PL_regkind[(U8)OP(rn)] == REF \
150 Search for mandatory following text node; for lookahead, the text must
151 follow but for lookbehind (rn->flags != 0) we skip to the next step.
153 #define FIND_NEXT_IMPT(rn) STMT_START { \
154 while (JUMPABLE(rn)) \
155 if (OP(rn) == SUSPEND || PL_regkind[(U8)OP(rn)] == CURLY) \
156 rn = NEXTOPER(NEXTOPER(rn)); \
157 else if (OP(rn) == PLUS) \
159 else if (OP(rn) == IFMATCH) \
160 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
161 else rn += NEXT_OFF(rn); \
164 static void restore_pos(pTHX_ void *arg);
167 S_regcppush(pTHX_ I32 parenfloor)
170 const int retval = PL_savestack_ix;
171 #define REGCP_PAREN_ELEMS 4
172 const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
175 if (paren_elems_to_push < 0)
176 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
178 #define REGCP_OTHER_ELEMS 6
179 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
180 for (p = PL_regsize; p > parenfloor; p--) {
181 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
182 SSPUSHINT(PL_regendp[p]);
183 SSPUSHINT(PL_regstartp[p]);
184 SSPUSHPTR(PL_reg_start_tmp[p]);
187 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
188 SSPUSHINT(PL_regsize);
189 SSPUSHINT(*PL_reglastparen);
190 SSPUSHINT(*PL_reglastcloseparen);
191 SSPUSHPTR(PL_reginput);
192 #define REGCP_FRAME_ELEMS 2
193 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
194 * are needed for the regexp context stack bookkeeping. */
195 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
196 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
201 /* These are needed since we do not localize EVAL nodes: */
202 # define REGCP_SET(cp) DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, \
203 " Setting an EVAL scope, savestack=%"IVdf"\n", \
204 (IV)PL_savestack_ix)); cp = PL_savestack_ix
206 # define REGCP_UNWIND(cp) DEBUG_EXECUTE_r(cp != PL_savestack_ix ? \
207 PerlIO_printf(Perl_debug_log, \
208 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
209 (IV)(cp), (IV)PL_savestack_ix) : 0); regcpblow(cp)
212 S_regcppop(pTHX_ const regexp *rex)
218 GET_RE_DEBUG_FLAGS_DECL;
220 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
222 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
223 i = SSPOPINT; /* Parentheses elements to pop. */
224 input = (char *) SSPOPPTR;
225 *PL_reglastcloseparen = SSPOPINT;
226 *PL_reglastparen = SSPOPINT;
227 PL_regsize = SSPOPINT;
229 /* Now restore the parentheses context. */
230 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
231 i > 0; i -= REGCP_PAREN_ELEMS) {
233 U32 paren = (U32)SSPOPINT;
234 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
235 PL_regstartp[paren] = SSPOPINT;
237 if (paren <= *PL_reglastparen)
238 PL_regendp[paren] = tmps;
240 PerlIO_printf(Perl_debug_log,
241 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
242 (UV)paren, (IV)PL_regstartp[paren],
243 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
244 (IV)PL_regendp[paren],
245 (paren > *PL_reglastparen ? "(no)" : ""));
249 if ((I32)(*PL_reglastparen + 1) <= rex->nparens) {
250 PerlIO_printf(Perl_debug_log,
251 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
252 (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
256 /* It would seem that the similar code in regtry()
257 * already takes care of this, and in fact it is in
258 * a better location to since this code can #if 0-ed out
259 * but the code in regtry() is needed or otherwise tests
260 * requiring null fields (pat.t#187 and split.t#{13,14}
261 * (as of patchlevel 7877) will fail. Then again,
262 * this code seems to be necessary or otherwise
263 * building DynaLoader will fail:
264 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
266 for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
268 PL_regstartp[i] = -1;
275 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
277 #define TRYPAREN(paren, n, input, where) { \
280 PL_regstartp[paren] = HOPc(input, -1) - PL_bostr; \
281 PL_regendp[paren] = input - PL_bostr; \
284 PL_regendp[paren] = -1; \
286 REGMATCH(next, where); \
290 PL_regendp[paren] = -1; \
295 * pregexec and friends
298 #ifndef PERL_IN_XSUB_RE
300 - pregexec - match a regexp against a string
303 Perl_pregexec(pTHX_ register regexp *prog, char *stringarg, register char *strend,
304 char *strbeg, I32 minend, SV *screamer, U32 nosave)
305 /* strend: pointer to null at end of string */
306 /* strbeg: real beginning of string */
307 /* minend: end of match must be >=minend after stringarg. */
308 /* nosave: For optimizations. */
311 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
312 nosave ? 0 : REXEC_COPY_STR);
317 * Need to implement the following flags for reg_anch:
319 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
321 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
322 * INTUIT_AUTORITATIVE_ML
323 * INTUIT_ONCE_NOML - Intuit can match in one location only.
326 * Another flag for this function: SECOND_TIME (so that float substrs
327 * with giant delta may be not rechecked).
330 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
332 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
333 Otherwise, only SvCUR(sv) is used to get strbeg. */
335 /* XXXX We assume that strpos is strbeg unless sv. */
337 /* XXXX Some places assume that there is a fixed substring.
338 An update may be needed if optimizer marks as "INTUITable"
339 RExen without fixed substrings. Similarly, it is assumed that
340 lengths of all the strings are no more than minlen, thus they
341 cannot come from lookahead.
342 (Or minlen should take into account lookahead.) */
344 /* A failure to find a constant substring means that there is no need to make
345 an expensive call to REx engine, thus we celebrate a failure. Similarly,
346 finding a substring too deep into the string means that less calls to
347 regtry() should be needed.
349 REx compiler's optimizer found 4 possible hints:
350 a) Anchored substring;
352 c) Whether we are anchored (beginning-of-line or \G);
353 d) First node (of those at offset 0) which may distingush positions;
354 We use a)b)d) and multiline-part of c), and try to find a position in the
355 string which does not contradict any of them.
358 /* Most of decisions we do here should have been done at compile time.
359 The nodes of the REx which we used for the search should have been
360 deleted from the finite automaton. */
363 Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
364 char *strend, U32 flags, re_scream_pos_data *data)
367 register I32 start_shift = 0;
368 /* Should be nonnegative! */
369 register I32 end_shift = 0;
374 const int do_utf8 = sv ? SvUTF8(sv) : 0; /* if no sv we have to assume bytes */
376 register char *other_last = NULL; /* other substr checked before this */
377 char *check_at = NULL; /* check substr found at this pos */
378 const I32 multiline = prog->reganch & PMf_MULTILINE;
380 const char * const i_strpos = strpos;
381 SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
384 GET_RE_DEBUG_FLAGS_DECL;
386 RX_MATCH_UTF8_set(prog,do_utf8);
388 if (prog->reganch & ROPT_UTF8) {
389 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
390 "UTF-8 regex...\n"));
391 PL_reg_flags |= RF_utf8;
395 const char *s = PL_reg_match_utf8 ?
396 sv_uni_display(dsv, sv, 60, UNI_DISPLAY_REGEX) :
398 const int len = PL_reg_match_utf8 ?
399 strlen(s) : strend - strpos;
402 if (PL_reg_match_utf8)
403 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
404 "UTF-8 target...\n"));
405 PerlIO_printf(Perl_debug_log,
406 "%sGuessing start of match, REx%s \"%s%.60s%s%s\" against \"%s%.*s%s%s\"...\n",
407 PL_colors[4], PL_colors[5], PL_colors[0],
410 (strlen(prog->precomp) > 60 ? "..." : ""),
412 (int)(len > 60 ? 60 : len),
414 (len > 60 ? "..." : "")
418 /* CHR_DIST() would be more correct here but it makes things slow. */
419 if (prog->minlen > strend - strpos) {
420 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
421 "String too short... [re_intuit_start]\n"));
424 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
427 if (!prog->check_utf8 && prog->check_substr)
428 to_utf8_substr(prog);
429 check = prog->check_utf8;
431 if (!prog->check_substr && prog->check_utf8)
432 to_byte_substr(prog);
433 check = prog->check_substr;
435 if (check == &PL_sv_undef) {
436 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
437 "Non-utf string cannot match utf check string\n"));
440 if (prog->reganch & ROPT_ANCH) { /* Match at beg-of-str or after \n */
441 ml_anch = !( (prog->reganch & ROPT_ANCH_SINGLE)
442 || ( (prog->reganch & ROPT_ANCH_BOL)
443 && !multiline ) ); /* Check after \n? */
446 if ( !(prog->reganch & (ROPT_ANCH_GPOS /* Checked by the caller */
447 | ROPT_IMPLICIT)) /* not a real BOL */
448 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
450 && (strpos != strbeg)) {
451 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
454 if (prog->check_offset_min == prog->check_offset_max &&
455 !(prog->reganch & ROPT_CANY_SEEN)) {
456 /* Substring at constant offset from beg-of-str... */
459 s = HOP3c(strpos, prog->check_offset_min, strend);
461 slen = SvCUR(check); /* >= 1 */
463 if ( strend - s > slen || strend - s < slen - 1
464 || (strend - s == slen && strend[-1] != '\n')) {
465 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
468 /* Now should match s[0..slen-2] */
470 if (slen && (*SvPVX_const(check) != *s
472 && memNE(SvPVX_const(check), s, slen)))) {
474 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
478 else if (*SvPVX_const(check) != *s
479 || ((slen = SvCUR(check)) > 1
480 && memNE(SvPVX_const(check), s, slen)))
483 goto success_at_start;
486 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
488 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
489 end_shift = prog->minlen - start_shift -
490 CHR_SVLEN(check) + (SvTAIL(check) != 0);
492 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
493 - (SvTAIL(check) != 0);
494 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
496 if (end_shift < eshift)
500 else { /* Can match at random position */
503 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
504 /* Should be nonnegative! */
505 end_shift = prog->minlen - start_shift -
506 CHR_SVLEN(check) + (SvTAIL(check) != 0);
509 #ifdef DEBUGGING /* 7/99: reports of failure (with the older version) */
511 Perl_croak(aTHX_ "panic: end_shift");
515 /* Find a possible match in the region s..strend by looking for
516 the "check" substring in the region corrected by start/end_shift. */
517 if (flags & REXEC_SCREAM) {
518 I32 p = -1; /* Internal iterator of scream. */
519 I32 * const pp = data ? data->scream_pos : &p;
521 if (PL_screamfirst[BmRARE(check)] >= 0
522 || ( BmRARE(check) == '\n'
523 && (BmPREVIOUS(check) == SvCUR(check) - 1)
525 s = screaminstr(sv, check,
526 start_shift + (s - strbeg), end_shift, pp, 0);
529 /* we may be pointing at the wrong string */
530 if (s && RX_MATCH_COPIED(prog))
531 s = strbeg + (s - SvPVX_const(sv));
533 *data->scream_olds = s;
535 else if (prog->reganch & ROPT_CANY_SEEN)
536 s = fbm_instr((U8*)(s + start_shift),
537 (U8*)(strend - end_shift),
538 check, multiline ? FBMrf_MULTILINE : 0);
540 s = fbm_instr(HOP3(s, start_shift, strend),
541 HOP3(strend, -end_shift, strbeg),
542 check, multiline ? FBMrf_MULTILINE : 0);
544 /* Update the count-of-usability, remove useless subpatterns,
547 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s %s substr \"%s%.*s%s\"%s%s",
548 (s ? "Found" : "Did not find"),
549 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) ? "anchored" : "floating"),
551 (int)(SvCUR(check) - (SvTAIL(check)!=0)),
553 PL_colors[1], (SvTAIL(check) ? "$" : ""),
554 (s ? " at offset " : "...\n") ) );
561 /* Finish the diagnostic message */
562 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
564 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
565 Start with the other substr.
566 XXXX no SCREAM optimization yet - and a very coarse implementation
567 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
568 *always* match. Probably should be marked during compile...
569 Probably it is right to do no SCREAM here...
572 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8) : (prog->float_substr && prog->anchored_substr)) {
573 /* Take into account the "other" substring. */
574 /* XXXX May be hopelessly wrong for UTF... */
577 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
580 char * const last = HOP3c(s, -start_shift, strbeg);
585 t = s - prog->check_offset_max;
586 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
588 || ((t = reghopmaybe3_c(s, -(prog->check_offset_max), strpos))
593 t = HOP3c(t, prog->anchored_offset, strend);
594 if (t < other_last) /* These positions already checked */
596 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
599 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
600 /* On end-of-str: see comment below. */
601 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
602 if (must == &PL_sv_undef) {
604 DEBUG_EXECUTE_r(must = prog->anchored_utf8); /* for debug */
609 HOP3(HOP3(last1, prog->anchored_offset, strend)
610 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
612 multiline ? FBMrf_MULTILINE : 0
614 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
615 "%s anchored substr \"%s%.*s%s\"%s",
616 (s ? "Found" : "Contradicts"),
619 - (SvTAIL(must)!=0)),
621 PL_colors[1], (SvTAIL(must) ? "$" : "")));
623 if (last1 >= last2) {
624 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
625 ", giving up...\n"));
628 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
629 ", trying floating at offset %ld...\n",
630 (long)(HOP3c(s1, 1, strend) - i_strpos)));
631 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
632 s = HOP3c(last, 1, strend);
636 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
637 (long)(s - i_strpos)));
638 t = HOP3c(s, -prog->anchored_offset, strbeg);
639 other_last = HOP3c(s, 1, strend);
647 else { /* Take into account the floating substring. */
652 t = HOP3c(s, -start_shift, strbeg);
654 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
655 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
656 last = HOP3c(t, prog->float_max_offset, strend);
657 s = HOP3c(t, prog->float_min_offset, strend);
660 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
661 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
662 /* fbm_instr() takes into account exact value of end-of-str
663 if the check is SvTAIL(ed). Since false positives are OK,
664 and end-of-str is not later than strend we are OK. */
665 if (must == &PL_sv_undef) {
667 DEBUG_EXECUTE_r(must = prog->float_utf8); /* for debug message */
670 s = fbm_instr((unsigned char*)s,
671 (unsigned char*)last + SvCUR(must)
673 must, multiline ? FBMrf_MULTILINE : 0);
674 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s floating substr \"%s%.*s%s\"%s",
675 (s ? "Found" : "Contradicts"),
677 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
679 PL_colors[1], (SvTAIL(must) ? "$" : "")));
682 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
683 ", giving up...\n"));
686 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
687 ", trying anchored starting at offset %ld...\n",
688 (long)(s1 + 1 - i_strpos)));
690 s = HOP3c(t, 1, strend);
694 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
695 (long)(s - i_strpos)));
696 other_last = s; /* Fix this later. --Hugo */
705 t = s - prog->check_offset_max;
706 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
708 || ((t = reghopmaybe3_c(s, -prog->check_offset_max, strpos))
710 /* Fixed substring is found far enough so that the match
711 cannot start at strpos. */
713 if (ml_anch && t[-1] != '\n') {
714 /* Eventually fbm_*() should handle this, but often
715 anchored_offset is not 0, so this check will not be wasted. */
716 /* XXXX In the code below we prefer to look for "^" even in
717 presence of anchored substrings. And we search even
718 beyond the found float position. These pessimizations
719 are historical artefacts only. */
721 while (t < strend - prog->minlen) {
723 if (t < check_at - prog->check_offset_min) {
724 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
725 /* Since we moved from the found position,
726 we definitely contradict the found anchored
727 substr. Due to the above check we do not
728 contradict "check" substr.
729 Thus we can arrive here only if check substr
730 is float. Redo checking for "other"=="fixed".
733 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
734 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
735 goto do_other_anchored;
737 /* We don't contradict the found floating substring. */
738 /* XXXX Why not check for STCLASS? */
740 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
741 PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
744 /* Position contradicts check-string */
745 /* XXXX probably better to look for check-string
746 than for "\n", so one should lower the limit for t? */
747 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
748 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
749 other_last = strpos = s = t + 1;
754 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
755 PL_colors[0], PL_colors[1]));
759 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
760 PL_colors[0], PL_colors[1]));
764 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
767 /* The found string does not prohibit matching at strpos,
768 - no optimization of calling REx engine can be performed,
769 unless it was an MBOL and we are not after MBOL,
770 or a future STCLASS check will fail this. */
772 /* Even in this situation we may use MBOL flag if strpos is offset
773 wrt the start of the string. */
774 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
775 && (strpos != strbeg) && strpos[-1] != '\n'
776 /* May be due to an implicit anchor of m{.*foo} */
777 && !(prog->reganch & ROPT_IMPLICIT))
782 DEBUG_EXECUTE_r( if (ml_anch)
783 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
784 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
787 if (!(prog->reganch & ROPT_NAUGHTY) /* XXXX If strpos moved? */
789 prog->check_utf8 /* Could be deleted already */
790 && --BmUSEFUL(prog->check_utf8) < 0
791 && (prog->check_utf8 == prog->float_utf8)
793 prog->check_substr /* Could be deleted already */
794 && --BmUSEFUL(prog->check_substr) < 0
795 && (prog->check_substr == prog->float_substr)
798 /* If flags & SOMETHING - do not do it many times on the same match */
799 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
800 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
801 if (do_utf8 ? prog->check_substr : prog->check_utf8)
802 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
803 prog->check_substr = prog->check_utf8 = NULL; /* disable */
804 prog->float_substr = prog->float_utf8 = NULL; /* clear */
805 check = NULL; /* abort */
807 /* XXXX This is a remnant of the old implementation. It
808 looks wasteful, since now INTUIT can use many
810 prog->reganch &= ~RE_USE_INTUIT;
817 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
818 if (prog->regstclass) {
819 /* minlen == 0 is possible if regstclass is \b or \B,
820 and the fixed substr is ''$.
821 Since minlen is already taken into account, s+1 is before strend;
822 accidentally, minlen >= 1 guaranties no false positives at s + 1
823 even for \b or \B. But (minlen? 1 : 0) below assumes that
824 regstclass does not come from lookahead... */
825 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
826 This leaves EXACTF only, which is dealt with in find_byclass(). */
827 const U8* const str = (U8*)STRING(prog->regstclass);
828 const int cl_l = (PL_regkind[(U8)OP(prog->regstclass)] == EXACT
829 ? CHR_DIST(str+STR_LEN(prog->regstclass), str)
831 const char * const endpos = (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
832 ? HOP3c(s, (prog->minlen ? cl_l : 0), strend)
833 : (prog->float_substr || prog->float_utf8
834 ? HOP3c(HOP3c(check_at, -start_shift, strbeg),
839 s = find_byclass(prog, prog->regstclass, s, endpos, NULL);
842 const char *what = NULL;
844 if (endpos == strend) {
845 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
846 "Could not match STCLASS...\n") );
849 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
850 "This position contradicts STCLASS...\n") );
851 if ((prog->reganch & ROPT_ANCH) && !ml_anch)
853 /* Contradict one of substrings */
854 if (prog->anchored_substr || prog->anchored_utf8) {
855 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
856 DEBUG_EXECUTE_r( what = "anchored" );
858 s = HOP3c(t, 1, strend);
859 if (s + start_shift + end_shift > strend) {
860 /* XXXX Should be taken into account earlier? */
861 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
862 "Could not match STCLASS...\n") );
867 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
868 "Looking for %s substr starting at offset %ld...\n",
869 what, (long)(s + start_shift - i_strpos)) );
872 /* Have both, check_string is floating */
873 if (t + start_shift >= check_at) /* Contradicts floating=check */
874 goto retry_floating_check;
875 /* Recheck anchored substring, but not floating... */
879 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
880 "Looking for anchored substr starting at offset %ld...\n",
881 (long)(other_last - i_strpos)) );
882 goto do_other_anchored;
884 /* Another way we could have checked stclass at the
885 current position only: */
890 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
891 "Looking for /%s^%s/m starting at offset %ld...\n",
892 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
895 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
897 /* Check is floating subtring. */
898 retry_floating_check:
899 t = check_at - start_shift;
900 DEBUG_EXECUTE_r( what = "floating" );
901 goto hop_and_restart;
904 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
905 "By STCLASS: moving %ld --> %ld\n",
906 (long)(t - i_strpos), (long)(s - i_strpos))
910 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
911 "Does not contradict STCLASS...\n");
916 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
917 PL_colors[4], (check ? "Guessed" : "Giving up"),
918 PL_colors[5], (long)(s - i_strpos)) );
921 fail_finish: /* Substring not found */
922 if (prog->check_substr || prog->check_utf8) /* could be removed already */
923 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
925 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
926 PL_colors[4], PL_colors[5]));
930 /* We know what class REx starts with. Try to find this position... */
931 /* if reginfo is NULL, its a dryrun */
934 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, const char
935 *strend, const regmatch_info *reginfo)
938 const I32 doevery = (prog->reganch & ROPT_SKIP) == 0;
942 register STRLEN uskip;
946 register I32 tmp = 1; /* Scratch variable? */
947 register const bool do_utf8 = PL_reg_match_utf8;
949 /* We know what class it must start with. */
953 while (s + (uskip = UTF8SKIP(s)) <= strend) {
954 if ((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
955 !UTF8_IS_INVARIANT((U8)s[0]) ?
956 reginclass(prog, c, (U8*)s, 0, do_utf8) :
957 REGINCLASS(prog, c, (U8*)s)) {
958 if (tmp && (!reginfo || regtry(reginfo, s)))
972 if (REGINCLASS(prog, c, (U8*)s) ||
973 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
974 /* The assignment of 2 is intentional:
975 * for the folded sharp s, the skip is 2. */
976 (skip = SHARP_S_SKIP))) {
977 if (tmp && (!reginfo || regtry(reginfo, s)))
990 if (tmp && (!reginfo || regtry(reginfo, s)))
999 ln = STR_LEN(c); /* length to match in octets/bytes */
1000 lnc = (I32) ln; /* length to match in characters */
1002 STRLEN ulen1, ulen2;
1004 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1005 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1006 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1008 to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1009 to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1011 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1013 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1016 while (sm < ((U8 *) m + ln)) {
1031 c2 = PL_fold_locale[c1];
1033 e = HOP3c(strend, -((I32)lnc), s);
1035 if (!reginfo && e < s)
1036 e = s; /* Due to minlen logic of intuit() */
1038 /* The idea in the EXACTF* cases is to first find the
1039 * first character of the EXACTF* node and then, if
1040 * necessary, case-insensitively compare the full
1041 * text of the node. The c1 and c2 are the first
1042 * characters (though in Unicode it gets a bit
1043 * more complicated because there are more cases
1044 * than just upper and lower: one needs to use
1045 * the so-called folding case for case-insensitive
1046 * matching (called "loose matching" in Unicode).
1047 * ibcmp_utf8() will do just that. */
1051 U8 tmpbuf [UTF8_MAXBYTES+1];
1052 STRLEN len, foldlen;
1053 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1055 /* Upper and lower of 1st char are equal -
1056 * probably not a "letter". */
1058 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1062 ibcmp_utf8(s, (char **)0, 0, do_utf8,
1063 m, (char **)0, ln, (bool)UTF))
1064 && (!reginfo || regtry(reginfo, s)) )
1067 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1068 uvchr_to_utf8(tmpbuf, c);
1069 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1071 && (f == c1 || f == c2)
1072 && (ln == foldlen ||
1073 !ibcmp_utf8((char *) foldbuf,
1074 (char **)0, foldlen, do_utf8,
1076 (char **)0, ln, (bool)UTF))
1077 && (!reginfo || regtry(reginfo, s)) )
1085 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1088 /* Handle some of the three Greek sigmas cases.
1089 * Note that not all the possible combinations
1090 * are handled here: some of them are handled
1091 * by the standard folding rules, and some of
1092 * them (the character class or ANYOF cases)
1093 * are handled during compiletime in
1094 * regexec.c:S_regclass(). */
1095 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1096 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1097 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1099 if ( (c == c1 || c == c2)
1101 ibcmp_utf8(s, (char **)0, 0, do_utf8,
1102 m, (char **)0, ln, (bool)UTF))
1103 && (!reginfo || regtry(reginfo, s)) )
1106 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
1107 uvchr_to_utf8(tmpbuf, c);
1108 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen);
1110 && (f == c1 || f == c2)
1111 && (ln == foldlen ||
1112 !ibcmp_utf8((char *) foldbuf,
1113 (char **)0, foldlen, do_utf8,
1115 (char **)0, ln, (bool)UTF))
1116 && (!reginfo || regtry(reginfo, s)) )
1127 && (ln == 1 || !(OP(c) == EXACTF
1129 : ibcmp_locale(s, m, ln)))
1130 && (!reginfo || regtry(reginfo, s)) )
1136 if ( (*(U8*)s == c1 || *(U8*)s == c2)
1137 && (ln == 1 || !(OP(c) == EXACTF
1139 : ibcmp_locale(s, m, ln)))
1140 && (!reginfo || regtry(reginfo, s)) )
1147 PL_reg_flags |= RF_tainted;
1154 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1155 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1157 tmp = ((OP(c) == BOUND ?
1158 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1159 LOAD_UTF8_CHARCLASS_ALNUM();
1160 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1161 if (tmp == !(OP(c) == BOUND ?
1162 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1163 isALNUM_LC_utf8((U8*)s)))
1166 if ((!reginfo || regtry(reginfo, s)))
1173 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1174 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1175 while (s < strend) {
1177 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1179 if ((!reginfo || regtry(reginfo, s)))
1185 if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, s)))
1189 PL_reg_flags |= RF_tainted;
1196 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1197 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1199 tmp = ((OP(c) == NBOUND ?
1200 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1201 LOAD_UTF8_CHARCLASS_ALNUM();
1202 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1203 if (tmp == !(OP(c) == NBOUND ?
1204 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1205 isALNUM_LC_utf8((U8*)s)))
1207 else if ((!reginfo || regtry(reginfo, s)))
1213 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1214 tmp = ((OP(c) == NBOUND ?
1215 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1216 while (s < strend) {
1218 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1220 else if ((!reginfo || regtry(reginfo, s)))
1225 if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, s)))
1230 LOAD_UTF8_CHARCLASS_ALNUM();
1231 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1232 if (swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1233 if (tmp && (!reginfo || regtry(reginfo, s)))
1244 while (s < strend) {
1246 if (tmp && (!reginfo || regtry(reginfo, s)))
1258 PL_reg_flags |= RF_tainted;
1260 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1261 if (isALNUM_LC_utf8((U8*)s)) {
1262 if (tmp && (!reginfo || regtry(reginfo, s)))
1273 while (s < strend) {
1274 if (isALNUM_LC(*s)) {
1275 if (tmp && (!reginfo || regtry(reginfo, s)))
1288 LOAD_UTF8_CHARCLASS_ALNUM();
1289 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1290 if (!swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8)) {
1291 if (tmp && (!reginfo || regtry(reginfo, s)))
1302 while (s < strend) {
1304 if (tmp && (!reginfo || regtry(reginfo, s)))
1316 PL_reg_flags |= RF_tainted;
1318 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1319 if (!isALNUM_LC_utf8((U8*)s)) {
1320 if (tmp && (!reginfo || regtry(reginfo, s)))
1331 while (s < strend) {
1332 if (!isALNUM_LC(*s)) {
1333 if (tmp && (!reginfo || regtry(reginfo, s)))
1346 LOAD_UTF8_CHARCLASS_SPACE();
1347 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1348 if (*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)) {
1349 if (tmp && (!reginfo || regtry(reginfo, s)))
1360 while (s < strend) {
1362 if (tmp && (!reginfo || regtry(reginfo, s)))
1374 PL_reg_flags |= RF_tainted;
1376 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1377 if (*s == ' ' || isSPACE_LC_utf8((U8*)s)) {
1378 if (tmp && (!reginfo || regtry(reginfo, s)))
1389 while (s < strend) {
1390 if (isSPACE_LC(*s)) {
1391 if (tmp && (!reginfo || regtry(reginfo, s)))
1404 LOAD_UTF8_CHARCLASS_SPACE();
1405 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1406 if (!(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8))) {
1407 if (tmp && (!reginfo || regtry(reginfo, s)))
1418 while (s < strend) {
1420 if (tmp && (!reginfo || regtry(reginfo, s)))
1432 PL_reg_flags |= RF_tainted;
1434 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1435 if (!(*s == ' ' || isSPACE_LC_utf8((U8*)s))) {
1436 if (tmp && (!reginfo || regtry(reginfo, s)))
1447 while (s < strend) {
1448 if (!isSPACE_LC(*s)) {
1449 if (tmp && (!reginfo || regtry(reginfo, s)))
1462 LOAD_UTF8_CHARCLASS_DIGIT();
1463 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1464 if (swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1465 if (tmp && (!reginfo || regtry(reginfo, s)))
1476 while (s < strend) {
1478 if (tmp && (!reginfo || regtry(reginfo, s)))
1490 PL_reg_flags |= RF_tainted;
1492 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1493 if (isDIGIT_LC_utf8((U8*)s)) {
1494 if (tmp && (!reginfo || regtry(reginfo, s)))
1505 while (s < strend) {
1506 if (isDIGIT_LC(*s)) {
1507 if (tmp && (!reginfo || regtry(reginfo, s)))
1520 LOAD_UTF8_CHARCLASS_DIGIT();
1521 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1522 if (!swash_fetch(PL_utf8_digit,(U8*)s, do_utf8)) {
1523 if (tmp && (!reginfo || regtry(reginfo, s)))
1534 while (s < strend) {
1536 if (tmp && (!reginfo || regtry(reginfo, s)))
1548 PL_reg_flags |= RF_tainted;
1550 while (s + (uskip = UTF8SKIP(s)) <= strend) {
1551 if (!isDIGIT_LC_utf8((U8*)s)) {
1552 if (tmp && (!reginfo || regtry(reginfo, s)))
1563 while (s < strend) {
1564 if (!isDIGIT_LC(*s)) {
1565 if (tmp && (!reginfo || regtry(reginfo, s)))
1577 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1586 - regexec_flags - match a regexp against a string
1589 Perl_regexec_flags(pTHX_ register regexp *prog, char *stringarg, register char *strend,
1590 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1591 /* strend: pointer to null at end of string */
1592 /* strbeg: real beginning of string */
1593 /* minend: end of match must be >=minend after stringarg. */
1594 /* data: May be used for some additional optimizations. */
1595 /* nosave: For optimizations. */
1599 register regnode *c;
1600 register char *startpos = stringarg;
1601 I32 minlen; /* must match at least this many chars */
1602 I32 dontbother = 0; /* how many characters not to try at end */
1603 I32 end_shift = 0; /* Same for the end. */ /* CC */
1604 I32 scream_pos = -1; /* Internal iterator of scream. */
1605 char *scream_olds = NULL;
1606 SV* oreplsv = GvSV(PL_replgv);
1607 const bool do_utf8 = DO_UTF8(sv);
1613 regmatch_info reginfo; /* create some info to pass to regtry etc */
1615 GET_RE_DEBUG_FLAGS_DECL;
1617 PERL_UNUSED_ARG(data);
1619 /* Be paranoid... */
1620 if (prog == NULL || startpos == NULL) {
1621 Perl_croak(aTHX_ "NULL regexp parameter");
1625 multiline = prog->reganch & PMf_MULTILINE;
1626 reginfo.prog = prog;
1629 dsv0 = PERL_DEBUG_PAD_ZERO(0);
1630 dsv1 = PERL_DEBUG_PAD_ZERO(1);
1633 RX_MATCH_UTF8_set(prog, do_utf8);
1635 minlen = prog->minlen;
1636 if (strend - startpos < minlen) {
1637 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1638 "String too short [regexec_flags]...\n"));
1642 /* Check validity of program. */
1643 if (UCHARAT(prog->program) != REG_MAGIC) {
1644 Perl_croak(aTHX_ "corrupted regexp program");
1648 PL_reg_eval_set = 0;
1651 if (prog->reganch & ROPT_UTF8)
1652 PL_reg_flags |= RF_utf8;
1654 /* Mark beginning of line for ^ and lookbehind. */
1655 reginfo.bol = startpos; /* XXX not used ??? */
1659 /* Mark end of line for $ (and such) */
1662 /* see how far we have to get to not match where we matched before */
1663 reginfo.till = startpos+minend;
1665 /* If there is a "must appear" string, look for it. */
1668 if (prog->reganch & ROPT_GPOS_SEEN) { /* Need to set reginfo->ganch */
1671 if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
1672 reginfo.ganch = startpos;
1673 else if (sv && SvTYPE(sv) >= SVt_PVMG
1675 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1676 && mg->mg_len >= 0) {
1677 reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
1678 if (prog->reganch & ROPT_ANCH_GPOS) {
1679 if (s > reginfo.ganch)
1684 else /* pos() not defined */
1685 reginfo.ganch = strbeg;
1688 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1689 re_scream_pos_data d;
1691 d.scream_olds = &scream_olds;
1692 d.scream_pos = &scream_pos;
1693 s = re_intuit_start(prog, sv, s, strend, flags, &d);
1695 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1696 goto phooey; /* not present */
1701 const char * const s0 = UTF
1702 ? pv_uni_display(dsv0, (U8*)prog->precomp, prog->prelen, 60,
1705 const int len0 = UTF ? SvCUR(dsv0) : prog->prelen;
1706 const char * const s1 = do_utf8 ? sv_uni_display(dsv1, sv, 60,
1707 UNI_DISPLAY_REGEX) : startpos;
1708 const int len1 = do_utf8 ? SvCUR(dsv1) : strend - startpos;
1711 PerlIO_printf(Perl_debug_log,
1712 "%sMatching REx%s \"%s%*.*s%s%s\" against \"%s%.*s%s%s\"\n",
1713 PL_colors[4], PL_colors[5], PL_colors[0],
1716 len0 > 60 ? "..." : "",
1718 (int)(len1 > 60 ? 60 : len1),
1720 (len1 > 60 ? "..." : "")
1724 /* Simplest case: anchored match need be tried only once. */
1725 /* [unless only anchor is BOL and multiline is set] */
1726 if (prog->reganch & (ROPT_ANCH & ~ROPT_ANCH_GPOS)) {
1727 if (s == startpos && regtry(®info, startpos))
1729 else if (multiline || (prog->reganch & ROPT_IMPLICIT)
1730 || (prog->reganch & ROPT_ANCH_MBOL)) /* XXXX SBOL? */
1735 dontbother = minlen - 1;
1736 end = HOP3c(strend, -dontbother, strbeg) - 1;
1737 /* for multiline we only have to try after newlines */
1738 if (prog->check_substr || prog->check_utf8) {
1742 if (regtry(®info, s))
1747 if (prog->reganch & RE_USE_INTUIT) {
1748 s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1759 if (*s++ == '\n') { /* don't need PL_utf8skip here */
1760 if (regtry(®info, s))
1767 } else if (prog->reganch & ROPT_ANCH_GPOS) {
1768 if (regtry(®info, reginfo.ganch))
1773 /* Messy cases: unanchored match. */
1774 if ((prog->anchored_substr || prog->anchored_utf8) && prog->reganch & ROPT_SKIP) {
1775 /* we have /x+whatever/ */
1776 /* it must be a one character string (XXXX Except UTF?) */
1781 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1782 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1783 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1786 while (s < strend) {
1788 DEBUG_EXECUTE_r( did_match = 1 );
1789 if (regtry(®info, s)) goto got_it;
1791 while (s < strend && *s == ch)
1798 while (s < strend) {
1800 DEBUG_EXECUTE_r( did_match = 1 );
1801 if (regtry(®info, s)) goto got_it;
1803 while (s < strend && *s == ch)
1809 DEBUG_EXECUTE_r(if (!did_match)
1810 PerlIO_printf(Perl_debug_log,
1811 "Did not find anchored character...\n")
1814 else if (prog->anchored_substr != NULL
1815 || prog->anchored_utf8 != NULL
1816 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1817 && prog->float_max_offset < strend - s)) {
1822 char *last1; /* Last position checked before */
1826 if (prog->anchored_substr || prog->anchored_utf8) {
1827 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1828 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1829 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1830 back_max = back_min = prog->anchored_offset;
1832 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1833 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1834 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1835 back_max = prog->float_max_offset;
1836 back_min = prog->float_min_offset;
1838 if (must == &PL_sv_undef)
1839 /* could not downgrade utf8 check substring, so must fail */
1842 last = HOP3c(strend, /* Cannot start after this */
1843 -(I32)(CHR_SVLEN(must)
1844 - (SvTAIL(must) != 0) + back_min), strbeg);
1847 last1 = HOPc(s, -1);
1849 last1 = s - 1; /* bogus */
1851 /* XXXX check_substr already used to find "s", can optimize if
1852 check_substr==must. */
1854 dontbother = end_shift;
1855 strend = HOPc(strend, -dontbother);
1856 while ( (s <= last) &&
1857 ((flags & REXEC_SCREAM)
1858 ? (s = screaminstr(sv, must, HOP3c(s, back_min, strend) - strbeg,
1859 end_shift, &scream_pos, 0))
1860 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, strend),
1861 (unsigned char*)strend, must,
1862 multiline ? FBMrf_MULTILINE : 0))) ) {
1863 /* we may be pointing at the wrong string */
1864 if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
1865 s = strbeg + (s - SvPVX_const(sv));
1866 DEBUG_EXECUTE_r( did_match = 1 );
1867 if (HOPc(s, -back_max) > last1) {
1868 last1 = HOPc(s, -back_min);
1869 s = HOPc(s, -back_max);
1872 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
1874 last1 = HOPc(s, -back_min);
1878 while (s <= last1) {
1879 if (regtry(®info, s))
1885 while (s <= last1) {
1886 if (regtry(®info, s))
1892 DEBUG_EXECUTE_r(if (!did_match)
1893 PerlIO_printf(Perl_debug_log,
1894 "Did not find %s substr \"%s%.*s%s\"%s...\n",
1895 ((must == prog->anchored_substr || must == prog->anchored_utf8)
1896 ? "anchored" : "floating"),
1898 (int)(SvCUR(must) - (SvTAIL(must)!=0)),
1900 PL_colors[1], (SvTAIL(must) ? "$" : ""))
1904 else if ((c = prog->regstclass)) {
1906 I32 op = (U8)OP(prog->regstclass);
1907 /* don't bother with what can't match */
1908 if (PL_regkind[op] != EXACT && op != CANY)
1909 strend = HOPc(strend, -(minlen - 1));
1912 SV *prop = sv_newmortal();
1918 regprop(prog, prop, c);
1920 pv_uni_display(dsv0, (U8*)SvPVX_const(prop), SvCUR(prop), 60,
1921 UNI_DISPLAY_REGEX) :
1923 len0 = UTF ? SvCUR(dsv0) : SvCUR(prop);
1925 sv_uni_display(dsv1, sv, 60, UNI_DISPLAY_REGEX) : s;
1926 len1 = UTF ? SvCUR(dsv1) : strend - s;
1927 PerlIO_printf(Perl_debug_log,
1928 "Matching stclass \"%*.*s\" against \"%*.*s\"\n",
1932 if (find_byclass(prog, c, s, strend, ®info))
1934 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass...\n"));
1938 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
1943 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1944 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1945 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
1947 if (flags & REXEC_SCREAM) {
1948 last = screaminstr(sv, float_real, s - strbeg,
1949 end_shift, &scream_pos, 1); /* last one */
1951 last = scream_olds; /* Only one occurrence. */
1952 /* we may be pointing at the wrong string */
1953 else if (RX_MATCH_COPIED(prog))
1954 s = strbeg + (s - SvPVX_const(sv));
1958 const char * const little = SvPV_const(float_real, len);
1960 if (SvTAIL(float_real)) {
1961 if (memEQ(strend - len + 1, little, len - 1))
1962 last = strend - len + 1;
1963 else if (!multiline)
1964 last = memEQ(strend - len, little, len)
1965 ? strend - len : NULL;
1971 last = rninstr(s, strend, little, little + len);
1973 last = strend; /* matching "$" */
1977 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1978 "%sCan't trim the tail, match fails (should not happen)%s\n",
1979 PL_colors[4], PL_colors[5]));
1980 goto phooey; /* Should not happen! */
1982 dontbother = strend - last + prog->float_min_offset;
1984 if (minlen && (dontbother < minlen))
1985 dontbother = minlen - 1;
1986 strend -= dontbother; /* this one's always in bytes! */
1987 /* We don't know much -- general case. */
1990 if (regtry(®info, s))
1999 if (regtry(®info, s))
2001 } while (s++ < strend);
2009 RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2011 if (PL_reg_eval_set) {
2012 /* Preserve the current value of $^R */
2013 if (oreplsv != GvSV(PL_replgv))
2014 sv_setsv(oreplsv, GvSV(PL_replgv));/* So that when GvSV(replgv) is
2015 restored, the value remains
2017 restore_pos(aTHX_ prog);
2020 /* make sure $`, $&, $', and $digit will work later */
2021 if ( !(flags & REXEC_NOT_FIRST) ) {
2022 RX_MATCH_COPY_FREE(prog);
2023 if (flags & REXEC_COPY_STR) {
2024 I32 i = PL_regeol - startpos + (stringarg - strbeg);
2025 #ifdef PERL_OLD_COPY_ON_WRITE
2027 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2029 PerlIO_printf(Perl_debug_log,
2030 "Copy on write: regexp capture, type %d\n",
2033 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2034 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2035 assert (SvPOKp(prog->saved_copy));
2039 RX_MATCH_COPIED_on(prog);
2040 s = savepvn(strbeg, i);
2046 prog->subbeg = strbeg;
2047 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2054 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2055 PL_colors[4], PL_colors[5]));
2056 if (PL_reg_eval_set)
2057 restore_pos(aTHX_ prog);
2062 - regtry - try match at specific point
2064 STATIC I32 /* 0 failure, 1 success */
2065 S_regtry(pTHX_ const regmatch_info *reginfo, char *startpos)
2071 regexp *prog = reginfo->prog;
2072 GET_RE_DEBUG_FLAGS_DECL;
2075 PL_regindent = 0; /* XXXX Not good when matches are reenterable... */
2077 if ((prog->reganch & ROPT_EVAL_SEEN) && !PL_reg_eval_set) {
2080 PL_reg_eval_set = RS_init;
2081 DEBUG_EXECUTE_r(DEBUG_s(
2082 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2083 (IV)(PL_stack_sp - PL_stack_base));
2085 SAVEI32(cxstack[cxstack_ix].blk_oldsp);
2086 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2087 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2089 /* Apparently this is not needed, judging by wantarray. */
2090 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2091 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2094 /* Make $_ available to executed code. */
2095 if (reginfo->sv != DEFSV) {
2097 DEFSV = reginfo->sv;
2100 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2101 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2102 /* prepare for quick setting of pos */
2103 #ifdef PERL_OLD_COPY_ON_WRITE
2105 sv_force_normal_flags(sv, 0);
2107 mg = sv_magicext(reginfo->sv, (SV*)0, PERL_MAGIC_regex_global,
2108 &PL_vtbl_mglob, NULL, 0);
2112 PL_reg_oldpos = mg->mg_len;
2113 SAVEDESTRUCTOR_X(restore_pos, prog);
2115 if (!PL_reg_curpm) {
2116 Newxz(PL_reg_curpm, 1, PMOP);
2119 SV* repointer = newSViv(0);
2120 /* so we know which PL_regex_padav element is PL_reg_curpm */
2121 SvFLAGS(repointer) |= SVf_BREAK;
2122 av_push(PL_regex_padav,repointer);
2123 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2124 PL_regex_pad = AvARRAY(PL_regex_padav);
2128 PM_SETRE(PL_reg_curpm, prog);
2129 PL_reg_oldcurpm = PL_curpm;
2130 PL_curpm = PL_reg_curpm;
2131 if (RX_MATCH_COPIED(prog)) {
2132 /* Here is a serious problem: we cannot rewrite subbeg,
2133 since it may be needed if this match fails. Thus
2134 $` inside (?{}) could fail... */
2135 PL_reg_oldsaved = prog->subbeg;
2136 PL_reg_oldsavedlen = prog->sublen;
2137 #ifdef PERL_OLD_COPY_ON_WRITE
2138 PL_nrs = prog->saved_copy;
2140 RX_MATCH_COPIED_off(prog);
2143 PL_reg_oldsaved = NULL;
2144 prog->subbeg = PL_bostr;
2145 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2147 prog->startp[0] = startpos - PL_bostr;
2148 PL_reginput = startpos;
2149 PL_regstartp = prog->startp;
2150 PL_regendp = prog->endp;
2151 PL_reglastparen = &prog->lastparen;
2152 PL_reglastcloseparen = &prog->lastcloseparen;
2153 prog->lastparen = 0;
2154 prog->lastcloseparen = 0;
2156 DEBUG_EXECUTE_r(PL_reg_starttry = startpos);
2157 if (PL_reg_start_tmpl <= prog->nparens) {
2158 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2159 if(PL_reg_start_tmp)
2160 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2162 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2165 /* XXXX What this code is doing here?!!! There should be no need
2166 to do this again and again, PL_reglastparen should take care of
2169 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2170 * Actually, the code in regcppop() (which Ilya may be meaning by
2171 * PL_reglastparen), is not needed at all by the test suite
2172 * (op/regexp, op/pat, op/split), but that code is needed, oddly
2173 * enough, for building DynaLoader, or otherwise this
2174 * "Error: '*' not in typemap in DynaLoader.xs, line 164"
2175 * will happen. Meanwhile, this code *is* needed for the
2176 * above-mentioned test suite tests to succeed. The common theme
2177 * on those tests seems to be returning null fields from matches.
2182 if (prog->nparens) {
2184 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2191 if (regmatch(reginfo, prog->program + 1)) {
2192 prog->endp[0] = PL_reginput - PL_bostr;
2195 REGCP_UNWIND(lastcp);
2199 #define RE_UNWIND_BRANCH 1
2200 #define RE_UNWIND_BRANCHJ 2
2204 typedef struct { /* XX: makes sense to enlarge it... */
2208 } re_unwind_generic_t;
2222 } re_unwind_branch_t;
2224 typedef union re_unwind_t {
2226 re_unwind_generic_t generic;
2227 re_unwind_branch_t branch;
2230 #define sayYES goto yes
2231 #define sayNO goto no
2232 #define sayNO_ANYOF goto no_anyof
2233 #define sayYES_FINAL goto yes_final
2234 #define sayNO_FINAL goto no_final
2235 #define sayNO_SILENT goto do_no
2236 #define saySAME(x) if (x) goto yes; else goto no
2238 #define POSCACHE_SUCCESS 0 /* caching success rather than failure */
2239 #define POSCACHE_SEEN 1 /* we know what we're caching */
2240 #define POSCACHE_START 2 /* the real cache: this bit maps to pos 0 */
2242 #define CACHEsayYES STMT_START { \
2243 if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2244 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2245 PL_reg_poscache[0] |= (1<<POSCACHE_SUCCESS) | (1<<POSCACHE_SEEN); \
2246 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2248 else if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS)) { \
2249 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2252 /* cache records failure, but this is success */ \
2254 PerlIO_printf(Perl_debug_log, \
2255 "%*s (remove success from failure cache)\n", \
2256 REPORT_CODE_OFF+PL_regindent*2, "") \
2258 PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2264 #define CACHEsayNO STMT_START { \
2265 if (st->u.whilem.cache_offset | st->u.whilem.cache_bit) { \
2266 if (!(PL_reg_poscache[0] & (1<<POSCACHE_SEEN))) { \
2267 PL_reg_poscache[0] |= (1<<POSCACHE_SEEN); \
2268 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2270 else if (!(PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))) { \
2271 PL_reg_poscache[st->u.whilem.cache_offset] |= (1<<st->u.whilem.cache_bit); \
2274 /* cache records success, but this is failure */ \
2276 PerlIO_printf(Perl_debug_log, \
2277 "%*s (remove failure from success cache)\n", \
2278 REPORT_CODE_OFF+PL_regindent*2, "") \
2280 PL_reg_poscache[st->u.whilem.cache_offset] &= ~(1<<st->u.whilem.cache_bit); \
2286 /* this is used to determine how far from the left messages like
2287 'failed...' are printed. Currently 29 makes these messages line
2288 up with the opcode they refer to. Earlier perls used 25 which
2289 left these messages outdented making reviewing a debug output
2292 #define REPORT_CODE_OFF 29
2295 /* Make sure there is a test for this +1 options in re_tests */
2296 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2298 /* this value indiciates that the c1/c2 "next char" test should be skipped */
2299 #define CHRTEST_VOID -1000
2301 #define SLAB_FIRST(s) (&(s)->states[0])
2302 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2304 /* grab a new slab and return the first slot in it */
2306 STATIC regmatch_state *
2309 regmatch_slab *s = PL_regmatch_slab->next;
2311 Newx(s, 1, regmatch_slab);
2312 s->prev = PL_regmatch_slab;
2314 PL_regmatch_slab->next = s;
2316 PL_regmatch_slab = s;
2317 return SLAB_FIRST(s);
2320 /* simulate a recursive call to regmatch */
2322 #define REGMATCH(ns, where) \
2325 st->resume_state = resume_##where; \
2326 goto start_recurse; \
2327 resume_point_##where:
2330 /* push a new regex state. Set newst to point to it */
2332 #define PUSH_STATE(newst, resume) \
2334 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "PUSH STATE(%d)\n", depth)); \
2338 st->locinput = locinput; \
2339 st->resume_state = resume; \
2341 if (newst > SLAB_LAST(PL_regmatch_slab)) \
2342 newst = S_push_slab(aTHX); \
2343 PL_regmatch_state = newst; \
2345 newst->minmod = 0; \
2347 newst->logical = 0; \
2348 newst->unwind = 0; \
2349 locinput = PL_reginput; \
2350 nextchr = UCHARAT(locinput);
2353 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE(%d)\n", depth)); \
2356 if (st < SLAB_FIRST(PL_regmatch_slab)) { \
2357 PL_regmatch_slab = PL_regmatch_slab->prev; \
2358 st = SLAB_LAST(PL_regmatch_slab); \
2360 PL_regmatch_state = st; \
2364 locinput = st->locinput; \
2365 nextchr = UCHARAT(locinput);
2368 - regmatch - main matching routine
2370 * Conceptually the strategy is simple: check to see whether the current
2371 * node matches, call self recursively to see whether the rest matches,
2372 * and then act accordingly. In practice we make some effort to avoid
2373 * recursion, in particular by going through "ordinary" nodes (that don't
2374 * need to know whether the rest of the match failed) by a loop instead of
2377 /* [lwall] I've hoisted the register declarations to the outer block in order to
2378 * maybe save a little bit of pushing and popping on the stack. It also takes
2379 * advantage of machines that use a register save mask on subroutine entry.
2381 * This function used to be heavily recursive, but since this had the
2382 * effect of blowing the CPU stack on complex regexes, it has been
2383 * restructured to be iterative, and to save state onto the heap rather
2384 * than the stack. Essentially whereever regmatch() used to be called, it
2385 * pushes the current state, notes where to return, then jumps back into
2388 * Originally the structure of this function used to look something like
2393 while (scan != NULL) {
2394 a++; // do stuff with a and b
2400 if (regmatch(...)) // recurse
2410 * Now it looks something like this:
2418 regmatch_state *st = new();
2420 st->a++; // do stuff with a and b
2422 while (scan != NULL) {
2430 st->resume_state = resume_FOO;
2431 goto start_recurse; // recurse
2440 st = new(); push a new state
2441 st->a = 1; st->b = 2;
2448 switch (resume_state) {
2450 goto resume_point_FOO;
2457 * WARNING: this means that any line in this function that contains a
2458 * REGMATCH() or TRYPAREN() is actually simulating a recursive call to
2459 * regmatch() using gotos instead. Thus the values of any local variables
2460 * not saved in the regmatch_state structure will have been lost when
2461 * execution resumes on the next line .
2463 * States (ie the st pointer) are allocated in slabs of about 4K in size.
2464 * PL_regmatch_state always points to the currently active state, and
2465 * PL_regmatch_slab points to the slab currently containing PL_regmatch_state.
2466 * The first time regmatch is called, the first slab is allocated, and is
2467 * never freed until interpreter desctruction. When the slab is full,
2468 * a new one is allocated chained to the end. At exit from regmatch, slabs
2469 * allocated since entry are freed.
2473 STATIC I32 /* 0 failure, 1 success */
2474 S_regmatch(pTHX_ const regmatch_info *reginfo, regnode *prog)
2477 register const bool do_utf8 = PL_reg_match_utf8;
2478 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2480 regexp *rex = reginfo->prog;
2482 regmatch_slab *orig_slab;
2483 regmatch_state *orig_state;
2485 /* the current state. This is a cached copy of PL_regmatch_state */
2486 register regmatch_state *st;
2488 /* cache heavy used fields of st in registers */
2489 register regnode *scan;
2490 register regnode *next;
2491 register I32 n = 0; /* initialize to shut up compiler warning */
2492 register char *locinput = PL_reginput;
2494 /* these variables are NOT saved during a recusive RFEGMATCH: */
2495 register I32 nextchr; /* is always set to UCHARAT(locinput) */
2496 bool result; /* return value of S_regmatch */
2497 regnode *inner; /* Next node in internal branch. */
2498 int depth = 0; /* depth of recursion */
2499 regmatch_state *newst; /* when pushing a state, this is the new one */
2500 regmatch_state *yes_state = NULL; /* state to pop to on success of
2504 SV *re_debug_flags = NULL;
2509 /* on first ever call to regmatch, allocate first slab */
2510 if (!PL_regmatch_slab) {
2511 Newx(PL_regmatch_slab, 1, regmatch_slab);
2512 PL_regmatch_slab->prev = NULL;
2513 PL_regmatch_slab->next = NULL;
2514 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2517 /* remember current high-water mark for exit */
2518 /* XXX this should be done with SAVE* instead */
2519 orig_slab = PL_regmatch_slab;
2520 orig_state = PL_regmatch_state;
2522 /* grab next free state slot */
2523 st = ++PL_regmatch_state;
2524 if (st > SLAB_LAST(PL_regmatch_slab))
2525 st = PL_regmatch_state = S_push_slab(aTHX);
2532 /* Note that nextchr is a byte even in UTF */
2533 nextchr = UCHARAT(locinput);
2535 while (scan != NULL) {
2538 SV * const prop = sv_newmortal();
2539 const int docolor = *PL_colors[0];
2540 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2541 int l = (PL_regeol - locinput) > taill ? taill : (PL_regeol - locinput);
2542 /* The part of the string before starttry has one color
2543 (pref0_len chars), between starttry and current
2544 position another one (pref_len - pref0_len chars),
2545 after the current position the third one.
2546 We assume that pref0_len <= pref_len, otherwise we
2547 decrease pref0_len. */
2548 int pref_len = (locinput - PL_bostr) > (5 + taill) - l
2549 ? (5 + taill) - l : locinput - PL_bostr;
2552 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2554 pref0_len = pref_len - (locinput - PL_reg_starttry);
2555 if (l + pref_len < (5 + taill) && l < PL_regeol - locinput)
2556 l = ( PL_regeol - locinput > (5 + taill) - pref_len
2557 ? (5 + taill) - pref_len : PL_regeol - locinput);
2558 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2562 if (pref0_len > pref_len)
2563 pref0_len = pref_len;
2564 regprop(rex, prop, scan);
2566 const char * const s0 =
2567 do_utf8 && OP(scan) != CANY ?
2568 pv_uni_display(PERL_DEBUG_PAD(0), (U8*)(locinput - pref_len),
2569 pref0_len, 60, UNI_DISPLAY_REGEX) :
2570 locinput - pref_len;
2571 const int len0 = do_utf8 ? strlen(s0) : pref0_len;
2572 const char * const s1 = do_utf8 && OP(scan) != CANY ?
2573 pv_uni_display(PERL_DEBUG_PAD(1),
2574 (U8*)(locinput - pref_len + pref0_len),
2575 pref_len - pref0_len, 60, UNI_DISPLAY_REGEX) :
2576 locinput - pref_len + pref0_len;
2577 const int len1 = do_utf8 ? strlen(s1) : pref_len - pref0_len;
2578 const char * const s2 = do_utf8 && OP(scan) != CANY ?
2579 pv_uni_display(PERL_DEBUG_PAD(2), (U8*)locinput,
2580 PL_regeol - locinput, 60, UNI_DISPLAY_REGEX) :
2582 const int len2 = do_utf8 ? strlen(s2) : l;
2583 PerlIO_printf(Perl_debug_log,
2584 "%4"IVdf" <%s%.*s%s%s%.*s%s%s%s%.*s%s>%*s|%3"IVdf":%*s%s\n",
2585 (IV)(locinput - PL_bostr),
2592 (docolor ? "" : "> <"),
2596 15 - l - pref_len + 1,
2598 (IV)(scan - rex->program), PL_regindent*2, "",
2603 next = scan + NEXT_OFF(scan);
2609 if (locinput == PL_bostr)
2611 /* reginfo->till = reginfo->bol; */
2616 if (locinput == PL_bostr ||
2617 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2623 if (locinput == PL_bostr)
2627 if (locinput == reginfo->ganch)
2633 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2638 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2640 if (PL_regeol - locinput > 1)
2644 if (PL_regeol != locinput)
2648 if (!nextchr && locinput >= PL_regeol)
2651 locinput += PL_utf8skip[nextchr];
2652 if (locinput > PL_regeol)
2654 nextchr = UCHARAT(locinput);
2657 nextchr = UCHARAT(++locinput);
2660 if (!nextchr && locinput >= PL_regeol)
2662 nextchr = UCHARAT(++locinput);
2665 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2668 locinput += PL_utf8skip[nextchr];
2669 if (locinput > PL_regeol)
2671 nextchr = UCHARAT(locinput);
2674 nextchr = UCHARAT(++locinput);
2680 traverse the TRIE keeping track of all accepting states
2681 we transition through until we get to a failing node.
2689 U8 *uc = ( U8* )locinput;
2696 U8 *uscan = (U8*)NULL;
2698 SV *sv_accept_buff = NULL;
2699 const enum { trie_plain, trie_utf8, trie_uft8_fold }
2700 trie_type = do_utf8 ?
2701 (OP(scan) == TRIE ? trie_utf8 : trie_uft8_fold)
2704 /* what trie are we using right now */
2706 = (reg_trie_data*)rex->data->data[ ARG( scan ) ];
2707 st->u.trie.accepted = 0; /* how many accepting states we have seen */
2710 while ( state && uc <= (U8*)PL_regeol ) {
2712 if (trie->states[ state ].wordnum) {
2713 if (!st->u.trie.accepted ) {
2716 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2717 sv_accept_buff=newSV(bufflen *
2718 sizeof(reg_trie_accepted) - 1);
2719 SvCUR_set(sv_accept_buff,
2720 sizeof(reg_trie_accepted));
2721 SvPOK_on(sv_accept_buff);
2722 sv_2mortal(sv_accept_buff);
2723 st->u.trie.accept_buff =
2724 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2727 if (st->u.trie.accepted >= bufflen) {
2729 st->u.trie.accept_buff =(reg_trie_accepted*)
2730 SvGROW(sv_accept_buff,
2731 bufflen * sizeof(reg_trie_accepted));
2733 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2734 + sizeof(reg_trie_accepted));
2736 st->u.trie.accept_buff[st->u.trie.accepted].wordnum = trie->states[state].wordnum;
2737 st->u.trie.accept_buff[st->u.trie.accepted].endpos = uc;
2738 ++st->u.trie.accepted;
2741 base = trie->states[ state ].trans.base;
2743 DEBUG_TRIE_EXECUTE_r(
2744 PerlIO_printf( Perl_debug_log,
2745 "%*s %sState: %4"UVxf", Base: %4"UVxf", Accepted: %4"UVxf" ",
2746 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2747 (UV)state, (UV)base, (UV)st->u.trie.accepted );
2751 switch (trie_type) {
2752 case trie_uft8_fold:
2754 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags );
2759 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2760 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags );
2761 uvc = to_uni_fold( uvc, foldbuf, &foldlen );
2762 foldlen -= UNISKIP( uvc );
2763 uscan = foldbuf + UNISKIP( uvc );
2767 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN,
2776 charid = trie->charmap[ uvc ];
2780 if (trie->widecharmap) {
2781 SV** svpp = (SV**)NULL;
2782 svpp = hv_fetch(trie->widecharmap,
2783 (char*)&uvc, sizeof(UV), 0);
2785 charid = (U16)SvIV(*svpp);
2790 (base + charid > trie->uniquecharcount )
2791 && (base + charid - 1 - trie->uniquecharcount
2793 && trie->trans[base + charid - 1 -
2794 trie->uniquecharcount].check == state)
2796 state = trie->trans[base + charid - 1 -
2797 trie->uniquecharcount ].next;
2808 DEBUG_TRIE_EXECUTE_r(
2809 PerlIO_printf( Perl_debug_log,
2810 "Charid:%3x CV:%4"UVxf" After State: %4"UVxf"%s\n",
2811 charid, uvc, (UV)state, PL_colors[5] );
2814 if (!st->u.trie.accepted )
2818 There was at least one accepting state that we
2819 transitioned through. Presumably the number of accepting
2820 states is going to be low, typically one or two. So we
2821 simply scan through to find the one with lowest wordnum.
2822 Once we find it, we swap the last state into its place
2823 and decrement the size. We then try to match the rest of
2824 the pattern at the point where the word ends, if we
2825 succeed then we end the loop, otherwise the loop
2826 eventually terminates once all of the accepting states
2830 if ( st->u.trie.accepted == 1 ) {
2832 SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ 0 ].wordnum-1, 0 );
2833 PerlIO_printf( Perl_debug_log,
2834 "%*s %sonly one match : #%d <%s>%s\n",
2835 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2836 st->u.trie.accept_buff[ 0 ].wordnum,
2837 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",
2840 PL_reginput = (char *)st->u.trie.accept_buff[ 0 ].endpos;
2841 /* in this case we free tmps/leave before we call regmatch
2842 as we wont be using accept_buff again. */
2845 REGMATCH(scan + NEXT_OFF(scan), TRIE1);
2846 /*** all unsaved local vars undefined at this point */
2849 PerlIO_printf( Perl_debug_log,"%*s %sgot %"IVdf" possible matches%s\n",
2850 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4], (IV)st->u.trie.accepted,
2853 while ( !result && st->u.trie.accepted-- ) {
2856 for( cur = 1 ; cur <= st->u.trie.accepted ; cur++ ) {
2857 DEBUG_TRIE_EXECUTE_r(
2858 PerlIO_printf( Perl_debug_log,
2859 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
2860 REPORT_CODE_OFF + PL_regindent * 2, "", PL_colors[4],
2861 (IV)best, st->u.trie.accept_buff[ best ].wordnum, (IV)cur,
2862 st->u.trie.accept_buff[ cur ].wordnum, PL_colors[5] );
2865 if (st->u.trie.accept_buff[cur].wordnum <
2866 st->u.trie.accept_buff[best].wordnum)
2870 reg_trie_data * const trie = (reg_trie_data*)
2871 rex->data->data[ARG(scan)];
2872 SV ** const tmp = av_fetch( trie->words, st->u.trie.accept_buff[ best ].wordnum - 1, 0 );
2873 PerlIO_printf( Perl_debug_log, "%*s %strying alternation #%d <%s> at 0x%p%s\n",
2874 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4],
2875 st->u.trie.accept_buff[best].wordnum,
2876 tmp ? SvPV_nolen_const( *tmp ) : "not compiled under -Dr",scan,
2879 if ( best<st->u.trie.accepted ) {
2880 reg_trie_accepted tmp = st->u.trie.accept_buff[ best ];
2881 st->u.trie.accept_buff[ best ] = st->u.trie.accept_buff[ st->u.trie.accepted ];
2882 st->u.trie.accept_buff[ st->u.trie.accepted ] = tmp;
2883 best = st->u.trie.accepted;
2885 PL_reginput = (char *)st->u.trie.accept_buff[ best ].endpos;
2888 as far as I can tell we only need the SAVETMPS/FREETMPS
2889 for re's with EVAL in them but I'm leaving them in for
2890 all until I can be sure.
2893 REGMATCH(scan + NEXT_OFF(scan), TRIE2);
2894 /*** all unsaved local vars undefined at this point */
2907 /* unreached codepoint */
2909 char *s = STRING(scan);
2910 st->ln = STR_LEN(scan);
2911 if (do_utf8 != UTF) {
2912 /* The target and the pattern have differing utf8ness. */
2914 const char *e = s + st->ln;
2917 /* The target is utf8, the pattern is not utf8. */
2922 if (NATIVE_TO_UNI(*(U8*)s) !=
2923 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
2931 /* The target is not utf8, the pattern is utf8. */
2936 if (NATIVE_TO_UNI(*((U8*)l)) !=
2937 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
2945 nextchr = UCHARAT(locinput);
2948 /* The target and the pattern have the same utf8ness. */
2949 /* Inline the first character, for speed. */
2950 if (UCHARAT(s) != nextchr)
2952 if (PL_regeol - locinput < st->ln)
2954 if (st->ln > 1 && memNE(s, locinput, st->ln))
2957 nextchr = UCHARAT(locinput);
2961 PL_reg_flags |= RF_tainted;
2964 char *s = STRING(scan);
2965 st->ln = STR_LEN(scan);
2967 if (do_utf8 || UTF) {
2968 /* Either target or the pattern are utf8. */
2970 char *e = PL_regeol;
2972 if (ibcmp_utf8(s, 0, st->ln, (bool)UTF,
2973 l, &e, 0, do_utf8)) {
2974 /* One more case for the sharp s:
2975 * pack("U0U*", 0xDF) =~ /ss/i,
2976 * the 0xC3 0x9F are the UTF-8
2977 * byte sequence for the U+00DF. */
2979 toLOWER(s[0]) == 's' &&
2981 toLOWER(s[1]) == 's' &&
2988 nextchr = UCHARAT(locinput);
2992 /* Neither the target and the pattern are utf8. */
2994 /* Inline the first character, for speed. */
2995 if (UCHARAT(s) != nextchr &&
2996 UCHARAT(s) != ((OP(scan) == EXACTF)
2997 ? PL_fold : PL_fold_locale)[nextchr])
2999 if (PL_regeol - locinput < st->ln)
3001 if (st->ln > 1 && (OP(scan) == EXACTF
3002 ? ibcmp(s, locinput, st->ln)
3003 : ibcmp_locale(s, locinput, st->ln)))
3006 nextchr = UCHARAT(locinput);
3011 STRLEN inclasslen = PL_regeol - locinput;
3013 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3015 if (locinput >= PL_regeol)
3017 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3018 nextchr = UCHARAT(locinput);
3023 nextchr = UCHARAT(locinput);
3024 if (!REGINCLASS(rex, scan, (U8*)locinput))
3026 if (!nextchr && locinput >= PL_regeol)
3028 nextchr = UCHARAT(++locinput);
3032 /* If we might have the case of the German sharp s
3033 * in a casefolding Unicode character class. */
3035 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3036 locinput += SHARP_S_SKIP;
3037 nextchr = UCHARAT(locinput);
3043 PL_reg_flags |= RF_tainted;
3049 LOAD_UTF8_CHARCLASS_ALNUM();
3050 if (!(OP(scan) == ALNUM
3051 ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3052 : isALNUM_LC_utf8((U8*)locinput)))
3056 locinput += PL_utf8skip[nextchr];
3057 nextchr = UCHARAT(locinput);
3060 if (!(OP(scan) == ALNUM
3061 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3063 nextchr = UCHARAT(++locinput);
3066 PL_reg_flags |= RF_tainted;
3069 if (!nextchr && locinput >= PL_regeol)
3072 LOAD_UTF8_CHARCLASS_ALNUM();
3073 if (OP(scan) == NALNUM
3074 ? swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3075 : isALNUM_LC_utf8((U8*)locinput))
3079 locinput += PL_utf8skip[nextchr];
3080 nextchr = UCHARAT(locinput);
3083 if (OP(scan) == NALNUM
3084 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3086 nextchr = UCHARAT(++locinput);
3090 PL_reg_flags |= RF_tainted;
3094 /* was last char in word? */
3096 if (locinput == PL_bostr)
3099 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3101 st->ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3103 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3104 st->ln = isALNUM_uni(st->ln);
3105 LOAD_UTF8_CHARCLASS_ALNUM();
3106 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3109 st->ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(st->ln));
3110 n = isALNUM_LC_utf8((U8*)locinput);
3114 st->ln = (locinput != PL_bostr) ?
3115 UCHARAT(locinput - 1) : '\n';
3116 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3117 st->ln = isALNUM(st->ln);
3118 n = isALNUM(nextchr);
3121 st->ln = isALNUM_LC(st->ln);
3122 n = isALNUM_LC(nextchr);
3125 if (((!st->ln) == (!n)) == (OP(scan) == BOUND ||
3126 OP(scan) == BOUNDL))
3130 PL_reg_flags |= RF_tainted;
3136 if (UTF8_IS_CONTINUED(nextchr)) {
3137 LOAD_UTF8_CHARCLASS_SPACE();
3138 if (!(OP(scan) == SPACE
3139 ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3140 : isSPACE_LC_utf8((U8*)locinput)))
3144 locinput += PL_utf8skip[nextchr];
3145 nextchr = UCHARAT(locinput);
3148 if (!(OP(scan) == SPACE
3149 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3151 nextchr = UCHARAT(++locinput);
3154 if (!(OP(scan) == SPACE
3155 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3157 nextchr = UCHARAT(++locinput);
3161 PL_reg_flags |= RF_tainted;
3164 if (!nextchr && locinput >= PL_regeol)
3167 LOAD_UTF8_CHARCLASS_SPACE();
3168 if (OP(scan) == NSPACE
3169 ? swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3170 : isSPACE_LC_utf8((U8*)locinput))
3174 locinput += PL_utf8skip[nextchr];
3175 nextchr = UCHARAT(locinput);
3178 if (OP(scan) == NSPACE
3179 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3181 nextchr = UCHARAT(++locinput);
3184 PL_reg_flags |= RF_tainted;
3190 LOAD_UTF8_CHARCLASS_DIGIT();
3191 if (!(OP(scan) == DIGIT
3192 ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3193 : isDIGIT_LC_utf8((U8*)locinput)))
3197 locinput += PL_utf8skip[nextchr];
3198 nextchr = UCHARAT(locinput);
3201 if (!(OP(scan) == DIGIT
3202 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3204 nextchr = UCHARAT(++locinput);
3207 PL_reg_flags |= RF_tainted;
3210 if (!nextchr && locinput >= PL_regeol)
3213 LOAD_UTF8_CHARCLASS_DIGIT();
3214 if (OP(scan) == NDIGIT
3215 ? swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3216 : isDIGIT_LC_utf8((U8*)locinput))
3220 locinput += PL_utf8skip[nextchr];
3221 nextchr = UCHARAT(locinput);
3224 if (OP(scan) == NDIGIT
3225 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3227 nextchr = UCHARAT(++locinput);
3230 if (locinput >= PL_regeol)
3233 LOAD_UTF8_CHARCLASS_MARK();
3234 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3236 locinput += PL_utf8skip[nextchr];
3237 while (locinput < PL_regeol &&
3238 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3239 locinput += UTF8SKIP(locinput);
3240 if (locinput > PL_regeol)
3245 nextchr = UCHARAT(locinput);
3248 PL_reg_flags |= RF_tainted;
3253 n = ARG(scan); /* which paren pair */
3254 st->ln = PL_regstartp[n];
3255 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3256 if ((I32)*PL_reglastparen < n || st->ln == -1)
3257 sayNO; /* Do not match unless seen CLOSEn. */
3258 if (st->ln == PL_regendp[n])
3261 s = PL_bostr + st->ln;
3262 if (do_utf8 && OP(scan) != REF) { /* REF can do byte comparison */
3264 const char *e = PL_bostr + PL_regendp[n];
3266 * Note that we can't do the "other character" lookup trick as
3267 * in the 8-bit case (no pun intended) because in Unicode we
3268 * have to map both upper and title case to lower case.
3270 if (OP(scan) == REFF) {
3272 STRLEN ulen1, ulen2;
3273 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3274 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3278 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3279 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3280 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3287 nextchr = UCHARAT(locinput);
3291 /* Inline the first character, for speed. */
3292 if (UCHARAT(s) != nextchr &&
3294 (UCHARAT(s) != ((OP(scan) == REFF
3295 ? PL_fold : PL_fold_locale)[nextchr]))))
3297 st->ln = PL_regendp[n] - st->ln;
3298 if (locinput + st->ln > PL_regeol)
3300 if (st->ln > 1 && (OP(scan) == REF
3301 ? memNE(s, locinput, st->ln)
3303 ? ibcmp(s, locinput, st->ln)
3304 : ibcmp_locale(s, locinput, st->ln))))
3307 nextchr = UCHARAT(locinput);
3320 /* execute the code in the {...} */
3322 SV ** const before = SP;
3323 OP_4tree * const oop = PL_op;
3324 COP * const ocurcop = PL_curcop;
3328 PL_op = (OP_4tree*)rex->data->data[n];
3329 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log, " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3330 PAD_SAVE_LOCAL(old_comppad, (PAD*)rex->data->data[n + 2]);
3331 PL_regendp[0] = PL_reg_magic->mg_len = locinput - PL_bostr;
3333 CALLRUNOPS(aTHX); /* Scalar context. */
3336 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
3343 PAD_RESTORE_LOCAL(old_comppad);
3344 PL_curcop = ocurcop;
3347 sv_setsv(save_scalar(PL_replgv), ret);
3351 if (st->logical == 2) { /* Postponed subexpression: /(??{...})/ */
3354 /* extract RE object from returned value; compiling if
3359 if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3360 mg = mg_find(sv, PERL_MAGIC_qr);
3361 else if (SvSMAGICAL(ret)) {
3362 if (SvGMAGICAL(ret))
3363 sv_unmagic(ret, PERL_MAGIC_qr);
3365 mg = mg_find(ret, PERL_MAGIC_qr);
3369 re = (regexp *)mg->mg_obj;
3370 (void)ReREFCNT_inc(re);
3374 const char * const t = SvPV_const(ret, len);
3376 const I32 osize = PL_regsize;
3379 if (DO_UTF8(ret)) pm.op_pmdynflags |= PMdf_DYN_UTF8;
3380 re = CALLREGCOMP(aTHX_ (char*)t, (char*)t + len, &pm);
3382 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3384 sv_magic(ret,(SV*)ReREFCNT_inc(re),
3390 /* run the pattern returned from (??{...}) */
3393 PerlIO_printf(Perl_debug_log,
3394 "Entering embedded \"%s%.60s%s%s\"\n",
3398 (strlen(re->precomp) > 60 ? "..." : ""))
3401 st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
3402 REGCP_SET(st->u.eval.lastcp);
3403 *PL_reglastparen = 0;
3404 *PL_reglastcloseparen = 0;
3405 PL_reginput = locinput;
3407 /* XXXX This is too dramatic a measure... */
3411 st->u.eval.toggleutf = ((PL_reg_flags & RF_utf8) != 0) ^
3412 ((re->reganch & ROPT_UTF8) != 0);
3413 if (st->u.eval.toggleutf) PL_reg_flags ^= RF_utf8;
3414 st->u.eval.prev_rex = rex;
3417 /* resume to current state on success */
3418 st->u.yes.prev_yes_state = yes_state;
3420 PUSH_STATE(newst, resume_EVAL);
3423 /* now continue from first node in postoned RE */
3424 next = re->program + 1;
3428 /* /(?(?{...})X|Y)/ */
3429 st->sw = SvTRUE(ret);
3434 n = ARG(scan); /* which paren pair */
3435 PL_reg_start_tmp[n] = locinput;
3440 n = ARG(scan); /* which paren pair */
3441 PL_regstartp[n] = PL_reg_start_tmp[n] - PL_bostr;
3442 PL_regendp[n] = locinput - PL_bostr;
3443 if (n > (I32)*PL_reglastparen)
3444 *PL_reglastparen = n;
3445 *PL_reglastcloseparen = n;
3448 n = ARG(scan); /* which paren pair */
3449 st->sw = ((I32)*PL_reglastparen >= n && PL_regendp[n] != -1);
3452 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3454 next = NEXTOPER(NEXTOPER(scan));
3456 next = scan + ARG(scan);
3457 if (OP(next) == IFTHEN) /* Fake one. */
3458 next = NEXTOPER(NEXTOPER(next));
3462 st->logical = scan->flags;
3464 /*******************************************************************
3465 cc points to the regmatch_state associated with the most recent CURLYX.
3466 This struct contains info about the innermost (...)* loop (an
3467 "infoblock"), and a pointer to the next outer cc.
3469 Here is how Y(A)*Z is processed (if it is compiled into CURLYX/WHILEM):
3471 1) After matching Y, regnode for CURLYX is processed;
3473 2) This regnode populates cc, and calls regmatch() recursively
3474 with the starting point at WHILEM node;
3476 3) Each hit of WHILEM node tries to match A and Z (in the order
3477 depending on the current iteration, min/max of {min,max} and
3478 greediness). The information about where are nodes for "A"
3479 and "Z" is read from cc, as is info on how many times "A"
3480 was already matched, and greediness.
3482 4) After A matches, the same WHILEM node is hit again.
3484 5) Each time WHILEM is hit, cc is the infoblock created by CURLYX
3485 of the same pair. Thus when WHILEM tries to match Z, it temporarily
3486 resets cc, since this Y(A)*Z can be a part of some other loop:
3487 as in (Y(A)*Z)*. If Z matches, the automaton will hit the WHILEM node
3488 of the external loop.
3490 Currently present infoblocks form a tree with a stem formed by st->cc
3491 and whatever it mentions via ->next, and additional attached trees
3492 corresponding to temporarily unset infoblocks as in "5" above.
3494 In the following picture, infoblocks for outer loop of
3495 (Y(A)*?Z)*?T are denoted O, for inner I. NULL starting block
3496 is denoted by x. The matched string is YAAZYAZT. Temporarily postponed
3497 infoblocks are drawn below the "reset" infoblock.
3499 In fact in the picture below we do not show failed matches for Z and T
3500 by WHILEM blocks. [We illustrate minimal matches, since for them it is
3501 more obvious *why* one needs to *temporary* unset infoblocks.]
3503 Matched REx position InfoBlocks Comment
3507 Y A)*?Z)*?T x <- O <- I
3508 YA )*?Z)*?T x <- O <- I
3509 YA A)*?Z)*?T x <- O <- I
3510 YAA )*?Z)*?T x <- O <- I
3511 YAA Z)*?T x <- O # Temporary unset I
3514 YAAZ Y(A)*?Z)*?T x <- O
3517 YAAZY (A)*?Z)*?T x <- O
3520 YAAZY A)*?Z)*?T x <- O <- I
3523 YAAZYA )*?Z)*?T x <- O <- I
3526 YAAZYA Z)*?T x <- O # Temporary unset I
3532 YAAZYAZ T x # Temporary unset O
3539 *******************************************************************/
3542 /* No need to save/restore up to this paren */
3543 I32 parenfloor = scan->flags;
3547 CURLYX and WHILEM are always paired: they're the moral
3548 equivalent of pp_enteriter anbd pp_iter.
3550 The only time next could be null is if the node tree is
3551 corrupt. This was mentioned on p5p a few days ago.
3553 See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3554 So we'll assert that this is true:
3557 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
3559 /* XXXX Probably it is better to teach regpush to support
3560 parenfloor > PL_regsize... */
3561 if (parenfloor > (I32)*PL_reglastparen)
3562 parenfloor = *PL_reglastparen; /* Pessimization... */
3564 st->u.curlyx.cp = PL_savestack_ix;
3565 st->u.curlyx.outercc = st->cc;
3567 /* these fields contain the state of the current curly.
3568 * they are accessed by subsequent WHILEMs;
3569 * cur and lastloc are also updated by WHILEM */
3570 st->u.curlyx.parenfloor = parenfloor;
3571 st->u.curlyx.cur = -1; /* this will be updated by WHILEM */
3572 st->u.curlyx.min = ARG1(scan);
3573 st->u.curlyx.max = ARG2(scan);
3574 st->u.curlyx.scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3575 st->u.curlyx.lastloc = 0;
3576 /* st->next and st->minmod are also read by WHILEM */
3578 PL_reginput = locinput;
3579 REGMATCH(PREVOPER(next), CURLYX); /* start on the WHILEM */
3580 /*** all unsaved local vars undefined at this point */
3581 regcpblow(st->u.curlyx.cp);
3582 st->cc = st->u.curlyx.outercc;
3588 * This is really hard to understand, because after we match
3589 * what we're trying to match, we must make sure the rest of
3590 * the REx is going to match for sure, and to do that we have
3591 * to go back UP the parse tree by recursing ever deeper. And
3592 * if it fails, we have to reset our parent's current state
3593 * that we can try again after backing off.
3598 st->cc gets initialised by CURLYX ready for use by WHILEM.
3599 So again, unless somethings been corrupted, st->cc cannot
3600 be null at that point in WHILEM.
3602 See http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2006-04/msg00556.html
3603 So we'll assert that this is true:
3606 st->u.whilem.lastloc = st->cc->u.curlyx.lastloc; /* Detection of 0-len. */
3607 st->u.whilem.cache_offset = 0;
3608 st->u.whilem.cache_bit = 0;
3610 n = st->cc->u.curlyx.cur + 1; /* how many we know we matched */
3611 PL_reginput = locinput;
3614 PerlIO_printf(Perl_debug_log,
3615 "%*s %ld out of %ld..%ld cc=%"UVxf"\n",
3616 REPORT_CODE_OFF+PL_regindent*2, "",
3617 (long)n, (long)st->cc->u.curlyx.min,
3618 (long)st->cc->u.curlyx.max, PTR2UV(st->cc))
3621 /* If degenerate scan matches "", assume scan done. */
3623 if (locinput == st->cc->u.curlyx.lastloc && n >= st->cc->u.curlyx.min) {
3624 st->u.whilem.savecc = st->cc;
3625 st->cc = st->cc->u.curlyx.outercc;
3627 st->ln = st->cc->u.curlyx.cur;
3629 PerlIO_printf(Perl_debug_log,
3630 "%*s empty match detected, try continuation...\n",
3631 REPORT_CODE_OFF+PL_regindent*2, "")
3633 REGMATCH(st->u.whilem.savecc->next, WHILEM1);
3634 /*** all unsaved local vars undefined at this point */
3635 st->cc = st->u.whilem.savecc;
3638 if (st->cc->u.curlyx.outercc)
3639 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3643 /* First just match a string of min scans. */
3645 if (n < st->cc->u.curlyx.min) {
3646 st->cc->u.curlyx.cur = n;
3647 st->cc->u.curlyx.lastloc = locinput;
3648 REGMATCH(st->cc->u.curlyx.scan, WHILEM2);
3649 /*** all unsaved local vars undefined at this point */
3652 st->cc->u.curlyx.cur = n - 1;
3653 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3658 /* Check whether we already were at this position.
3659 Postpone detection until we know the match is not
3660 *that* much linear. */
3661 if (!PL_reg_maxiter) {
3662 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
3663 PL_reg_leftiter = PL_reg_maxiter;
3665 if (PL_reg_leftiter-- == 0) {
3666 const I32 size = (PL_reg_maxiter + 7 + POSCACHE_START)/8;
3667 if (PL_reg_poscache) {
3668 if ((I32)PL_reg_poscache_size < size) {
3669 Renew(PL_reg_poscache, size, char);
3670 PL_reg_poscache_size = size;
3672 Zero(PL_reg_poscache, size, char);
3675 PL_reg_poscache_size = size;
3676 Newxz(PL_reg_poscache, size, char);
3679 PerlIO_printf(Perl_debug_log,
3680 "%sDetected a super-linear match, switching on caching%s...\n",
3681 PL_colors[4], PL_colors[5])
3684 if (PL_reg_leftiter < 0) {
3685 st->u.whilem.cache_offset = locinput - PL_bostr;
3687 st->u.whilem.cache_offset = (scan->flags & 0xf) - 1 + POSCACHE_START
3688 + st->u.whilem.cache_offset * (scan->flags>>4);
3689 st->u.whilem.cache_bit = st->u.whilem.cache_offset % 8;
3690 st->u.whilem.cache_offset /= 8;
3691 if (PL_reg_poscache[st->u.whilem.cache_offset] & (1<<st->u.whilem.cache_bit)) {
3693 PerlIO_printf(Perl_debug_log,
3694 "%*s already tried at this position...\n",
3695 REPORT_CODE_OFF+PL_regindent*2, "")
3697 if (PL_reg_poscache[0] & (1<<POSCACHE_SUCCESS))
3698 /* cache records success */
3701 /* cache records failure */
3707 /* Prefer next over scan for minimal matching. */
3709 if (st->cc->minmod) {
3710 st->u.whilem.savecc = st->cc;
3711 st->cc = st->cc->u.curlyx.outercc;
3713 st->ln = st->cc->u.curlyx.cur;
3714 st->u.whilem.cp = regcppush(st->u.whilem.savecc->u.curlyx.parenfloor);
3715 REGCP_SET(st->u.whilem.lastcp);
3716 REGMATCH(st->u.whilem.savecc->next, WHILEM3);
3717 /*** all unsaved local vars undefined at this point */
3718 st->cc = st->u.whilem.savecc;
3720 regcpblow(st->u.whilem.cp);
3721 CACHEsayYES; /* All done. */
3723 REGCP_UNWIND(st->u.whilem.lastcp);
3725 if (st->cc->u.curlyx.outercc)
3726 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3728 if (n >= st->cc->u.curlyx.max) { /* Maximum greed exceeded? */
3729 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3730 && !(PL_reg_flags & RF_warned)) {
3731 PL_reg_flags |= RF_warned;
3732 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3733 "Complex regular subexpression recursion",
3740 PerlIO_printf(Perl_debug_log,
3741 "%*s trying longer...\n",
3742 REPORT_CODE_OFF+PL_regindent*2, "")
3744 /* Try scanning more and see if it helps. */
3745 PL_reginput = locinput;
3746 st->cc->u.curlyx.cur = n;
3747 st->cc->u.curlyx.lastloc = locinput;
3748 st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3749 REGCP_SET(st->u.whilem.lastcp);
3750 REGMATCH(st->cc->u.curlyx.scan, WHILEM4);
3751 /*** all unsaved local vars undefined at this point */
3753 regcpblow(st->u.whilem.cp);
3756 REGCP_UNWIND(st->u.whilem.lastcp);
3758 st->cc->u.curlyx.cur = n - 1;
3759 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3763 /* Prefer scan over next for maximal matching. */
3765 if (n < st->cc->u.curlyx.max) { /* More greed allowed? */
3766 st->u.whilem.cp = regcppush(st->cc->u.curlyx.parenfloor);
3767 st->cc->u.curlyx.cur = n;
3768 st->cc->u.curlyx.lastloc = locinput;
3769 REGCP_SET(st->u.whilem.lastcp);
3770 REGMATCH(st->cc->u.curlyx.scan, WHILEM5);
3771 /*** all unsaved local vars undefined at this point */
3773 regcpblow(st->u.whilem.cp);
3776 REGCP_UNWIND(st->u.whilem.lastcp);
3777 regcppop(rex); /* Restore some previous $<digit>s? */
3778 PL_reginput = locinput;
3780 PerlIO_printf(Perl_debug_log,
3781 "%*s failed, try continuation...\n",
3782 REPORT_CODE_OFF+PL_regindent*2, "")
3785 if (ckWARN(WARN_REGEXP) && n >= REG_INFTY
3786 && !(PL_reg_flags & RF_warned)) {
3787 PL_reg_flags |= RF_warned;
3788 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
3789 "Complex regular subexpression recursion",
3793 /* Failed deeper matches of scan, so see if this one works. */
3794 st->u.whilem.savecc = st->cc;
3795 st->cc = st->cc->u.curlyx.outercc;
3797 st->ln = st->cc->u.curlyx.cur;
3798 REGMATCH(st->u.whilem.savecc->next, WHILEM6);
3799 /*** all unsaved local vars undefined at this point */
3800 st->cc = st->u.whilem.savecc;
3803 if (st->cc->u.curlyx.outercc)
3804 st->cc->u.curlyx.outercc->u.curlyx.cur = st->ln;
3805 st->cc->u.curlyx.cur = n - 1;
3806 st->cc->u.curlyx.lastloc = st->u.whilem.lastloc;
3811 next = scan + ARG(scan);
3814 inner = NEXTOPER(NEXTOPER(scan));
3817 inner = NEXTOPER(scan);
3822 if (!next || OP(next) != type) /* No choice. */
3823 next = inner; /* Avoid recursion. */
3825 const I32 lastparen = *PL_reglastparen;
3826 /* Put unwinding data on stack */
3827 const I32 unwind1 = SSNEWt(1,re_unwind_branch_t);
3828 re_unwind_branch_t * const uw = SSPTRt(unwind1,re_unwind_branch_t);
3830 uw->prev = st->unwind;
3831 st->unwind = unwind1;
3832 uw->type = ((type == BRANCH)
3834 : RE_UNWIND_BRANCHJ);
3835 uw->lastparen = lastparen;
3837 uw->locinput = locinput;
3838 uw->nextchr = nextchr;
3839 uw->minmod = st->minmod;
3841 uw->regindent = ++PL_regindent;
3844 REGCP_SET(uw->lastcp);
3846 /* Now go into the first branch */
3856 st->u.curlym.l = st->u.curlym.matches = 0;
3858 /* We suppose that the next guy does not need
3859 backtracking: in particular, it is of constant non-zero length,
3860 and has no parenths to influence future backrefs. */
3861 st->ln = ARG1(scan); /* min to match */
3862 n = ARG2(scan); /* max to match */
3863 st->u.curlym.paren = scan->flags;
3864 if (st->u.curlym.paren) {
3865 if (st->u.curlym.paren > PL_regsize)
3866 PL_regsize = st->u.curlym.paren;
3867 if (st->u.curlym.paren > (I32)*PL_reglastparen)
3868 *PL_reglastparen = st->u.curlym.paren;
3870 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
3871 if (st->u.curlym.paren)
3872 scan += NEXT_OFF(scan); /* Skip former OPEN. */
3873 PL_reginput = locinput;
3874 st->u.curlym.maxwanted = st->minmod ? st->ln : n;
3875 while (PL_reginput < PL_regeol && st->u.curlym.matches < st->u.curlym.maxwanted) {
3876 /* resume to current state on success */
3877 st->u.yes.prev_yes_state = yes_state;
3879 REGMATCH(scan, CURLYM1);
3880 yes_state = st->u.yes.prev_yes_state;
3881 /*** all unsaved local vars undefined at this point */
3884 /* on first match, determine length, u.curlym.l */
3885 if (!st->u.curlym.matches++) {
3886 if (PL_reg_match_utf8) {
3888 while (s < PL_reginput) {
3894 st->u.curlym.l = PL_reginput - locinput;
3896 if (st->u.curlym.l == 0) {
3897 st->u.curlym.matches = st->u.curlym.maxwanted;
3901 locinput = PL_reginput;
3904 PL_reginput = locinput;
3905 if (st->u.curlym.matches < st->ln) {
3911 PerlIO_printf(Perl_debug_log,
3912 "%*s matched %"IVdf" times, len=%"IVdf"...\n",
3913 (int)(REPORT_CODE_OFF+PL_regindent*2), "",
3914 (IV) st->u.curlym.matches, (IV)st->u.curlym.l)
3917 /* calculate c1 and c1 for possible match of 1st char
3918 * following curly */
3919 st->u.curlym.c1 = st->u.curlym.c2 = CHRTEST_VOID;
3920 if (HAS_TEXT(next) || JUMPABLE(next)) {
3921 regnode *text_node = next;
3922 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
3923 if (HAS_TEXT(text_node)
3924 && PL_regkind[(U8)OP(text_node)] != REF)
3926 st->u.curlym.c1 = (U8)*STRING(text_node);
3928 (OP(text_node) == EXACTF || OP(text_node) == REFF)
3929 ? PL_fold[st->u.curlym.c1]
3930 : (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
3931 ? PL_fold_locale[st->u.curlym.c1]
3936 REGCP_SET(st->u.curlym.lastcp);
3938 st->u.curlym.minmod = st->minmod;
3940 while (st->u.curlym.matches >= st->ln
3941 && (st->u.curlym.matches <= n
3942 /* for REG_INFTY, ln could overflow to negative */
3943 || (n == REG_INFTY && st->u.curlym.matches >= 0)))
3945 /* If it could work, try it. */
3946 if (st->u.curlym.c1 == CHRTEST_VOID ||
3947 UCHARAT(PL_reginput) == st->u.curlym.c1 ||
3948 UCHARAT(PL_reginput) == st->u.curlym.c2)
3951 PerlIO_printf(Perl_debug_log,
3952 "%*s trying tail with matches=%"IVdf"...\n",
3953 (int)(REPORT_CODE_OFF+PL_regindent*2),
3954 "", (IV)st->u.curlym.matches)
3956 if (st->u.curlym.paren) {
3957 if (st->u.curlym.matches) {
3958 PL_regstartp[st->u.curlym.paren]
3959 = HOPc(PL_reginput, -st->u.curlym.l) - PL_bostr;
3960 PL_regendp[st->u.curlym.paren] = PL_reginput - PL_bostr;
3963 PL_regendp[st->u.curlym.paren] = -1;
3965 /* resume to current state on success */
3966 st->u.yes.prev_yes_state = yes_state;
3968 REGMATCH(next, CURLYM2);
3969 yes_state = st->u.yes.prev_yes_state;
3970 /*** all unsaved local vars undefined at this point */
3972 /* XXX tmp sayYES; */
3974 REGCP_UNWIND(st->u.curlym.lastcp);
3976 /* Couldn't or didn't -- move forward/backward. */
3977 if (st->u.curlym.minmod) {
3978 PL_reginput = locinput;
3979 /* resume to current state on success */
3980 st->u.yes.prev_yes_state = yes_state;
3982 REGMATCH(scan, CURLYM3);
3983 yes_state = st->u.yes.prev_yes_state;
3984 /*** all unsaved local vars undefined at this point */
3986 st->u.curlym.matches++;
3987 locinput = PL_reginput;
3993 st->u.curlym.matches--;
3994 locinput = HOPc(locinput, -st->u.curlym.l);
3995 PL_reginput = locinput;
4003 st->u.plus.paren = scan->flags; /* Which paren to set */
4004 if (st->u.plus.paren > PL_regsize)
4005 PL_regsize = st->u.plus.paren;
4006 if (st->u.plus.paren > (I32)*PL_reglastparen)
4007 *PL_reglastparen = st->u.plus.paren;
4008 st->ln = ARG1(scan); /* min to match */
4009 n = ARG2(scan); /* max to match */
4010 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4013 st->u.plus.paren = 0;
4014 st->ln = ARG1(scan); /* min to match */
4015 n = ARG2(scan); /* max to match */
4016 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4021 scan = NEXTOPER(scan);
4022 st->u.plus.paren = 0;
4027 scan = NEXTOPER(scan);
4028 st->u.plus.paren = 0;
4031 * Lookahead to avoid useless match attempts
4032 * when we know what character comes next.
4036 * Used to only do .*x and .*?x, but now it allows
4037 * for )'s, ('s and (?{ ... })'s to be in the way
4038 * of the quantifier and the EXACT-like node. -- japhy
4041 if (HAS_TEXT(next) || JUMPABLE(next)) {
4043 regnode *text_node = next;
4045 if (! HAS_TEXT(text_node)) FIND_NEXT_IMPT(text_node);
4047 if (! HAS_TEXT(text_node))
4048 st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4050 if (PL_regkind[(U8)OP(text_node)] == REF) {
4051 st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4052 goto assume_ok_easy;
4054 else { s = (U8*)STRING(text_node); }
4057 st->u.plus.c2 = st->u.plus.c1 = *s;
4058 if (OP(text_node) == EXACTF || OP(text_node) == REFF)
4059 st->u.plus.c2 = PL_fold[st->u.plus.c1];
4060 else if (OP(text_node) == EXACTFL || OP(text_node) == REFFL)
4061 st->u.plus.c2 = PL_fold_locale[st->u.plus.c1];
4064 if (OP(text_node) == EXACTF || OP(text_node) == REFF) {
4065 STRLEN ulen1, ulen2;
4066 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4067 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4069 to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4070 to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4072 st->u.plus.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4074 st->u.plus.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4078 st->u.plus.c2 = st->u.plus.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4085 st->u.plus.c1 = st->u.plus.c2 = CHRTEST_VOID;
4087 PL_reginput = locinput;
4090 if (st->ln && regrepeat(rex, scan, st->ln) < st->ln)
4092 locinput = PL_reginput;
4093 REGCP_SET(st->u.plus.lastcp);
4094 if (st->u.plus.c1 != CHRTEST_VOID) {
4095 st->u.plus.old = locinput;
4096 st->u.plus.count = 0;
4098 if (n == REG_INFTY) {
4099 st->u.plus.e = PL_regeol - 1;
4101 while (UTF8_IS_CONTINUATION(*(U8*)st->u.plus.e))
4106 for (st->u.plus.e = locinput;
4107 m >0 && st->u.plus.e + UTF8SKIP(st->u.plus.e) <= PL_regeol; m--)
4108 st->u.plus.e += UTF8SKIP(st->u.plus.e);
4111 st->u.plus.e = locinput + n - st->ln;
4112 if (st->u.plus.e >= PL_regeol)
4113 st->u.plus.e = PL_regeol - 1;
4116 /* Find place 'next' could work */
4118 if (st->u.plus.c1 == st->u.plus.c2) {
4119 while (locinput <= st->u.plus.e &&
4120 UCHARAT(locinput) != st->u.plus.c1)
4123 while (locinput <= st->u.plus.e
4124 && UCHARAT(locinput) != st->u.plus.c1
4125 && UCHARAT(locinput) != st->u.plus.c2)
4128 st->u.plus.count = locinput - st->u.plus.old;
4131 if (st->u.plus.c1 == st->u.plus.c2) {
4133 /* count initialised to
4134 * utf8_distance(old, locinput) */
4135 while (locinput <= st->u.plus.e &&
4136 utf8n_to_uvchr((U8*)locinput,
4137 UTF8_MAXBYTES, &len,
4138 uniflags) != (UV)st->u.plus.c1) {
4143 /* count initialised to
4144 * utf8_distance(old, locinput) */
4145 while (locinput <= st->u.plus.e) {
4147 const UV c = utf8n_to_uvchr((U8*)locinput,
4148 UTF8_MAXBYTES, &len,
4150 if (c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4157 if (locinput > st->u.plus.e)
4159 /* PL_reginput == old now */
4160 if (locinput != st->u.plus.old) {
4161 st->ln = 1; /* Did some */
4162 if (regrepeat(rex, scan, st->u.plus.count) < st->u.plus.count)
4165 /* PL_reginput == locinput now */
4166 TRYPAREN(st->u.plus.paren, st->ln, locinput, PLUS1);
4167 /*** all unsaved local vars undefined at this point */
4168 PL_reginput = locinput; /* Could be reset... */
4169 REGCP_UNWIND(st->u.plus.lastcp);
4170 /* Couldn't or didn't -- move forward. */
4171 st->u.plus.old = locinput;
4173 locinput += UTF8SKIP(locinput);
4176 st->u.plus.count = 1;
4180 while (n >= st->ln || (n == REG_INFTY && st->ln > 0)) { /* ln overflow ? */
4182 if (st->u.plus.c1 != CHRTEST_VOID) {
4184 c = utf8n_to_uvchr((U8*)PL_reginput,
4188 c = UCHARAT(PL_reginput);
4189 /* If it could work, try it. */
4190 if (c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4192 TRYPAREN(st->u.plus.paren, st->ln, PL_reginput, PLUS2);
4193 /*** all unsaved local vars undefined at this point */
4194 REGCP_UNWIND(st->u.plus.lastcp);
4197 /* If it could work, try it. */
4198 else if (st->u.plus.c1 == CHRTEST_VOID)
4200 TRYPAREN(st->u.plus.paren, st->ln, PL_reginput, PLUS3);
4201 /*** all unsaved local vars undefined at this point */
4202 REGCP_UNWIND(st->u.plus.lastcp);
4204 /* Couldn't or didn't -- move forward. */
4205 PL_reginput = locinput;
4206 if (regrepeat(rex, scan, 1)) {
4208 locinput = PL_reginput;
4215 n = regrepeat(rex, scan, n);
4216 locinput = PL_reginput;
4217 if (st->ln < n && PL_regkind[(U8)OP(next)] == EOL &&
4218 (OP(next) != MEOL ||
4219 OP(next) == SEOL || OP(next) == EOS))
4221 st->ln = n; /* why back off? */
4222 /* ...because $ and \Z can match before *and* after
4223 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
4224 We should back off by one in this case. */
4225 if (UCHARAT(PL_reginput - 1) == '\n' && OP(next) != EOS)
4228 REGCP_SET(st->u.plus.lastcp);
4231 while (n >= st->ln) {
4232 if (st->u.plus.c1 != CHRTEST_VOID) {
4234 c = utf8n_to_uvchr((U8*)PL_reginput,
4238 c = UCHARAT(PL_reginput);
4240 /* If it could work, try it. */
4241 if (st->u.plus.c1 == CHRTEST_VOID || c == (UV)st->u.plus.c1 || c == (UV)st->u.plus.c2)
4243 TRYPAREN(st->u.plus.paren, n, PL_reginput, PLUS4);
4244 /*** all unsaved local vars undefined at this point */
4245 REGCP_UNWIND(st->u.plus.lastcp);
4247 /* Couldn't or didn't -- back up. */
4249 PL_reginput = locinput = HOPc(locinput, -1);
4256 if (locinput < reginfo->till) {
4257 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4258 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4260 (long)(locinput - PL_reg_starttry),
4261 (long)(reginfo->till - PL_reg_starttry),
4263 sayNO_FINAL; /* Cannot match: too short. */
4265 PL_reginput = locinput; /* put where regtry can find it */
4266 sayYES_FINAL; /* Success! */
4268 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4270 PerlIO_printf(Perl_debug_log,
4271 "%*s %ssubpattern success...%s\n",
4272 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5]));
4273 PL_reginput = locinput; /* put where regtry can find it */
4274 sayYES_FINAL; /* Success! */
4276 case SUSPEND: /* (?>FOO) */
4277 st->u.ifmatch.wanted = 1;
4278 PL_reginput = locinput;
4281 case UNLESSM: /* -ve lookaround: (?!FOO), or with flags, (?<!foo) */
4282 st->u.ifmatch.wanted = 0;
4283 goto ifmatch_trivial_fail_test;
4285 case IFMATCH: /* +ve lookaround: (?=FOO), or with flags, (?<=foo) */
4286 st->u.ifmatch.wanted = 1;
4287 ifmatch_trivial_fail_test:
4289 char * const s = HOPBACKc(locinput, scan->flags);
4294 st->sw = 1 - st->u.ifmatch.wanted;
4296 else if (st->u.ifmatch.wanted)
4298 next = scan + ARG(scan);
4306 PL_reginput = locinput;
4309 /* resume to current state on success */
4310 st->u.yes.prev_yes_state = yes_state;
4312 PUSH_STATE(newst, resume_IFMATCH);
4314 next = NEXTOPER(NEXTOPER(scan));
4318 next = scan + ARG(scan);
4323 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
4324 PTR2UV(scan), OP(scan));
4325 Perl_croak(aTHX_ "regexp memory corruption");
4333 /* simulate recursively calling regmatch(), but without actually
4334 * recursing - ie save the current state on the heap rather than on
4335 * the stack, then re-enter the loop. This avoids complex regexes
4336 * blowing the processor stack */
4340 /* push new state */
4341 regmatch_state *oldst = st;
4345 /* grab the next free state slot */
4347 if (st > SLAB_LAST(PL_regmatch_slab))
4348 st = S_push_slab(aTHX);
4349 PL_regmatch_state = st;
4353 oldst->locinput = locinput;
4356 locinput = PL_reginput;
4357 nextchr = UCHARAT(locinput);
4371 * We get here only if there's trouble -- normally "case END" is
4372 * the terminating point.
4374 Perl_croak(aTHX_ "corrupted regexp pointers");
4381 /* we have successfully completed a subexpression, but we must now
4382 * pop to the state marked by yes_state and continue from there */
4384 /*XXX tmp for CURLYM*/
4385 regmatch_slab * const oslab = PL_regmatch_slab;
4386 regmatch_state * const ost = st;
4387 regmatch_state * const oys = yes_state;
4390 assert(st != yes_state);
4391 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
4392 || yes_state > SLAB_LAST(PL_regmatch_slab))
4394 /* not in this slab, pop slab */
4395 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
4396 PL_regmatch_slab = PL_regmatch_slab->prev;
4397 st = SLAB_LAST(PL_regmatch_slab);
4399 depth -= (st - yes_state);
4400 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "POP STATE TO (%d)\n", depth));
4402 yes_state = st->u.yes.prev_yes_state;
4403 PL_regmatch_state = st;
4405 switch (st->resume_state) {
4407 if (st->u.eval.toggleutf)
4408 PL_reg_flags ^= RF_utf8;
4410 rex = st->u.eval.prev_rex;
4411 /* XXXX This is too dramatic a measure... */
4413 /* Restore parens of the caller without popping the
4416 const I32 tmp = PL_savestack_ix;
4417 PL_savestack_ix = st->u.eval.lastcp;
4419 PL_savestack_ix = tmp;
4421 PL_reginput = locinput;
4422 /* continue at the node following the (??{...}) */
4426 case resume_IFMATCH:
4429 st->sw = st->u.ifmatch.wanted;
4431 else if (!st->u.ifmatch.wanted)
4434 if (OP(st->scan) == SUSPEND)
4435 locinput = PL_reginput;
4437 locinput = PL_reginput = st->locinput;
4438 nextchr = UCHARAT(locinput);
4440 next = st->scan + ARG(st->scan);
4441 if (next == st->scan)
4445 /* XXX tmp don't handle yes_state yet */
4446 case resume_CURLYM1:
4447 case resume_CURLYM2:
4448 case resume_CURLYM3:
4449 PL_regmatch_slab =oslab;
4451 PL_regmatch_state = st;
4454 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "XXX revering a CURLYM\n"));
4458 Perl_croak(aTHX_ "unexpected yes reume state");
4462 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
4463 PL_colors[4], PL_colors[5]));
4470 /* XXX this is duplicate(ish) code to that in the do_no section.
4471 * eventually a yes should just pop the stack back to the current
4474 /* restore previous state and re-enter */
4477 switch (st->resume_state) {
4479 goto resume_point_TRIE1;
4481 goto resume_point_TRIE2;
4483 goto resume_point_CURLYX;
4484 case resume_WHILEM1:
4485 goto resume_point_WHILEM1;
4486 case resume_WHILEM2:
4487 goto resume_point_WHILEM2;
4488 case resume_WHILEM3:
4489 goto resume_point_WHILEM3;
4490 case resume_WHILEM4:
4491 goto resume_point_WHILEM4;
4492 case resume_WHILEM5:
4493 goto resume_point_WHILEM5;
4494 case resume_WHILEM6:
4495 goto resume_point_WHILEM6;
4496 case resume_CURLYM1:
4497 goto resume_point_CURLYM1;
4498 case resume_CURLYM2:
4499 goto resume_point_CURLYM2;
4500 case resume_CURLYM3:
4501 goto resume_point_CURLYM3;
4503 goto resume_point_PLUS1;
4505 goto resume_point_PLUS2;
4507 goto resume_point_PLUS3;
4509 goto resume_point_PLUS4;
4511 case resume_IFMATCH:
4514 Perl_croak(aTHX_ "regexp resume memory corruption");
4521 PerlIO_printf(Perl_debug_log,
4522 "%*s %sfailed...%s\n",
4523 REPORT_CODE_OFF+PL_regindent*2, "", PL_colors[4], PL_colors[5])
4529 re_unwind_t * const uw = SSPTRt(st->unwind,re_unwind_t);
4532 case RE_UNWIND_BRANCH:
4533 case RE_UNWIND_BRANCHJ:
4535 re_unwind_branch_t * const uwb = &(uw->branch);
4536 const I32 lastparen = uwb->lastparen;
4538 REGCP_UNWIND(uwb->lastcp);
4539 for (n = *PL_reglastparen; n > lastparen; n--)
4541 *PL_reglastparen = n;
4542 scan = next = uwb->next;
4543 st->minmod = uwb->minmod;
4545 OP(scan) != (uwb->type == RE_UNWIND_BRANCH
4546 ? BRANCH : BRANCHJ) ) { /* Failure */
4547 st->unwind = uwb->prev;
4553 /* Have more choice yet. Reuse the same uwb. */
4554 if ((n = (uwb->type == RE_UNWIND_BRANCH
4555 ? NEXT_OFF(next) : ARG(next))))
4558 next = NULL; /* XXXX Needn't unwinding in this case... */
4560 next = NEXTOPER(scan);
4561 if (uwb->type == RE_UNWIND_BRANCHJ)
4562 next = NEXTOPER(next);
4563 locinput = uwb->locinput;
4564 nextchr = uwb->nextchr;
4566 PL_regindent = uwb->regindent;
4573 Perl_croak(aTHX_ "regexp unwind memory corruption");
4584 /* there's a previous state to backtrack to */
4586 switch (st->resume_state) {
4588 goto resume_point_TRIE1;
4590 goto resume_point_TRIE2;
4592 /* we have failed an (??{...}). Restore state to the outer re
4593 * then re-throw the failure */
4594 if (st->u.eval.toggleutf)
4595 PL_reg_flags ^= RF_utf8;
4597 rex = st->u.eval.prev_rex;
4598 yes_state = st->u.yes.prev_yes_state;
4600 /* XXXX This is too dramatic a measure... */
4603 PL_reginput = locinput;
4604 REGCP_UNWIND(st->u.eval.lastcp);
4609 goto resume_point_CURLYX;
4610 case resume_WHILEM1:
4611 goto resume_point_WHILEM1;
4612 case resume_WHILEM2:
4613 goto resume_point_WHILEM2;
4614 case resume_WHILEM3:
4615 goto resume_point_WHILEM3;
4616 case resume_WHILEM4:
4617 goto resume_point_WHILEM4;
4618 case resume_WHILEM5:
4619 goto resume_point_WHILEM5;
4620 case resume_WHILEM6:
4621 goto resume_point_WHILEM6;
4622 case resume_CURLYM1:
4623 goto resume_point_CURLYM1;
4624 case resume_CURLYM2:
4625 goto resume_point_CURLYM2;
4626 case resume_CURLYM3:
4627 goto resume_point_CURLYM3;
4628 case resume_IFMATCH:
4629 yes_state = st->u.yes.prev_yes_state;
4632 st->sw = !st->u.ifmatch.wanted;
4634 else if (st->u.ifmatch.wanted)
4637 assert(OP(scan) != SUSPEND); /* XXX DAPM tmp */
4638 locinput = PL_reginput = st->locinput;
4639 nextchr = UCHARAT(locinput);
4640 next = scan + ARG(scan);
4646 goto resume_point_PLUS1;
4648 goto resume_point_PLUS2;
4650 goto resume_point_PLUS3;
4652 goto resume_point_PLUS4;
4654 Perl_croak(aTHX_ "regexp resume memory corruption");
4660 /* restore original high-water mark */
4661 PL_regmatch_slab = orig_slab;
4662 PL_regmatch_state = orig_state;
4664 /* free all slabs above current one */
4665 if (orig_slab->next) {
4666 regmatch_slab *sl = orig_slab->next;
4667 orig_slab->next = NULL;
4669 regmatch_slab * const osl = sl;
4680 - regrepeat - repeatedly match something simple, report how many
4683 * [This routine now assumes that it will only match on things of length 1.
4684 * That was true before, but now we assume scan - reginput is the count,
4685 * rather than incrementing count on every character. [Er, except utf8.]]
4688 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max)
4691 register char *scan;
4693 register char *loceol = PL_regeol;
4694 register I32 hardcount = 0;
4695 register bool do_utf8 = PL_reg_match_utf8;
4698 if (max == REG_INFTY)
4700 else if (max < loceol - scan)
4701 loceol = scan + max;
4706 while (scan < loceol && hardcount < max && *scan != '\n') {
4707 scan += UTF8SKIP(scan);
4711 while (scan < loceol && *scan != '\n')
4718 while (scan < loceol && hardcount < max) {
4719 scan += UTF8SKIP(scan);
4729 case EXACT: /* length of string is 1 */
4731 while (scan < loceol && UCHARAT(scan) == c)
4734 case EXACTF: /* length of string is 1 */
4736 while (scan < loceol &&
4737 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
4740 case EXACTFL: /* length of string is 1 */
4741 PL_reg_flags |= RF_tainted;
4743 while (scan < loceol &&
4744 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
4750 while (hardcount < max && scan < loceol &&
4751 reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
4752 scan += UTF8SKIP(scan);
4756 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
4763 LOAD_UTF8_CHARCLASS_ALNUM();
4764 while (hardcount < max && scan < loceol &&
4765 swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4766 scan += UTF8SKIP(scan);
4770 while (scan < loceol && isALNUM(*scan))
4775 PL_reg_flags |= RF_tainted;
4778 while (hardcount < max && scan < loceol &&
4779 isALNUM_LC_utf8((U8*)scan)) {
4780 scan += UTF8SKIP(scan);
4784 while (scan < loceol && isALNUM_LC(*scan))
4791 LOAD_UTF8_CHARCLASS_ALNUM();
4792 while (hardcount < max && scan < loceol &&
4793 !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
4794 scan += UTF8SKIP(scan);
4798 while (scan < loceol && !isALNUM(*scan))
4803 PL_reg_flags |= RF_tainted;
4806 while (hardcount < max && scan < loceol &&
4807 !isALNUM_LC_utf8((U8*)scan)) {
4808 scan += UTF8SKIP(scan);
4812 while (scan < loceol && !isALNUM_LC(*scan))
4819 LOAD_UTF8_CHARCLASS_SPACE();
4820 while (hardcount < max && scan < loceol &&
4822 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4823 scan += UTF8SKIP(scan);
4827 while (scan < loceol && isSPACE(*scan))
4832 PL_reg_flags |= RF_tainted;
4835 while (hardcount < max && scan < loceol &&
4836 (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4837 scan += UTF8SKIP(scan);
4841 while (scan < loceol && isSPACE_LC(*scan))
4848 LOAD_UTF8_CHARCLASS_SPACE();
4849 while (hardcount < max && scan < loceol &&
4851 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
4852 scan += UTF8SKIP(scan);
4856 while (scan < loceol && !isSPACE(*scan))
4861 PL_reg_flags |= RF_tainted;
4864 while (hardcount < max && scan < loceol &&
4865 !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
4866 scan += UTF8SKIP(scan);
4870 while (scan < loceol && !isSPACE_LC(*scan))
4877 LOAD_UTF8_CHARCLASS_DIGIT();
4878 while (hardcount < max && scan < loceol &&
4879 swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4880 scan += UTF8SKIP(scan);
4884 while (scan < loceol && isDIGIT(*scan))
4891 LOAD_UTF8_CHARCLASS_DIGIT();
4892 while (hardcount < max && scan < loceol &&
4893 !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
4894 scan += UTF8SKIP(scan);
4898 while (scan < loceol && !isDIGIT(*scan))
4902 default: /* Called on something of 0 width. */
4903 break; /* So match right here or not at all. */
4909 c = scan - PL_reginput;
4913 SV *re_debug_flags = NULL;
4914 SV * const prop = sv_newmortal();
4917 regprop(prog, prop, p);
4918 PerlIO_printf(Perl_debug_log,
4919 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
4920 REPORT_CODE_OFF+1, "", SvPVX_const(prop),(IV)c,(IV)max);
4928 #ifndef PERL_IN_XSUB_RE
4930 - regclass_swash - prepare the utf8 swash
4934 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
4940 const struct reg_data *data = prog ? prog->data : NULL;
4942 if (data && data->count) {
4943 const U32 n = ARG(node);
4945 if (data->what[n] == 's') {
4946 SV * const rv = (SV*)data->data[n];
4947 AV * const av = (AV*)SvRV((SV*)rv);
4948 SV **const ary = AvARRAY(av);
4951 /* See the end of regcomp.c:S_regclass() for
4952 * documentation of these array elements. */
4955 a = SvROK(ary[1]) ? &ary[1] : 0;
4956 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : 0;
4960 else if (si && doinit) {
4961 sw = swash_init("utf8", "", si, 1, 0);
4962 (void)av_store(av, 1, sw);
4979 - reginclass - determine if a character falls into a character class
4981 The n is the ANYOF regnode, the p is the target string, lenp
4982 is pointer to the maximum length of how far to go in the p
4983 (if the lenp is zero, UTF8SKIP(p) is used),
4984 do_utf8 tells whether the target string is in UTF-8.
4989 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
4992 const char flags = ANYOF_FLAGS(n);
4998 if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
4999 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5000 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5001 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5002 if (len == (STRLEN)-1)
5003 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5006 plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5007 if (do_utf8 || (flags & ANYOF_UNICODE)) {
5010 if (do_utf8 && !ANYOF_RUNTIME(n)) {
5011 if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5014 if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5018 SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5021 if (swash_fetch(sw, p, do_utf8))
5023 else if (flags & ANYOF_FOLD) {
5024 if (!match && lenp && av) {
5026 for (i = 0; i <= av_len(av); i++) {
5027 SV* const sv = *av_fetch(av, i, FALSE);
5029 const char * const s = SvPV_const(sv, len);
5031 if (len <= plen && memEQ(s, (char*)p, len)) {
5039 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5042 to_utf8_fold(p, tmpbuf, &tmplen);
5043 if (swash_fetch(sw, tmpbuf, do_utf8))
5049 if (match && lenp && *lenp == 0)
5050 *lenp = UNISKIP(NATIVE_TO_UNI(c));
5052 if (!match && c < 256) {
5053 if (ANYOF_BITMAP_TEST(n, c))
5055 else if (flags & ANYOF_FOLD) {
5058 if (flags & ANYOF_LOCALE) {
5059 PL_reg_flags |= RF_tainted;
5060 f = PL_fold_locale[c];
5064 if (f != c && ANYOF_BITMAP_TEST(n, f))
5068 if (!match && (flags & ANYOF_CLASS)) {
5069 PL_reg_flags |= RF_tainted;
5071 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
5072 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
5073 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
5074 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
5075 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
5076 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
5077 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
5078 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5079 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
5080 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
5081 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
5082 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
5083 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
5084 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
5085 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
5086 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
5087 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
5088 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
5089 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
5090 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
5091 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
5092 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
5093 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
5094 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
5095 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
5096 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
5097 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
5098 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
5099 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
5100 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
5101 ) /* How's that for a conditional? */
5108 return (flags & ANYOF_INVERT) ? !match : match;
5112 S_reghop3(U8 *s, I32 off, U8* lim)
5116 while (off-- && s < lim) {
5117 /* XXX could check well-formedness here */
5125 if (UTF8_IS_CONTINUED(*s)) {
5126 while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5129 /* XXX could check well-formedness here */
5137 S_reghopmaybe3(U8* s, I32 off, U8* lim)
5141 while (off-- && s < lim) {
5142 /* XXX could check well-formedness here */
5152 if (UTF8_IS_CONTINUED(*s)) {
5153 while (s > (U8*)lim && UTF8_IS_CONTINUATION(*s))
5156 /* XXX could check well-formedness here */
5168 restore_pos(pTHX_ void *arg)
5171 regexp * const rex = (regexp *)arg;
5172 if (PL_reg_eval_set) {
5173 if (PL_reg_oldsaved) {
5174 rex->subbeg = PL_reg_oldsaved;
5175 rex->sublen = PL_reg_oldsavedlen;
5176 #ifdef PERL_OLD_COPY_ON_WRITE
5177 rex->saved_copy = PL_nrs;
5179 RX_MATCH_COPIED_on(rex);
5181 PL_reg_magic->mg_len = PL_reg_oldpos;
5182 PL_reg_eval_set = 0;
5183 PL_curpm = PL_reg_oldcurpm;
5188 S_to_utf8_substr(pTHX_ register regexp *prog)
5190 if (prog->float_substr && !prog->float_utf8) {
5191 SV* const sv = newSVsv(prog->float_substr);
5192 prog->float_utf8 = sv;
5193 sv_utf8_upgrade(sv);
5194 if (SvTAIL(prog->float_substr))
5196 if (prog->float_substr == prog->check_substr)
5197 prog->check_utf8 = sv;
5199 if (prog->anchored_substr && !prog->anchored_utf8) {
5200 SV* const sv = newSVsv(prog->anchored_substr);
5201 prog->anchored_utf8 = sv;
5202 sv_utf8_upgrade(sv);
5203 if (SvTAIL(prog->anchored_substr))
5205 if (prog->anchored_substr == prog->check_substr)
5206 prog->check_utf8 = sv;
5211 S_to_byte_substr(pTHX_ register regexp *prog)
5214 if (prog->float_utf8 && !prog->float_substr) {
5215 SV* sv = newSVsv(prog->float_utf8);
5216 prog->float_substr = sv;
5217 if (sv_utf8_downgrade(sv, TRUE)) {
5218 if (SvTAIL(prog->float_utf8))
5222 prog->float_substr = sv = &PL_sv_undef;
5224 if (prog->float_utf8 == prog->check_utf8)
5225 prog->check_substr = sv;
5227 if (prog->anchored_utf8 && !prog->anchored_substr) {
5228 SV* sv = newSVsv(prog->anchored_utf8);
5229 prog->anchored_substr = sv;
5230 if (sv_utf8_downgrade(sv, TRUE)) {
5231 if (SvTAIL(prog->anchored_utf8))
5235 prog->anchored_substr = sv = &PL_sv_undef;
5237 if (prog->anchored_utf8 == prog->check_utf8)
5238 prog->check_substr = sv;
5244 * c-indentation-style: bsd
5246 * indent-tabs-mode: t
5249 * ex: set ts=8 sts=4 sw=4 noet: