5 * "One Ring to rule them all, One Ring to find them..."
8 /* This file contains functions for executing a regular expression. See
9 * also regcomp.c which funnily enough, contains functions for compiling
10 * a regular expression.
12 * This file is also copied at build time to ext/re/re_exec.c, where
13 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
14 * This causes the main functions to be compiled under new names and with
15 * debugging support added, which makes "use re 'debug'" work.
18 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
19 * confused with the original package (see point 3 below). Thanks, Henry!
22 /* Additional note: this code is very heavily munged from Henry's version
23 * in places. In some spots I've traded clarity for efficiency, so don't
24 * blame Henry for some of the lack of readability.
27 /* The names of the functions have been changed from regcomp and
28 * regexec to pregcomp and pregexec in order to avoid conflicts
29 * with the POSIX routines of the same names.
32 #ifdef PERL_EXT_RE_BUILD
37 * pregcomp and pregexec -- regsub and regerror are not used in perl
39 * Copyright (c) 1986 by University of Toronto.
40 * Written by Henry Spencer. Not derived from licensed software.
42 * Permission is granted to anyone to use this software for any
43 * purpose on any computer system, and to redistribute it freely,
44 * subject to the following restrictions:
46 * 1. The author is not responsible for the consequences of use of
47 * this software, no matter how awful, even if they arise
50 * 2. The origin of this software must not be misrepresented, either
51 * by explicit claim or by omission.
53 * 3. Altered versions must be plainly marked as such, and must not
54 * be misrepresented as being the original software.
56 **** Alterations to Henry's code are...
58 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
59 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 by Larry Wall and others
61 **** You may distribute under the terms of either the GNU General Public
62 **** License or the Artistic License, as specified in the README file.
64 * Beware that some of this code is subtly aware of the way operator
65 * precedence is structured in regular expressions. Serious changes in
66 * regular-expression syntax might require a total rethink.
69 #define PERL_IN_REGEXEC_C
72 #ifdef PERL_IN_XSUB_RE
78 #define RF_tainted 1 /* tainted information used? */
79 #define RF_warned 2 /* warned about big count? */
81 #define RF_utf8 8 /* Pattern contains multibyte chars? */
83 #define UTF ((PL_reg_flags & RF_utf8) != 0)
85 #define RS_init 1 /* eval environment created */
86 #define RS_set 2 /* replsv value is set */
92 #define REGINCLASS(prog,p,c) (ANYOF_FLAGS(p) ? reginclass(prog,p,c,0,0) : ANYOF_BITMAP_TEST(p,*(c)))
98 #define CHR_SVLEN(sv) (do_utf8 ? sv_len_utf8(sv) : SvCUR(sv))
99 #define CHR_DIST(a,b) (PL_reg_match_utf8 ? utf8_distance(a,b) : a - b)
101 #define HOPc(pos,off) \
102 (char *)(PL_reg_match_utf8 \
103 ? reghop3((U8*)pos, off, (U8*)(off >= 0 ? PL_regeol : PL_bostr)) \
105 #define HOPBACKc(pos, off) \
106 (char*)(PL_reg_match_utf8\
107 ? reghopmaybe3((U8*)pos, -off, (U8*)PL_bostr) \
108 : (pos - off >= PL_bostr) \
112 #define HOP3(pos,off,lim) (PL_reg_match_utf8 ? reghop3((U8*)(pos), off, (U8*)(lim)) : (U8*)(pos + off))
113 #define HOP3c(pos,off,lim) ((char*)HOP3(pos,off,lim))
115 #define LOAD_UTF8_CHARCLASS(class,str) STMT_START { \
116 if (!CAT2(PL_utf8_,class)) { bool ok; ENTER; save_re_context(); ok=CAT2(is_utf8_,class)((const U8*)str); assert(ok); LEAVE; } } STMT_END
117 #define LOAD_UTF8_CHARCLASS_ALNUM() LOAD_UTF8_CHARCLASS(alnum,"a")
118 #define LOAD_UTF8_CHARCLASS_DIGIT() LOAD_UTF8_CHARCLASS(digit,"0")
119 #define LOAD_UTF8_CHARCLASS_SPACE() LOAD_UTF8_CHARCLASS(space," ")
120 #define LOAD_UTF8_CHARCLASS_MARK() LOAD_UTF8_CHARCLASS(mark, "\xcd\x86")
122 /* TODO: Combine JUMPABLE and HAS_TEXT to cache OP(rn) */
124 /* for use after a quantifier and before an EXACT-like node -- japhy */
125 /* it would be nice to rework regcomp.sym to generate this stuff. sigh */
126 #define JUMPABLE(rn) ( \
128 (OP(rn) == CLOSE && (!cur_eval || cur_eval->u.eval.close_paren != ARG(rn))) || \
130 OP(rn) == SUSPEND || OP(rn) == IFMATCH || \
131 OP(rn) == PLUS || OP(rn) == MINMOD || \
132 OP(rn) == KEEPS || (PL_regkind[OP(rn)] == VERB) || \
133 (PL_regkind[OP(rn)] == CURLY && ARG1(rn) > 0) \
135 #define IS_EXACT(rn) (PL_regkind[OP(rn)] == EXACT)
137 #define HAS_TEXT(rn) ( IS_EXACT(rn) || PL_regkind[OP(rn)] == REF )
140 /* Currently these are only used when PL_regkind[OP(rn)] == EXACT so
141 we don't need this definition. */
142 #define IS_TEXT(rn) ( OP(rn)==EXACT || OP(rn)==REF || OP(rn)==NREF )
143 #define IS_TEXTF(rn) ( OP(rn)==EXACTF || OP(rn)==REFF || OP(rn)==NREFF )
144 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL || OP(rn)==REFFL || OP(rn)==NREFFL )
147 /* ... so we use this as its faster. */
148 #define IS_TEXT(rn) ( OP(rn)==EXACT )
149 #define IS_TEXTF(rn) ( OP(rn)==EXACTF )
150 #define IS_TEXTFL(rn) ( OP(rn)==EXACTFL )
155 Search for mandatory following text node; for lookahead, the text must
156 follow but for lookbehind (rn->flags != 0) we skip to the next step.
158 #define FIND_NEXT_IMPT(rn) STMT_START { \
159 while (JUMPABLE(rn)) { \
160 const OPCODE type = OP(rn); \
161 if (type == SUSPEND || PL_regkind[type] == CURLY) \
162 rn = NEXTOPER(NEXTOPER(rn)); \
163 else if (type == PLUS) \
165 else if (type == IFMATCH) \
166 rn = (rn->flags == 0) ? NEXTOPER(NEXTOPER(rn)) : rn + ARG(rn); \
167 else rn += NEXT_OFF(rn); \
172 static void restore_pos(pTHX_ void *arg);
175 S_regcppush(pTHX_ I32 parenfloor)
178 const int retval = PL_savestack_ix;
179 #define REGCP_PAREN_ELEMS 4
180 const int paren_elems_to_push = (PL_regsize - parenfloor) * REGCP_PAREN_ELEMS;
182 GET_RE_DEBUG_FLAGS_DECL;
184 if (paren_elems_to_push < 0)
185 Perl_croak(aTHX_ "panic: paren_elems_to_push < 0");
187 #define REGCP_OTHER_ELEMS 7
188 SSGROW(paren_elems_to_push + REGCP_OTHER_ELEMS);
190 for (p = PL_regsize; p > parenfloor; p--) {
191 /* REGCP_PARENS_ELEMS are pushed per pairs of parentheses. */
192 SSPUSHINT(PL_regoffs[p].end);
193 SSPUSHINT(PL_regoffs[p].start);
194 SSPUSHPTR(PL_reg_start_tmp[p]);
196 DEBUG_BUFFERS_r(PerlIO_printf(Perl_debug_log,
197 " saving \\%"UVuf" %"IVdf"(%"IVdf")..%"IVdf"\n",
198 (UV)p, (IV)PL_regoffs[p].start,
199 (IV)(PL_reg_start_tmp[p] - PL_bostr),
200 (IV)PL_regoffs[p].end
203 /* REGCP_OTHER_ELEMS are pushed in any case, parentheses or no. */
204 SSPUSHPTR(PL_regoffs);
205 SSPUSHINT(PL_regsize);
206 SSPUSHINT(*PL_reglastparen);
207 SSPUSHINT(*PL_reglastcloseparen);
208 SSPUSHPTR(PL_reginput);
209 #define REGCP_FRAME_ELEMS 2
210 /* REGCP_FRAME_ELEMS are part of the REGCP_OTHER_ELEMS and
211 * are needed for the regexp context stack bookkeeping. */
212 SSPUSHINT(paren_elems_to_push + REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
213 SSPUSHINT(SAVEt_REGCONTEXT); /* Magic cookie. */
218 /* These are needed since we do not localize EVAL nodes: */
219 #define REGCP_SET(cp) \
221 PerlIO_printf(Perl_debug_log, \
222 " Setting an EVAL scope, savestack=%"IVdf"\n", \
223 (IV)PL_savestack_ix)); \
226 #define REGCP_UNWIND(cp) \
228 if (cp != PL_savestack_ix) \
229 PerlIO_printf(Perl_debug_log, \
230 " Clearing an EVAL scope, savestack=%"IVdf"..%"IVdf"\n", \
231 (IV)(cp), (IV)PL_savestack_ix)); \
235 S_regcppop(pTHX_ const regexp *rex)
241 GET_RE_DEBUG_FLAGS_DECL;
243 /* Pop REGCP_OTHER_ELEMS before the parentheses loop starts. */
245 assert(i == SAVEt_REGCONTEXT); /* Check that the magic cookie is there. */
246 i = SSPOPINT; /* Parentheses elements to pop. */
247 input = (char *) SSPOPPTR;
248 *PL_reglastcloseparen = SSPOPINT;
249 *PL_reglastparen = SSPOPINT;
250 PL_regsize = SSPOPINT;
251 PL_regoffs=(regexp_paren_pair *) SSPOPPTR;
254 /* Now restore the parentheses context. */
255 for (i -= (REGCP_OTHER_ELEMS - REGCP_FRAME_ELEMS);
256 i > 0; i -= REGCP_PAREN_ELEMS) {
258 U32 paren = (U32)SSPOPINT;
259 PL_reg_start_tmp[paren] = (char *) SSPOPPTR;
260 PL_regoffs[paren].start = SSPOPINT;
262 if (paren <= *PL_reglastparen)
263 PL_regoffs[paren].end = tmps;
265 PerlIO_printf(Perl_debug_log,
266 " restoring \\%"UVuf" to %"IVdf"(%"IVdf")..%"IVdf"%s\n",
267 (UV)paren, (IV)PL_regoffs[paren].start,
268 (IV)(PL_reg_start_tmp[paren] - PL_bostr),
269 (IV)PL_regoffs[paren].end,
270 (paren > *PL_reglastparen ? "(no)" : ""));
274 if (*PL_reglastparen + 1 <= rex->nparens) {
275 PerlIO_printf(Perl_debug_log,
276 " restoring \\%"IVdf"..\\%"IVdf" to undef\n",
277 (IV)(*PL_reglastparen + 1), (IV)rex->nparens);
281 /* It would seem that the similar code in regtry()
282 * already takes care of this, and in fact it is in
283 * a better location to since this code can #if 0-ed out
284 * but the code in regtry() is needed or otherwise tests
285 * requiring null fields (pat.t#187 and split.t#{13,14}
286 * (as of patchlevel 7877) will fail. Then again,
287 * this code seems to be necessary or otherwise
288 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
289 * --jhi updated by dapm */
290 for (i = *PL_reglastparen + 1; i <= rex->nparens; i++) {
292 PL_regoffs[i].start = -1;
293 PL_regoffs[i].end = -1;
299 #define regcpblow(cp) LEAVE_SCOPE(cp) /* Ignores regcppush()ed data. */
302 * pregexec and friends
305 #ifndef PERL_IN_XSUB_RE
307 - pregexec - match a regexp against a string
310 Perl_pregexec(pTHX_ REGEXP * const prog, char* stringarg, register char *strend,
311 char *strbeg, I32 minend, SV *screamer, U32 nosave)
312 /* strend: pointer to null at end of string */
313 /* strbeg: real beginning of string */
314 /* minend: end of match must be >=minend after stringarg. */
315 /* nosave: For optimizations. */
318 regexec_flags(prog, stringarg, strend, strbeg, minend, screamer, NULL,
319 nosave ? 0 : REXEC_COPY_STR);
324 * Need to implement the following flags for reg_anch:
326 * USE_INTUIT_NOML - Useful to call re_intuit_start() first
328 * INTUIT_AUTORITATIVE_NOML - Can trust a positive answer
329 * INTUIT_AUTORITATIVE_ML
330 * INTUIT_ONCE_NOML - Intuit can match in one location only.
333 * Another flag for this function: SECOND_TIME (so that float substrs
334 * with giant delta may be not rechecked).
337 /* Assumptions: if ANCH_GPOS, then strpos is anchored. XXXX Check GPOS logic */
339 /* If SCREAM, then SvPVX_const(sv) should be compatible with strpos and strend.
340 Otherwise, only SvCUR(sv) is used to get strbeg. */
342 /* XXXX We assume that strpos is strbeg unless sv. */
344 /* XXXX Some places assume that there is a fixed substring.
345 An update may be needed if optimizer marks as "INTUITable"
346 RExen without fixed substrings. Similarly, it is assumed that
347 lengths of all the strings are no more than minlen, thus they
348 cannot come from lookahead.
349 (Or minlen should take into account lookahead.)
350 NOTE: Some of this comment is not correct. minlen does now take account
351 of lookahead/behind. Further research is required. -- demerphq
355 /* A failure to find a constant substring means that there is no need to make
356 an expensive call to REx engine, thus we celebrate a failure. Similarly,
357 finding a substring too deep into the string means that less calls to
358 regtry() should be needed.
360 REx compiler's optimizer found 4 possible hints:
361 a) Anchored substring;
363 c) Whether we are anchored (beginning-of-line or \G);
364 d) First node (of those at offset 0) which may distingush positions;
365 We use a)b)d) and multiline-part of c), and try to find a position in the
366 string which does not contradict any of them.
369 /* Most of decisions we do here should have been done at compile time.
370 The nodes of the REx which we used for the search should have been
371 deleted from the finite automaton. */
374 Perl_re_intuit_start(pTHX_ REGEXP * const prog, SV *sv, char *strpos,
375 char *strend, const U32 flags, re_scream_pos_data *data)
378 register I32 start_shift = 0;
379 /* Should be nonnegative! */
380 register I32 end_shift = 0;
385 const bool do_utf8 = (sv && SvUTF8(sv)) ? 1 : 0; /* if no sv we have to assume bytes */
387 register char *other_last = NULL; /* other substr checked before this */
388 char *check_at = NULL; /* check substr found at this pos */
389 const I32 multiline = prog->extflags & RXf_PMf_MULTILINE;
390 RXi_GET_DECL(prog,progi);
392 const char * const i_strpos = strpos;
395 GET_RE_DEBUG_FLAGS_DECL;
397 RX_MATCH_UTF8_set(prog,do_utf8);
399 if (prog->extflags & RXf_UTF8) {
400 PL_reg_flags |= RF_utf8;
403 debug_start_match(prog, do_utf8, strpos, strend,
404 sv ? "Guessing start of match in sv for"
405 : "Guessing start of match in string for");
408 /* CHR_DIST() would be more correct here but it makes things slow. */
409 if (prog->minlen > strend - strpos) {
410 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
411 "String too short... [re_intuit_start]\n"));
415 strbeg = (sv && SvPOK(sv)) ? strend - SvCUR(sv) : strpos;
418 if (!prog->check_utf8 && prog->check_substr)
419 to_utf8_substr(prog);
420 check = prog->check_utf8;
422 if (!prog->check_substr && prog->check_utf8)
423 to_byte_substr(prog);
424 check = prog->check_substr;
426 if (check == &PL_sv_undef) {
427 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
428 "Non-utf8 string cannot match utf8 check string\n"));
431 if (prog->extflags & RXf_ANCH) { /* Match at beg-of-str or after \n */
432 ml_anch = !( (prog->extflags & RXf_ANCH_SINGLE)
433 || ( (prog->extflags & RXf_ANCH_BOL)
434 && !multiline ) ); /* Check after \n? */
437 if ( !(prog->extflags & RXf_ANCH_GPOS) /* Checked by the caller */
438 && !(prog->intflags & PREGf_IMPLICIT) /* not a real BOL */
439 /* SvCUR is not set on references: SvRV and SvPVX_const overlap */
441 && (strpos != strbeg)) {
442 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not at start...\n"));
445 if (prog->check_offset_min == prog->check_offset_max &&
446 !(prog->extflags & RXf_CANY_SEEN)) {
447 /* Substring at constant offset from beg-of-str... */
450 s = HOP3c(strpos, prog->check_offset_min, strend);
453 slen = SvCUR(check); /* >= 1 */
455 if ( strend - s > slen || strend - s < slen - 1
456 || (strend - s == slen && strend[-1] != '\n')) {
457 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String too long...\n"));
460 /* Now should match s[0..slen-2] */
462 if (slen && (*SvPVX_const(check) != *s
464 && memNE(SvPVX_const(check), s, slen)))) {
466 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "String not equal...\n"));
470 else if (*SvPVX_const(check) != *s
471 || ((slen = SvCUR(check)) > 1
472 && memNE(SvPVX_const(check), s, slen)))
475 goto success_at_start;
478 /* Match is anchored, but substr is not anchored wrt beg-of-str. */
480 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
481 end_shift = prog->check_end_shift;
484 const I32 end = prog->check_offset_max + CHR_SVLEN(check)
485 - (SvTAIL(check) != 0);
486 const I32 eshift = CHR_DIST((U8*)strend, (U8*)s) - end;
488 if (end_shift < eshift)
492 else { /* Can match at random position */
495 start_shift = prog->check_offset_min; /* okay to underestimate on CC */
496 end_shift = prog->check_end_shift;
498 /* end shift should be non negative here */
501 #ifdef QDEBUGGING /* 7/99: reports of failure (with the older version) */
503 Perl_croak(aTHX_ "panic: end_shift: %"IVdf" pattern:\n%s\n ",
504 (IV)end_shift, prog->precomp);
508 /* Find a possible match in the region s..strend by looking for
509 the "check" substring in the region corrected by start/end_shift. */
512 I32 srch_start_shift = start_shift;
513 I32 srch_end_shift = end_shift;
514 if (srch_start_shift < 0 && strbeg - s > srch_start_shift) {
515 srch_end_shift -= ((strbeg - s) - srch_start_shift);
516 srch_start_shift = strbeg - s;
518 DEBUG_OPTIMISE_MORE_r({
519 PerlIO_printf(Perl_debug_log, "Check offset min: %"IVdf" Start shift: %"IVdf" End shift %"IVdf" Real End Shift: %"IVdf"\n",
520 (IV)prog->check_offset_min,
521 (IV)srch_start_shift,
523 (IV)prog->check_end_shift);
526 if (flags & REXEC_SCREAM) {
527 I32 p = -1; /* Internal iterator of scream. */
528 I32 * const pp = data ? data->scream_pos : &p;
530 if (PL_screamfirst[BmRARE(check)] >= 0
531 || ( BmRARE(check) == '\n'
532 && (BmPREVIOUS(check) == SvCUR(check) - 1)
534 s = screaminstr(sv, check,
535 srch_start_shift + (s - strbeg), srch_end_shift, pp, 0);
538 /* we may be pointing at the wrong string */
539 if (s && RX_MATCH_COPIED(prog))
540 s = strbeg + (s - SvPVX_const(sv));
542 *data->scream_olds = s;
547 if (prog->extflags & RXf_CANY_SEEN) {
548 start_point= (U8*)(s + srch_start_shift);
549 end_point= (U8*)(strend - srch_end_shift);
551 start_point= HOP3(s, srch_start_shift, srch_start_shift < 0 ? strbeg : strend);
552 end_point= HOP3(strend, -srch_end_shift, strbeg);
554 DEBUG_OPTIMISE_MORE_r({
555 PerlIO_printf(Perl_debug_log, "fbm_instr len=%d str=<%.*s>\n",
556 (int)(end_point - start_point),
557 (int)(end_point - start_point) > 20 ? 20 : (int)(end_point - start_point),
561 s = fbm_instr( start_point, end_point,
562 check, multiline ? FBMrf_MULTILINE : 0);
565 /* Update the count-of-usability, remove useless subpatterns,
569 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
570 SvPVX_const(check), RE_SV_DUMPLEN(check), 30);
571 PerlIO_printf(Perl_debug_log, "%s %s substr %s%s%s",
572 (s ? "Found" : "Did not find"),
573 (check == (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)
574 ? "anchored" : "floating"),
577 (s ? " at offset " : "...\n") );
582 /* Finish the diagnostic message */
583 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%ld...\n", (long)(s - i_strpos)) );
585 /* XXX dmq: first branch is for positive lookbehind...
586 Our check string is offset from the beginning of the pattern.
587 So we need to do any stclass tests offset forward from that
596 /* Got a candidate. Check MBOL anchoring, and the *other* substr.
597 Start with the other substr.
598 XXXX no SCREAM optimization yet - and a very coarse implementation
599 XXXX /ttx+/ results in anchored="ttx", floating="x". floating will
600 *always* match. Probably should be marked during compile...
601 Probably it is right to do no SCREAM here...
604 if (do_utf8 ? (prog->float_utf8 && prog->anchored_utf8)
605 : (prog->float_substr && prog->anchored_substr))
607 /* Take into account the "other" substring. */
608 /* XXXX May be hopelessly wrong for UTF... */
611 if (check == (do_utf8 ? prog->float_utf8 : prog->float_substr)) {
614 char * const last = HOP3c(s, -start_shift, strbeg);
616 char * const saved_s = s;
619 t = s - prog->check_offset_max;
620 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
622 || ((t = (char*)reghopmaybe3((U8*)s, -(prog->check_offset_max), (U8*)strpos))
627 t = HOP3c(t, prog->anchored_offset, strend);
628 if (t < other_last) /* These positions already checked */
630 last2 = last1 = HOP3c(strend, -prog->minlen, strbeg);
633 /* XXXX It is not documented what units *_offsets are in.
634 We assume bytes, but this is clearly wrong.
635 Meaning this code needs to be carefully reviewed for errors.
639 /* On end-of-str: see comment below. */
640 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
641 if (must == &PL_sv_undef) {
643 DEBUG_r(must = prog->anchored_utf8); /* for debug */
648 HOP3(HOP3(last1, prog->anchored_offset, strend)
649 + SvCUR(must), -(SvTAIL(must)!=0), strbeg),
651 multiline ? FBMrf_MULTILINE : 0
654 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
655 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
656 PerlIO_printf(Perl_debug_log, "%s anchored substr %s%s",
657 (s ? "Found" : "Contradicts"),
658 quoted, RE_SV_TAIL(must));
663 if (last1 >= last2) {
664 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
665 ", giving up...\n"));
668 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
669 ", trying floating at offset %ld...\n",
670 (long)(HOP3c(saved_s, 1, strend) - i_strpos)));
671 other_last = HOP3c(last1, prog->anchored_offset+1, strend);
672 s = HOP3c(last, 1, strend);
676 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
677 (long)(s - i_strpos)));
678 t = HOP3c(s, -prog->anchored_offset, strbeg);
679 other_last = HOP3c(s, 1, strend);
687 else { /* Take into account the floating substring. */
689 char * const saved_s = s;
692 t = HOP3c(s, -start_shift, strbeg);
694 HOP3c(strend, -prog->minlen + prog->float_min_offset, strbeg);
695 if (CHR_DIST((U8*)last, (U8*)t) > prog->float_max_offset)
696 last = HOP3c(t, prog->float_max_offset, strend);
697 s = HOP3c(t, prog->float_min_offset, strend);
700 /* XXXX It is not documented what units *_offsets are in. Assume bytes. */
701 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
702 /* fbm_instr() takes into account exact value of end-of-str
703 if the check is SvTAIL(ed). Since false positives are OK,
704 and end-of-str is not later than strend we are OK. */
705 if (must == &PL_sv_undef) {
707 DEBUG_r(must = prog->float_utf8); /* for debug message */
710 s = fbm_instr((unsigned char*)s,
711 (unsigned char*)last + SvCUR(must)
713 must, multiline ? FBMrf_MULTILINE : 0);
715 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
716 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
717 PerlIO_printf(Perl_debug_log, "%s floating substr %s%s",
718 (s ? "Found" : "Contradicts"),
719 quoted, RE_SV_TAIL(must));
723 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
724 ", giving up...\n"));
727 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
728 ", trying anchored starting at offset %ld...\n",
729 (long)(saved_s + 1 - i_strpos)));
731 s = HOP3c(t, 1, strend);
735 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, " at offset %ld...\n",
736 (long)(s - i_strpos)));
737 other_last = s; /* Fix this later. --Hugo */
747 t= (char*)HOP3( s, -prog->check_offset_max, (prog->check_offset_max<0) ? strend : strpos);
749 DEBUG_OPTIMISE_MORE_r(
750 PerlIO_printf(Perl_debug_log,
751 "Check offset min:%"IVdf" max:%"IVdf" S:%"IVdf" t:%"IVdf" D:%"IVdf" end:%"IVdf"\n",
752 (IV)prog->check_offset_min,
753 (IV)prog->check_offset_max,
761 if (s - strpos > prog->check_offset_max /* signed-corrected t > strpos */
763 || ((t = (char*)reghopmaybe3((U8*)s, -prog->check_offset_max, (U8*) ((prog->check_offset_max<0) ? strend : strpos)))
766 /* Fixed substring is found far enough so that the match
767 cannot start at strpos. */
769 if (ml_anch && t[-1] != '\n') {
770 /* Eventually fbm_*() should handle this, but often
771 anchored_offset is not 0, so this check will not be wasted. */
772 /* XXXX In the code below we prefer to look for "^" even in
773 presence of anchored substrings. And we search even
774 beyond the found float position. These pessimizations
775 are historical artefacts only. */
777 while (t < strend - prog->minlen) {
779 if (t < check_at - prog->check_offset_min) {
780 if (do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) {
781 /* Since we moved from the found position,
782 we definitely contradict the found anchored
783 substr. Due to the above check we do not
784 contradict "check" substr.
785 Thus we can arrive here only if check substr
786 is float. Redo checking for "other"=="fixed".
789 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld, rescanning for anchored from offset %ld...\n",
790 PL_colors[0], PL_colors[1], (long)(strpos - i_strpos), (long)(strpos - i_strpos + prog->anchored_offset)));
791 goto do_other_anchored;
793 /* We don't contradict the found floating substring. */
794 /* XXXX Why not check for STCLASS? */
796 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m at offset %ld...\n",
797 PL_colors[0], PL_colors[1], (long)(s - i_strpos)));
800 /* Position contradicts check-string */
801 /* XXXX probably better to look for check-string
802 than for "\n", so one should lower the limit for t? */
803 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Found /%s^%s/m, restarting lookup for check-string at offset %ld...\n",
804 PL_colors[0], PL_colors[1], (long)(t + 1 - i_strpos)));
805 other_last = strpos = s = t + 1;
810 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Did not find /%s^%s/m...\n",
811 PL_colors[0], PL_colors[1]));
815 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Starting position does not contradict /%s^%s/m...\n",
816 PL_colors[0], PL_colors[1]));
820 ++BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr); /* hooray/5 */
823 /* The found string does not prohibit matching at strpos,
824 - no optimization of calling REx engine can be performed,
825 unless it was an MBOL and we are not after MBOL,
826 or a future STCLASS check will fail this. */
828 /* Even in this situation we may use MBOL flag if strpos is offset
829 wrt the start of the string. */
830 if (ml_anch && sv && !SvROK(sv) /* See prev comment on SvROK */
831 && (strpos != strbeg) && strpos[-1] != '\n'
832 /* May be due to an implicit anchor of m{.*foo} */
833 && !(prog->intflags & PREGf_IMPLICIT))
838 DEBUG_EXECUTE_r( if (ml_anch)
839 PerlIO_printf(Perl_debug_log, "Position at offset %ld does not contradict /%s^%s/m...\n",
840 (long)(strpos - i_strpos), PL_colors[0], PL_colors[1]);
843 if (!(prog->intflags & PREGf_NAUGHTY) /* XXXX If strpos moved? */
845 prog->check_utf8 /* Could be deleted already */
846 && --BmUSEFUL(prog->check_utf8) < 0
847 && (prog->check_utf8 == prog->float_utf8)
849 prog->check_substr /* Could be deleted already */
850 && --BmUSEFUL(prog->check_substr) < 0
851 && (prog->check_substr == prog->float_substr)
854 /* If flags & SOMETHING - do not do it many times on the same match */
855 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "... Disabling check substring...\n"));
856 SvREFCNT_dec(do_utf8 ? prog->check_utf8 : prog->check_substr);
857 if (do_utf8 ? prog->check_substr : prog->check_utf8)
858 SvREFCNT_dec(do_utf8 ? prog->check_substr : prog->check_utf8);
859 prog->check_substr = prog->check_utf8 = NULL; /* disable */
860 prog->float_substr = prog->float_utf8 = NULL; /* clear */
861 check = NULL; /* abort */
863 /* XXXX This is a remnant of the old implementation. It
864 looks wasteful, since now INTUIT can use many
866 prog->extflags &= ~RXf_USE_INTUIT;
873 /* XXXX BmUSEFUL already changed, maybe multiple change is meaningful... */
874 /* trie stclasses are too expensive to use here, we are better off to
875 leave it to regmatch itself */
876 if (progi->regstclass && PL_regkind[OP(progi->regstclass)]!=TRIE) {
877 /* minlen == 0 is possible if regstclass is \b or \B,
878 and the fixed substr is ''$.
879 Since minlen is already taken into account, s+1 is before strend;
880 accidentally, minlen >= 1 guaranties no false positives at s + 1
881 even for \b or \B. But (minlen? 1 : 0) below assumes that
882 regstclass does not come from lookahead... */
883 /* If regstclass takes bytelength more than 1: If charlength==1, OK.
884 This leaves EXACTF only, which is dealt with in find_byclass(). */
885 const U8* const str = (U8*)STRING(progi->regstclass);
886 const int cl_l = (PL_regkind[OP(progi->regstclass)] == EXACT
887 ? CHR_DIST(str+STR_LEN(progi->regstclass), str)
890 if (prog->anchored_substr || prog->anchored_utf8 || ml_anch)
891 endpos= HOP3c(s, (prog->minlen ? cl_l : 0), strend);
892 else if (prog->float_substr || prog->float_utf8)
893 endpos= HOP3c(HOP3c(check_at, -start_shift, strbeg), cl_l, strend);
897 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "start_shift: %"IVdf" check_at: %"IVdf" s: %"IVdf" endpos: %"IVdf"\n",
898 (IV)start_shift, (IV)(check_at - strbeg), (IV)(s - strbeg), (IV)(endpos - strbeg)));
901 s = find_byclass(prog, progi->regstclass, s, endpos, NULL);
904 const char *what = NULL;
906 if (endpos == strend) {
907 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
908 "Could not match STCLASS...\n") );
911 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
912 "This position contradicts STCLASS...\n") );
913 if ((prog->extflags & RXf_ANCH) && !ml_anch)
915 /* Contradict one of substrings */
916 if (prog->anchored_substr || prog->anchored_utf8) {
917 if ((do_utf8 ? prog->anchored_utf8 : prog->anchored_substr) == check) {
918 DEBUG_EXECUTE_r( what = "anchored" );
920 s = HOP3c(t, 1, strend);
921 if (s + start_shift + end_shift > strend) {
922 /* XXXX Should be taken into account earlier? */
923 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
924 "Could not match STCLASS...\n") );
929 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
930 "Looking for %s substr starting at offset %ld...\n",
931 what, (long)(s + start_shift - i_strpos)) );
934 /* Have both, check_string is floating */
935 if (t + start_shift >= check_at) /* Contradicts floating=check */
936 goto retry_floating_check;
937 /* Recheck anchored substring, but not floating... */
941 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
942 "Looking for anchored substr starting at offset %ld...\n",
943 (long)(other_last - i_strpos)) );
944 goto do_other_anchored;
946 /* Another way we could have checked stclass at the
947 current position only: */
952 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
953 "Looking for /%s^%s/m starting at offset %ld...\n",
954 PL_colors[0], PL_colors[1], (long)(t - i_strpos)) );
957 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr)) /* Could have been deleted */
959 /* Check is floating subtring. */
960 retry_floating_check:
961 t = check_at - start_shift;
962 DEBUG_EXECUTE_r( what = "floating" );
963 goto hop_and_restart;
966 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
967 "By STCLASS: moving %ld --> %ld\n",
968 (long)(t - i_strpos), (long)(s - i_strpos))
972 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
973 "Does not contradict STCLASS...\n");
978 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%s%s:%s match at offset %ld\n",
979 PL_colors[4], (check ? "Guessed" : "Giving up"),
980 PL_colors[5], (long)(s - i_strpos)) );
983 fail_finish: /* Substring not found */
984 if (prog->check_substr || prog->check_utf8) /* could be removed already */
985 BmUSEFUL(do_utf8 ? prog->check_utf8 : prog->check_substr) += 5; /* hooray */
987 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch rejected by optimizer%s\n",
988 PL_colors[4], PL_colors[5]));
992 #define DECL_TRIE_TYPE(scan) \
993 const enum { trie_plain, trie_utf8, trie_utf8_fold, trie_latin_utf8_fold } \
994 trie_type = (scan->flags != EXACT) \
995 ? (do_utf8 ? trie_utf8_fold : (UTF ? trie_latin_utf8_fold : trie_plain)) \
996 : (do_utf8 ? trie_utf8 : trie_plain)
998 #define REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc, uscan, len, \
999 uvc, charid, foldlen, foldbuf, uniflags) STMT_START { \
1000 switch (trie_type) { \
1001 case trie_utf8_fold: \
1002 if ( foldlen>0 ) { \
1003 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1008 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1009 uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
1010 foldlen -= UNISKIP( uvc ); \
1011 uscan = foldbuf + UNISKIP( uvc ); \
1014 case trie_latin_utf8_fold: \
1015 if ( foldlen>0 ) { \
1016 uvc = utf8n_to_uvuni( uscan, UTF8_MAXLEN, &len, uniflags ); \
1022 uvc = to_uni_fold( *(U8*)uc, foldbuf, &foldlen ); \
1023 foldlen -= UNISKIP( uvc ); \
1024 uscan = foldbuf + UNISKIP( uvc ); \
1028 uvc = utf8n_to_uvuni( (U8*)uc, UTF8_MAXLEN, &len, uniflags ); \
1036 charid = trie->charmap[ uvc ]; \
1040 if (widecharmap) { \
1041 SV** const svpp = hv_fetch(widecharmap, \
1042 (char*)&uvc, sizeof(UV), 0); \
1044 charid = (U16)SvIV(*svpp); \
1049 #define REXEC_FBC_EXACTISH_CHECK(CoNd) \
1051 char *my_strend= (char *)strend; \
1054 !ibcmp_utf8(s, &my_strend, 0, do_utf8, \
1055 m, NULL, ln, (bool)UTF)) \
1056 && (!reginfo || regtry(reginfo, &s)) ) \
1059 U8 foldbuf[UTF8_MAXBYTES_CASE+1]; \
1060 uvchr_to_utf8(tmpbuf, c); \
1061 f = to_utf8_fold(tmpbuf, foldbuf, &foldlen); \
1063 && (f == c1 || f == c2) \
1065 !ibcmp_utf8(s, &my_strend, 0, do_utf8,\
1066 m, NULL, ln, (bool)UTF)) \
1067 && (!reginfo || regtry(reginfo, &s)) ) \
1073 #define REXEC_FBC_EXACTISH_SCAN(CoNd) \
1077 && (ln == 1 || !(OP(c) == EXACTF \
1079 : ibcmp_locale(s, m, ln))) \
1080 && (!reginfo || regtry(reginfo, &s)) ) \
1086 #define REXEC_FBC_UTF8_SCAN(CoDe) \
1088 while (s + (uskip = UTF8SKIP(s)) <= strend) { \
1094 #define REXEC_FBC_SCAN(CoDe) \
1096 while (s < strend) { \
1102 #define REXEC_FBC_UTF8_CLASS_SCAN(CoNd) \
1103 REXEC_FBC_UTF8_SCAN( \
1105 if (tmp && (!reginfo || regtry(reginfo, &s))) \
1114 #define REXEC_FBC_CLASS_SCAN(CoNd) \
1117 if (tmp && (!reginfo || regtry(reginfo, &s))) \
1126 #define REXEC_FBC_TRYIT \
1127 if ((!reginfo || regtry(reginfo, &s))) \
1130 #define REXEC_FBC_CSCAN(CoNdUtF8,CoNd) \
1132 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1135 REXEC_FBC_CLASS_SCAN(CoNd); \
1139 #define REXEC_FBC_CSCAN_PRELOAD(UtFpReLoAd,CoNdUtF8,CoNd) \
1142 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1145 REXEC_FBC_CLASS_SCAN(CoNd); \
1149 #define REXEC_FBC_CSCAN_TAINT(CoNdUtF8,CoNd) \
1150 PL_reg_flags |= RF_tainted; \
1152 REXEC_FBC_UTF8_CLASS_SCAN(CoNdUtF8); \
1155 REXEC_FBC_CLASS_SCAN(CoNd); \
1159 #define DUMP_EXEC_POS(li,s,doutf8) \
1160 dump_exec_pos(li,s,(PL_regeol),(PL_bostr),(PL_reg_starttry),doutf8)
1162 /* We know what class REx starts with. Try to find this position... */
1163 /* if reginfo is NULL, its a dryrun */
1164 /* annoyingly all the vars in this routine have different names from their counterparts
1165 in regmatch. /grrr */
1168 S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s,
1169 const char *strend, regmatch_info *reginfo)
1172 const I32 doevery = (prog->intflags & PREGf_SKIP) == 0;
1176 register STRLEN uskip;
1180 register I32 tmp = 1; /* Scratch variable? */
1181 register const bool do_utf8 = PL_reg_match_utf8;
1182 RXi_GET_DECL(prog,progi);
1184 /* We know what class it must start with. */
1188 REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
1189 !UTF8_IS_INVARIANT((U8)s[0]) ?
1190 reginclass(prog, c, (U8*)s, 0, do_utf8) :
1191 REGINCLASS(prog, c, (U8*)s));
1194 while (s < strend) {
1197 if (REGINCLASS(prog, c, (U8*)s) ||
1198 (ANYOF_FOLD_SHARP_S(c, s, strend) &&
1199 /* The assignment of 2 is intentional:
1200 * for the folded sharp s, the skip is 2. */
1201 (skip = SHARP_S_SKIP))) {
1202 if (tmp && (!reginfo || regtry(reginfo, &s)))
1215 if (tmp && (!reginfo || regtry(reginfo, &s)))
1223 ln = STR_LEN(c); /* length to match in octets/bytes */
1224 lnc = (I32) ln; /* length to match in characters */
1226 STRLEN ulen1, ulen2;
1228 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
1229 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
1230 /* used by commented-out code below */
1231 /*const U32 uniflags = UTF8_ALLOW_DEFAULT;*/
1233 /* XXX: Since the node will be case folded at compile
1234 time this logic is a little odd, although im not
1235 sure that its actually wrong. --dmq */
1237 c1 = to_utf8_lower((U8*)m, tmpbuf1, &ulen1);
1238 c2 = to_utf8_upper((U8*)m, tmpbuf2, &ulen2);
1240 /* XXX: This is kinda strange. to_utf8_XYZ returns the
1241 codepoint of the first character in the converted
1242 form, yet originally we did the extra step.
1243 No tests fail by commenting this code out however
1244 so Ive left it out. -- dmq.
1246 c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXBYTES_CASE,
1248 c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXBYTES_CASE,
1253 while (sm < ((U8 *) m + ln)) {
1268 c2 = PL_fold_locale[c1];
1270 e = HOP3c(strend, -((I32)lnc), s);
1272 if (!reginfo && e < s)
1273 e = s; /* Due to minlen logic of intuit() */
1275 /* The idea in the EXACTF* cases is to first find the
1276 * first character of the EXACTF* node and then, if
1277 * necessary, case-insensitively compare the full
1278 * text of the node. The c1 and c2 are the first
1279 * characters (though in Unicode it gets a bit
1280 * more complicated because there are more cases
1281 * than just upper and lower: one needs to use
1282 * the so-called folding case for case-insensitive
1283 * matching (called "loose matching" in Unicode).
1284 * ibcmp_utf8() will do just that. */
1286 if (do_utf8 || UTF) {
1288 U8 tmpbuf [UTF8_MAXBYTES+1];
1291 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1293 /* Upper and lower of 1st char are equal -
1294 * probably not a "letter". */
1297 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1302 REXEC_FBC_EXACTISH_CHECK(c == c1);
1308 c = utf8n_to_uvchr((U8*)s, UTF8_MAXBYTES, &len,
1314 /* Handle some of the three Greek sigmas cases.
1315 * Note that not all the possible combinations
1316 * are handled here: some of them are handled
1317 * by the standard folding rules, and some of
1318 * them (the character class or ANYOF cases)
1319 * are handled during compiletime in
1320 * regexec.c:S_regclass(). */
1321 if (c == (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA ||
1322 c == (UV)UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA)
1323 c = (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA;
1325 REXEC_FBC_EXACTISH_CHECK(c == c1 || c == c2);
1330 /* Neither pattern nor string are UTF8 */
1332 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1);
1334 REXEC_FBC_EXACTISH_SCAN(*(U8*)s == c1 || *(U8*)s == c2);
1338 PL_reg_flags |= RF_tainted;
1345 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1346 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1348 tmp = ((OP(c) == BOUND ?
1349 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1350 LOAD_UTF8_CHARCLASS_ALNUM();
1351 REXEC_FBC_UTF8_SCAN(
1352 if (tmp == !(OP(c) == BOUND ?
1353 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1354 isALNUM_LC_utf8((U8*)s)))
1362 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1363 tmp = ((OP(c) == BOUND ? isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1366 !(OP(c) == BOUND ? isALNUM(*s) : isALNUM_LC(*s))) {
1372 if ((!prog->minlen && tmp) && (!reginfo || regtry(reginfo, &s)))
1376 PL_reg_flags |= RF_tainted;
1383 U8 * const r = reghop3((U8*)s, -1, (U8*)PL_bostr);
1384 tmp = utf8n_to_uvchr(r, UTF8SKIP(r), 0, UTF8_ALLOW_DEFAULT);
1386 tmp = ((OP(c) == NBOUND ?
1387 isALNUM_uni(tmp) : isALNUM_LC_uvchr(UNI_TO_NATIVE(tmp))) != 0);
1388 LOAD_UTF8_CHARCLASS_ALNUM();
1389 REXEC_FBC_UTF8_SCAN(
1390 if (tmp == !(OP(c) == NBOUND ?
1391 (bool)swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8) :
1392 isALNUM_LC_utf8((U8*)s)))
1394 else REXEC_FBC_TRYIT;
1398 tmp = (s != PL_bostr) ? UCHARAT(s - 1) : '\n';
1399 tmp = ((OP(c) == NBOUND ?
1400 isALNUM(tmp) : isALNUM_LC(tmp)) != 0);
1403 !(OP(c) == NBOUND ? isALNUM(*s) : isALNUM_LC(*s)))
1405 else REXEC_FBC_TRYIT;
1408 if ((!prog->minlen && !tmp) && (!reginfo || regtry(reginfo, &s)))
1412 REXEC_FBC_CSCAN_PRELOAD(
1413 LOAD_UTF8_CHARCLASS_ALNUM(),
1414 swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1418 REXEC_FBC_CSCAN_TAINT(
1419 isALNUM_LC_utf8((U8*)s),
1423 REXEC_FBC_CSCAN_PRELOAD(
1424 LOAD_UTF8_CHARCLASS_ALNUM(),
1425 !swash_fetch(PL_utf8_alnum, (U8*)s, do_utf8),
1429 REXEC_FBC_CSCAN_TAINT(
1430 !isALNUM_LC_utf8((U8*)s),
1434 REXEC_FBC_CSCAN_PRELOAD(
1435 LOAD_UTF8_CHARCLASS_SPACE(),
1436 *s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8),
1440 REXEC_FBC_CSCAN_TAINT(
1441 *s == ' ' || isSPACE_LC_utf8((U8*)s),
1445 REXEC_FBC_CSCAN_PRELOAD(
1446 LOAD_UTF8_CHARCLASS_SPACE(),
1447 !(*s == ' ' || swash_fetch(PL_utf8_space,(U8*)s, do_utf8)),
1451 REXEC_FBC_CSCAN_TAINT(
1452 !(*s == ' ' || isSPACE_LC_utf8((U8*)s)),
1456 REXEC_FBC_CSCAN_PRELOAD(
1457 LOAD_UTF8_CHARCLASS_DIGIT(),
1458 swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1462 REXEC_FBC_CSCAN_TAINT(
1463 isDIGIT_LC_utf8((U8*)s),
1467 REXEC_FBC_CSCAN_PRELOAD(
1468 LOAD_UTF8_CHARCLASS_DIGIT(),
1469 !swash_fetch(PL_utf8_digit,(U8*)s, do_utf8),
1473 REXEC_FBC_CSCAN_TAINT(
1474 !isDIGIT_LC_utf8((U8*)s),
1480 is_LNBREAK_latin1(s)
1490 !is_VERTWS_latin1(s)
1495 is_HORIZWS_latin1(s)
1499 !is_HORIZWS_utf8(s),
1500 !is_HORIZWS_latin1(s)
1506 /* what trie are we using right now */
1508 = (reg_ac_data*)progi->data->data[ ARG( c ) ];
1510 = (reg_trie_data*)progi->data->data[ aho->trie ];
1511 HV *widecharmap = (HV*) progi->data->data[ aho->trie + 1 ];
1513 const char *last_start = strend - trie->minlen;
1515 const char *real_start = s;
1517 STRLEN maxlen = trie->maxlen;
1519 U8 **points; /* map of where we were in the input string
1520 when reading a given char. For ASCII this
1521 is unnecessary overhead as the relationship
1522 is always 1:1, but for Unicode, especially
1523 case folded Unicode this is not true. */
1524 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1528 GET_RE_DEBUG_FLAGS_DECL;
1530 /* We can't just allocate points here. We need to wrap it in
1531 * an SV so it gets freed properly if there is a croak while
1532 * running the match */
1535 sv_points=newSV(maxlen * sizeof(U8 *));
1536 SvCUR_set(sv_points,
1537 maxlen * sizeof(U8 *));
1538 SvPOK_on(sv_points);
1539 sv_2mortal(sv_points);
1540 points=(U8**)SvPV_nolen(sv_points );
1541 if ( trie_type != trie_utf8_fold
1542 && (trie->bitmap || OP(c)==AHOCORASICKC) )
1545 bitmap=(U8*)trie->bitmap;
1547 bitmap=(U8*)ANYOF_BITMAP(c);
1549 /* this is the Aho-Corasick algorithm modified a touch
1550 to include special handling for long "unknown char"
1551 sequences. The basic idea being that we use AC as long
1552 as we are dealing with a possible matching char, when
1553 we encounter an unknown char (and we have not encountered
1554 an accepting state) we scan forward until we find a legal
1556 AC matching is basically that of trie matching, except
1557 that when we encounter a failing transition, we fall back
1558 to the current states "fail state", and try the current char
1559 again, a process we repeat until we reach the root state,
1560 state 1, or a legal transition. If we fail on the root state
1561 then we can either terminate if we have reached an accepting
1562 state previously, or restart the entire process from the beginning
1566 while (s <= last_start) {
1567 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1575 U8 *uscan = (U8*)NULL;
1576 U8 *leftmost = NULL;
1578 U32 accepted_word= 0;
1582 while ( state && uc <= (U8*)strend ) {
1584 U32 word = aho->states[ state ].wordnum;
1588 DEBUG_TRIE_EXECUTE_r(
1589 if ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1590 dump_exec_pos( (char *)uc, c, strend, real_start,
1591 (char *)uc, do_utf8 );
1592 PerlIO_printf( Perl_debug_log,
1593 " Scanning for legal start char...\n");
1596 while ( uc <= (U8*)last_start && !BITMAP_TEST(bitmap,*uc) ) {
1601 if (uc >(U8*)last_start) break;
1605 U8 *lpos= points[ (pointpos - trie->wordlen[word-1] ) % maxlen ];
1606 if (!leftmost || lpos < leftmost) {
1607 DEBUG_r(accepted_word=word);
1613 points[pointpos++ % maxlen]= uc;
1614 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
1615 uscan, len, uvc, charid, foldlen,
1617 DEBUG_TRIE_EXECUTE_r({
1618 dump_exec_pos( (char *)uc, c, strend, real_start,
1620 PerlIO_printf(Perl_debug_log,
1621 " Charid:%3u CP:%4"UVxf" ",
1627 word = aho->states[ state ].wordnum;
1629 base = aho->states[ state ].trans.base;
1631 DEBUG_TRIE_EXECUTE_r({
1633 dump_exec_pos( (char *)uc, c, strend, real_start,
1635 PerlIO_printf( Perl_debug_log,
1636 "%sState: %4"UVxf", word=%"UVxf,
1637 failed ? " Fail transition to " : "",
1638 (UV)state, (UV)word);
1643 (base + charid > trie->uniquecharcount )
1644 && (base + charid - 1 - trie->uniquecharcount
1646 && trie->trans[base + charid - 1 -
1647 trie->uniquecharcount].check == state
1648 && (tmp=trie->trans[base + charid - 1 -
1649 trie->uniquecharcount ].next))
1651 DEBUG_TRIE_EXECUTE_r(
1652 PerlIO_printf( Perl_debug_log," - legal\n"));
1657 DEBUG_TRIE_EXECUTE_r(
1658 PerlIO_printf( Perl_debug_log," - fail\n"));
1660 state = aho->fail[state];
1664 /* we must be accepting here */
1665 DEBUG_TRIE_EXECUTE_r(
1666 PerlIO_printf( Perl_debug_log," - accepting\n"));
1675 if (!state) state = 1;
1678 if ( aho->states[ state ].wordnum ) {
1679 U8 *lpos = points[ (pointpos - trie->wordlen[aho->states[ state ].wordnum-1]) % maxlen ];
1680 if (!leftmost || lpos < leftmost) {
1681 DEBUG_r(accepted_word=aho->states[ state ].wordnum);
1686 s = (char*)leftmost;
1687 DEBUG_TRIE_EXECUTE_r({
1689 Perl_debug_log,"Matches word #%"UVxf" at position %"IVdf". Trying full pattern...\n",
1690 (UV)accepted_word, (IV)(s - real_start)
1693 if (!reginfo || regtry(reginfo, &s)) {
1699 DEBUG_TRIE_EXECUTE_r({
1700 PerlIO_printf( Perl_debug_log,"Pattern failed. Looking for new start point...\n");
1703 DEBUG_TRIE_EXECUTE_r(
1704 PerlIO_printf( Perl_debug_log,"No match.\n"));
1713 Perl_croak(aTHX_ "panic: unknown regstclass %d", (int)OP(c));
1722 S_swap_match_buff (pTHX_ regexp *prog) {
1723 regexp_paren_pair *t;
1726 /* We have to be careful. If the previous successful match
1727 was from this regex we don't want a subsequent paritally
1728 successful match to clobber the old results.
1729 So when we detect this possibility we add a swap buffer
1730 to the re, and switch the buffer each match. If we fail
1731 we switch it back, otherwise we leave it swapped.
1733 Newxz(prog->swap, (prog->nparens + 1), regexp_paren_pair);
1736 prog->swap = prog->offs;
1742 - regexec_flags - match a regexp against a string
1745 Perl_regexec_flags(pTHX_ REGEXP * const prog, char *stringarg, register char *strend,
1746 char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
1747 /* strend: pointer to null at end of string */
1748 /* strbeg: real beginning of string */
1749 /* minend: end of match must be >=minend after stringarg. */
1750 /* data: May be used for some additional optimizations.
1751 Currently its only used, with a U32 cast, for transmitting
1752 the ganch offset when doing a /g match. This will change */
1753 /* nosave: For optimizations. */
1756 /*register*/ char *s;
1757 register regnode *c;
1758 /*register*/ char *startpos = stringarg;
1759 I32 minlen; /* must match at least this many chars */
1760 I32 dontbother = 0; /* how many characters not to try at end */
1761 I32 end_shift = 0; /* Same for the end. */ /* CC */
1762 I32 scream_pos = -1; /* Internal iterator of scream. */
1763 char *scream_olds = NULL;
1764 const bool do_utf8 = (bool)DO_UTF8(sv);
1766 RXi_GET_DECL(prog,progi);
1767 regmatch_info reginfo; /* create some info to pass to regtry etc */
1768 bool swap_on_fail = 0;
1770 GET_RE_DEBUG_FLAGS_DECL;
1772 PERL_UNUSED_ARG(data);
1774 /* Be paranoid... */
1775 if (prog == NULL || startpos == NULL) {
1776 Perl_croak(aTHX_ "NULL regexp parameter");
1780 multiline = prog->extflags & RXf_PMf_MULTILINE;
1781 reginfo.prog = prog;
1783 RX_MATCH_UTF8_set(prog, do_utf8);
1785 debug_start_match(prog, do_utf8, startpos, strend,
1789 minlen = prog->minlen;
1791 if (strend - startpos < (minlen+(prog->check_offset_min<0?prog->check_offset_min:0))) {
1792 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
1793 "String too short [regexec_flags]...\n"));
1798 /* Check validity of program. */
1799 if (UCHARAT(progi->program) != REG_MAGIC) {
1800 Perl_croak(aTHX_ "corrupted regexp program");
1804 PL_reg_eval_set = 0;
1807 if (prog->extflags & RXf_UTF8)
1808 PL_reg_flags |= RF_utf8;
1810 /* Mark beginning of line for ^ and lookbehind. */
1811 reginfo.bol = startpos; /* XXX not used ??? */
1815 /* Mark end of line for $ (and such) */
1818 /* see how far we have to get to not match where we matched before */
1819 reginfo.till = startpos+minend;
1821 /* If there is a "must appear" string, look for it. */
1824 if (prog->extflags & RXf_GPOS_SEEN) { /* Need to set reginfo->ganch */
1827 if (flags & REXEC_IGNOREPOS) /* Means: check only at start */
1828 reginfo.ganch = startpos + prog->gofs;
1829 else if (sv && SvTYPE(sv) >= SVt_PVMG
1831 && (mg = mg_find(sv, PERL_MAGIC_regex_global))
1832 && mg->mg_len >= 0) {
1833 reginfo.ganch = strbeg + mg->mg_len; /* Defined pos() */
1834 if (prog->extflags & RXf_ANCH_GPOS) {
1835 if (s > reginfo.ganch)
1837 s = reginfo.ganch - prog->gofs;
1841 reginfo.ganch = strbeg + PTR2UV(data);
1842 } else /* pos() not defined */
1843 reginfo.ganch = strbeg;
1845 if (PL_curpm && (PM_GETRE(PL_curpm) == prog)) {
1847 swap_match_buff(prog); /* do we need a save destructor here for
1850 if (!(flags & REXEC_CHECKED) && (prog->check_substr != NULL || prog->check_utf8 != NULL)) {
1851 re_scream_pos_data d;
1853 d.scream_olds = &scream_olds;
1854 d.scream_pos = &scream_pos;
1855 s = re_intuit_start(prog, sv, s, strend, flags, &d);
1857 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Not present...\n"));
1858 goto phooey; /* not present */
1864 /* Simplest case: anchored match need be tried only once. */
1865 /* [unless only anchor is BOL and multiline is set] */
1866 if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {
1867 if (s == startpos && regtry(®info, &startpos))
1869 else if (multiline || (prog->intflags & PREGf_IMPLICIT)
1870 || (prog->extflags & RXf_ANCH_MBOL)) /* XXXX SBOL? */
1875 dontbother = minlen - 1;
1876 end = HOP3c(strend, -dontbother, strbeg) - 1;
1877 /* for multiline we only have to try after newlines */
1878 if (prog->check_substr || prog->check_utf8) {
1882 if (regtry(®info, &s))
1887 if (prog->extflags & RXf_USE_INTUIT) {
1888 s = re_intuit_start(prog, sv, s + 1, strend, flags, NULL);
1899 if (*s++ == '\n') { /* don't need PL_utf8skip here */
1900 if (regtry(®info, &s))
1907 } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK))
1909 /* the warning about reginfo.ganch being used without intialization
1910 is bogus -- we set it above, when prog->extflags & RXf_GPOS_SEEN
1911 and we only enter this block when the same bit is set. */
1912 char *tmp_s = reginfo.ganch - prog->gofs;
1913 if (regtry(®info, &tmp_s))
1918 /* Messy cases: unanchored match. */
1919 if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {
1920 /* we have /x+whatever/ */
1921 /* it must be a one character string (XXXX Except UTF?) */
1926 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1927 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1928 ch = SvPVX_const(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr)[0];
1933 DEBUG_EXECUTE_r( did_match = 1 );
1934 if (regtry(®info, &s)) goto got_it;
1936 while (s < strend && *s == ch)
1944 DEBUG_EXECUTE_r( did_match = 1 );
1945 if (regtry(®info, &s)) goto got_it;
1947 while (s < strend && *s == ch)
1952 DEBUG_EXECUTE_r(if (!did_match)
1953 PerlIO_printf(Perl_debug_log,
1954 "Did not find anchored character...\n")
1957 else if (prog->anchored_substr != NULL
1958 || prog->anchored_utf8 != NULL
1959 || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
1960 && prog->float_max_offset < strend - s)) {
1965 char *last1; /* Last position checked before */
1969 if (prog->anchored_substr || prog->anchored_utf8) {
1970 if (!(do_utf8 ? prog->anchored_utf8 : prog->anchored_substr))
1971 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1972 must = do_utf8 ? prog->anchored_utf8 : prog->anchored_substr;
1973 back_max = back_min = prog->anchored_offset;
1975 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
1976 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
1977 must = do_utf8 ? prog->float_utf8 : prog->float_substr;
1978 back_max = prog->float_max_offset;
1979 back_min = prog->float_min_offset;
1983 if (must == &PL_sv_undef)
1984 /* could not downgrade utf8 check substring, so must fail */
1990 last = HOP3c(strend, /* Cannot start after this */
1991 -(I32)(CHR_SVLEN(must)
1992 - (SvTAIL(must) != 0) + back_min), strbeg);
1995 last1 = HOPc(s, -1);
1997 last1 = s - 1; /* bogus */
1999 /* XXXX check_substr already used to find "s", can optimize if
2000 check_substr==must. */
2002 dontbother = end_shift;
2003 strend = HOPc(strend, -dontbother);
2004 while ( (s <= last) &&
2005 ((flags & REXEC_SCREAM)
2006 ? (s = screaminstr(sv, must, HOP3c(s, back_min, (back_min<0 ? strbeg : strend)) - strbeg,
2007 end_shift, &scream_pos, 0))
2008 : (s = fbm_instr((unsigned char*)HOP3(s, back_min, (back_min<0 ? strbeg : strend)),
2009 (unsigned char*)strend, must,
2010 multiline ? FBMrf_MULTILINE : 0))) ) {
2011 /* we may be pointing at the wrong string */
2012 if ((flags & REXEC_SCREAM) && RX_MATCH_COPIED(prog))
2013 s = strbeg + (s - SvPVX_const(sv));
2014 DEBUG_EXECUTE_r( did_match = 1 );
2015 if (HOPc(s, -back_max) > last1) {
2016 last1 = HOPc(s, -back_min);
2017 s = HOPc(s, -back_max);
2020 char * const t = (last1 >= PL_bostr) ? HOPc(last1, 1) : last1 + 1;
2022 last1 = HOPc(s, -back_min);
2026 while (s <= last1) {
2027 if (regtry(®info, &s))
2033 while (s <= last1) {
2034 if (regtry(®info, &s))
2040 DEBUG_EXECUTE_r(if (!did_match) {
2041 RE_PV_QUOTED_DECL(quoted, do_utf8, PERL_DEBUG_PAD_ZERO(0),
2042 SvPVX_const(must), RE_SV_DUMPLEN(must), 30);
2043 PerlIO_printf(Perl_debug_log, "Did not find %s substr %s%s...\n",
2044 ((must == prog->anchored_substr || must == prog->anchored_utf8)
2045 ? "anchored" : "floating"),
2046 quoted, RE_SV_TAIL(must));
2050 else if ( (c = progi->regstclass) ) {
2052 const OPCODE op = OP(progi->regstclass);
2053 /* don't bother with what can't match */
2054 if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
2055 strend = HOPc(strend, -(minlen - 1));
2058 SV * const prop = sv_newmortal();
2059 regprop(prog, prop, c);
2061 RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
2063 PerlIO_printf(Perl_debug_log,
2064 "Matching stclass %.*s against %s (%d chars)\n",
2065 (int)SvCUR(prop), SvPVX_const(prop),
2066 quoted, (int)(strend - s));
2069 if (find_byclass(prog, c, s, strend, ®info))
2071 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
2075 if (prog->float_substr != NULL || prog->float_utf8 != NULL) {
2080 if (!(do_utf8 ? prog->float_utf8 : prog->float_substr))
2081 do_utf8 ? to_utf8_substr(prog) : to_byte_substr(prog);
2082 float_real = do_utf8 ? prog->float_utf8 : prog->float_substr;
2084 if (flags & REXEC_SCREAM) {
2085 last = screaminstr(sv, float_real, s - strbeg,
2086 end_shift, &scream_pos, 1); /* last one */
2088 last = scream_olds; /* Only one occurrence. */
2089 /* we may be pointing at the wrong string */
2090 else if (RX_MATCH_COPIED(prog))
2091 s = strbeg + (s - SvPVX_const(sv));
2095 const char * const little = SvPV_const(float_real, len);
2097 if (SvTAIL(float_real)) {
2098 if (memEQ(strend - len + 1, little, len - 1))
2099 last = strend - len + 1;
2100 else if (!multiline)
2101 last = memEQ(strend - len, little, len)
2102 ? strend - len : NULL;
2108 last = rninstr(s, strend, little, little + len);
2110 last = strend; /* matching "$" */
2115 PerlIO_printf(Perl_debug_log,
2116 "%sCan't trim the tail, match fails (should not happen)%s\n",
2117 PL_colors[4], PL_colors[5]));
2118 goto phooey; /* Should not happen! */
2120 dontbother = strend - last + prog->float_min_offset;
2122 if (minlen && (dontbother < minlen))
2123 dontbother = minlen - 1;
2124 strend -= dontbother; /* this one's always in bytes! */
2125 /* We don't know much -- general case. */
2128 if (regtry(®info, &s))
2137 if (regtry(®info, &s))
2139 } while (s++ < strend);
2147 RX_MATCH_TAINTED_set(prog, PL_reg_flags & RF_tainted);
2149 if (PL_reg_eval_set)
2150 restore_pos(aTHX_ prog);
2151 if (prog->paren_names)
2152 (void)hv_iterinit(prog->paren_names);
2154 /* make sure $`, $&, $', and $digit will work later */
2155 if ( !(flags & REXEC_NOT_FIRST) ) {
2156 RX_MATCH_COPY_FREE(prog);
2157 if (flags & REXEC_COPY_STR) {
2158 const I32 i = PL_regeol - startpos + (stringarg - strbeg);
2159 #ifdef PERL_OLD_COPY_ON_WRITE
2161 || (SvFLAGS(sv) & CAN_COW_MASK) == CAN_COW_FLAGS)) {
2163 PerlIO_printf(Perl_debug_log,
2164 "Copy on write: regexp capture, type %d\n",
2167 prog->saved_copy = sv_setsv_cow(prog->saved_copy, sv);
2168 prog->subbeg = (char *)SvPVX_const(prog->saved_copy);
2169 assert (SvPOKp(prog->saved_copy));
2173 RX_MATCH_COPIED_on(prog);
2174 s = savepvn(strbeg, i);
2180 prog->subbeg = strbeg;
2181 prog->sublen = PL_regeol - strbeg; /* strend may have been modified */
2188 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch failed%s\n",
2189 PL_colors[4], PL_colors[5]));
2190 if (PL_reg_eval_set)
2191 restore_pos(aTHX_ prog);
2193 /* we failed :-( roll it back */
2194 swap_match_buff(prog);
2201 - regtry - try match at specific point
2203 STATIC I32 /* 0 failure, 1 success */
2204 S_regtry(pTHX_ regmatch_info *reginfo, char **startpos)
2208 regexp *prog = reginfo->prog;
2209 RXi_GET_DECL(prog,progi);
2210 GET_RE_DEBUG_FLAGS_DECL;
2211 reginfo->cutpoint=NULL;
2213 if ((prog->extflags & RXf_EVAL_SEEN) && !PL_reg_eval_set) {
2216 PL_reg_eval_set = RS_init;
2217 DEBUG_EXECUTE_r(DEBUG_s(
2218 PerlIO_printf(Perl_debug_log, " setting stack tmpbase at %"IVdf"\n",
2219 (IV)(PL_stack_sp - PL_stack_base));
2222 cxstack[cxstack_ix].blk_oldsp = PL_stack_sp - PL_stack_base;
2223 /* Otherwise OP_NEXTSTATE will free whatever on stack now. */
2225 /* Apparently this is not needed, judging by wantarray. */
2226 /* SAVEI8(cxstack[cxstack_ix].blk_gimme);
2227 cxstack[cxstack_ix].blk_gimme = G_SCALAR; */
2230 /* Make $_ available to executed code. */
2231 if (reginfo->sv != DEFSV) {
2233 DEFSV = reginfo->sv;
2236 if (!(SvTYPE(reginfo->sv) >= SVt_PVMG && SvMAGIC(reginfo->sv)
2237 && (mg = mg_find(reginfo->sv, PERL_MAGIC_regex_global)))) {
2238 /* prepare for quick setting of pos */
2239 #ifdef PERL_OLD_COPY_ON_WRITE
2240 if (SvIsCOW(reginfo->sv))
2241 sv_force_normal_flags(reginfo->sv, 0);
2243 mg = sv_magicext(reginfo->sv, NULL, PERL_MAGIC_regex_global,
2244 &PL_vtbl_mglob, NULL, 0);
2248 PL_reg_oldpos = mg->mg_len;
2249 SAVEDESTRUCTOR_X(restore_pos, prog);
2251 if (!PL_reg_curpm) {
2252 Newxz(PL_reg_curpm, 1, PMOP);
2255 SV* const repointer = newSViv(0);
2256 /* so we know which PL_regex_padav element is PL_reg_curpm */
2257 SvFLAGS(repointer) |= SVf_BREAK;
2258 av_push(PL_regex_padav,repointer);
2259 PL_reg_curpm->op_pmoffset = av_len(PL_regex_padav);
2260 PL_regex_pad = AvARRAY(PL_regex_padav);
2264 PM_SETRE(PL_reg_curpm, prog);
2265 PL_reg_oldcurpm = PL_curpm;
2266 PL_curpm = PL_reg_curpm;
2267 if (RX_MATCH_COPIED(prog)) {
2268 /* Here is a serious problem: we cannot rewrite subbeg,
2269 since it may be needed if this match fails. Thus
2270 $` inside (?{}) could fail... */
2271 PL_reg_oldsaved = prog->subbeg;
2272 PL_reg_oldsavedlen = prog->sublen;
2273 #ifdef PERL_OLD_COPY_ON_WRITE
2274 PL_nrs = prog->saved_copy;
2276 RX_MATCH_COPIED_off(prog);
2279 PL_reg_oldsaved = NULL;
2280 prog->subbeg = PL_bostr;
2281 prog->sublen = PL_regeol - PL_bostr; /* strend may have been modified */
2283 DEBUG_EXECUTE_r(PL_reg_starttry = *startpos);
2284 prog->offs[0].start = *startpos - PL_bostr;
2285 PL_reginput = *startpos;
2286 PL_reglastparen = &prog->lastparen;
2287 PL_reglastcloseparen = &prog->lastcloseparen;
2288 prog->lastparen = 0;
2289 prog->lastcloseparen = 0;
2291 PL_regoffs = prog->offs;
2292 if (PL_reg_start_tmpl <= prog->nparens) {
2293 PL_reg_start_tmpl = prog->nparens*3/2 + 3;
2294 if(PL_reg_start_tmp)
2295 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2297 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
2300 /* XXXX What this code is doing here?!!! There should be no need
2301 to do this again and again, PL_reglastparen should take care of
2304 /* Tests pat.t#187 and split.t#{13,14} seem to depend on this code.
2305 * Actually, the code in regcppop() (which Ilya may be meaning by
2306 * PL_reglastparen), is not needed at all by the test suite
2307 * (op/regexp, op/pat, op/split), but that code is needed otherwise
2308 * this erroneously leaves $1 defined: "1" =~ /^(?:(\d)x)?\d$/
2309 * Meanwhile, this code *is* needed for the
2310 * above-mentioned test suite tests to succeed. The common theme
2311 * on those tests seems to be returning null fields from matches.
2312 * --jhi updated by dapm */
2314 if (prog->nparens) {
2315 regexp_paren_pair *pp = PL_regoffs;
2317 for (i = prog->nparens; i > (I32)*PL_reglastparen; i--) {
2325 if (regmatch(reginfo, progi->program + 1)) {
2326 PL_regoffs[0].end = PL_reginput - PL_bostr;
2329 if (reginfo->cutpoint)
2330 *startpos= reginfo->cutpoint;
2331 REGCP_UNWIND(lastcp);
2336 #define sayYES goto yes
2337 #define sayNO goto no
2338 #define sayNO_SILENT goto no_silent
2340 /* we dont use STMT_START/END here because it leads to
2341 "unreachable code" warnings, which are bogus, but distracting. */
2342 #define CACHEsayNO \
2343 if (ST.cache_mask) \
2344 PL_reg_poscache[ST.cache_offset] |= ST.cache_mask; \
2347 /* this is used to determine how far from the left messages like
2348 'failed...' are printed. It should be set such that messages
2349 are inline with the regop output that created them.
2351 #define REPORT_CODE_OFF 32
2354 /* Make sure there is a test for this +1 options in re_tests */
2355 #define TRIE_INITAL_ACCEPT_BUFFLEN 4;
2357 #define CHRTEST_UNINIT -1001 /* c1/c2 haven't been calculated yet */
2358 #define CHRTEST_VOID -1000 /* the c1/c2 "next char" test should be skipped */
2360 #define SLAB_FIRST(s) (&(s)->states[0])
2361 #define SLAB_LAST(s) (&(s)->states[PERL_REGMATCH_SLAB_SLOTS-1])
2363 /* grab a new slab and return the first slot in it */
2365 STATIC regmatch_state *
2368 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2371 regmatch_slab *s = PL_regmatch_slab->next;
2373 Newx(s, 1, regmatch_slab);
2374 s->prev = PL_regmatch_slab;
2376 PL_regmatch_slab->next = s;
2378 PL_regmatch_slab = s;
2379 return SLAB_FIRST(s);
2383 /* push a new state then goto it */
2385 #define PUSH_STATE_GOTO(state, node) \
2387 st->resume_state = state; \
2390 /* push a new state with success backtracking, then goto it */
2392 #define PUSH_YES_STATE_GOTO(state, node) \
2394 st->resume_state = state; \
2395 goto push_yes_state;
2401 regmatch() - main matching routine
2403 This is basically one big switch statement in a loop. We execute an op,
2404 set 'next' to point the next op, and continue. If we come to a point which
2405 we may need to backtrack to on failure such as (A|B|C), we push a
2406 backtrack state onto the backtrack stack. On failure, we pop the top
2407 state, and re-enter the loop at the state indicated. If there are no more
2408 states to pop, we return failure.
2410 Sometimes we also need to backtrack on success; for example /A+/, where
2411 after successfully matching one A, we need to go back and try to
2412 match another one; similarly for lookahead assertions: if the assertion
2413 completes successfully, we backtrack to the state just before the assertion
2414 and then carry on. In these cases, the pushed state is marked as
2415 'backtrack on success too'. This marking is in fact done by a chain of
2416 pointers, each pointing to the previous 'yes' state. On success, we pop to
2417 the nearest yes state, discarding any intermediate failure-only states.
2418 Sometimes a yes state is pushed just to force some cleanup code to be
2419 called at the end of a successful match or submatch; e.g. (??{$re}) uses
2420 it to free the inner regex.
2422 Note that failure backtracking rewinds the cursor position, while
2423 success backtracking leaves it alone.
2425 A pattern is complete when the END op is executed, while a subpattern
2426 such as (?=foo) is complete when the SUCCESS op is executed. Both of these
2427 ops trigger the "pop to last yes state if any, otherwise return true"
2430 A common convention in this function is to use A and B to refer to the two
2431 subpatterns (or to the first nodes thereof) in patterns like /A*B/: so A is
2432 the subpattern to be matched possibly multiple times, while B is the entire
2433 rest of the pattern. Variable and state names reflect this convention.
2435 The states in the main switch are the union of ops and failure/success of
2436 substates associated with with that op. For example, IFMATCH is the op
2437 that does lookahead assertions /(?=A)B/ and so the IFMATCH state means
2438 'execute IFMATCH'; while IFMATCH_A is a state saying that we have just
2439 successfully matched A and IFMATCH_A_fail is a state saying that we have
2440 just failed to match A. Resume states always come in pairs. The backtrack
2441 state we push is marked as 'IFMATCH_A', but when that is popped, we resume
2442 at IFMATCH_A or IFMATCH_A_fail, depending on whether we are backtracking
2443 on success or failure.
2445 The struct that holds a backtracking state is actually a big union, with
2446 one variant for each major type of op. The variable st points to the
2447 top-most backtrack struct. To make the code clearer, within each
2448 block of code we #define ST to alias the relevant union.
2450 Here's a concrete example of a (vastly oversimplified) IFMATCH
2456 #define ST st->u.ifmatch
2458 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2459 ST.foo = ...; // some state we wish to save
2461 // push a yes backtrack state with a resume value of
2462 // IFMATCH_A/IFMATCH_A_fail, then continue execution at the
2464 PUSH_YES_STATE_GOTO(IFMATCH_A, A);
2467 case IFMATCH_A: // we have successfully executed A; now continue with B
2469 bar = ST.foo; // do something with the preserved value
2472 case IFMATCH_A_fail: // A failed, so the assertion failed
2473 ...; // do some housekeeping, then ...
2474 sayNO; // propagate the failure
2481 For any old-timers reading this who are familiar with the old recursive
2482 approach, the code above is equivalent to:
2484 case IFMATCH: // we are executing the IFMATCH op, (?=A)B
2493 ...; // do some housekeeping, then ...
2494 sayNO; // propagate the failure
2497 The topmost backtrack state, pointed to by st, is usually free. If you
2498 want to claim it, populate any ST.foo fields in it with values you wish to
2499 save, then do one of
2501 PUSH_STATE_GOTO(resume_state, node);
2502 PUSH_YES_STATE_GOTO(resume_state, node);
2504 which sets that backtrack state's resume value to 'resume_state', pushes a
2505 new free entry to the top of the backtrack stack, then goes to 'node'.
2506 On backtracking, the free slot is popped, and the saved state becomes the
2507 new free state. An ST.foo field in this new top state can be temporarily
2508 accessed to retrieve values, but once the main loop is re-entered, it
2509 becomes available for reuse.
2511 Note that the depth of the backtrack stack constantly increases during the
2512 left-to-right execution of the pattern, rather than going up and down with
2513 the pattern nesting. For example the stack is at its maximum at Z at the
2514 end of the pattern, rather than at X in the following:
2516 /(((X)+)+)+....(Y)+....Z/
2518 The only exceptions to this are lookahead/behind assertions and the cut,
2519 (?>A), which pop all the backtrack states associated with A before
2522 Bascktrack state structs are allocated in slabs of about 4K in size.
2523 PL_regmatch_state and st always point to the currently active state,
2524 and PL_regmatch_slab points to the slab currently containing
2525 PL_regmatch_state. The first time regmatch() is called, the first slab is
2526 allocated, and is never freed until interpreter destruction. When the slab
2527 is full, a new one is allocated and chained to the end. At exit from
2528 regmatch(), slabs allocated since entry are freed.
2533 #define DEBUG_STATE_pp(pp) \
2535 DUMP_EXEC_POS(locinput, scan, do_utf8); \
2536 PerlIO_printf(Perl_debug_log, \
2537 " %*s"pp" %s%s%s%s%s\n", \
2539 PL_reg_name[st->resume_state], \
2540 ((st==yes_state||st==mark_state) ? "[" : ""), \
2541 ((st==yes_state) ? "Y" : ""), \
2542 ((st==mark_state) ? "M" : ""), \
2543 ((st==yes_state||st==mark_state) ? "]" : "") \
2548 #define REG_NODE_NUM(x) ((x) ? (int)((x)-prog) : -1)
2553 S_debug_start_match(pTHX_ const regexp *prog, const bool do_utf8,
2554 const char *start, const char *end, const char *blurb)
2556 const bool utf8_pat= prog->extflags & RXf_UTF8 ? 1 : 0;
2560 RE_PV_QUOTED_DECL(s0, utf8_pat, PERL_DEBUG_PAD_ZERO(0),
2561 prog->precomp, prog->prelen, 60);
2563 RE_PV_QUOTED_DECL(s1, do_utf8, PERL_DEBUG_PAD_ZERO(1),
2564 start, end - start, 60);
2566 PerlIO_printf(Perl_debug_log,
2567 "%s%s REx%s %s against %s\n",
2568 PL_colors[4], blurb, PL_colors[5], s0, s1);
2570 if (do_utf8||utf8_pat)
2571 PerlIO_printf(Perl_debug_log, "UTF-8 %s%s%s...\n",
2572 utf8_pat ? "pattern" : "",
2573 utf8_pat && do_utf8 ? " and " : "",
2574 do_utf8 ? "string" : ""
2580 S_dump_exec_pos(pTHX_ const char *locinput,
2581 const regnode *scan,
2582 const char *loc_regeol,
2583 const char *loc_bostr,
2584 const char *loc_reg_starttry,
2587 const int docolor = *PL_colors[0] || *PL_colors[2] || *PL_colors[4];
2588 const int taill = (docolor ? 10 : 7); /* 3 chars for "> <" */
2589 int l = (loc_regeol - locinput) > taill ? taill : (loc_regeol - locinput);
2590 /* The part of the string before starttry has one color
2591 (pref0_len chars), between starttry and current
2592 position another one (pref_len - pref0_len chars),
2593 after the current position the third one.
2594 We assume that pref0_len <= pref_len, otherwise we
2595 decrease pref0_len. */
2596 int pref_len = (locinput - loc_bostr) > (5 + taill) - l
2597 ? (5 + taill) - l : locinput - loc_bostr;
2600 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput - pref_len)))
2602 pref0_len = pref_len - (locinput - loc_reg_starttry);
2603 if (l + pref_len < (5 + taill) && l < loc_regeol - locinput)
2604 l = ( loc_regeol - locinput > (5 + taill) - pref_len
2605 ? (5 + taill) - pref_len : loc_regeol - locinput);
2606 while (do_utf8 && UTF8_IS_CONTINUATION(*(U8*)(locinput + l)))
2610 if (pref0_len > pref_len)
2611 pref0_len = pref_len;
2613 const int is_uni = (do_utf8 && OP(scan) != CANY) ? 1 : 0;
2615 RE_PV_COLOR_DECL(s0,len0,is_uni,PERL_DEBUG_PAD(0),
2616 (locinput - pref_len),pref0_len, 60, 4, 5);
2618 RE_PV_COLOR_DECL(s1,len1,is_uni,PERL_DEBUG_PAD(1),
2619 (locinput - pref_len + pref0_len),
2620 pref_len - pref0_len, 60, 2, 3);
2622 RE_PV_COLOR_DECL(s2,len2,is_uni,PERL_DEBUG_PAD(2),
2623 locinput, loc_regeol - locinput, 10, 0, 1);
2625 const STRLEN tlen=len0+len1+len2;
2626 PerlIO_printf(Perl_debug_log,
2627 "%4"IVdf" <%.*s%.*s%s%.*s>%*s|",
2628 (IV)(locinput - loc_bostr),
2631 (docolor ? "" : "> <"),
2633 (int)(tlen > 19 ? 0 : 19 - tlen),
2640 /* reg_check_named_buff_matched()
2641 * Checks to see if a named buffer has matched. The data array of
2642 * buffer numbers corresponding to the buffer is expected to reside
2643 * in the regexp->data->data array in the slot stored in the ARG() of
2644 * node involved. Note that this routine doesn't actually care about the
2645 * name, that information is not preserved from compilation to execution.
2646 * Returns the index of the leftmost defined buffer with the given name
2647 * or 0 if non of the buffers matched.
2650 S_reg_check_named_buff_matched(pTHX_ const regexp *rex, const regnode *scan) {
2652 RXi_GET_DECL(rex,rexi);
2653 SV *sv_dat=(SV*)rexi->data->data[ ARG( scan ) ];
2654 I32 *nums=(I32*)SvPVX(sv_dat);
2655 for ( n=0; n<SvIVX(sv_dat); n++ ) {
2656 if ((I32)*PL_reglastparen >= nums[n] &&
2657 PL_regoffs[nums[n]].end != -1)
2666 /* free all slabs above current one - called during LEAVE_SCOPE */
2669 S_clear_backtrack_stack(pTHX_ void *p)
2671 regmatch_slab *s = PL_regmatch_slab->next;
2676 PL_regmatch_slab->next = NULL;
2678 regmatch_slab * const osl = s;
2685 #define SETREX(Re1,Re2) \
2686 if (PL_reg_eval_set) PM_SETRE((PL_reg_curpm), (Re2)); \
2689 STATIC I32 /* 0 failure, 1 success */
2690 S_regmatch(pTHX_ regmatch_info *reginfo, regnode *prog)
2692 #if PERL_VERSION < 9 && !defined(PERL_CORE)
2696 register const bool do_utf8 = PL_reg_match_utf8;
2697 const U32 uniflags = UTF8_ALLOW_DEFAULT;
2699 regexp *rex = reginfo->prog;
2700 RXi_GET_DECL(rex,rexi);
2704 /* the current state. This is a cached copy of PL_regmatch_state */
2705 register regmatch_state *st;
2707 /* cache heavy used fields of st in registers */
2708 register regnode *scan;
2709 register regnode *next;
2710 register U32 n = 0; /* general value; init to avoid compiler warning */
2711 register I32 ln = 0; /* len or last; init to avoid compiler warning */
2712 register char *locinput = PL_reginput;
2713 register I32 nextchr; /* is always set to UCHARAT(locinput) */
2715 bool result = 0; /* return value of S_regmatch */
2716 int depth = 0; /* depth of backtrack stack */
2717 U32 nochange_depth = 0; /* depth of GOSUB recursion with nochange */
2718 const U32 max_nochange_depth =
2719 (3 * rex->nparens > MAX_RECURSE_EVAL_NOCHANGE_DEPTH) ?
2720 3 * rex->nparens : MAX_RECURSE_EVAL_NOCHANGE_DEPTH;
2722 regmatch_state *yes_state = NULL; /* state to pop to on success of
2724 /* mark_state piggy backs on the yes_state logic so that when we unwind
2725 the stack on success we can update the mark_state as we go */
2726 regmatch_state *mark_state = NULL; /* last mark state we have seen */
2728 regmatch_state *cur_eval = NULL; /* most recent EVAL_AB state */
2729 struct regmatch_state *cur_curlyx = NULL; /* most recent curlyx */
2731 bool no_final = 0; /* prevent failure from backtracking? */
2732 bool do_cutgroup = 0; /* no_final only until next branch/trie entry */
2733 char *startpoint = PL_reginput;
2734 SV *popmark = NULL; /* are we looking for a mark? */
2735 SV *sv_commit = NULL; /* last mark name seen in failure */
2736 SV *sv_yes_mark = NULL; /* last mark name we have seen
2737 during a successfull match */
2738 U32 lastopen = 0; /* last open we saw */
2739 bool has_cutgroup = RX_HAS_CUTGROUP(rex) ? 1 : 0;
2741 SV* const oreplsv = GvSV(PL_replgv);
2744 /* these three flags are set by various ops to signal information to
2745 * the very next op. They have a useful lifetime of exactly one loop
2746 * iteration, and are not preserved or restored by state pushes/pops
2748 bool sw = 0; /* the condition value in (?(cond)a|b) */
2749 bool minmod = 0; /* the next "{n,m}" is a "{n,m}?" */
2750 int logical = 0; /* the following EVAL is:
2754 or the following IFMATCH/UNLESSM is:
2755 false: plain (?=foo)
2756 true: used as a condition: (?(?=foo))
2760 GET_RE_DEBUG_FLAGS_DECL;
2763 DEBUG_OPTIMISE_r( DEBUG_EXECUTE_r({
2764 PerlIO_printf(Perl_debug_log,"regmatch start\n");
2766 /* on first ever call to regmatch, allocate first slab */
2767 if (!PL_regmatch_slab) {
2768 Newx(PL_regmatch_slab, 1, regmatch_slab);
2769 PL_regmatch_slab->prev = NULL;
2770 PL_regmatch_slab->next = NULL;
2771 PL_regmatch_state = SLAB_FIRST(PL_regmatch_slab);
2774 oldsave = PL_savestack_ix;
2775 SAVEDESTRUCTOR_X(S_clear_backtrack_stack, NULL);
2776 SAVEVPTR(PL_regmatch_slab);
2777 SAVEVPTR(PL_regmatch_state);
2779 /* grab next free state slot */
2780 st = ++PL_regmatch_state;
2781 if (st > SLAB_LAST(PL_regmatch_slab))
2782 st = PL_regmatch_state = S_push_slab(aTHX);
2784 /* Note that nextchr is a byte even in UTF */
2785 nextchr = UCHARAT(locinput);
2787 while (scan != NULL) {
2790 SV * const prop = sv_newmortal();
2791 regnode *rnext=regnext(scan);
2792 DUMP_EXEC_POS( locinput, scan, do_utf8 );
2793 regprop(rex, prop, scan);
2795 PerlIO_printf(Perl_debug_log,
2796 "%3"IVdf":%*s%s(%"IVdf")\n",
2797 (IV)(scan - rexi->program), depth*2, "",
2799 (PL_regkind[OP(scan)] == END || !rnext) ?
2800 0 : (IV)(rnext - rexi->program));
2803 next = scan + NEXT_OFF(scan);
2806 state_num = OP(scan);
2809 switch (state_num) {
2811 if (locinput == PL_bostr)
2813 /* reginfo->till = reginfo->bol; */
2818 if (locinput == PL_bostr ||
2819 ((nextchr || locinput < PL_regeol) && locinput[-1] == '\n'))
2825 if (locinput == PL_bostr)
2829 if (locinput == reginfo->ganch)
2834 /* update the startpoint */
2835 st->u.keeper.val = PL_regoffs[0].start;
2836 PL_reginput = locinput;
2837 PL_regoffs[0].start = locinput - PL_bostr;
2838 PUSH_STATE_GOTO(KEEPS_next, next);
2840 case KEEPS_next_fail:
2841 /* rollback the start point change */
2842 PL_regoffs[0].start = st->u.keeper.val;
2848 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2853 if ((nextchr || locinput < PL_regeol) && nextchr != '\n')
2855 if (PL_regeol - locinput > 1)
2859 if (PL_regeol != locinput)
2863 if (!nextchr && locinput >= PL_regeol)
2866 locinput += PL_utf8skip[nextchr];
2867 if (locinput > PL_regeol)
2869 nextchr = UCHARAT(locinput);
2872 nextchr = UCHARAT(++locinput);
2875 if (!nextchr && locinput >= PL_regeol)
2877 nextchr = UCHARAT(++locinput);
2880 if ((!nextchr && locinput >= PL_regeol) || nextchr == '\n')
2883 locinput += PL_utf8skip[nextchr];
2884 if (locinput > PL_regeol)
2886 nextchr = UCHARAT(locinput);
2889 nextchr = UCHARAT(++locinput);
2893 #define ST st->u.trie
2895 /* In this case the charclass data is available inline so
2896 we can fail fast without a lot of extra overhead.
2898 if (scan->flags == EXACT || !do_utf8) {
2899 if(!ANYOF_BITMAP_TEST(scan, *locinput)) {
2901 PerlIO_printf(Perl_debug_log,
2902 "%*s %sfailed to match trie start class...%s\n",
2903 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2912 /* what type of TRIE am I? (utf8 makes this contextual) */
2913 DECL_TRIE_TYPE(scan);
2915 /* what trie are we using right now */
2916 reg_trie_data * const trie
2917 = (reg_trie_data*)rexi->data->data[ ARG( scan ) ];
2918 HV * widecharmap = (HV *)rexi->data->data[ ARG( scan ) + 1 ];
2919 U32 state = trie->startstate;
2921 if (trie->bitmap && trie_type != trie_utf8_fold &&
2922 !TRIE_BITMAP_TEST(trie,*locinput)
2924 if (trie->states[ state ].wordnum) {
2926 PerlIO_printf(Perl_debug_log,
2927 "%*s %smatched empty string...%s\n",
2928 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2933 PerlIO_printf(Perl_debug_log,
2934 "%*s %sfailed to match trie start class...%s\n",
2935 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5])
2942 U8 *uc = ( U8* )locinput;
2946 U8 *uscan = (U8*)NULL;
2948 SV *sv_accept_buff = NULL;
2949 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
2951 ST.accepted = 0; /* how many accepting states we have seen */
2953 ST.jump = trie->jump;
2956 traverse the TRIE keeping track of all accepting states
2957 we transition through until we get to a failing node.
2960 while ( state && uc <= (U8*)PL_regeol ) {
2961 U32 base = trie->states[ state ].trans.base;
2964 /* We use charid to hold the wordnum as we don't use it
2965 for charid until after we have done the wordnum logic.
2966 We define an alias just so that the wordnum logic reads
2969 #define got_wordnum charid
2970 got_wordnum = trie->states[ state ].wordnum;
2972 if ( got_wordnum ) {
2973 if ( ! ST.accepted ) {
2975 /* SAVETMPS; */ /* XXX is this necessary? dmq */
2976 bufflen = TRIE_INITAL_ACCEPT_BUFFLEN;
2977 sv_accept_buff=newSV(bufflen *
2978 sizeof(reg_trie_accepted) - 1);
2979 SvCUR_set(sv_accept_buff, 0);
2980 SvPOK_on(sv_accept_buff);
2981 sv_2mortal(sv_accept_buff);
2984 (reg_trie_accepted*)SvPV_nolen(sv_accept_buff );
2987 if (ST.accepted >= bufflen) {
2989 ST.accept_buff =(reg_trie_accepted*)
2990 SvGROW(sv_accept_buff,
2991 bufflen * sizeof(reg_trie_accepted));
2993 SvCUR_set(sv_accept_buff,SvCUR(sv_accept_buff)
2994 + sizeof(reg_trie_accepted));
2997 ST.accept_buff[ST.accepted].wordnum = got_wordnum;
2998 ST.accept_buff[ST.accepted].endpos = uc;
3000 } while (trie->nextword && (got_wordnum= trie->nextword[got_wordnum]));
3004 DEBUG_TRIE_EXECUTE_r({
3005 DUMP_EXEC_POS( (char *)uc, scan, do_utf8 );
3006 PerlIO_printf( Perl_debug_log,
3007 "%*s %sState: %4"UVxf" Accepted: %4"UVxf" ",
3008 2+depth * 2, "", PL_colors[4],
3009 (UV)state, (UV)ST.accepted );
3013 REXEC_TRIE_READ_CHAR(trie_type, trie, widecharmap, uc,
3014 uscan, len, uvc, charid, foldlen,
3018 (base + charid > trie->uniquecharcount )
3019 && (base + charid - 1 - trie->uniquecharcount
3021 && trie->trans[base + charid - 1 -
3022 trie->uniquecharcount].check == state)
3024 state = trie->trans[base + charid - 1 -
3025 trie->uniquecharcount ].next;
3036 DEBUG_TRIE_EXECUTE_r(
3037 PerlIO_printf( Perl_debug_log,
3038 "Charid:%3x CP:%4"UVxf" After State: %4"UVxf"%s\n",
3039 charid, uvc, (UV)state, PL_colors[5] );
3046 PerlIO_printf( Perl_debug_log,
3047 "%*s %sgot %"IVdf" possible matches%s\n",
3048 REPORT_CODE_OFF + depth * 2, "",
3049 PL_colors[4], (IV)ST.accepted, PL_colors[5] );
3052 goto trie_first_try; /* jump into the fail handler */
3054 case TRIE_next_fail: /* we failed - try next alterative */
3056 REGCP_UNWIND(ST.cp);
3057 for (n = *PL_reglastparen; n > ST.lastparen; n--)
3058 PL_regoffs[n].end = -1;
3059 *PL_reglastparen = n;
3068 ST.lastparen = *PL_reglastparen;
3071 if ( ST.accepted == 1 ) {
3072 /* only one choice left - just continue */
3074 AV *const trie_words
3075 = (AV *) rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET];
3076 SV ** const tmp = av_fetch( trie_words,
3077 ST.accept_buff[ 0 ].wordnum-1, 0 );
3078 SV *sv= tmp ? sv_newmortal() : NULL;
3080 PerlIO_printf( Perl_debug_log,
3081 "%*s %sonly one match left: #%d <%s>%s\n",
3082 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3083 ST.accept_buff[ 0 ].wordnum,
3084 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3085 PL_colors[0], PL_colors[1],
3086 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3088 : "not compiled under -Dr",
3091 PL_reginput = (char *)ST.accept_buff[ 0 ].endpos;
3092 /* in this case we free tmps/leave before we call regmatch
3093 as we wont be using accept_buff again. */
3095 locinput = PL_reginput;
3096 nextchr = UCHARAT(locinput);
3097 if ( !ST.jump || !ST.jump[ST.accept_buff[0].wordnum])
3100 scan = ST.me + ST.jump[ST.accept_buff[0].wordnum];
3101 if (!has_cutgroup) {
3106 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3109 continue; /* execute rest of RE */
3112 if ( !ST.accepted-- ) {
3114 PerlIO_printf( Perl_debug_log,
3115 "%*s %sTRIE failed...%s\n",
3116 REPORT_CODE_OFF+depth*2, "",
3127 There are at least two accepting states left. Presumably
3128 the number of accepting states is going to be low,
3129 typically two. So we simply scan through to find the one
3130 with lowest wordnum. Once we find it, we swap the last
3131 state into its place and decrement the size. We then try to
3132 match the rest of the pattern at the point where the word
3133 ends. If we succeed, control just continues along the
3134 regex; if we fail we return here to try the next accepting
3141 for( cur = 1 ; cur <= ST.accepted ; cur++ ) {
3142 DEBUG_TRIE_EXECUTE_r(
3143 PerlIO_printf( Perl_debug_log,
3144 "%*s %sgot %"IVdf" (%d) as best, looking at %"IVdf" (%d)%s\n",
3145 REPORT_CODE_OFF + depth * 2, "", PL_colors[4],
3146 (IV)best, ST.accept_buff[ best ].wordnum, (IV)cur,
3147 ST.accept_buff[ cur ].wordnum, PL_colors[5] );
3150 if (ST.accept_buff[cur].wordnum <
3151 ST.accept_buff[best].wordnum)
3156 AV *const trie_words
3157 = (AV *) rexi->data->data[ARG(ST.me)+TRIE_WORDS_OFFSET];
3158 SV ** const tmp = av_fetch( trie_words,
3159 ST.accept_buff[ best ].wordnum - 1, 0 );
3160 regnode *nextop=(!ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) ?
3162 ST.me + ST.jump[ST.accept_buff[best].wordnum];
3163 SV *sv= tmp ? sv_newmortal() : NULL;
3165 PerlIO_printf( Perl_debug_log,
3166 "%*s %strying alternation #%d <%s> at node #%d %s\n",
3167 REPORT_CODE_OFF+depth*2, "", PL_colors[4],
3168 ST.accept_buff[best].wordnum,
3169 tmp ? pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 0,
3170 PL_colors[0], PL_colors[1],
3171 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0)
3172 ) : "not compiled under -Dr",
3173 REG_NODE_NUM(nextop),
3177 if ( best<ST.accepted ) {
3178 reg_trie_accepted tmp = ST.accept_buff[ best ];
3179 ST.accept_buff[ best ] = ST.accept_buff[ ST.accepted ];
3180 ST.accept_buff[ ST.accepted ] = tmp;
3183 PL_reginput = (char *)ST.accept_buff[ best ].endpos;
3184 if ( !ST.jump || !ST.jump[ST.accept_buff[best].wordnum]) {
3187 scan = ST.me + ST.jump[ST.accept_buff[best].wordnum];
3189 PUSH_YES_STATE_GOTO(TRIE_next, scan);
3200 char *s = STRING(scan);
3202 if (do_utf8 != UTF) {
3203 /* The target and the pattern have differing utf8ness. */
3205 const char * const e = s + ln;
3208 /* The target is utf8, the pattern is not utf8. */
3213 if (NATIVE_TO_UNI(*(U8*)s) !=
3214 utf8n_to_uvuni((U8*)l, UTF8_MAXBYTES, &ulen,
3222 /* The target is not utf8, the pattern is utf8. */
3227 if (NATIVE_TO_UNI(*((U8*)l)) !=
3228 utf8n_to_uvuni((U8*)s, UTF8_MAXBYTES, &ulen,
3236 nextchr = UCHARAT(locinput);
3239 /* The target and the pattern have the same utf8ness. */
3240 /* Inline the first character, for speed. */
3241 if (UCHARAT(s) != nextchr)
3243 if (PL_regeol - locinput < ln)
3245 if (ln > 1 && memNE(s, locinput, ln))
3248 nextchr = UCHARAT(locinput);
3252 PL_reg_flags |= RF_tainted;
3255 char * const s = STRING(scan);
3258 if (do_utf8 || UTF) {
3259 /* Either target or the pattern are utf8. */
3260 const char * const l = locinput;
3261 char *e = PL_regeol;
3263 if (ibcmp_utf8(s, 0, ln, (bool)UTF,
3264 l, &e, 0, do_utf8)) {
3265 /* One more case for the sharp s:
3266 * pack("U0U*", 0xDF) =~ /ss/i,
3267 * the 0xC3 0x9F are the UTF-8
3268 * byte sequence for the U+00DF. */
3271 toLOWER(s[0]) == 's' &&
3273 toLOWER(s[1]) == 's' &&
3280 nextchr = UCHARAT(locinput);
3284 /* Neither the target and the pattern are utf8. */
3286 /* Inline the first character, for speed. */
3287 if (UCHARAT(s) != nextchr &&
3288 UCHARAT(s) != ((OP(scan) == EXACTF)
3289 ? PL_fold : PL_fold_locale)[nextchr])
3291 if (PL_regeol - locinput < ln)
3293 if (ln > 1 && (OP(scan) == EXACTF
3294 ? ibcmp(s, locinput, ln)
3295 : ibcmp_locale(s, locinput, ln)))
3298 nextchr = UCHARAT(locinput);
3303 STRLEN inclasslen = PL_regeol - locinput;
3305 if (!reginclass(rex, scan, (U8*)locinput, &inclasslen, do_utf8))
3307 if (locinput >= PL_regeol)
3309 locinput += inclasslen ? inclasslen : UTF8SKIP(locinput);
3310 nextchr = UCHARAT(locinput);
3315 nextchr = UCHARAT(locinput);
3316 if (!REGINCLASS(rex, scan, (U8*)locinput))
3318 if (!nextchr && locinput >= PL_regeol)
3320 nextchr = UCHARAT(++locinput);
3324 /* If we might have the case of the German sharp s
3325 * in a casefolding Unicode character class. */
3327 if (ANYOF_FOLD_SHARP_S(scan, locinput, PL_regeol)) {
3328 locinput += SHARP_S_SKIP;
3329 nextchr = UCHARAT(locinput);
3335 PL_reg_flags |= RF_tainted;
3341 LOAD_UTF8_CHARCLASS_ALNUM();
3342 if (!(OP(scan) == ALNUM
3343 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3344 : isALNUM_LC_utf8((U8*)locinput)))
3348 locinput += PL_utf8skip[nextchr];
3349 nextchr = UCHARAT(locinput);
3352 if (!(OP(scan) == ALNUM
3353 ? isALNUM(nextchr) : isALNUM_LC(nextchr)))
3355 nextchr = UCHARAT(++locinput);
3358 PL_reg_flags |= RF_tainted;
3361 if (!nextchr && locinput >= PL_regeol)
3364 LOAD_UTF8_CHARCLASS_ALNUM();
3365 if (OP(scan) == NALNUM
3366 ? (bool)swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8)
3367 : isALNUM_LC_utf8((U8*)locinput))
3371 locinput += PL_utf8skip[nextchr];
3372 nextchr = UCHARAT(locinput);
3375 if (OP(scan) == NALNUM
3376 ? isALNUM(nextchr) : isALNUM_LC(nextchr))
3378 nextchr = UCHARAT(++locinput);
3382 PL_reg_flags |= RF_tainted;
3386 /* was last char in word? */
3388 if (locinput == PL_bostr)
3391 const U8 * const r = reghop3((U8*)locinput, -1, (U8*)PL_bostr);
3393 ln = utf8n_to_uvchr(r, UTF8SKIP(r), 0, uniflags);
3395 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3396 ln = isALNUM_uni(ln);
3397 LOAD_UTF8_CHARCLASS_ALNUM();
3398 n = swash_fetch(PL_utf8_alnum, (U8*)locinput, do_utf8);
3401 ln = isALNUM_LC_uvchr(UNI_TO_NATIVE(ln));
3402 n = isALNUM_LC_utf8((U8*)locinput);
3406 ln = (locinput != PL_bostr) ?
3407 UCHARAT(locinput - 1) : '\n';
3408 if (OP(scan) == BOUND || OP(scan) == NBOUND) {
3410 n = isALNUM(nextchr);
3413 ln = isALNUM_LC(ln);
3414 n = isALNUM_LC(nextchr);
3417 if (((!ln) == (!n)) == (OP(scan) == BOUND ||
3418 OP(scan) == BOUNDL))
3422 PL_reg_flags |= RF_tainted;
3428 if (UTF8_IS_CONTINUED(nextchr)) {
3429 LOAD_UTF8_CHARCLASS_SPACE();
3430 if (!(OP(scan) == SPACE
3431 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3432 : isSPACE_LC_utf8((U8*)locinput)))
3436 locinput += PL_utf8skip[nextchr];
3437 nextchr = UCHARAT(locinput);
3440 if (!(OP(scan) == SPACE
3441 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3443 nextchr = UCHARAT(++locinput);
3446 if (!(OP(scan) == SPACE
3447 ? isSPACE(nextchr) : isSPACE_LC(nextchr)))
3449 nextchr = UCHARAT(++locinput);
3453 PL_reg_flags |= RF_tainted;
3456 if (!nextchr && locinput >= PL_regeol)
3459 LOAD_UTF8_CHARCLASS_SPACE();
3460 if (OP(scan) == NSPACE
3461 ? (bool)swash_fetch(PL_utf8_space, (U8*)locinput, do_utf8)
3462 : isSPACE_LC_utf8((U8*)locinput))
3466 locinput += PL_utf8skip[nextchr];
3467 nextchr = UCHARAT(locinput);
3470 if (OP(scan) == NSPACE
3471 ? isSPACE(nextchr) : isSPACE_LC(nextchr))
3473 nextchr = UCHARAT(++locinput);
3476 PL_reg_flags |= RF_tainted;
3482 LOAD_UTF8_CHARCLASS_DIGIT();
3483 if (!(OP(scan) == DIGIT
3484 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3485 : isDIGIT_LC_utf8((U8*)locinput)))
3489 locinput += PL_utf8skip[nextchr];
3490 nextchr = UCHARAT(locinput);
3493 if (!(OP(scan) == DIGIT
3494 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr)))
3496 nextchr = UCHARAT(++locinput);
3499 PL_reg_flags |= RF_tainted;
3502 if (!nextchr && locinput >= PL_regeol)
3505 LOAD_UTF8_CHARCLASS_DIGIT();
3506 if (OP(scan) == NDIGIT
3507 ? (bool)swash_fetch(PL_utf8_digit, (U8*)locinput, do_utf8)
3508 : isDIGIT_LC_utf8((U8*)locinput))
3512 locinput += PL_utf8skip[nextchr];
3513 nextchr = UCHARAT(locinput);
3516 if (OP(scan) == NDIGIT
3517 ? isDIGIT(nextchr) : isDIGIT_LC(nextchr))
3519 nextchr = UCHARAT(++locinput);
3522 if (locinput >= PL_regeol)
3525 LOAD_UTF8_CHARCLASS_MARK();
3526 if (swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3528 locinput += PL_utf8skip[nextchr];
3529 while (locinput < PL_regeol &&
3530 swash_fetch(PL_utf8_mark,(U8*)locinput, do_utf8))
3531 locinput += UTF8SKIP(locinput);
3532 if (locinput > PL_regeol)
3537 nextchr = UCHARAT(locinput);
3544 PL_reg_flags |= RF_tainted;
3549 n = reg_check_named_buff_matched(rex,scan);
3552 type = REF + ( type - NREF );
3559 PL_reg_flags |= RF_tainted;
3563 n = ARG(scan); /* which paren pair */
3566 ln = PL_regoffs[n].start;
3567 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3568 if (*PL_reglastparen < n || ln == -1)
3569 sayNO; /* Do not match unless seen CLOSEn. */
3570 if (ln == PL_regoffs[n].end)
3574 if (do_utf8 && type != REF) { /* REF can do byte comparison */
3576 const char *e = PL_bostr + PL_regoffs[n].end;
3578 * Note that we can't do the "other character" lookup trick as
3579 * in the 8-bit case (no pun intended) because in Unicode we
3580 * have to map both upper and title case to lower case.
3584 STRLEN ulen1, ulen2;
3585 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
3586 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
3590 toLOWER_utf8((U8*)s, tmpbuf1, &ulen1);
3591 toLOWER_utf8((U8*)l, tmpbuf2, &ulen2);
3592 if (ulen1 != ulen2 || memNE((char *)tmpbuf1, (char *)tmpbuf2, ulen1))
3599 nextchr = UCHARAT(locinput);
3603 /* Inline the first character, for speed. */
3604 if (UCHARAT(s) != nextchr &&
3606 (UCHARAT(s) != (type == REFF
3607 ? PL_fold : PL_fold_locale)[nextchr])))
3609 ln = PL_regoffs[n].end - ln;
3610 if (locinput + ln > PL_regeol)
3612 if (ln > 1 && (type == REF
3613 ? memNE(s, locinput, ln)
3615 ? ibcmp(s, locinput, ln)
3616 : ibcmp_locale(s, locinput, ln))))
3619 nextchr = UCHARAT(locinput);
3629 #define ST st->u.eval
3633 regexp_internal *rei;
3634 regnode *startpoint;
3637 case GOSUB: /* /(...(?1))/ /(...(?&foo))/ */
3638 if (cur_eval && cur_eval->locinput==locinput) {
3639 if (cur_eval->u.eval.close_paren == (U32)ARG(scan))
3640 Perl_croak(aTHX_ "Infinite recursion in regex");
3641 if ( ++nochange_depth > max_nochange_depth )
3643 "Pattern subroutine nesting without pos change"
3644 " exceeded limit in regex");
3650 (void)ReREFCNT_inc(rex);
3651 if (OP(scan)==GOSUB) {
3652 startpoint = scan + ARG2L(scan);
3653 ST.close_paren = ARG(scan);
3655 startpoint = rei->program+1;
3658 goto eval_recurse_doit;
3660 case EVAL: /* /(?{A})B/ /(??{A})B/ and /(?(?{A})X|Y)B/ */
3661 if (cur_eval && cur_eval->locinput==locinput) {
3662 if ( ++nochange_depth > max_nochange_depth )
3663 Perl_croak(aTHX_ "EVAL without pos change exceeded limit in regex");
3668 /* execute the code in the {...} */
3670 SV ** const before = SP;
3671 OP_4tree * const oop = PL_op;
3672 COP * const ocurcop = PL_curcop;
3676 PL_op = (OP_4tree*)rexi->data->data[n];
3677 DEBUG_STATE_r( PerlIO_printf(Perl_debug_log,
3678 " re_eval 0x%"UVxf"\n", PTR2UV(PL_op)) );
3679 PAD_SAVE_LOCAL(old_comppad, (PAD*)rexi->data->data[n + 2]);
3680 PL_regoffs[0].end = PL_reg_magic->mg_len = locinput - PL_bostr;
3683 SV *sv_mrk = get_sv("REGMARK", 1);
3684 sv_setsv(sv_mrk, sv_yes_mark);
3687 CALLRUNOPS(aTHX); /* Scalar context. */
3690 ret = &PL_sv_undef; /* protect against empty (?{}) blocks. */
3697 PAD_RESTORE_LOCAL(old_comppad);
3698 PL_curcop = ocurcop;
3701 sv_setsv(save_scalar(PL_replgv), ret);
3705 if (logical == 2) { /* Postponed subexpression: /(??{...})/ */
3708 /* extract RE object from returned value; compiling if
3713 if(SvROK(ret) && SvSMAGICAL(sv = SvRV(ret)))
3714 mg = mg_find(sv, PERL_MAGIC_qr);
3715 else if (SvSMAGICAL(ret)) {
3716 if (SvGMAGICAL(ret))
3717 sv_unmagic(ret, PERL_MAGIC_qr);
3719 mg = mg_find(ret, PERL_MAGIC_qr);
3723 re = reg_temp_copy((regexp *)mg->mg_obj); /*XXX:dmq*/
3727 const I32 osize = PL_regsize;
3729 if (DO_UTF8(ret)) pm_flags |= RXf_UTF8;
3730 re = CALLREGCOMP(ret, pm_flags);
3732 & (SVs_TEMP | SVs_PADTMP | SVf_READONLY
3734 SvUPGRADE(ret, SVt_ORANGE);
3735 sv_magic(ret,(SV*)ReREFCNT_inc(re),
3741 RX_MATCH_COPIED_off(re);
3742 re->subbeg = rex->subbeg;
3743 re->sublen = rex->sublen;
3746 debug_start_match(re, do_utf8, locinput, PL_regeol,
3747 "Matching embedded");
3749 startpoint = rei->program + 1;
3750 ST.close_paren = 0; /* only used for GOSUB */
3751 /* borrowed from regtry */
3752 if (PL_reg_start_tmpl <= re->nparens) {
3753 PL_reg_start_tmpl = re->nparens*3/2 + 3;
3754 if(PL_reg_start_tmp)
3755 Renew(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3757 Newx(PL_reg_start_tmp, PL_reg_start_tmpl, char*);
3760 eval_recurse_doit: /* Share code with GOSUB below this line */
3761 /* run the pattern returned from (??{...}) */
3762 ST.cp = regcppush(0); /* Save *all* the positions. */
3763 REGCP_SET(ST.lastcp);
3765 PL_regoffs = re->offs; /* essentially NOOP on GOSUB */
3767 *PL_reglastparen = 0;
3768 *PL_reglastcloseparen = 0;
3769 PL_reginput = locinput;
3772 /* XXXX This is too dramatic a measure... */
3775 ST.toggle_reg_flags = PL_reg_flags;
3776 if (re->extflags & RXf_UTF8)
3777 PL_reg_flags |= RF_utf8;
3779 PL_reg_flags &= ~RF_utf8;
3780 ST.toggle_reg_flags ^= PL_reg_flags; /* diff of old and new */
3783 ST.prev_curlyx = cur_curlyx;
3788 ST.prev_eval = cur_eval;
3790 /* now continue from first node in postoned RE */
3791 PUSH_YES_STATE_GOTO(EVAL_AB, startpoint);
3794 /* logical is 1, /(?(?{...})X|Y)/ */
3795 sw = (bool)SvTRUE(ret);
3800 case EVAL_AB: /* cleanup after a successful (??{A})B */
3801 /* note: this is called twice; first after popping B, then A */
3802 PL_reg_flags ^= ST.toggle_reg_flags;
3804 SETREX(rex,ST.prev_rex);
3805 rexi = RXi_GET(rex);
3807 cur_eval = ST.prev_eval;
3808 cur_curlyx = ST.prev_curlyx;
3809 /* XXXX This is too dramatic a measure... */
3811 if ( nochange_depth )
3816 case EVAL_AB_fail: /* unsuccessfully ran A or B in (??{A})B */
3817 /* note: this is called twice; first after popping B, then A */
3818 PL_reg_flags ^= ST.toggle_reg_flags;
3820 SETREX(rex,ST.prev_rex);
3821 rexi = RXi_GET(rex);
3822 PL_reginput = locinput;
3823 REGCP_UNWIND(ST.lastcp);
3825 cur_eval = ST.prev_eval;
3826 cur_curlyx = ST.prev_curlyx;
3827 /* XXXX This is too dramatic a measure... */
3829 if ( nochange_depth )
3835 n = ARG(scan); /* which paren pair */
3836 PL_reg_start_tmp[n] = locinput;
3842 n = ARG(scan); /* which paren pair */
3843 PL_regoffs[n].start = PL_reg_start_tmp[n] - PL_bostr;
3844 PL_regoffs[n].end = locinput - PL_bostr;
3845 /*if (n > PL_regsize)
3847 if (n > *PL_reglastparen)
3848 *PL_reglastparen = n;
3849 *PL_reglastcloseparen = n;
3850 if (cur_eval && cur_eval->u.eval.close_paren == n) {
3858 cursor && OP(cursor)!=END;
3859 cursor=regnext(cursor))
3861 if ( OP(cursor)==CLOSE ){
3863 if ( n <= lastopen ) {
3865 = PL_reg_start_tmp[n] - PL_bostr;
3866 PL_regoffs[n].end = locinput - PL_bostr;
3867 /*if (n > PL_regsize)
3869 if (n > *PL_reglastparen)
3870 *PL_reglastparen = n;
3871 *PL_reglastcloseparen = n;
3872 if ( n == ARG(scan) || (cur_eval &&
3873 cur_eval->u.eval.close_paren == n))
3882 n = ARG(scan); /* which paren pair */
3883 sw = (bool)(*PL_reglastparen >= n && PL_regoffs[n].end != -1);
3886 /* reg_check_named_buff_matched returns 0 for no match */
3887 sw = (bool)(0 < reg_check_named_buff_matched(rex,scan));
3891 sw = (cur_eval && (!n || cur_eval->u.eval.close_paren == n));
3897 PL_reg_leftiter = PL_reg_maxiter; /* Void cache */
3899 next = NEXTOPER(NEXTOPER(scan));
3901 next = scan + ARG(scan);
3902 if (OP(next) == IFTHEN) /* Fake one. */
3903 next = NEXTOPER(NEXTOPER(next));
3907 logical = scan->flags;
3910 /*******************************************************************
3912 The CURLYX/WHILEM pair of ops handle the most generic case of the /A*B/
3913 pattern, where A and B are subpatterns. (For simple A, CURLYM or
3914 STAR/PLUS/CURLY/CURLYN are used instead.)
3916 A*B is compiled as <CURLYX><A><WHILEM><B>
3918 On entry to the subpattern, CURLYX is called. This pushes a CURLYX
3919 state, which contains the current count, initialised to -1. It also sets
3920 cur_curlyx to point to this state, with any previous value saved in the
3923 CURLYX then jumps straight to the WHILEM op, rather than executing A,
3924 since the pattern may possibly match zero times (i.e. it's a while {} loop
3925 rather than a do {} while loop).
3927 Each entry to WHILEM represents a successful match of A. The count in the
3928 CURLYX block is incremented, another WHILEM state is pushed, and execution
3929 passes to A or B depending on greediness and the current count.
3931 For example, if matching against the string a1a2a3b (where the aN are
3932 substrings that match /A/), then the match progresses as follows: (the
3933 pushed states are interspersed with the bits of strings matched so far):
3936 <CURLYX cnt=0><WHILEM>
3937 <CURLYX cnt=1><WHILEM> a1 <WHILEM>
3938 <CURLYX cnt=2><WHILEM> a1 <WHILEM> a2 <WHILEM>
3939 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM>
3940 <CURLYX cnt=3><WHILEM> a1 <WHILEM> a2 <WHILEM> a3 <WHILEM> b
3942 (Contrast this with something like CURLYM, which maintains only a single
3946 a1 <CURLYM cnt=1> a2
3947 a1 a2 <CURLYM cnt=2> a3
3948 a1 a2 a3 <CURLYM cnt=3> b
3951 Each WHILEM state block marks a point to backtrack to upon partial failure
3952 of A or B, and also contains some minor state data related to that
3953 iteration. The CURLYX block, pointed to by cur_curlyx, contains the
3954 overall state, such as the count, and pointers to the A and B ops.
3956 This is complicated slightly by nested CURLYX/WHILEM's. Since cur_curlyx
3957 must always point to the *current* CURLYX block, the rules are:
3959 When executing CURLYX, save the old cur_curlyx in the CURLYX state block,
3960 and set cur_curlyx to point the new block.
3962 When popping the CURLYX block after a successful or unsuccessful match,
3963 restore the previous cur_curlyx.
3965 When WHILEM is about to execute B, save the current cur_curlyx, and set it
3966 to the outer one saved in the CURLYX block.
3968 When popping the WHILEM block after a successful or unsuccessful B match,
3969 restore the previous cur_curlyx.
3971 Here's an example for the pattern (AI* BI)*BO
3972 I and O refer to inner and outer, C and W refer to CURLYX and WHILEM:
3975 curlyx backtrack stack
3976 ------ ---------------
3978 CO <CO prev=NULL> <WO>
3979 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
3980 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
3981 NULL <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi <WO prev=CO> bo
3983 At this point the pattern succeeds, and we work back down the stack to
3984 clean up, restoring as we go:
3986 CO <CO prev=NULL> <WO> <CI prev=CO> <WI> ai <WI prev=CI> bi
3987 CI <CO prev=NULL> <WO> <CI prev=CO> <WI> ai
3988 CO <CO prev=NULL> <WO>
3991 *******************************************************************/
3993 #define ST st->u.curlyx
3995 case CURLYX: /* start of /A*B/ (for complex A) */
3997 /* No need to save/restore up to this paren */
3998 I32 parenfloor = scan->flags;
4000 assert(next); /* keep Coverity happy */
4001 if (OP(PREVOPER(next)) == NOTHING) /* LONGJMP */
4004 /* XXXX Probably it is better to teach regpush to support
4005 parenfloor > PL_regsize... */
4006 if (parenfloor > (I32)*PL_reglastparen)
4007 parenfloor = *PL_reglastparen; /* Pessimization... */
4009 ST.prev_curlyx= cur_curlyx;
4011 ST.cp = PL_savestack_ix;
4013 /* these fields contain the state of the current curly.
4014 * they are accessed by subsequent WHILEMs */
4015 ST.parenfloor = parenfloor;
4016 ST.min = ARG1(scan);
4017 ST.max = ARG2(scan);
4018 ST.A = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
4022 ST.count = -1; /* this will be updated by WHILEM */
4023 ST.lastloc = NULL; /* this will be updated by WHILEM */
4025 PL_reginput = locinput;
4026 PUSH_YES_STATE_GOTO(CURLYX_end, PREVOPER(next));
4030 case CURLYX_end: /* just finished matching all of A*B */
4031 cur_curlyx = ST.prev_curlyx;
4035 case CURLYX_end_fail: /* just failed to match all of A*B */
4037 cur_curlyx = ST.prev_curlyx;
4043 #define ST st->u.whilem
4045 case WHILEM: /* just matched an A in /A*B/ (for complex A) */
4047 /* see the discussion above about CURLYX/WHILEM */
4049 assert(cur_curlyx); /* keep Coverity happy */
4050 n = ++cur_curlyx->u.curlyx.count; /* how many A's matched */
4051 ST.save_lastloc = cur_curlyx->u.curlyx.lastloc;
4052 ST.cache_offset = 0;
4055 PL_reginput = locinput;
4057 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4058 "%*s whilem: matched %ld out of %ld..%ld\n",
4059 REPORT_CODE_OFF+depth*2, "", (long)n,
4060 (long)cur_curlyx->u.curlyx.min,
4061 (long)cur_curlyx->u.curlyx.max)
4064 /* First just match a string of min A's. */
4066 if (n < cur_curlyx->u.curlyx.min) {
4067 cur_curlyx->u.curlyx.lastloc = locinput;
4068 PUSH_STATE_GOTO(WHILEM_A_pre, cur_curlyx->u.curlyx.A);
4072 /* If degenerate A matches "", assume A done. */
4074 if (locinput == cur_curlyx->u.curlyx.lastloc) {
4075 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4076 "%*s whilem: empty match detected, trying continuation...\n",
4077 REPORT_CODE_OFF+depth*2, "")
4079 goto do_whilem_B_max;
4082 /* super-linear cache processing */
4086 if (!PL_reg_maxiter) {
4087 /* start the countdown: Postpone detection until we
4088 * know the match is not *that* much linear. */
4089 PL_reg_maxiter = (PL_regeol - PL_bostr + 1) * (scan->flags>>4);
4090 /* possible overflow for long strings and many CURLYX's */
4091 if (PL_reg_maxiter < 0)
4092 PL_reg_maxiter = I32_MAX;
4093 PL_reg_leftiter = PL_reg_maxiter;
4096 if (PL_reg_leftiter-- == 0) {
4097 /* initialise cache */
4098 const I32 size = (PL_reg_maxiter + 7)/8;
4099 if (PL_reg_poscache) {
4100 if ((I32)PL_reg_poscache_size < size) {
4101 Renew(PL_reg_poscache, size, char);
4102 PL_reg_poscache_size = size;
4104 Zero(PL_reg_poscache, size, char);
4107 PL_reg_poscache_size = size;
4108 Newxz(PL_reg_poscache, size, char);
4110 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4111 "%swhilem: Detected a super-linear match, switching on caching%s...\n",
4112 PL_colors[4], PL_colors[5])
4116 if (PL_reg_leftiter < 0) {
4117 /* have we already failed at this position? */
4119 offset = (scan->flags & 0xf) - 1
4120 + (locinput - PL_bostr) * (scan->flags>>4);
4121 mask = 1 << (offset % 8);
4123 if (PL_reg_poscache[offset] & mask) {
4124 DEBUG_EXECUTE_r( PerlIO_printf(Perl_debug_log,
4125 "%*s whilem: (cache) already tried at this position...\n",
4126 REPORT_CODE_OFF+depth*2, "")
4128 sayNO; /* cache records failure */
4130 ST.cache_offset = offset;
4131 ST.cache_mask = mask;
4135 /* Prefer B over A for minimal matching. */
4137 if (cur_curlyx->u.curlyx.minmod) {
4138 ST.save_curlyx = cur_curlyx;
4139 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4140 ST.cp = regcppush(ST.save_curlyx->u.curlyx.parenfloor);
4141 REGCP_SET(ST.lastcp);
4142 PUSH_YES_STATE_GOTO(WHILEM_B_min, ST.save_curlyx->u.curlyx.B);
4146 /* Prefer A over B for maximal matching. */
4148 if (n < cur_curlyx->u.curlyx.max) { /* More greed allowed? */
4149 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4150 cur_curlyx->u.curlyx.lastloc = locinput;
4151 REGCP_SET(ST.lastcp);
4152 PUSH_STATE_GOTO(WHILEM_A_max, cur_curlyx->u.curlyx.A);
4155 goto do_whilem_B_max;
4159 case WHILEM_B_min: /* just matched B in a minimal match */
4160 case WHILEM_B_max: /* just matched B in a maximal match */
4161 cur_curlyx = ST.save_curlyx;
4165 case WHILEM_B_max_fail: /* just failed to match B in a maximal match */
4166 cur_curlyx = ST.save_curlyx;
4167 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4168 cur_curlyx->u.curlyx.count--;
4172 case WHILEM_A_min_fail: /* just failed to match A in a minimal match */
4173 REGCP_UNWIND(ST.lastcp);
4176 case WHILEM_A_pre_fail: /* just failed to match even minimal A */
4177 cur_curlyx->u.curlyx.lastloc = ST.save_lastloc;
4178 cur_curlyx->u.curlyx.count--;
4182 case WHILEM_A_max_fail: /* just failed to match A in a maximal match */
4183 REGCP_UNWIND(ST.lastcp);
4184 regcppop(rex); /* Restore some previous $<digit>s? */
4185 PL_reginput = locinput;
4186 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4187 "%*s whilem: failed, trying continuation...\n",
4188 REPORT_CODE_OFF+depth*2, "")
4191 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4192 && ckWARN(WARN_REGEXP)
4193 && !(PL_reg_flags & RF_warned))
4195 PL_reg_flags |= RF_warned;
4196 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s limit (%d) exceeded",
4197 "Complex regular subexpression recursion",
4202 ST.save_curlyx = cur_curlyx;
4203 cur_curlyx = cur_curlyx->u.curlyx.prev_curlyx;
4204 PUSH_YES_STATE_GOTO(WHILEM_B_max, ST.save_curlyx->u.curlyx.B);
4207 case WHILEM_B_min_fail: /* just failed to match B in a minimal match */
4208 cur_curlyx = ST.save_curlyx;
4209 REGCP_UNWIND(ST.lastcp);
4212 if (cur_curlyx->u.curlyx.count >= cur_curlyx->u.curlyx.max) {
4213 /* Maximum greed exceeded */
4214 if (cur_curlyx->u.curlyx.count >= REG_INFTY
4215 && ckWARN(WARN_REGEXP)
4216 && !(PL_reg_flags & RF_warned))
4218 PL_reg_flags |= RF_warned;
4219 Perl_warner(aTHX_ packWARN(WARN_REGEXP),
4220 "%s limit (%d) exceeded",
4221 "Complex regular subexpression recursion",
4224 cur_curlyx->u.curlyx.count--;
4228 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4229 "%*s trying longer...\n", REPORT_CODE_OFF+depth*2, "")
4231 /* Try grabbing another A and see if it helps. */
4232 PL_reginput = locinput;
4233 cur_curlyx->u.curlyx.lastloc = locinput;
4234 ST.cp = regcppush(cur_curlyx->u.curlyx.parenfloor);
4235 REGCP_SET(ST.lastcp);
4236 PUSH_STATE_GOTO(WHILEM_A_min, ST.save_curlyx->u.curlyx.A);
4240 #define ST st->u.branch
4242 case BRANCHJ: /* /(...|A|...)/ with long next pointer */
4243 next = scan + ARG(scan);
4246 scan = NEXTOPER(scan);
4249 case BRANCH: /* /(...|A|...)/ */
4250 scan = NEXTOPER(scan); /* scan now points to inner node */
4251 ST.lastparen = *PL_reglastparen;
4252 ST.next_branch = next;
4254 PL_reginput = locinput;
4256 /* Now go into the branch */
4258 PUSH_YES_STATE_GOTO(BRANCH_next, scan);
4260 PUSH_STATE_GOTO(BRANCH_next, scan);
4264 PL_reginput = locinput;
4265 sv_yes_mark = st->u.mark.mark_name = scan->flags ? NULL :
4266 (SV*)rexi->data->data[ ARG( scan ) ];
4267 PUSH_STATE_GOTO(CUTGROUP_next,next);
4269 case CUTGROUP_next_fail:
4272 if (st->u.mark.mark_name)
4273 sv_commit = st->u.mark.mark_name;
4279 case BRANCH_next_fail: /* that branch failed; try the next, if any */
4284 REGCP_UNWIND(ST.cp);
4285 for (n = *PL_reglastparen; n > ST.lastparen; n--)
4286 PL_regoffs[n].end = -1;
4287 *PL_reglastparen = n;
4288 /*dmq: *PL_reglastcloseparen = n; */
4289 scan = ST.next_branch;
4290 /* no more branches? */
4291 if (!scan || (OP(scan) != BRANCH && OP(scan) != BRANCHJ)) {
4293 PerlIO_printf( Perl_debug_log,
4294 "%*s %sBRANCH failed...%s\n",
4295 REPORT_CODE_OFF+depth*2, "",
4301 continue; /* execute next BRANCH[J] op */
4309 #define ST st->u.curlym
4311 case CURLYM: /* /A{m,n}B/ where A is fixed-length */
4313 /* This is an optimisation of CURLYX that enables us to push
4314 * only a single backtracking state, no matter now many matches
4315 * there are in {m,n}. It relies on the pattern being constant
4316 * length, with no parens to influence future backrefs
4320 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4322 /* if paren positive, emulate an OPEN/CLOSE around A */
4324 U32 paren = ST.me->flags;
4325 if (paren > PL_regsize)
4327 if (paren > *PL_reglastparen)
4328 *PL_reglastparen = paren;
4329 scan += NEXT_OFF(scan); /* Skip former OPEN. */
4337 ST.c1 = CHRTEST_UNINIT;
4340 if (!(ST.minmod ? ARG1(ST.me) : ARG2(ST.me))) /* min/max */
4343 curlym_do_A: /* execute the A in /A{m,n}B/ */
4344 PL_reginput = locinput;
4345 PUSH_YES_STATE_GOTO(CURLYM_A, ST.A); /* match A */
4348 case CURLYM_A: /* we've just matched an A */
4349 locinput = st->locinput;
4350 nextchr = UCHARAT(locinput);
4353 /* after first match, determine A's length: u.curlym.alen */
4354 if (ST.count == 1) {
4355 if (PL_reg_match_utf8) {
4357 while (s < PL_reginput) {
4363 ST.alen = PL_reginput - locinput;
4366 ST.count = ST.minmod ? ARG1(ST.me) : ARG2(ST.me);
4369 PerlIO_printf(Perl_debug_log,
4370 "%*s CURLYM now matched %"IVdf" times, len=%"IVdf"...\n",
4371 (int)(REPORT_CODE_OFF+(depth*2)), "",
4372 (IV) ST.count, (IV)ST.alen)
4375 locinput = PL_reginput;
4377 if (cur_eval && cur_eval->u.eval.close_paren &&
4378 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4381 if ( ST.count < (ST.minmod ? ARG1(ST.me) : ARG2(ST.me)) )
4382 goto curlym_do_A; /* try to match another A */
4383 goto curlym_do_B; /* try to match B */
4385 case CURLYM_A_fail: /* just failed to match an A */
4386 REGCP_UNWIND(ST.cp);
4388 if (ST.minmod || ST.count < ARG1(ST.me) /* min*/
4389 || (cur_eval && cur_eval->u.eval.close_paren &&
4390 cur_eval->u.eval.close_paren == (U32)ST.me->flags))
4393 curlym_do_B: /* execute the B in /A{m,n}B/ */
4394 PL_reginput = locinput;
4395 if (ST.c1 == CHRTEST_UNINIT) {
4396 /* calculate c1 and c2 for possible match of 1st char
4397 * following curly */
4398 ST.c1 = ST.c2 = CHRTEST_VOID;
4399 if (HAS_TEXT(ST.B) || JUMPABLE(ST.B)) {
4400 regnode *text_node = ST.B;
4401 if (! HAS_TEXT(text_node))
4402 FIND_NEXT_IMPT(text_node);
4405 (HAS_TEXT(text_node) && PL_regkind[OP(text_node)] == EXACT)
4407 But the former is redundant in light of the latter.
4409 if this changes back then the macro for
4410 IS_TEXT and friends need to change.
4412 if (PL_regkind[OP(text_node)] == EXACT)
4415 ST.c1 = (U8)*STRING(text_node);
4417 (IS_TEXTF(text_node))
4419 : (IS_TEXTFL(text_node))
4420 ? PL_fold_locale[ST.c1]
4427 PerlIO_printf(Perl_debug_log,
4428 "%*s CURLYM trying tail with matches=%"IVdf"...\n",
4429 (int)(REPORT_CODE_OFF+(depth*2)),
4432 if (ST.c1 != CHRTEST_VOID
4433 && UCHARAT(PL_reginput) != ST.c1
4434 && UCHARAT(PL_reginput) != ST.c2)
4436 /* simulate B failing */
4438 PerlIO_printf(Perl_debug_log,
4439 "%*s CURLYM Fast bail c1=%"IVdf" c2=%"IVdf"\n",
4440 (int)(REPORT_CODE_OFF+(depth*2)),"",
4443 state_num = CURLYM_B_fail;
4444 goto reenter_switch;
4448 /* mark current A as captured */
4449 I32 paren = ST.me->flags;
4451 PL_regoffs[paren].start
4452 = HOPc(PL_reginput, -ST.alen) - PL_bostr;
4453 PL_regoffs[paren].end = PL_reginput - PL_bostr;
4454 /*dmq: *PL_reglastcloseparen = paren; */
4457 PL_regoffs[paren].end = -1;
4458 if (cur_eval && cur_eval->u.eval.close_paren &&
4459 cur_eval->u.eval.close_paren == (U32)ST.me->flags)
4468 PUSH_STATE_GOTO(CURLYM_B, ST.B); /* match B */
4471 case CURLYM_B_fail: /* just failed to match a B */
4472 REGCP_UNWIND(ST.cp);
4474 if (ST.count == ARG2(ST.me) /* max */)
4476 goto curlym_do_A; /* try to match a further A */
4478 /* backtrack one A */
4479 if (ST.count == ARG1(ST.me) /* min */)
4482 locinput = HOPc(locinput, -ST.alen);
4483 goto curlym_do_B; /* try to match B */
4486 #define ST st->u.curly
4488 #define CURLY_SETPAREN(paren, success) \
4491 PL_regoffs[paren].start = HOPc(locinput, -1) - PL_bostr; \
4492 PL_regoffs[paren].end = locinput - PL_bostr; \
4493 *PL_reglastcloseparen = paren; \
4496 PL_regoffs[paren].end = -1; \
4499 case STAR: /* /A*B/ where A is width 1 */
4503 scan = NEXTOPER(scan);
4505 case PLUS: /* /A+B/ where A is width 1 */
4509 scan = NEXTOPER(scan);
4511 case CURLYN: /* /(A){m,n}B/ where A is width 1 */
4512 ST.paren = scan->flags; /* Which paren to set */
4513 if (ST.paren > PL_regsize)
4514 PL_regsize = ST.paren;
4515 if (ST.paren > *PL_reglastparen)
4516 *PL_reglastparen = ST.paren;
4517 ST.min = ARG1(scan); /* min to match */
4518 ST.max = ARG2(scan); /* max to match */
4519 if (cur_eval && cur_eval->u.eval.close_paren &&
4520 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4524 scan = regnext(NEXTOPER(scan) + NODE_STEP_REGNODE);
4526 case CURLY: /* /A{m,n}B/ where A is width 1 */
4528 ST.min = ARG1(scan); /* min to match */
4529 ST.max = ARG2(scan); /* max to match */
4530 scan = NEXTOPER(scan) + NODE_STEP_REGNODE;
4533 * Lookahead to avoid useless match attempts
4534 * when we know what character comes next.
4536 * Used to only do .*x and .*?x, but now it allows
4537 * for )'s, ('s and (?{ ... })'s to be in the way
4538 * of the quantifier and the EXACT-like node. -- japhy
4541 if (ST.min > ST.max) /* XXX make this a compile-time check? */
4543 if (HAS_TEXT(next) || JUMPABLE(next)) {
4545 regnode *text_node = next;
4547 if (! HAS_TEXT(text_node))
4548 FIND_NEXT_IMPT(text_node);
4550 if (! HAS_TEXT(text_node))
4551 ST.c1 = ST.c2 = CHRTEST_VOID;
4553 if ( PL_regkind[OP(text_node)] != EXACT ) {
4554 ST.c1 = ST.c2 = CHRTEST_VOID;
4555 goto assume_ok_easy;
4558 s = (U8*)STRING(text_node);
4560 /* Currently we only get here when
4562 PL_rekind[OP(text_node)] == EXACT
4564 if this changes back then the macro for IS_TEXT and
4565 friends need to change. */
4568 if (IS_TEXTF(text_node))
4569 ST.c2 = PL_fold[ST.c1];
4570 else if (IS_TEXTFL(text_node))
4571 ST.c2 = PL_fold_locale[ST.c1];
4574 if (IS_TEXTF(text_node)) {
4575 STRLEN ulen1, ulen2;
4576 U8 tmpbuf1[UTF8_MAXBYTES_CASE+1];
4577 U8 tmpbuf2[UTF8_MAXBYTES_CASE+1];
4579 to_utf8_lower((U8*)s, tmpbuf1, &ulen1);
4580 to_utf8_upper((U8*)s, tmpbuf2, &ulen2);
4582 ST.c1 = utf8n_to_uvchr(tmpbuf1, UTF8_MAXLEN, 0,
4584 0 : UTF8_ALLOW_ANY);
4585 ST.c2 = utf8n_to_uvchr(tmpbuf2, UTF8_MAXLEN, 0,
4587 0 : UTF8_ALLOW_ANY);
4589 ST.c1 = utf8n_to_uvuni(tmpbuf1, UTF8_MAXBYTES, 0,
4591 ST.c2 = utf8n_to_uvuni(tmpbuf2, UTF8_MAXBYTES, 0,
4596 ST.c2 = ST.c1 = utf8n_to_uvchr(s, UTF8_MAXBYTES, 0,
4603 ST.c1 = ST.c2 = CHRTEST_VOID;
4608 PL_reginput = locinput;
4611 if (ST.min && regrepeat(rex, ST.A, ST.min, depth) < ST.min)
4614 locinput = PL_reginput;
4616 if (ST.c1 == CHRTEST_VOID)
4617 goto curly_try_B_min;
4619 ST.oldloc = locinput;
4621 /* set ST.maxpos to the furthest point along the
4622 * string that could possibly match */
4623 if (ST.max == REG_INFTY) {
4624 ST.maxpos = PL_regeol - 1;
4626 while (UTF8_IS_CONTINUATION(*(U8*)ST.maxpos))
4630 int m = ST.max - ST.min;
4631 for (ST.maxpos = locinput;
4632 m >0 && ST.maxpos + UTF8SKIP(ST.maxpos) <= PL_regeol; m--)
4633 ST.maxpos += UTF8SKIP(ST.maxpos);
4636 ST.maxpos = locinput + ST.max - ST.min;
4637 if (ST.maxpos >= PL_regeol)
4638 ST.maxpos = PL_regeol - 1;
4640 goto curly_try_B_min_known;
4644 ST.count = regrepeat(rex, ST.A, ST.max, depth);
4645 locinput = PL_reginput;
4646 if (ST.count < ST.min)
4648 if ((ST.count > ST.min)
4649 && (PL_regkind[OP(ST.B)] == EOL) && (OP(ST.B) != MEOL))
4651 /* A{m,n} must come at the end of the string, there's
4652 * no point in backing off ... */
4654 /* ...except that $ and \Z can match before *and* after
4655 newline at the end. Consider "\n\n" =~ /\n+\Z\n/.
4656 We may back off by one in this case. */
4657 if (UCHARAT(PL_reginput - 1) == '\n' && OP(ST.B) != EOS)
4661 goto curly_try_B_max;
4666 case CURLY_B_min_known_fail:
4667 /* failed to find B in a non-greedy match where c1,c2 valid */
4668 if (ST.paren && ST.count)
4669 PL_regoffs[ST.paren].end = -1;
4671 PL_reginput = locinput; /* Could be reset... */
4672 REGCP_UNWIND(ST.cp);
4673 /* Couldn't or didn't -- move forward. */
4674 ST.oldloc = locinput;
4676 locinput += UTF8SKIP(locinput);
4680 curly_try_B_min_known:
4681 /* find the next place where 'B' could work, then call B */
4685 n = (ST.oldloc == locinput) ? 0 : 1;
4686 if (ST.c1 == ST.c2) {
4688 /* set n to utf8_distance(oldloc, locinput) */
4689 while (locinput <= ST.maxpos &&
4690 utf8n_to_uvchr((U8*)locinput,
4691 UTF8_MAXBYTES, &len,
4692 uniflags) != (UV)ST.c1) {
4698 /* set n to utf8_distance(oldloc, locinput) */
4699 while (locinput <= ST.maxpos) {
4701 const UV c = utf8n_to_uvchr((U8*)locinput,
4702 UTF8_MAXBYTES, &len,
4704 if (c == (UV)ST.c1 || c == (UV)ST.c2)
4712 if (ST.c1 == ST.c2) {
4713 while (locinput <= ST.maxpos &&
4714 UCHARAT(locinput) != ST.c1)
4718 while (locinput <= ST.maxpos
4719 && UCHARAT(locinput) != ST.c1
4720 && UCHARAT(locinput) != ST.c2)
4723 n = locinput - ST.oldloc;
4725 if (locinput > ST.maxpos)
4727 /* PL_reginput == oldloc now */
4730 if (regrepeat(rex, ST.A, n, depth) < n)
4733 PL_reginput = locinput;
4734 CURLY_SETPAREN(ST.paren, ST.count);
4735 if (cur_eval && cur_eval->u.eval.close_paren &&
4736 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4739 PUSH_STATE_GOTO(CURLY_B_min_known, ST.B);
4744 case CURLY_B_min_fail:
4745 /* failed to find B in a non-greedy match where c1,c2 invalid */
4746 if (ST.paren && ST.count)
4747 PL_regoffs[ST.paren].end = -1;
4749 REGCP_UNWIND(ST.cp);
4750 /* failed -- move forward one */
4751 PL_reginput = locinput;
4752 if (regrepeat(rex, ST.A, 1, depth)) {
4754 locinput = PL_reginput;
4755 if (ST.count <= ST.max || (ST.max == REG_INFTY &&
4756 ST.count > 0)) /* count overflow ? */
4759 CURLY_SETPAREN(ST.paren, ST.count);
4760 if (cur_eval && cur_eval->u.eval.close_paren &&
4761 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4764 PUSH_STATE_GOTO(CURLY_B_min, ST.B);
4772 /* a successful greedy match: now try to match B */
4773 if (cur_eval && cur_eval->u.eval.close_paren &&
4774 cur_eval->u.eval.close_paren == (U32)ST.paren) {
4779 if (ST.c1 != CHRTEST_VOID)
4780 c = do_utf8 ? utf8n_to_uvchr((U8*)PL_reginput,
4781 UTF8_MAXBYTES, 0, uniflags)
4782 : (UV) UCHARAT(PL_reginput);
4783 /* If it could work, try it. */
4784 if (ST.c1 == CHRTEST_VOID || c == (UV)ST.c1 || c == (UV)ST.c2) {
4785 CURLY_SETPAREN(ST.paren, ST.count);
4786 PUSH_STATE_GOTO(CURLY_B_max, ST.B);
4791 case CURLY_B_max_fail:
4792 /* failed to find B in a greedy match */
4793 if (ST.paren && ST.count)
4794 PL_regoffs[ST.paren].end = -1;
4796 REGCP_UNWIND(ST.cp);
4798 if (--ST.count < ST.min)
4800 PL_reginput = locinput = HOPc(locinput, -1);
4801 goto curly_try_B_max;
4808 /* we've just finished A in /(??{A})B/; now continue with B */
4810 st->u.eval.toggle_reg_flags
4811 = cur_eval->u.eval.toggle_reg_flags;
4812 PL_reg_flags ^= st->u.eval.toggle_reg_flags;
4814 st->u.eval.prev_rex = rex; /* inner */
4815 SETREX(rex,cur_eval->u.eval.prev_rex);
4816 rexi = RXi_GET(rex);
4817 cur_curlyx = cur_eval->u.eval.prev_curlyx;
4819 st->u.eval.cp = regcppush(0); /* Save *all* the positions. */
4820 REGCP_SET(st->u.eval.lastcp);
4821 PL_reginput = locinput;
4823 /* Restore parens of the outer rex without popping the
4825 tmpix = PL_savestack_ix;
4826 PL_savestack_ix = cur_eval->u.eval.lastcp;
4828 PL_savestack_ix = tmpix;
4830 st->u.eval.prev_eval = cur_eval;
4831 cur_eval = cur_eval->u.eval.prev_eval;
4833 PerlIO_printf(Perl_debug_log, "%*s EVAL trying tail ... %"UVxf"\n",
4834 REPORT_CODE_OFF+depth*2, "",PTR2UV(cur_eval)););
4835 if ( nochange_depth )
4838 PUSH_YES_STATE_GOTO(EVAL_AB,
4839 st->u.eval.prev_eval->u.eval.B); /* match B */
4842 if (locinput < reginfo->till) {
4843 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log,
4844 "%sMatch possible, but length=%ld is smaller than requested=%ld, failing!%s\n",
4846 (long)(locinput - PL_reg_starttry),
4847 (long)(reginfo->till - PL_reg_starttry),
4850 sayNO_SILENT; /* Cannot match: too short. */
4852 PL_reginput = locinput; /* put where regtry can find it */
4853 sayYES; /* Success! */
4855 case SUCCEED: /* successful SUSPEND/UNLESSM/IFMATCH/CURLYM */
4857 PerlIO_printf(Perl_debug_log,
4858 "%*s %ssubpattern success...%s\n",
4859 REPORT_CODE_OFF+depth*2, "", PL_colors[4], PL_colors[5]));
4860 PL_reginput = locinput; /* put where regtry can find it */
4861 sayYES; /* Success! */
4864 #define ST st->u.ifmatch
4866 case SUSPEND: /* (?>A) */
4868 PL_reginput = locinput;
4871 case UNLESSM: /* -ve lookaround: (?!A), or with flags, (?<!A) */
4873 goto ifmatch_trivial_fail_test;
4875 case IFMATCH: /* +ve lookaround: (?=A), or with flags, (?<=A) */
4877 ifmatch_trivial_fail_test:
4879 char * const s = HOPBACKc(locinput, scan->flags);
4884 sw = 1 - (bool)ST.wanted;
4888 next = scan + ARG(scan);
4896 PL_reginput = locinput;
4900 ST.logical = logical;
4901 /* execute body of (?...A) */
4902 PUSH_YES_STATE_GOTO(IFMATCH_A, NEXTOPER(NEXTOPER(scan)));
4905 case IFMATCH_A_fail: /* body of (?...A) failed */
4906 ST.wanted = !ST.wanted;
4909 case IFMATCH_A: /* body of (?...A) succeeded */
4911 sw = (bool)ST.wanted;
4913 else if (!ST.wanted)
4916 if (OP(ST.me) == SUSPEND)
4917 locinput = PL_reginput;
4919 locinput = PL_reginput = st->locinput;
4920 nextchr = UCHARAT(locinput);
4922 scan = ST.me + ARG(ST.me);
4925 continue; /* execute B */
4930 next = scan + ARG(scan);
4935 reginfo->cutpoint = PL_regeol;
4938 PL_reginput = locinput;
4940 sv_yes_mark = sv_commit = (SV*)rexi->data->data[ ARG( scan ) ];
4941 PUSH_STATE_GOTO(COMMIT_next,next);
4943 case COMMIT_next_fail:
4950 #define ST st->u.mark
4952 ST.prev_mark = mark_state;
4953 ST.mark_name = sv_commit = sv_yes_mark
4954 = (SV*)rexi->data->data[ ARG( scan ) ];
4956 ST.mark_loc = PL_reginput = locinput;
4957 PUSH_YES_STATE_GOTO(MARKPOINT_next,next);
4959 case MARKPOINT_next:
4960 mark_state = ST.prev_mark;
4963 case MARKPOINT_next_fail:
4964 if (popmark && sv_eq(ST.mark_name,popmark))
4966 if (ST.mark_loc > startpoint)
4967 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
4968 popmark = NULL; /* we found our mark */
4969 sv_commit = ST.mark_name;
4972 PerlIO_printf(Perl_debug_log,
4973 "%*s %ssetting cutpoint to mark:%"SVf"...%s\n",
4974 REPORT_CODE_OFF+depth*2, "",
4975 PL_colors[4], SVfARG(sv_commit), PL_colors[5]);
4978 mark_state = ST.prev_mark;
4979 sv_yes_mark = mark_state ?
4980 mark_state->u.mark.mark_name : NULL;
4984 PL_reginput = locinput;
4986 /* (*SKIP) : if we fail we cut here*/
4987 ST.mark_name = NULL;
4988 ST.mark_loc = locinput;
4989 PUSH_STATE_GOTO(SKIP_next,next);
4991 /* (*SKIP:NAME) : if there is a (*MARK:NAME) fail where it was,
4992 otherwise do nothing. Meaning we need to scan
4994 regmatch_state *cur = mark_state;
4995 SV *find = (SV*)rexi->data->data[ ARG( scan ) ];
4998 if ( sv_eq( cur->u.mark.mark_name,
5001 ST.mark_name = find;
5002 PUSH_STATE_GOTO( SKIP_next, next );
5004 cur = cur->u.mark.prev_mark;
5007 /* Didn't find our (*MARK:NAME) so ignore this (*SKIP:NAME) */
5009 case SKIP_next_fail:
5011 /* (*CUT:NAME) - Set up to search for the name as we
5012 collapse the stack*/
5013 popmark = ST.mark_name;
5015 /* (*CUT) - No name, we cut here.*/
5016 if (ST.mark_loc > startpoint)
5017 reginfo->cutpoint = HOPBACKc(ST.mark_loc, 1);
5018 /* but we set sv_commit to latest mark_name if there
5019 is one so they can test to see how things lead to this
5022 sv_commit=mark_state->u.mark.mark_name;
5030 if ( n == (U32)what_len_TRICKYFOLD(locinput,do_utf8,ln) ) {
5032 } else if ( 0xDF == n && !do_utf8 && !UTF ) {
5035 U8 folded[UTF8_MAXBYTES_CASE+1];
5037 const char * const l = locinput;
5038 char *e = PL_regeol;
5039 to_uni_fold(n, folded, &foldlen);
5041 if (ibcmp_utf8((const char*) folded, 0, foldlen, 1,
5042 l, &e, 0, do_utf8)) {
5047 nextchr = UCHARAT(locinput);
5050 if ((n=is_LNBREAK(locinput,do_utf8))) {
5052 nextchr = UCHARAT(locinput);
5057 #define CASE_CLASS(nAmE) \
5059 if ((n=is_##nAmE(locinput,do_utf8))) { \
5061 nextchr = UCHARAT(locinput); \
5066 if ((n=is_##nAmE(locinput,do_utf8))) { \
5069 locinput += UTF8SKIP(locinput); \
5070 nextchr = UCHARAT(locinput); \
5075 CASE_CLASS(HORIZWS);
5079 PerlIO_printf(Perl_error_log, "%"UVxf" %d\n",
5080 PTR2UV(scan), OP(scan));
5081 Perl_croak(aTHX_ "regexp memory corruption");
5085 /* switch break jumps here */
5086 scan = next; /* prepare to execute the next op and ... */
5087 continue; /* ... jump back to the top, reusing st */
5091 /* push a state that backtracks on success */
5092 st->u.yes.prev_yes_state = yes_state;
5096 /* push a new regex state, then continue at scan */
5098 regmatch_state *newst;
5101 regmatch_state *cur = st;
5102 regmatch_state *curyes = yes_state;
5104 regmatch_slab *slab = PL_regmatch_slab;
5105 for (;curd > -1;cur--,curd--) {
5106 if (cur < SLAB_FIRST(slab)) {
5108 cur = SLAB_LAST(slab);
5110 PerlIO_printf(Perl_error_log, "%*s#%-3d %-10s %s\n",
5111 REPORT_CODE_OFF + 2 + depth * 2,"",
5112 curd, PL_reg_name[cur->resume_state],
5113 (curyes == cur) ? "yes" : ""
5116 curyes = cur->u.yes.prev_yes_state;
5119 DEBUG_STATE_pp("push")
5122 st->locinput = locinput;
5124 if (newst > SLAB_LAST(PL_regmatch_slab))
5125 newst = S_push_slab(aTHX);
5126 PL_regmatch_state = newst;
5128 locinput = PL_reginput;
5129 nextchr = UCHARAT(locinput);
5137 * We get here only if there's trouble -- normally "case END" is
5138 * the terminating point.
5140 Perl_croak(aTHX_ "corrupted regexp pointers");
5146 /* we have successfully completed a subexpression, but we must now
5147 * pop to the state marked by yes_state and continue from there */
5148 assert(st != yes_state);
5150 while (st != yes_state) {
5152 if (st < SLAB_FIRST(PL_regmatch_slab)) {
5153 PL_regmatch_slab = PL_regmatch_slab->prev;
5154 st = SLAB_LAST(PL_regmatch_slab);
5158 DEBUG_STATE_pp("pop (no final)");
5160 DEBUG_STATE_pp("pop (yes)");
5166 while (yes_state < SLAB_FIRST(PL_regmatch_slab)
5167 || yes_state > SLAB_LAST(PL_regmatch_slab))
5169 /* not in this slab, pop slab */
5170 depth -= (st - SLAB_FIRST(PL_regmatch_slab) + 1);
5171 PL_regmatch_slab = PL_regmatch_slab->prev;
5172 st = SLAB_LAST(PL_regmatch_slab);
5174 depth -= (st - yes_state);
5177 yes_state = st->u.yes.prev_yes_state;
5178 PL_regmatch_state = st;
5181 locinput= st->locinput;
5182 nextchr = UCHARAT(locinput);
5184 state_num = st->resume_state + no_final;
5185 goto reenter_switch;
5188 DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "%sMatch successful!%s\n",
5189 PL_colors[4], PL_colors[5]));
5191 if (PL_reg_eval_set) {
5192 /* each successfully executed (?{...}) block does the equivalent of
5193 * local $^R = do {...}
5194 * When popping the save stack, all these locals would be undone;
5195 * bypass this by setting the outermost saved $^R to the latest
5197 if (oreplsv != GvSV(PL_replgv))
5198 sv_setsv(oreplsv, GvSV(PL_replgv));
5205 PerlIO_printf(Perl_debug_log,
5206 "%*s %sfailed...%s\n",
5207 REPORT_CODE_OFF+depth*2, "",
5208 PL_colors[4], PL_colors[5])
5220 /* there's a previous state to backtrack to */
5222 if (st < SLAB_FIRST(PL_regmatch_slab)) {
5223 PL_regmatch_slab = PL_regmatch_slab->prev;
5224 st = SLAB_LAST(PL_regmatch_slab);
5226 PL_regmatch_state = st;
5227 locinput= st->locinput;
5228 nextchr = UCHARAT(locinput);
5230 DEBUG_STATE_pp("pop");
5232 if (yes_state == st)
5233 yes_state = st->u.yes.prev_yes_state;
5235 state_num = st->resume_state + 1; /* failure = success + 1 */
5236 goto reenter_switch;
5241 if (rex->intflags & PREGf_VERBARG_SEEN) {
5242 SV *sv_err = get_sv("REGERROR", 1);
5243 SV *sv_mrk = get_sv("REGMARK", 1);
5245 sv_commit = &PL_sv_no;
5247 sv_yes_mark = &PL_sv_yes;
5250 sv_commit = &PL_sv_yes;
5251 sv_yes_mark = &PL_sv_no;
5253 sv_setsv(sv_err, sv_commit);
5254 sv_setsv(sv_mrk, sv_yes_mark);
5257 /* clean up; in particular, free all slabs above current one */
5258 LEAVE_SCOPE(oldsave);
5264 - regrepeat - repeatedly match something simple, report how many
5267 * [This routine now assumes that it will only match on things of length 1.
5268 * That was true before, but now we assume scan - reginput is the count,
5269 * rather than incrementing count on every character. [Er, except utf8.]]
5272 S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth)
5275 register char *scan;
5277 register char *loceol = PL_regeol;
5278 register I32 hardcount = 0;
5279 register bool do_utf8 = PL_reg_match_utf8;
5281 PERL_UNUSED_ARG(depth);
5285 if (max == REG_INFTY)
5287 else if (max < loceol - scan)
5288 loceol = scan + max;
5293 while (scan < loceol && hardcount < max && *scan != '\n') {
5294 scan += UTF8SKIP(scan);
5298 while (scan < loceol && *scan != '\n')
5305 while (scan < loceol && hardcount < max) {
5306 scan += UTF8SKIP(scan);
5316 case EXACT: /* length of string is 1 */
5318 while (scan < loceol && UCHARAT(scan) == c)
5321 case EXACTF: /* length of string is 1 */
5323 while (scan < loceol &&
5324 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold[c]))
5327 case EXACTFL: /* length of string is 1 */
5328 PL_reg_flags |= RF_tainted;
5330 while (scan < loceol &&
5331 (UCHARAT(scan) == c || UCHARAT(scan) == PL_fold_locale[c]))
5337 while (hardcount < max && scan < loceol &&
5338 reginclass(prog, p, (U8*)scan, 0, do_utf8)) {
5339 scan += UTF8SKIP(scan);
5343 while (scan < loceol && REGINCLASS(prog, p, (U8*)scan))
5350 LOAD_UTF8_CHARCLASS_ALNUM();
5351 while (hardcount < max && scan < loceol &&
5352 swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5353 scan += UTF8SKIP(scan);
5357 while (scan < loceol && isALNUM(*scan))
5362 PL_reg_flags |= RF_tainted;
5365 while (hardcount < max && scan < loceol &&
5366 isALNUM_LC_utf8((U8*)scan)) {
5367 scan += UTF8SKIP(scan);
5371 while (scan < loceol && isALNUM_LC(*scan))
5378 LOAD_UTF8_CHARCLASS_ALNUM();
5379 while (hardcount < max && scan < loceol &&
5380 !swash_fetch(PL_utf8_alnum, (U8*)scan, do_utf8)) {
5381 scan += UTF8SKIP(scan);
5385 while (scan < loceol && !isALNUM(*scan))
5390 PL_reg_flags |= RF_tainted;
5393 while (hardcount < max && scan < loceol &&
5394 !isALNUM_LC_utf8((U8*)scan)) {
5395 scan += UTF8SKIP(scan);
5399 while (scan < loceol && !isALNUM_LC(*scan))
5406 LOAD_UTF8_CHARCLASS_SPACE();
5407 while (hardcount < max && scan < loceol &&
5409 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5410 scan += UTF8SKIP(scan);
5414 while (scan < loceol && isSPACE(*scan))
5419 PL_reg_flags |= RF_tainted;
5422 while (hardcount < max && scan < loceol &&
5423 (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5424 scan += UTF8SKIP(scan);
5428 while (scan < loceol && isSPACE_LC(*scan))
5435 LOAD_UTF8_CHARCLASS_SPACE();
5436 while (hardcount < max && scan < loceol &&
5438 swash_fetch(PL_utf8_space,(U8*)scan, do_utf8))) {
5439 scan += UTF8SKIP(scan);
5443 while (scan < loceol && !isSPACE(*scan))
5448 PL_reg_flags |= RF_tainted;
5451 while (hardcount < max && scan < loceol &&
5452 !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) {
5453 scan += UTF8SKIP(scan);
5457 while (scan < loceol && !isSPACE_LC(*scan))
5464 LOAD_UTF8_CHARCLASS_DIGIT();
5465 while (hardcount < max && scan < loceol &&
5466 swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5467 scan += UTF8SKIP(scan);
5471 while (scan < loceol && isDIGIT(*scan))
5478 LOAD_UTF8_CHARCLASS_DIGIT();
5479 while (hardcount < max && scan < loceol &&
5480 !swash_fetch(PL_utf8_digit, (U8*)scan, do_utf8)) {
5481 scan += UTF8SKIP(scan);
5485 while (scan < loceol && !isDIGIT(*scan))
5491 while (hardcount < max && scan < loceol && (c=is_LNBREAK_utf8(scan))) {
5497 LNBREAK can match two latin chars, which is ok,
5498 because we have a null terminated string, but we
5499 have to use hardcount in this situation
5501 while (scan < loceol && (c=is_LNBREAK_latin1(scan))) {
5510 while (hardcount < max && scan < loceol && (c=is_HORIZWS_utf8(scan))) {
5515 while (scan < loceol && is_HORIZWS_latin1(scan))
5522 while (hardcount < max && scan < loceol && !is_HORIZWS_utf8(scan)) {
5523 scan += UTF8SKIP(scan);
5527 while (scan < loceol && !is_HORIZWS_latin1(scan))
5535 while (hardcount < max && scan < loceol && (c=is_VERTWS_utf8(scan))) {
5540 while (scan < loceol && is_VERTWS_latin1(scan))
5548 while (hardcount < max && scan < loceol && !is_VERTWS_utf8(scan)) {
5549 scan += UTF8SKIP(scan);
5553 while (scan < loceol && !is_VERTWS_latin1(scan))
5559 default: /* Called on something of 0 width. */
5560 break; /* So match right here or not at all. */
5566 c = scan - PL_reginput;
5570 GET_RE_DEBUG_FLAGS_DECL;
5572 SV * const prop = sv_newmortal();
5573 regprop(prog, prop, p);
5574 PerlIO_printf(Perl_debug_log,
5575 "%*s %s can match %"IVdf" times out of %"IVdf"...\n",
5576 REPORT_CODE_OFF + depth*2, "", SvPVX_const(prop),(IV)c,(IV)max);
5584 #if !defined(PERL_IN_XSUB_RE) || defined(PLUGGABLE_RE_EXTENSION)
5586 - regclass_swash - prepare the utf8 swash
5590 Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
5596 RXi_GET_DECL(prog,progi);
5597 const struct reg_data * const data = prog ? progi->data : NULL;
5599 if (data && data->count) {
5600 const U32 n = ARG(node);
5602 if (data->what[n] == 's') {
5603 SV * const rv = (SV*)data->data[n];
5604 AV * const av = (AV*)SvRV((SV*)rv);
5605 SV **const ary = AvARRAY(av);
5608 /* See the end of regcomp.c:S_regclass() for
5609 * documentation of these array elements. */
5612 a = SvROK(ary[1]) ? &ary[1] : NULL;
5613 b = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;
5617 else if (si && doinit) {
5618 sw = swash_init("utf8", "", si, 1, 0);
5619 (void)av_store(av, 1, sw);
5636 - reginclass - determine if a character falls into a character class
5638 The n is the ANYOF regnode, the p is the target string, lenp
5639 is pointer to the maximum length of how far to go in the p
5640 (if the lenp is zero, UTF8SKIP(p) is used),
5641 do_utf8 tells whether the target string is in UTF-8.
5646 S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
5649 const char flags = ANYOF_FLAGS(n);
5655 if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
5656 c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
5657 (UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
5658 /* see [perl #37836] for UTF8_ALLOW_ANYUV */
5659 if (len == (STRLEN)-1)
5660 Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
5663 plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
5664 if (do_utf8 || (flags & ANYOF_UNICODE)) {
5667 if (do_utf8 && !ANYOF_RUNTIME(n)) {
5668 if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
5671 if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
5675 SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
5678 if (swash_fetch(sw, p, do_utf8))
5680 else if (flags & ANYOF_FOLD) {
5681 if (!match && lenp && av) {
5683 for (i = 0; i <= av_len(av); i++) {
5684 SV* const sv = *av_fetch(av, i, FALSE);
5686 const char * const s = SvPV_const(sv, len);
5688 if (len <= plen && memEQ(s, (char*)p, len)) {
5696 U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
5699 to_utf8_fold(p, tmpbuf, &tmplen);
5700 if (swash_fetch(sw, tmpbuf, do_utf8))
5706 if (match && lenp && *lenp == 0)
5707 *lenp = UNISKIP(NATIVE_TO_UNI(c));
5709 if (!match && c < 256) {
5710 if (ANYOF_BITMAP_TEST(n, c))
5712 else if (flags & ANYOF_FOLD) {
5715 if (flags & ANYOF_LOCALE) {
5716 PL_reg_flags |= RF_tainted;
5717 f = PL_fold_locale[c];
5721 if (f != c && ANYOF_BITMAP_TEST(n, f))
5725 if (!match && (flags & ANYOF_CLASS)) {
5726 PL_reg_flags |= RF_tainted;
5728 (ANYOF_CLASS_TEST(n, ANYOF_ALNUM) && isALNUM_LC(c)) ||
5729 (ANYOF_CLASS_TEST(n, ANYOF_NALNUM) && !isALNUM_LC(c)) ||
5730 (ANYOF_CLASS_TEST(n, ANYOF_SPACE) && isSPACE_LC(c)) ||
5731 (ANYOF_CLASS_TEST(n, ANYOF_NSPACE) && !isSPACE_LC(c)) ||
5732 (ANYOF_CLASS_TEST(n, ANYOF_DIGIT) && isDIGIT_LC(c)) ||
5733 (ANYOF_CLASS_TEST(n, ANYOF_NDIGIT) && !isDIGIT_LC(c)) ||
5734 (ANYOF_CLASS_TEST(n, ANYOF_ALNUMC) && isALNUMC_LC(c)) ||
5735 (ANYOF_CLASS_TEST(n, ANYOF_NALNUMC) && !isALNUMC_LC(c)) ||
5736 (ANYOF_CLASS_TEST(n, ANYOF_ALPHA) && isALPHA_LC(c)) ||
5737 (ANYOF_CLASS_TEST(n, ANYOF_NALPHA) && !isALPHA_LC(c)) ||
5738 (ANYOF_CLASS_TEST(n, ANYOF_ASCII) && isASCII(c)) ||
5739 (ANYOF_CLASS_TEST(n, ANYOF_NASCII) && !isASCII(c)) ||
5740 (ANYOF_CLASS_TEST(n, ANYOF_CNTRL) && isCNTRL_LC(c)) ||
5741 (ANYOF_CLASS_TEST(n, ANYOF_NCNTRL) && !isCNTRL_LC(c)) ||
5742 (ANYOF_CLASS_TEST(n, ANYOF_GRAPH) && isGRAPH_LC(c)) ||
5743 (ANYOF_CLASS_TEST(n, ANYOF_NGRAPH) && !isGRAPH_LC(c)) ||
5744 (ANYOF_CLASS_TEST(n, ANYOF_LOWER) && isLOWER_LC(c)) ||
5745 (ANYOF_CLASS_TEST(n, ANYOF_NLOWER) && !isLOWER_LC(c)) ||
5746 (ANYOF_CLASS_TEST(n, ANYOF_PRINT) && isPRINT_LC(c)) ||
5747 (ANYOF_CLASS_TEST(n, ANYOF_NPRINT) && !isPRINT_LC(c)) ||
5748 (ANYOF_CLASS_TEST(n, ANYOF_PUNCT) && isPUNCT_LC(c)) ||
5749 (ANYOF_CLASS_TEST(n, ANYOF_NPUNCT) && !isPUNCT_LC(c)) ||
5750 (ANYOF_CLASS_TEST(n, ANYOF_UPPER) && isUPPER_LC(c)) ||
5751 (ANYOF_CLASS_TEST(n, ANYOF_NUPPER) && !isUPPER_LC(c)) ||
5752 (ANYOF_CLASS_TEST(n, ANYOF_XDIGIT) && isXDIGIT(c)) ||
5753 (ANYOF_CLASS_TEST(n, ANYOF_NXDIGIT) && !isXDIGIT(c)) ||
5754 (ANYOF_CLASS_TEST(n, ANYOF_PSXSPC) && isPSXSPC(c)) ||
5755 (ANYOF_CLASS_TEST(n, ANYOF_NPSXSPC) && !isPSXSPC(c)) ||
5756 (ANYOF_CLASS_TEST(n, ANYOF_BLANK) && isBLANK(c)) ||
5757 (ANYOF_CLASS_TEST(n, ANYOF_NBLANK) && !isBLANK(c))
5758 ) /* How's that for a conditional? */
5765 return (flags & ANYOF_INVERT) ? !match : match;
5769 S_reghop3(U8 *s, I32 off, const U8* lim)
5773 while (off-- && s < lim) {
5774 /* XXX could check well-formedness here */
5779 while (off++ && s > lim) {
5781 if (UTF8_IS_CONTINUED(*s)) {
5782 while (s > lim && UTF8_IS_CONTINUATION(*s))
5785 /* XXX could check well-formedness here */
5792 /* there are a bunch of places where we use two reghop3's that should
5793 be replaced with this routine. but since thats not done yet
5794 we ifdef it out - dmq
5797 S_reghop4(U8 *s, I32 off, const U8* llim, const U8* rlim)
5801 while (off-- && s < rlim) {
5802 /* XXX could check well-formedness here */
5807 while (off++ && s > llim) {
5809 if (UTF8_IS_CONTINUED(*s)) {
5810 while (s > llim && UTF8_IS_CONTINUATION(*s))
5813 /* XXX could check well-formedness here */
5821 S_reghopmaybe3(U8* s, I32 off, const U8* lim)
5825 while (off-- && s < lim) {
5826 /* XXX could check well-formedness here */
5833 while (off++ && s > lim) {
5835 if (UTF8_IS_CONTINUED(*s)) {
5836 while (s > lim && UTF8_IS_CONTINUATION(*s))
5839 /* XXX could check well-formedness here */
5848 restore_pos(pTHX_ void *arg)
5851 regexp * const rex = (regexp *)arg;
5852 if (PL_reg_eval_set) {
5853 if (PL_reg_oldsaved) {
5854 rex->subbeg = PL_reg_oldsaved;
5855 rex->sublen = PL_reg_oldsavedlen;
5856 #ifdef PERL_OLD_COPY_ON_WRITE
5857 rex->saved_copy = PL_nrs;
5859 RX_MATCH_COPIED_on(rex);
5861 PL_reg_magic->mg_len = PL_reg_oldpos;
5862 PL_reg_eval_set = 0;
5863 PL_curpm = PL_reg_oldcurpm;
5868 S_to_utf8_substr(pTHX_ register regexp *prog)
5872 if (prog->substrs->data[i].substr
5873 && !prog->substrs->data[i].utf8_substr) {
5874 SV* const sv = newSVsv(prog->substrs->data[i].substr);
5875 prog->substrs->data[i].utf8_substr = sv;
5876 sv_utf8_upgrade(sv);
5877 if (SvVALID(prog->substrs->data[i].substr)) {
5878 const U8 flags = BmFLAGS(prog->substrs->data[i].substr);
5879 if (flags & FBMcf_TAIL) {
5880 /* Trim the trailing \n that fbm_compile added last
5882 SvCUR_set(sv, SvCUR(sv) - 1);
5883 /* Whilst this makes the SV technically "invalid" (as its
5884 buffer is no longer followed by "\0") when fbm_compile()
5885 adds the "\n" back, a "\0" is restored. */
5887 fbm_compile(sv, flags);
5889 if (prog->substrs->data[i].substr == prog->check_substr)
5890 prog->check_utf8 = sv;
5896 S_to_byte_substr(pTHX_ register regexp *prog)
5901 if (prog->substrs->data[i].utf8_substr
5902 && !prog->substrs->data[i].substr) {
5903 SV* sv = newSVsv(prog->substrs->data[i].utf8_substr);
5904 if (sv_utf8_downgrade(sv, TRUE)) {
5905 if (SvVALID(prog->substrs->data[i].utf8_substr)) {
5907 = BmFLAGS(prog->substrs->data[i].utf8_substr);
5908 if (flags & FBMcf_TAIL) {
5909 /* Trim the trailing \n that fbm_compile added last
5911 SvCUR_set(sv, SvCUR(sv) - 1);
5913 fbm_compile(sv, flags);
5919 prog->substrs->data[i].substr = sv;
5920 if (prog->substrs->data[i].utf8_substr == prog->check_utf8)
5921 prog->check_substr = sv;
5928 * c-indentation-style: bsd
5930 * indent-tabs-mode: t
5933 * ex: set ts=8 sts=4 sw=4 noet: