5 * "A fair jaw-cracker dwarf-language must be." --Samwise Gamgee
8 /* This file contains functions for compiling a regular expression. See
9 * also regexec.c which funnily enough, contains functions for executing
10 * a regular expression.
12 * This file is also copied at build time to ext/re/re_comp.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.
57 **** Alterations to Henry's code are...
59 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
60 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
62 **** You may distribute under the terms of either the GNU General Public
63 **** License or the Artistic License, as specified in the README file.
66 * Beware that some of this code is subtly aware of the way operator
67 * precedence is structured in regular expressions. Serious changes in
68 * regular-expression syntax might require a total rethink.
71 #define PERL_IN_REGCOMP_C
74 #ifndef PERL_IN_XSUB_RE
79 #ifdef PERL_IN_XSUB_RE
90 # if defined(BUGGY_MSC6)
91 /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
92 # pragma optimize("a",off)
93 /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
94 # pragma optimize("w",on )
95 # endif /* BUGGY_MSC6 */
102 typedef struct RExC_state_t {
103 U32 flags; /* are we folding, multilining? */
104 char *precomp; /* uncompiled string. */
106 char *start; /* Start of input for compile */
107 char *end; /* End of input for compile */
108 char *parse; /* Input-scan pointer. */
109 I32 whilem_seen; /* number of WHILEM in this expr */
110 regnode *emit_start; /* Start of emitted-code area */
111 regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */
112 I32 naughty; /* How bad is this pattern? */
113 I32 sawback; /* Did we see \1, ...? */
115 I32 size; /* Code size. */
116 I32 npar; /* () count. */
122 char *starttry; /* -Dr: where regtry was called. */
123 #define RExC_starttry (pRExC_state->starttry)
126 const char *lastparse;
128 #define RExC_lastparse (pRExC_state->lastparse)
129 #define RExC_lastnum (pRExC_state->lastnum)
133 #define RExC_flags (pRExC_state->flags)
134 #define RExC_precomp (pRExC_state->precomp)
135 #define RExC_rx (pRExC_state->rx)
136 #define RExC_start (pRExC_state->start)
137 #define RExC_end (pRExC_state->end)
138 #define RExC_parse (pRExC_state->parse)
139 #define RExC_whilem_seen (pRExC_state->whilem_seen)
140 #define RExC_offsets (pRExC_state->rx->offsets) /* I am not like the others */
141 #define RExC_emit (pRExC_state->emit)
142 #define RExC_emit_start (pRExC_state->emit_start)
143 #define RExC_naughty (pRExC_state->naughty)
144 #define RExC_sawback (pRExC_state->sawback)
145 #define RExC_seen (pRExC_state->seen)
146 #define RExC_size (pRExC_state->size)
147 #define RExC_npar (pRExC_state->npar)
148 #define RExC_extralen (pRExC_state->extralen)
149 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
150 #define RExC_seen_evals (pRExC_state->seen_evals)
151 #define RExC_utf8 (pRExC_state->utf8)
153 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
154 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
155 ((*s) == '{' && regcurly(s)))
158 #undef SPSTART /* dratted cpp namespace... */
161 * Flags to be passed up and down.
163 #define WORST 0 /* Worst case. */
164 #define HASWIDTH 0x1 /* Known to match non-null strings. */
165 #define SIMPLE 0x2 /* Simple enough to be STAR/PLUS operand. */
166 #define SPSTART 0x4 /* Starts with * or +. */
167 #define TRYAGAIN 0x8 /* Weeded out a declaration. */
169 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
171 /* whether trie related optimizations are enabled */
172 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
173 #define TRIE_STUDY_OPT
176 /* Length of a variant. */
178 typedef struct scan_data_t {
184 I32 last_end; /* min value, <0 unless valid. */
187 SV **longest; /* Either &l_fixed, or &l_float. */
191 I32 offset_float_min;
192 I32 offset_float_max;
196 struct regnode_charclass_class *start_class;
200 * Forward declarations for pregcomp()'s friends.
203 static const scan_data_t zero_scan_data =
204 { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0};
206 #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
207 #define SF_BEFORE_SEOL 0x0001
208 #define SF_BEFORE_MEOL 0x0002
209 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
210 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
213 # define SF_FIX_SHIFT_EOL (0+2)
214 # define SF_FL_SHIFT_EOL (0+4)
216 # define SF_FIX_SHIFT_EOL (+2)
217 # define SF_FL_SHIFT_EOL (+4)
220 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
221 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
223 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
224 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
225 #define SF_IS_INF 0x0040
226 #define SF_HAS_PAR 0x0080
227 #define SF_IN_PAR 0x0100
228 #define SF_HAS_EVAL 0x0200
229 #define SCF_DO_SUBSTR 0x0400
230 #define SCF_DO_STCLASS_AND 0x0800
231 #define SCF_DO_STCLASS_OR 0x1000
232 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
233 #define SCF_WHILEM_VISITED_POS 0x2000
235 #define SCF_EXACT_TRIE 0x4000 /* should re study once we are done? */
237 #define UTF (RExC_utf8 != 0)
238 #define LOC ((RExC_flags & PMf_LOCALE) != 0)
239 #define FOLD ((RExC_flags & PMf_FOLD) != 0)
241 #define OOB_UNICODE 12345678
242 #define OOB_NAMEDCLASS -1
244 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
245 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
248 /* length of regex to show in messages that don't mark a position within */
249 #define RegexLengthToShowInErrorMessages 127
252 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
253 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
254 * op/pragma/warn/regcomp.
256 #define MARKER1 "<-- HERE" /* marker as it appears in the description */
257 #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
259 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
262 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
263 * arg. Show regex, up to a maximum length. If it's too long, chop and add
266 #define FAIL(msg) STMT_START { \
267 const char *ellipses = ""; \
268 IV len = RExC_end - RExC_precomp; \
271 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
272 if (len > RegexLengthToShowInErrorMessages) { \
273 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
274 len = RegexLengthToShowInErrorMessages - 10; \
277 Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
278 msg, (int)len, RExC_precomp, ellipses); \
282 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
284 #define Simple_vFAIL(m) STMT_START { \
285 const IV offset = RExC_parse - RExC_precomp; \
286 Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
287 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
291 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
293 #define vFAIL(m) STMT_START { \
295 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
300 * Like Simple_vFAIL(), but accepts two arguments.
302 #define Simple_vFAIL2(m,a1) STMT_START { \
303 const IV offset = RExC_parse - RExC_precomp; \
304 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \
305 (int)offset, RExC_precomp, RExC_precomp + offset); \
309 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
311 #define vFAIL2(m,a1) STMT_START { \
313 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
314 Simple_vFAIL2(m, a1); \
319 * Like Simple_vFAIL(), but accepts three arguments.
321 #define Simple_vFAIL3(m, a1, a2) STMT_START { \
322 const IV offset = RExC_parse - RExC_precomp; \
323 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \
324 (int)offset, RExC_precomp, RExC_precomp + offset); \
328 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
330 #define vFAIL3(m,a1,a2) STMT_START { \
332 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
333 Simple_vFAIL3(m, a1, a2); \
337 * Like Simple_vFAIL(), but accepts four arguments.
339 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \
340 const IV offset = RExC_parse - RExC_precomp; \
341 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, \
342 (int)offset, RExC_precomp, RExC_precomp + offset); \
345 #define vWARN(loc,m) STMT_START { \
346 const IV offset = loc - RExC_precomp; \
347 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \
348 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
351 #define vWARNdep(loc,m) STMT_START { \
352 const IV offset = loc - RExC_precomp; \
353 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
354 "%s" REPORT_LOCATION, \
355 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
359 #define vWARN2(loc, m, a1) STMT_START { \
360 const IV offset = loc - RExC_precomp; \
361 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
362 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
365 #define vWARN3(loc, m, a1, a2) STMT_START { \
366 const IV offset = loc - RExC_precomp; \
367 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
368 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
371 #define vWARN4(loc, m, a1, a2, a3) STMT_START { \
372 const IV offset = loc - RExC_precomp; \
373 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
374 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
377 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \
378 const IV offset = loc - RExC_precomp; \
379 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
380 a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
384 /* Allow for side effects in s */
385 #define REGC(c,s) STMT_START { \
386 if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
389 /* Macros for recording node offsets. 20001227 mjd@plover.com
390 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
391 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
392 * Element 0 holds the number n.
393 * Position is 1 indexed.
396 #define Set_Node_Offset_To_R(node,byte) STMT_START { \
398 MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \
399 __LINE__, (node), (int)(byte))); \
401 Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
403 RExC_offsets[2*(node)-1] = (byte); \
408 #define Set_Node_Offset(node,byte) \
409 Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
410 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
412 #define Set_Node_Length_To_R(node,len) STMT_START { \
414 MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \
415 __LINE__, (int)(node), (int)(len))); \
417 Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
419 RExC_offsets[2*(node)] = (len); \
424 #define Set_Node_Length(node,len) \
425 Set_Node_Length_To_R((node)-RExC_emit_start, len)
426 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
427 #define Set_Node_Cur_Length(node) \
428 Set_Node_Length(node, RExC_parse - parse_start)
430 /* Get offsets and lengths */
431 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
432 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
434 #define Set_Node_Offset_Length(node,offset,len) STMT_START { \
435 Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \
436 Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \
440 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
441 #define EXPERIMENTAL_INPLACESCAN
444 static void clear_re(pTHX_ void *r);
446 /* Mark that we cannot extend a found fixed substring at this point.
447 Updata the longest found anchored substring and the longest found
448 floating substrings if needed. */
451 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data)
453 const STRLEN l = CHR_SVLEN(data->last_found);
454 const STRLEN old_l = CHR_SVLEN(*data->longest);
456 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
457 SvSetMagicSV(*data->longest, data->last_found);
458 if (*data->longest == data->longest_fixed) {
459 data->offset_fixed = l ? data->last_start_min : data->pos_min;
460 if (data->flags & SF_BEFORE_EOL)
462 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
464 data->flags &= ~SF_FIX_BEFORE_EOL;
467 data->offset_float_min = l ? data->last_start_min : data->pos_min;
468 data->offset_float_max = (l
469 ? data->last_start_max
470 : data->pos_min + data->pos_delta);
471 if ((U32)data->offset_float_max > (U32)I32_MAX)
472 data->offset_float_max = I32_MAX;
473 if (data->flags & SF_BEFORE_EOL)
475 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
477 data->flags &= ~SF_FL_BEFORE_EOL;
480 SvCUR_set(data->last_found, 0);
482 SV * const sv = data->last_found;
483 if (SvUTF8(sv) && SvMAGICAL(sv)) {
484 MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
490 data->flags &= ~SF_BEFORE_EOL;
493 /* Can match anything (initialization) */
495 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
497 ANYOF_CLASS_ZERO(cl);
498 ANYOF_BITMAP_SETALL(cl);
499 cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
501 cl->flags |= ANYOF_LOCALE;
504 /* Can match anything (initialization) */
506 S_cl_is_anything(const struct regnode_charclass_class *cl)
510 for (value = 0; value <= ANYOF_MAX; value += 2)
511 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
513 if (!(cl->flags & ANYOF_UNICODE_ALL))
515 if (!ANYOF_BITMAP_TESTALLSET(cl))
520 /* Can match anything (initialization) */
522 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
524 Zero(cl, 1, struct regnode_charclass_class);
526 cl_anything(pRExC_state, cl);
530 S_cl_init_zero(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
532 Zero(cl, 1, struct regnode_charclass_class);
534 cl_anything(pRExC_state, cl);
536 cl->flags |= ANYOF_LOCALE;
539 /* 'And' a given class with another one. Can create false positives */
540 /* We assume that cl is not inverted */
542 S_cl_and(struct regnode_charclass_class *cl,
543 const struct regnode_charclass_class *and_with)
545 if (!(and_with->flags & ANYOF_CLASS)
546 && !(cl->flags & ANYOF_CLASS)
547 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
548 && !(and_with->flags & ANYOF_FOLD)
549 && !(cl->flags & ANYOF_FOLD)) {
552 if (and_with->flags & ANYOF_INVERT)
553 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
554 cl->bitmap[i] &= ~and_with->bitmap[i];
556 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
557 cl->bitmap[i] &= and_with->bitmap[i];
558 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
559 if (!(and_with->flags & ANYOF_EOS))
560 cl->flags &= ~ANYOF_EOS;
562 if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE &&
563 !(and_with->flags & ANYOF_INVERT)) {
564 cl->flags &= ~ANYOF_UNICODE_ALL;
565 cl->flags |= ANYOF_UNICODE;
566 ARG_SET(cl, ARG(and_with));
568 if (!(and_with->flags & ANYOF_UNICODE_ALL) &&
569 !(and_with->flags & ANYOF_INVERT))
570 cl->flags &= ~ANYOF_UNICODE_ALL;
571 if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)) &&
572 !(and_with->flags & ANYOF_INVERT))
573 cl->flags &= ~ANYOF_UNICODE;
576 /* 'OR' a given class with another one. Can create false positives */
577 /* We assume that cl is not inverted */
579 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
581 if (or_with->flags & ANYOF_INVERT) {
583 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
584 * <= (B1 | !B2) | (CL1 | !CL2)
585 * which is wasteful if CL2 is small, but we ignore CL2:
586 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
587 * XXXX Can we handle case-fold? Unclear:
588 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
589 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
591 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
592 && !(or_with->flags & ANYOF_FOLD)
593 && !(cl->flags & ANYOF_FOLD) ) {
596 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
597 cl->bitmap[i] |= ~or_with->bitmap[i];
598 } /* XXXX: logic is complicated otherwise */
600 cl_anything(pRExC_state, cl);
603 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
604 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
605 && (!(or_with->flags & ANYOF_FOLD)
606 || (cl->flags & ANYOF_FOLD)) ) {
609 /* OR char bitmap and class bitmap separately */
610 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
611 cl->bitmap[i] |= or_with->bitmap[i];
612 if (or_with->flags & ANYOF_CLASS) {
613 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
614 cl->classflags[i] |= or_with->classflags[i];
615 cl->flags |= ANYOF_CLASS;
618 else { /* XXXX: logic is complicated, leave it along for a moment. */
619 cl_anything(pRExC_state, cl);
622 if (or_with->flags & ANYOF_EOS)
623 cl->flags |= ANYOF_EOS;
625 if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
626 ARG(cl) != ARG(or_with)) {
627 cl->flags |= ANYOF_UNICODE_ALL;
628 cl->flags &= ~ANYOF_UNICODE;
630 if (or_with->flags & ANYOF_UNICODE_ALL) {
631 cl->flags |= ANYOF_UNICODE_ALL;
632 cl->flags &= ~ANYOF_UNICODE;
638 make_trie(startbranch,first,last,tail,flags,depth)
639 startbranch: the first branch in the whole branch sequence
640 first : start branch of sequence of branch-exact nodes.
641 May be the same as startbranch
642 last : Thing following the last branch.
643 May be the same as tail.
644 tail : item following the branch sequence
645 flags : currently the OP() type we will be building one of /EXACT(|F|Fl)/
648 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
650 A trie is an N'ary tree where the branches are determined by digital
651 decomposition of the key. IE, at the root node you look up the 1st character and
652 follow that branch repeat until you find the end of the branches. Nodes can be
653 marked as "accepting" meaning they represent a complete word. Eg:
657 would convert into the following structure. Numbers represent states, letters
658 following numbers represent valid transitions on the letter from that state, if
659 the number is in square brackets it represents an accepting state, otherwise it
660 will be in parenthesis.
662 +-h->+-e->[3]-+-r->(8)-+-s->[9]
666 (1) +-i->(6)-+-s->[7]
668 +-s->(3)-+-h->(4)-+-e->[5]
670 Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
672 This shows that when matching against the string 'hers' we will begin at state 1
673 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
674 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
675 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
676 single traverse. We store a mapping from accepting to state to which word was
677 matched, and then when we have multiple possibilities we try to complete the
678 rest of the regex in the order in which they occured in the alternation.
680 The only prior NFA like behaviour that would be changed by the TRIE support is
681 the silent ignoring of duplicate alternations which are of the form:
683 / (DUPE|DUPE) X? (?{ ... }) Y /x
685 Thus EVAL blocks follwing a trie may be called a different number of times with
686 and without the optimisation. With the optimisations dupes will be silently
687 ignored. This inconsistant behaviour of EVAL type nodes is well established as
688 the following demonstrates:
690 'words'=~/(word|word|word)(?{ print $1 })[xyz]/
692 which prints out 'word' three times, but
694 'words'=~/(word|word|word)(?{ print $1 })S/
696 which doesnt print it out at all. This is due to other optimisations kicking in.
698 Example of what happens on a structural level:
700 The regexp /(ac|ad|ab)+/ will produce the folowing debug output:
702 1: CURLYM[1] {1,32767}(18)
713 This would be optimizable with startbranch=5, first=5, last=16, tail=16
714 and should turn into:
716 1: CURLYM[1] {1,32767}(18)
718 [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
726 Cases where tail != last would be like /(?foo|bar)baz/:
736 which would be optimizable with startbranch=1, first=1, last=7, tail=8
737 and would end up looking like:
740 [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
747 d = uvuni_to_utf8_flags(d, uv, 0);
749 is the recommended Unicode-aware way of saying
754 #define TRIE_STORE_REVCHAR \
756 SV *tmp = Perl_newSVpvf_nocontext( "%c", (int)uvc ); \
757 av_push( TRIE_REVCHARMAP(trie), tmp ); \
760 #define TRIE_READ_CHAR STMT_START { \
764 if ( foldlen > 0 ) { \
765 uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags ); \
770 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
771 uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
772 foldlen -= UNISKIP( uvc ); \
773 scan = foldbuf + UNISKIP( uvc ); \
776 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
785 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
786 #define TRIE_LIST_CUR(state) ( TRIE_LIST_ITEM( state, 0 ).forid )
787 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
788 #define TRIE_LIST_USED(idx) ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
790 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \
791 if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \
792 TRIE_LIST_LEN( state ) *= 2; \
793 Renew( trie->states[ state ].trans.list, \
794 TRIE_LIST_LEN( state ), reg_trie_trans_le ); \
796 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \
797 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns; \
798 TRIE_LIST_CUR( state )++; \
801 #define TRIE_LIST_NEW(state) STMT_START { \
802 Newxz( trie->states[ state ].trans.list, \
803 4, reg_trie_trans_le ); \
804 TRIE_LIST_CUR( state ) = 1; \
805 TRIE_LIST_LEN( state ) = 4; \
808 #define TRIE_HANDLE_WORD(state) STMT_START { \
809 if ( !trie->states[ state ].wordnum ) { \
810 /* we haven't inserted this word into the structure yet. */ \
812 trie->wordlen[ curword ] = wordlen; \
813 trie->states[ state ].wordnum = ++curword; \
815 /* store the word for dumping */ \
817 if (OP(noper) != NOTHING) \
818 tmp = newSVpvn(STRING(noper), STR_LEN(noper)); \
820 tmp = newSVpvn( "", 0 ); \
821 if ( UTF ) SvUTF8_on( tmp ); \
822 av_push( trie->words, tmp ); \
825 NOOP; /* It's a dupe. So ignore it. */ \
832 dump_trie_interim_list(trie,next_alloc)
833 dump_trie_interim_table(trie,next_alloc)
835 These routines dump out a trie in a somewhat readable format.
836 The _interim_ variants are used for debugging the interim
837 tables that are used to generate the final compressed
838 representation which is what dump_trie expects.
840 Part of the reason for their existance is to provide a form
841 of documentation as to how the different representations function.
847 Dumps the final compressed table form of the trie to Perl_debug_log.
848 Used for debugging make_trie().
852 S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth)
855 GET_RE_DEBUG_FLAGS_DECL;
857 PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
858 (int)depth * 2 + 2,"",
859 "Match","Base","Ofs" );
861 for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
862 SV ** const tmp = av_fetch( trie->revcharmap, state, 0);
864 PerlIO_printf( Perl_debug_log, "%4.4s ", SvPV_nolen_const( *tmp ) );
867 PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
868 (int)depth * 2 + 2,"");
870 for( state = 0 ; state < trie->uniquecharcount ; state++ )
871 PerlIO_printf( Perl_debug_log, "-----");
872 PerlIO_printf( Perl_debug_log, "\n");
874 for( state = 1 ; state < TRIE_LASTSTATE(trie) ; state++ ) {
875 const U32 base = trie->states[ state ].trans.base;
877 PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
879 if ( trie->states[ state ].wordnum ) {
880 PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
882 PerlIO_printf( Perl_debug_log, "%6s", "" );
885 PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
890 while( ( base + ofs < trie->uniquecharcount ) ||
891 ( base + ofs - trie->uniquecharcount < trie->lasttrans
892 && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
895 PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
897 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
898 if ( ( base + ofs >= trie->uniquecharcount ) &&
899 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
900 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
902 PerlIO_printf( Perl_debug_log, "%4"UVXf" ",
903 (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
905 PerlIO_printf( Perl_debug_log, "%4s "," ." );
909 PerlIO_printf( Perl_debug_log, "]");
912 PerlIO_printf( Perl_debug_log, "\n" );
916 dump_trie_interim_list(trie,next_alloc)
917 Dumps a fully constructed but uncompressed trie in list form.
918 List tries normally only are used for construction when the number of
919 possible chars (trie->uniquecharcount) is very high.
920 Used for debugging make_trie().
923 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc,U32 depth)
926 GET_RE_DEBUG_FLAGS_DECL;
927 /* print out the table precompression. */
928 PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s",
929 (int)depth * 2 + 2,"", (int)depth * 2 + 2,"");
930 PerlIO_printf( Perl_debug_log, "------:-----+-----------------" );
932 for( state=1 ; state < next_alloc ; state ++ ) {
935 PerlIO_printf( Perl_debug_log, "\n%*s %4"UVXf" :",
936 (int)depth * 2 + 2,"", (UV)state );
937 if ( ! trie->states[ state ].wordnum ) {
938 PerlIO_printf( Perl_debug_log, "%5s| ","");
940 PerlIO_printf( Perl_debug_log, "W%4x| ",
941 trie->states[ state ].wordnum
944 for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
945 SV ** const tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
946 PerlIO_printf( Perl_debug_log, "%s:%3X=%4"UVXf" | ",
947 SvPV_nolen_const( *tmp ),
948 TRIE_LIST_ITEM(state,charid).forid,
949 (UV)TRIE_LIST_ITEM(state,charid).newstate
957 dump_trie_interim_table(trie,next_alloc)
958 Dumps a fully constructed but uncompressed trie in table form.
959 This is the normal DFA style state transition table, with a few
960 twists to facilitate compression later.
961 Used for debugging make_trie().
964 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc, U32 depth)
968 GET_RE_DEBUG_FLAGS_DECL;
971 print out the table precompression so that we can do a visual check
972 that they are identical.
975 PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
977 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
978 SV ** const tmp = av_fetch( trie->revcharmap, charid, 0);
980 PerlIO_printf( Perl_debug_log, "%4.4s ", SvPV_nolen_const( *tmp ) );
984 PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
986 for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
987 PerlIO_printf( Perl_debug_log, "%4s-", "----" );
990 PerlIO_printf( Perl_debug_log, "\n" );
992 for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
994 PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
995 (int)depth * 2 + 2,"",
996 (UV)TRIE_NODENUM( state ) );
998 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
999 PerlIO_printf( Perl_debug_log, "%4"UVXf" ",
1000 (UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next ) );
1002 if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1003 PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1005 PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1006 trie->states[ TRIE_NODENUM( state ) ].wordnum );
1013 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special) \
1014 ( ( base + charid >= ucharcount \
1015 && base + charid < ubound \
1016 && state == trie->trans[ base - ucharcount + charid ].check \
1017 && trie->trans[ base - ucharcount + charid ].next ) \
1018 ? trie->trans[ base - ucharcount + charid ].next \
1019 : ( state==1 ? special : 0 ) \
1023 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
1025 /* The Trie is constructed and compressed now so we can build a fail array now if its needed
1027 This is apparently the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
1028 "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
1031 We find the fail state for each state in the trie, this state is the longest proper
1032 suffix of the current states 'word' that is also a proper prefix of another word in our
1033 trie. State 1 represents the word '' and is the thus the default fail state. This allows
1034 the DFA not to have to restart after its tried and failed a word at a given point, it
1035 simply continues as though it had been matching the other word in the first place.
1037 'abcdgu'=~/abcdefg|cdgu/
1038 When we get to 'd' we are still matching the first word, we would encounter 'g' which would
1039 fail, which would bring use to the state representing 'd' in the second word where we would
1040 try 'g' and succeed, prodceding to match 'cdgu'.
1042 /* add a fail transition */
1043 reg_trie_data *trie=(reg_trie_data *)RExC_rx->data->data[ARG(source)];
1045 const U32 ucharcount = trie->uniquecharcount;
1046 const U32 numstates = trie->laststate;
1047 const U32 ubound = trie->lasttrans + ucharcount;
1051 U32 base = trie->states[ 1 ].trans.base;
1054 const U32 data_slot = add_data( pRExC_state, 1, "T" );
1055 GET_RE_DEBUG_FLAGS_DECL;
1057 ARG_SET( stclass, data_slot );
1058 Newxz( aho, 1, reg_ac_data );
1059 RExC_rx->data->data[ data_slot ] = (void*)aho;
1061 aho->states=(reg_trie_state *)savepvn((const char*)trie->states,
1062 (trie->laststate+1)*sizeof(reg_trie_state));
1063 Newxz( q, numstates, U32);
1064 Newxz( aho->fail, numstates, U32 );
1067 fail[ 0 ] = fail[ 1 ] = 1;
1069 for ( charid = 0; charid < ucharcount ; charid++ ) {
1070 const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
1072 q[ q_write ] = newstate;
1073 /* set to point at the root */
1074 fail[ q[ q_write++ ] ]=1;
1077 while ( q_read < q_write) {
1078 const U32 cur = q[ q_read++ % numstates ];
1079 base = trie->states[ cur ].trans.base;
1081 for ( charid = 0 ; charid < ucharcount ; charid++ ) {
1082 const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
1084 U32 fail_state = cur;
1087 fail_state = fail[ fail_state ];
1088 fail_base = aho->states[ fail_state ].trans.base;
1089 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
1091 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
1092 fail[ ch_state ] = fail_state;
1093 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
1095 aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
1097 q[ q_write++ % numstates] = ch_state;
1102 DEBUG_TRIE_COMPILE_MORE_r({
1103 PerlIO_printf(Perl_debug_log, "%*sFail: 1", (int)(depth * 2), "");
1104 for( q_read=2; q_read<numstates; q_read++ ) {
1105 PerlIO_printf(Perl_debug_log, ", %"UVuf, fail[q_read]);
1107 PerlIO_printf(Perl_debug_log, "\n");
1110 /*RExC_seen |= REG_SEEN_TRIEDFA;*/
1116 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 flags, U32 depth)
1119 /* first pass, loop through and scan words */
1120 reg_trie_data *trie;
1122 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1127 /* we just use folder as a flag in utf8 */
1128 const U8 * const folder = ( flags == EXACTF
1130 : ( flags == EXACTFL
1136 const U32 data_slot = add_data( pRExC_state, 1, "t" );
1137 SV *re_trie_maxbuff;
1139 /* these are only used during construction but are useful during
1140 * debugging so we store them in the struct when debugging.
1141 * Wordcount is actually superfluous in debugging as we have
1142 * (AV*)trie->words to use for it, but that's not available when
1143 * not debugging... We could make the macro use the AV during
1144 * debugging though...
1146 U16 trie_wordcount=0;
1147 STRLEN trie_charcount=0;
1148 /*U32 trie_laststate=0;*/
1149 AV *trie_revcharmap;
1151 GET_RE_DEBUG_FLAGS_DECL;
1153 Newxz( trie, 1, reg_trie_data );
1155 trie->startstate = 1;
1156 RExC_rx->data->data[ data_slot ] = (void*)trie;
1157 Newxz( trie->charmap, 256, U16 );
1158 if (!(UTF && folder))
1159 Newxz( trie->bitmap, ANYOF_BITMAP_SIZE, char );
1161 trie->words = newAV();
1163 TRIE_REVCHARMAP(trie) = newAV();
1165 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1166 if (!SvIOK(re_trie_maxbuff)) {
1167 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1170 PerlIO_printf( Perl_debug_log,
1171 "%*smake_trie start==%d, first==%d, last==%d, tail==%d\n",
1172 (int)depth * 2 + 2, "",
1173 REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
1174 REG_NODE_NUM(last), REG_NODE_NUM(tail));
1176 /* -- First loop and Setup --
1178 We first traverse the branches and scan each word to determine if it
1179 contains widechars, and how many unique chars there are, this is
1180 important as we have to build a table with at least as many columns as we
1183 We use an array of integers to represent the character codes 0..255
1184 (trie->charmap) and we use a an HV* to store unicode characters. We use the
1185 native representation of the character value as the key and IV's for the
1188 *TODO* If we keep track of how many times each character is used we can
1189 remap the columns so that the table compression later on is more
1190 efficient in terms of memory by ensuring most common value is in the
1191 middle and the least common are on the outside. IMO this would be better
1192 than a most to least common mapping as theres a decent chance the most
1193 common letter will share a node with the least common, meaning the node
1194 will not be compressable. With a middle is most common approach the worst
1195 case is when we have the least common nodes twice.
1199 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1200 regnode * const noper = NEXTOPER( cur );
1201 const U8 *uc = (U8*)STRING( noper );
1202 const U8 * const e = uc + STR_LEN( noper );
1204 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1205 const U8 *scan = (U8*)NULL;
1206 U32 wordlen = 0; /* required init */
1209 TRIE_WORDCOUNT(trie)++;
1210 if (OP(noper) == NOTHING) {
1215 TRIE_BITMAP_SET(trie,*uc);
1216 if ( folder ) TRIE_BITMAP_SET(trie,folder[ *uc ]);
1218 for ( ; uc < e ; uc += len ) {
1219 TRIE_CHARCOUNT(trie)++;
1223 if ( !trie->charmap[ uvc ] ) {
1224 trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1226 trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1231 if ( !trie->widecharmap )
1232 trie->widecharmap = newHV();
1234 svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1237 Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1239 if ( !SvTRUE( *svpp ) ) {
1240 sv_setiv( *svpp, ++trie->uniquecharcount );
1245 if( cur == first ) {
1248 } else if (chars < trie->minlen) {
1250 } else if (chars > trie->maxlen) {
1254 } /* end first pass */
1255 DEBUG_TRIE_COMPILE_r(
1256 PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1257 (int)depth * 2 + 2,"",
1258 ( trie->widecharmap ? "UTF8" : "NATIVE" ), TRIE_WORDCOUNT(trie),
1259 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1260 (int)trie->minlen, (int)trie->maxlen )
1262 Newxz( trie->wordlen, TRIE_WORDCOUNT(trie), U32 );
1265 We now know what we are dealing with in terms of unique chars and
1266 string sizes so we can calculate how much memory a naive
1267 representation using a flat table will take. If it's over a reasonable
1268 limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1269 conservative but potentially much slower representation using an array
1272 At the end we convert both representations into the same compressed
1273 form that will be used in regexec.c for matching with. The latter
1274 is a form that cannot be used to construct with but has memory
1275 properties similar to the list form and access properties similar
1276 to the table form making it both suitable for fast searches and
1277 small enough that its feasable to store for the duration of a program.
1279 See the comment in the code where the compressed table is produced
1280 inplace from the flat tabe representation for an explanation of how
1281 the compression works.
1286 if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1288 Second Pass -- Array Of Lists Representation
1290 Each state will be represented by a list of charid:state records
1291 (reg_trie_trans_le) the first such element holds the CUR and LEN
1292 points of the allocated array. (See defines above).
1294 We build the initial structure using the lists, and then convert
1295 it into the compressed table form which allows faster lookups
1296 (but cant be modified once converted).
1299 STRLEN transcount = 1;
1301 Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state );
1305 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1307 regnode * const noper = NEXTOPER( cur );
1308 U8 *uc = (U8*)STRING( noper );
1309 const U8 * const e = uc + STR_LEN( noper );
1310 U32 state = 1; /* required init */
1311 U16 charid = 0; /* sanity init */
1312 U8 *scan = (U8*)NULL; /* sanity init */
1313 STRLEN foldlen = 0; /* required init */
1314 U32 wordlen = 0; /* required init */
1315 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1317 if (OP(noper) != NOTHING) {
1318 for ( ; uc < e ; uc += len ) {
1323 charid = trie->charmap[ uvc ];
1325 SV** const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0);
1329 charid=(U16)SvIV( *svpp );
1338 if ( !trie->states[ state ].trans.list ) {
1339 TRIE_LIST_NEW( state );
1341 for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1342 if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1343 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1348 newstate = next_alloc++;
1349 TRIE_LIST_PUSH( state, charid, newstate );
1354 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1356 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1359 TRIE_HANDLE_WORD(state);
1361 } /* end second pass */
1363 TRIE_LASTSTATE(trie) = next_alloc;
1364 Renew( trie->states, next_alloc, reg_trie_state );
1366 /* and now dump it out before we compress it */
1367 DEBUG_TRIE_COMPILE_MORE_r(
1368 dump_trie_interim_list(trie,next_alloc,depth+1)
1371 Newxz( trie->trans, transcount ,reg_trie_trans );
1378 for( state=1 ; state < next_alloc ; state ++ ) {
1382 DEBUG_TRIE_COMPILE_MORE_r(
1383 PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1387 if (trie->states[state].trans.list) {
1388 U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1392 for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1393 const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1394 if ( forid < minid ) {
1396 } else if ( forid > maxid ) {
1400 if ( transcount < tp + maxid - minid + 1) {
1402 Renew( trie->trans, transcount, reg_trie_trans );
1403 Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1405 base = trie->uniquecharcount + tp - minid;
1406 if ( maxid == minid ) {
1408 for ( ; zp < tp ; zp++ ) {
1409 if ( ! trie->trans[ zp ].next ) {
1410 base = trie->uniquecharcount + zp - minid;
1411 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1412 trie->trans[ zp ].check = state;
1418 trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1419 trie->trans[ tp ].check = state;
1424 for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1425 const U32 tid = base - trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1426 trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1427 trie->trans[ tid ].check = state;
1429 tp += ( maxid - minid + 1 );
1431 Safefree(trie->states[ state ].trans.list);
1434 DEBUG_TRIE_COMPILE_MORE_r(
1435 PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1438 trie->states[ state ].trans.base=base;
1440 trie->lasttrans = tp + 1;
1444 Second Pass -- Flat Table Representation.
1446 we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1447 We know that we will need Charcount+1 trans at most to store the data
1448 (one row per char at worst case) So we preallocate both structures
1449 assuming worst case.
1451 We then construct the trie using only the .next slots of the entry
1454 We use the .check field of the first entry of the node temporarily to
1455 make compression both faster and easier by keeping track of how many non
1456 zero fields are in the node.
1458 Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1461 There are two terms at use here: state as a TRIE_NODEIDX() which is a
1462 number representing the first entry of the node, and state as a
1463 TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1464 TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1465 are 2 entrys per node. eg:
1473 The table is internally in the right hand, idx form. However as we also
1474 have to deal with the states array which is indexed by nodenum we have to
1475 use TRIE_NODENUM() to convert.
1480 Newxz( trie->trans, ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1,
1482 Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state );
1483 next_alloc = trie->uniquecharcount + 1;
1486 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1488 regnode * const noper = NEXTOPER( cur );
1489 const U8 *uc = (U8*)STRING( noper );
1490 const U8 * const e = uc + STR_LEN( noper );
1492 U32 state = 1; /* required init */
1494 U16 charid = 0; /* sanity init */
1495 U32 accept_state = 0; /* sanity init */
1496 U8 *scan = (U8*)NULL; /* sanity init */
1498 STRLEN foldlen = 0; /* required init */
1499 U32 wordlen = 0; /* required init */
1500 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1502 if ( OP(noper) != NOTHING ) {
1503 for ( ; uc < e ; uc += len ) {
1508 charid = trie->charmap[ uvc ];
1510 SV* const * const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0);
1511 charid = svpp ? (U16)SvIV(*svpp) : 0;
1515 if ( !trie->trans[ state + charid ].next ) {
1516 trie->trans[ state + charid ].next = next_alloc;
1517 trie->trans[ state ].check++;
1518 next_alloc += trie->uniquecharcount;
1520 state = trie->trans[ state + charid ].next;
1522 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1524 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1527 accept_state = TRIE_NODENUM( state );
1528 TRIE_HANDLE_WORD(accept_state);
1530 } /* end second pass */
1532 /* and now dump it out before we compress it */
1533 DEBUG_TRIE_COMPILE_MORE_r(
1534 dump_trie_interim_table(trie,next_alloc,depth+1)
1539 * Inplace compress the table.*
1541 For sparse data sets the table constructed by the trie algorithm will
1542 be mostly 0/FAIL transitions or to put it another way mostly empty.
1543 (Note that leaf nodes will not contain any transitions.)
1545 This algorithm compresses the tables by eliminating most such
1546 transitions, at the cost of a modest bit of extra work during lookup:
1548 - Each states[] entry contains a .base field which indicates the
1549 index in the state[] array wheres its transition data is stored.
1551 - If .base is 0 there are no valid transitions from that node.
1553 - If .base is nonzero then charid is added to it to find an entry in
1556 -If trans[states[state].base+charid].check!=state then the
1557 transition is taken to be a 0/Fail transition. Thus if there are fail
1558 transitions at the front of the node then the .base offset will point
1559 somewhere inside the previous nodes data (or maybe even into a node
1560 even earlier), but the .check field determines if the transition is
1563 The following process inplace converts the table to the compressed
1564 table: We first do not compress the root node 1,and mark its all its
1565 .check pointers as 1 and set its .base pointer as 1 as well. This
1566 allows to do a DFA construction from the compressed table later, and
1567 ensures that any .base pointers we calculate later are greater than
1570 - We set 'pos' to indicate the first entry of the second node.
1572 - We then iterate over the columns of the node, finding the first and
1573 last used entry at l and m. We then copy l..m into pos..(pos+m-l),
1574 and set the .check pointers accordingly, and advance pos
1575 appropriately and repreat for the next node. Note that when we copy
1576 the next pointers we have to convert them from the original
1577 NODEIDX form to NODENUM form as the former is not valid post
1580 - If a node has no transitions used we mark its base as 0 and do not
1581 advance the pos pointer.
1583 - If a node only has one transition we use a second pointer into the
1584 structure to fill in allocated fail transitions from other states.
1585 This pointer is independent of the main pointer and scans forward
1586 looking for null transitions that are allocated to a state. When it
1587 finds one it writes the single transition into the "hole". If the
1588 pointer doesnt find one the single transition is appeneded as normal.
1590 - Once compressed we can Renew/realloc the structures to release the
1593 See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
1594 specifically Fig 3.47 and the associated pseudocode.
1598 const U32 laststate = TRIE_NODENUM( next_alloc );
1601 TRIE_LASTSTATE(trie) = laststate;
1603 for ( state = 1 ; state < laststate ; state++ ) {
1605 const U32 stateidx = TRIE_NODEIDX( state );
1606 const U32 o_used = trie->trans[ stateidx ].check;
1607 U32 used = trie->trans[ stateidx ].check;
1608 trie->trans[ stateidx ].check = 0;
1610 for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
1611 if ( flag || trie->trans[ stateidx + charid ].next ) {
1612 if ( trie->trans[ stateidx + charid ].next ) {
1614 for ( ; zp < pos ; zp++ ) {
1615 if ( ! trie->trans[ zp ].next ) {
1619 trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
1620 trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1621 trie->trans[ zp ].check = state;
1622 if ( ++zp > pos ) pos = zp;
1629 trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
1631 trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1632 trie->trans[ pos ].check = state;
1637 trie->lasttrans = pos + 1;
1638 Renew( trie->states, laststate + 1, reg_trie_state);
1639 DEBUG_TRIE_COMPILE_MORE_r(
1640 PerlIO_printf( Perl_debug_log,
1641 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
1642 (int)depth * 2 + 2,"",
1643 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
1646 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
1649 } /* end table compress */
1651 /* resize the trans array to remove unused space */
1652 Renew( trie->trans, trie->lasttrans, reg_trie_trans);
1654 /* and now dump out the compressed format */
1655 DEBUG_TRIE_COMPILE_r(
1656 dump_trie(trie,depth+1)
1659 { /* Modify the program and insert the new TRIE node*/
1661 U8 nodetype =(U8)(flags & 0xFF);
1668 This means we convert either the first branch or the first Exact,
1669 depending on whether the thing following (in 'last') is a branch
1670 or not and whther first is the startbranch (ie is it a sub part of
1671 the alternation or is it the whole thing.)
1672 Assuming its a sub part we conver the EXACT otherwise we convert
1673 the whole branch sequence, including the first.
1675 /* Find the node we are going to overwrite */
1676 if ( first == startbranch && OP( last ) != BRANCH ) {
1677 /* whole branch chain */
1680 const regnode *nop = NEXTOPER( convert );
1681 mjd_offset= Node_Offset((nop));
1682 mjd_nodelen= Node_Length((nop));
1685 /* branch sub-chain */
1686 convert = NEXTOPER( first );
1687 NEXT_OFF( first ) = (U16)(last - first);
1689 mjd_offset= Node_Offset((convert));
1690 mjd_nodelen= Node_Length((convert));
1694 PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
1695 (int)depth * 2 + 2, "",
1696 mjd_offset,mjd_nodelen)
1699 /* But first we check to see if there is a common prefix we can
1700 split out as an EXACT and put in front of the TRIE node. */
1701 trie->startstate= 1;
1702 if ( trie->bitmap && !trie->widecharmap ) {
1705 PerlIO_printf(Perl_debug_log, "%*sLaststate:%"UVuf"\n",
1706 (int)depth * 2 + 2, "",
1707 TRIE_LASTSTATE(trie))
1709 for ( state = 1 ; state < TRIE_LASTSTATE(trie)-1 ; state++ ) {
1713 const U32 base = trie->states[ state ].trans.base;
1715 if ( trie->states[state].wordnum )
1718 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1719 if ( ( base + ofs >= trie->uniquecharcount ) &&
1720 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1721 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1723 if ( ++count > 1 ) {
1724 SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), ofs, 0);
1725 const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
1726 if ( state == 1 ) break;
1728 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
1730 PerlIO_printf(Perl_debug_log,
1731 "%*sNew Start State=%"UVuf" Class: [",
1732 (int)depth * 2 + 2, "",
1735 SV ** const tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
1736 const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
1738 TRIE_BITMAP_SET(trie,*ch);
1740 TRIE_BITMAP_SET(trie, folder[ *ch ]);
1742 PerlIO_printf(Perl_debug_log, (char*)ch)
1746 TRIE_BITMAP_SET(trie,*ch);
1748 TRIE_BITMAP_SET(trie,folder[ *ch ]);
1749 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
1755 SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
1756 const char *ch = SvPV_nolen_const( *tmp );
1758 PerlIO_printf( Perl_debug_log,
1759 "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
1760 (int)depth * 2 + 2, "",
1764 OP( convert ) = nodetype;
1765 str=STRING(convert);
1773 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
1778 regnode *n = convert+NODE_SZ_STR(convert);
1779 NEXT_OFF(convert) = NODE_SZ_STR(convert);
1780 trie->startstate = state;
1781 trie->minlen -= (state - 1);
1782 trie->maxlen -= (state - 1);
1784 regnode *fix = convert;
1786 Set_Node_Offset_Length(convert, mjd_offset, state - 1);
1787 while( ++fix < n ) {
1788 Set_Node_Offset_Length(fix, 0, 0);
1794 NEXT_OFF(convert) = (U16)(tail - convert);
1798 if ( trie->maxlen ) {
1799 OP( convert ) = TRIE;
1800 NEXT_OFF( convert ) = (U16)(tail - convert);
1801 ARG_SET( convert, data_slot );
1803 /* store the type in the flags */
1804 convert->flags = nodetype;
1805 /* XXX We really should free up the resource in trie now, as we wont use them */
1807 /* needed for dumping*/
1809 regnode *optimize = convert + NODE_STEP_REGNODE + regarglen[ TRIE ];
1810 regnode *opt = convert;
1811 while (++opt<optimize) {
1812 Set_Node_Offset_Length(opt,0,0);
1814 /* We now need to mark all of the space originally used by the
1815 branches as optimized away. This keeps the dumpuntil from
1816 throwing a wobbly as it doesnt use regnext() to traverse the
1818 We also "fix" the offsets
1820 while( optimize < last ) {
1821 mjd_nodelen += Node_Length((optimize));
1822 OP( optimize ) = OPTIMIZED;
1823 Set_Node_Offset_Length(optimize,0,0);
1826 Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
1828 } /* end node insert */
1830 SvREFCNT_dec(TRIE_REVCHARMAP(trie));
1836 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
1837 * These need to be revisited when a newer toolchain becomes available.
1839 #if defined(__sparc64__) && defined(__GNUC__)
1840 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
1841 # undef SPARC64_GCC_WORKAROUND
1842 # define SPARC64_GCC_WORKAROUND 1
1846 #define DEBUG_PEEP(str,scan,depth) \
1847 DEBUG_OPTIMISE_r({ \
1848 SV * const mysv=sv_newmortal(); \
1849 regnode *Next = regnext(scan); \
1850 regprop(RExC_rx, mysv, scan); \
1851 PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s [%d]\n", \
1852 (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
1853 Next ? (REG_NODE_NUM(Next)) : 0 ); \
1856 #define JOIN_EXACT(scan,min,flags) \
1857 if (PL_regkind[OP(scan)] == EXACT) \
1858 join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
1861 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
1862 /* Merge several consecutive EXACTish nodes into one. */
1863 regnode *n = regnext(scan);
1865 regnode *next = scan + NODE_SZ_STR(scan);
1869 regnode *stop = scan;
1871 GET_RE_DEBUG_FLAGS_DECL;
1872 DEBUG_PEEP("join",scan,depth);
1874 /* Skip NOTHING, merge EXACT*. */
1876 ( PL_regkind[OP(n)] == NOTHING ||
1877 (stringok && (OP(n) == OP(scan))))
1879 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
1881 if (OP(n) == TAIL || n > next)
1883 if (PL_regkind[OP(n)] == NOTHING) {
1885 DEBUG_PEEP("skip:",n,depth);
1886 NEXT_OFF(scan) += NEXT_OFF(n);
1887 next = n + NODE_STEP_REGNODE;
1894 else if (stringok) {
1895 const int oldl = STR_LEN(scan);
1896 regnode * const nnext = regnext(n);
1898 DEBUG_PEEP("merg",n,depth);
1901 if (oldl + STR_LEN(n) > U8_MAX)
1903 NEXT_OFF(scan) += NEXT_OFF(n);
1904 STR_LEN(scan) += STR_LEN(n);
1905 next = n + NODE_SZ_STR(n);
1906 /* Now we can overwrite *n : */
1907 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
1915 #ifdef EXPERIMENTAL_INPLACESCAN
1916 if (flags && !NEXT_OFF(n)) {
1917 DEBUG_PEEP("atch",val,depth);
1918 if (reg_off_by_arg[OP(n)]) {
1919 ARG_SET(n, val - n);
1922 NEXT_OFF(n) = val - n;
1929 if (UTF && ( OP(scan) == EXACTF ) && ( STR_LEN(scan) >= 6 ) ) {
1931 Two problematic code points in Unicode casefolding of EXACT nodes:
1933 U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
1934 U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
1940 U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
1941 U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
1943 This means that in case-insensitive matching (or "loose matching",
1944 as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
1945 length of the above casefolded versions) can match a target string
1946 of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
1947 This would rather mess up the minimum length computation.
1949 What we'll do is to look for the tail four bytes, and then peek
1950 at the preceding two bytes to see whether we need to decrease
1951 the minimum length by four (six minus two).
1953 Thanks to the design of UTF-8, there cannot be false matches:
1954 A sequence of valid UTF-8 bytes cannot be a subsequence of
1955 another valid sequence of UTF-8 bytes.
1958 char * const s0 = STRING(scan), *s, *t;
1959 char * const s1 = s0 + STR_LEN(scan) - 1;
1960 char * const s2 = s1 - 4;
1961 const char t0[] = "\xcc\x88\xcc\x81";
1962 const char * const t1 = t0 + 3;
1965 s < s2 && (t = ninstr(s, s1, t0, t1));
1967 if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
1968 ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
1975 n = scan + NODE_SZ_STR(scan);
1977 if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
1984 DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
1988 /* REx optimizer. Converts nodes into quickier variants "in place".
1989 Finds fixed substrings. */
1991 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
1992 to the position after last scanned or to NULL. */
1997 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp, I32 *deltap,
1998 regnode *last, scan_data_t *data, U32 flags, U32 depth)
1999 /* scanp: Start here (read-write). */
2000 /* deltap: Write maxlen-minlen here. */
2001 /* last: Stop before this one. */
2004 I32 min = 0, pars = 0, code;
2005 regnode *scan = *scanp, *next;
2007 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2008 int is_inf_internal = 0; /* The studied chunk is infinite */
2009 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2010 scan_data_t data_fake;
2011 struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
2012 SV *re_trie_maxbuff = NULL;
2014 GET_RE_DEBUG_FLAGS_DECL;
2016 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2019 while (scan && OP(scan) != END && scan < last) {
2020 /* Peephole optimizer: */
2021 DEBUG_PEEP("Peep",scan,depth);
2023 JOIN_EXACT(scan,&min,0);
2025 /* Follow the next-chain of the current node and optimize
2026 away all the NOTHINGs from it. */
2027 if (OP(scan) != CURLYX) {
2028 const int max = (reg_off_by_arg[OP(scan)]
2030 /* I32 may be smaller than U16 on CRAYs! */
2031 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2032 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2036 /* Skip NOTHING and LONGJMP. */
2037 while ((n = regnext(n))
2038 && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2039 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2040 && off + noff < max)
2042 if (reg_off_by_arg[OP(scan)])
2045 NEXT_OFF(scan) = off;
2050 /* The principal pseudo-switch. Cannot be a switch, since we
2051 look into several different things. */
2052 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2053 || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
2054 next = regnext(scan);
2056 /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2058 if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
2059 I32 max1 = 0, min1 = I32_MAX, num = 0;
2060 struct regnode_charclass_class accum;
2061 regnode * const startbranch=scan;
2063 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
2064 scan_commit(pRExC_state, data); /* Cannot merge strings after this. */
2065 if (flags & SCF_DO_STCLASS)
2066 cl_init_zero(pRExC_state, &accum);
2068 while (OP(scan) == code) {
2069 I32 deltanext, minnext, f = 0, fake;
2070 struct regnode_charclass_class this_class;
2073 data_fake.flags = 0;
2075 data_fake.whilem_c = data->whilem_c;
2076 data_fake.last_closep = data->last_closep;
2079 data_fake.last_closep = &fake;
2080 next = regnext(scan);
2081 scan = NEXTOPER(scan);
2083 scan = NEXTOPER(scan);
2084 if (flags & SCF_DO_STCLASS) {
2085 cl_init(pRExC_state, &this_class);
2086 data_fake.start_class = &this_class;
2087 f = SCF_DO_STCLASS_AND;
2089 if (flags & SCF_WHILEM_VISITED_POS)
2090 f |= SCF_WHILEM_VISITED_POS;
2092 /* we suppose the run is continuous, last=next...*/
2093 minnext = study_chunk(pRExC_state, &scan, &deltanext,
2094 next, &data_fake, f,depth+1);
2097 if (max1 < minnext + deltanext)
2098 max1 = minnext + deltanext;
2099 if (deltanext == I32_MAX)
2100 is_inf = is_inf_internal = 1;
2102 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2105 if (data_fake.flags & SF_HAS_EVAL)
2106 data->flags |= SF_HAS_EVAL;
2107 data->whilem_c = data_fake.whilem_c;
2109 if (flags & SCF_DO_STCLASS)
2110 cl_or(pRExC_state, &accum, &this_class);
2111 if (code == SUSPEND)
2114 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2116 if (flags & SCF_DO_SUBSTR) {
2117 data->pos_min += min1;
2118 data->pos_delta += max1 - min1;
2119 if (max1 != min1 || is_inf)
2120 data->longest = &(data->longest_float);
2123 delta += max1 - min1;
2124 if (flags & SCF_DO_STCLASS_OR) {
2125 cl_or(pRExC_state, data->start_class, &accum);
2127 cl_and(data->start_class, &and_with);
2128 flags &= ~SCF_DO_STCLASS;
2131 else if (flags & SCF_DO_STCLASS_AND) {
2133 cl_and(data->start_class, &accum);
2134 flags &= ~SCF_DO_STCLASS;
2137 /* Switch to OR mode: cache the old value of
2138 * data->start_class */
2139 StructCopy(data->start_class, &and_with,
2140 struct regnode_charclass_class);
2141 flags &= ~SCF_DO_STCLASS_AND;
2142 StructCopy(&accum, data->start_class,
2143 struct regnode_charclass_class);
2144 flags |= SCF_DO_STCLASS_OR;
2145 data->start_class->flags |= ANYOF_EOS;
2151 Assuming this was/is a branch we are dealing with: 'scan' now
2152 points at the item that follows the branch sequence, whatever
2153 it is. We now start at the beginning of the sequence and look
2159 which would be constructed from a pattern like /A|LIST|OF|WORDS/
2161 If we can find such a subseqence we need to turn the first
2162 element into a trie and then add the subsequent branch exact
2163 strings to the trie.
2167 1. patterns where the whole set of branch can be converted to a trie,
2169 2. patterns where only a subset of the alternations can be
2170 converted to a trie.
2172 In case 1 we can replace the whole set with a single regop
2173 for the trie. In case 2 we need to keep the start and end
2176 'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2177 becomes BRANCH TRIE; BRANCH X;
2179 Hypthetically when we know the regex isnt anchored we can
2180 turn a case 1 into a DFA and let it rip... Every time it finds a match
2181 it would just call its tail, no WHILEM/CURLY needed.
2184 if (PERL_ENABLE_TRIE_OPTIMISATION) {
2186 if (!re_trie_maxbuff) {
2187 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2188 if (!SvIOK(re_trie_maxbuff))
2189 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2191 if ( SvIV(re_trie_maxbuff)>=0 && OP( startbranch )==BRANCH ) {
2193 regnode *first = (regnode *)NULL;
2194 regnode *last = (regnode *)NULL;
2195 regnode *tail = scan;
2200 SV * const mysv = sv_newmortal(); /* for dumping */
2202 /* var tail is used because there may be a TAIL
2203 regop in the way. Ie, the exacts will point to the
2204 thing following the TAIL, but the last branch will
2205 point at the TAIL. So we advance tail. If we
2206 have nested (?:) we may have to move through several
2210 while ( OP( tail ) == TAIL ) {
2211 /* this is the TAIL generated by (?:) */
2212 tail = regnext( tail );
2217 regprop(RExC_rx, mysv, tail );
2218 PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2219 (int)depth * 2 + 2, "",
2220 "Looking for TRIE'able sequences. Tail node is: ",
2221 SvPV_nolen_const( mysv )
2227 step through the branches, cur represents each
2228 branch, noper is the first thing to be matched
2229 as part of that branch and noper_next is the
2230 regnext() of that node. if noper is an EXACT
2231 and noper_next is the same as scan (our current
2232 position in the regex) then the EXACT branch is
2233 a possible optimization target. Once we have
2234 two or more consequetive such branches we can
2235 create a trie of the EXACT's contents and stich
2236 it in place. If the sequence represents all of
2237 the branches we eliminate the whole thing and
2238 replace it with a single TRIE. If it is a
2239 subsequence then we need to stitch it in. This
2240 means the first branch has to remain, and needs
2241 to be repointed at the item on the branch chain
2242 following the last branch optimized. This could
2243 be either a BRANCH, in which case the
2244 subsequence is internal, or it could be the
2245 item following the branch sequence in which
2246 case the subsequence is at the end.
2250 /* dont use tail as the end marker for this traverse */
2251 for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
2252 regnode * const noper = NEXTOPER( cur );
2253 regnode * const noper_next = regnext( noper );
2256 regprop(RExC_rx, mysv, cur);
2257 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
2258 (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
2260 regprop(RExC_rx, mysv, noper);
2261 PerlIO_printf( Perl_debug_log, " -> %s",
2262 SvPV_nolen_const(mysv));
2265 regprop(RExC_rx, mysv, noper_next );
2266 PerlIO_printf( Perl_debug_log,"\t=> %s\t",
2267 SvPV_nolen_const(mysv));
2269 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
2270 REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
2272 if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
2273 : PL_regkind[ OP( noper ) ] == EXACT )
2274 || OP(noper) == NOTHING )
2275 && noper_next == tail && count<U16_MAX)
2278 if ( !first || optype == NOTHING ) {
2279 if (!first) first = cur;
2280 optype = OP( noper );
2286 made+=make_trie( pRExC_state, startbranch, first, cur, tail, optype, depth+1 );
2288 if ( PL_regkind[ OP( noper ) ] == EXACT
2289 && noper_next == tail )
2293 optype = OP( noper );
2303 regprop(RExC_rx, mysv, cur);
2304 PerlIO_printf( Perl_debug_log,
2305 "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
2306 "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
2310 made+= make_trie( pRExC_state, startbranch, first, scan, tail, optype, depth+1 );
2311 #ifdef TRIE_STUDY_OPT
2312 if ( made && startbranch == first ) {
2313 if ( OP(first)!=TRIE )
2314 flags |= SCF_EXACT_TRIE;
2316 regnode *chk=*scanp;
2317 while ( OP( chk ) == OPEN )
2318 chk = regnext( chk );
2320 flags |= SCF_EXACT_TRIE;
2329 else if ( code == BRANCHJ ) { /* single branch is optimized. */
2330 scan = NEXTOPER(NEXTOPER(scan));
2331 } else /* single branch is optimized. */
2332 scan = NEXTOPER(scan);
2335 else if (OP(scan) == EXACT) {
2336 I32 l = STR_LEN(scan);
2339 const U8 * const s = (U8*)STRING(scan);
2340 l = utf8_length(s, s + l);
2341 uc = utf8_to_uvchr(s, NULL);
2343 uc = *((U8*)STRING(scan));
2346 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
2347 /* The code below prefers earlier match for fixed
2348 offset, later match for variable offset. */
2349 if (data->last_end == -1) { /* Update the start info. */
2350 data->last_start_min = data->pos_min;
2351 data->last_start_max = is_inf
2352 ? I32_MAX : data->pos_min + data->pos_delta;
2354 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
2356 SvUTF8_on(data->last_found);
2358 SV * const sv = data->last_found;
2359 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
2360 mg_find(sv, PERL_MAGIC_utf8) : NULL;
2361 if (mg && mg->mg_len >= 0)
2362 mg->mg_len += utf8_length((U8*)STRING(scan),
2363 (U8*)STRING(scan)+STR_LEN(scan));
2365 data->last_end = data->pos_min + l;
2366 data->pos_min += l; /* As in the first entry. */
2367 data->flags &= ~SF_BEFORE_EOL;
2369 if (flags & SCF_DO_STCLASS_AND) {
2370 /* Check whether it is compatible with what we know already! */
2374 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2375 && !ANYOF_BITMAP_TEST(data->start_class, uc)
2376 && (!(data->start_class->flags & ANYOF_FOLD)
2377 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2380 ANYOF_CLASS_ZERO(data->start_class);
2381 ANYOF_BITMAP_ZERO(data->start_class);
2383 ANYOF_BITMAP_SET(data->start_class, uc);
2384 data->start_class->flags &= ~ANYOF_EOS;
2386 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
2388 else if (flags & SCF_DO_STCLASS_OR) {
2389 /* false positive possible if the class is case-folded */
2391 ANYOF_BITMAP_SET(data->start_class, uc);
2393 data->start_class->flags |= ANYOF_UNICODE_ALL;
2394 data->start_class->flags &= ~ANYOF_EOS;
2395 cl_and(data->start_class, &and_with);
2397 flags &= ~SCF_DO_STCLASS;
2399 else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
2400 I32 l = STR_LEN(scan);
2401 UV uc = *((U8*)STRING(scan));
2403 /* Search for fixed substrings supports EXACT only. */
2404 if (flags & SCF_DO_SUBSTR) {
2406 scan_commit(pRExC_state, data);
2409 const U8 * const s = (U8 *)STRING(scan);
2410 l = utf8_length(s, s + l);
2411 uc = utf8_to_uvchr(s, NULL);
2414 if (flags & SCF_DO_SUBSTR)
2416 if (flags & SCF_DO_STCLASS_AND) {
2417 /* Check whether it is compatible with what we know already! */
2421 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2422 && !ANYOF_BITMAP_TEST(data->start_class, uc)
2423 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2425 ANYOF_CLASS_ZERO(data->start_class);
2426 ANYOF_BITMAP_ZERO(data->start_class);
2428 ANYOF_BITMAP_SET(data->start_class, uc);
2429 data->start_class->flags &= ~ANYOF_EOS;
2430 data->start_class->flags |= ANYOF_FOLD;
2431 if (OP(scan) == EXACTFL)
2432 data->start_class->flags |= ANYOF_LOCALE;
2435 else if (flags & SCF_DO_STCLASS_OR) {
2436 if (data->start_class->flags & ANYOF_FOLD) {
2437 /* false positive possible if the class is case-folded.
2438 Assume that the locale settings are the same... */
2440 ANYOF_BITMAP_SET(data->start_class, uc);
2441 data->start_class->flags &= ~ANYOF_EOS;
2443 cl_and(data->start_class, &and_with);
2445 flags &= ~SCF_DO_STCLASS;
2447 #ifdef TRIE_STUDY_OPT
2448 else if (OP(scan) == TRIE) {
2449 reg_trie_data *trie=RExC_rx->data->data[ ARG(scan) ];
2450 min += trie->minlen;
2451 delta += (trie->maxlen - trie->minlen);
2452 flags &= ~SCF_DO_STCLASS; /* xxx */
2453 if (flags & SCF_DO_SUBSTR) {
2454 scan_commit(pRExC_state,data); /* Cannot expect anything... */
2455 data->pos_min += trie->minlen;
2456 data->pos_delta += (trie->maxlen - trie->minlen);
2457 if (trie->maxlen != trie->minlen)
2458 data->longest = &(data->longest_float);
2462 else if (strchr((const char*)PL_varies,OP(scan))) {
2463 I32 mincount, maxcount, minnext, deltanext, fl = 0;
2464 I32 f = flags, pos_before = 0;
2465 regnode * const oscan = scan;
2466 struct regnode_charclass_class this_class;
2467 struct regnode_charclass_class *oclass = NULL;
2468 I32 next_is_eval = 0;
2470 switch (PL_regkind[OP(scan)]) {
2471 case WHILEM: /* End of (?:...)* . */
2472 scan = NEXTOPER(scan);
2475 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
2476 next = NEXTOPER(scan);
2477 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
2479 maxcount = REG_INFTY;
2480 next = regnext(scan);
2481 scan = NEXTOPER(scan);
2485 if (flags & SCF_DO_SUBSTR)
2490 if (flags & SCF_DO_STCLASS) {
2492 maxcount = REG_INFTY;
2493 next = regnext(scan);
2494 scan = NEXTOPER(scan);
2497 is_inf = is_inf_internal = 1;
2498 scan = regnext(scan);
2499 if (flags & SCF_DO_SUBSTR) {
2500 scan_commit(pRExC_state, data); /* Cannot extend fixed substrings */
2501 data->longest = &(data->longest_float);
2503 goto optimize_curly_tail;
2505 mincount = ARG1(scan);
2506 maxcount = ARG2(scan);
2507 next = regnext(scan);
2508 if (OP(scan) == CURLYX) {
2509 I32 lp = (data ? *(data->last_closep) : 0);
2510 scan->flags = ((lp <= U8_MAX) ? (U8)lp : U8_MAX);
2512 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2513 next_is_eval = (OP(scan) == EVAL);
2515 if (flags & SCF_DO_SUBSTR) {
2516 if (mincount == 0) scan_commit(pRExC_state,data); /* Cannot extend fixed substrings */
2517 pos_before = data->pos_min;
2521 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
2523 data->flags |= SF_IS_INF;
2525 if (flags & SCF_DO_STCLASS) {
2526 cl_init(pRExC_state, &this_class);
2527 oclass = data->start_class;
2528 data->start_class = &this_class;
2529 f |= SCF_DO_STCLASS_AND;
2530 f &= ~SCF_DO_STCLASS_OR;
2532 /* These are the cases when once a subexpression
2533 fails at a particular position, it cannot succeed
2534 even after backtracking at the enclosing scope.
2536 XXXX what if minimal match and we are at the
2537 initial run of {n,m}? */
2538 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
2539 f &= ~SCF_WHILEM_VISITED_POS;
2541 /* This will finish on WHILEM, setting scan, or on NULL: */
2542 minnext = study_chunk(pRExC_state, &scan, &deltanext, last, data,
2544 ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
2546 if (flags & SCF_DO_STCLASS)
2547 data->start_class = oclass;
2548 if (mincount == 0 || minnext == 0) {
2549 if (flags & SCF_DO_STCLASS_OR) {
2550 cl_or(pRExC_state, data->start_class, &this_class);
2552 else if (flags & SCF_DO_STCLASS_AND) {
2553 /* Switch to OR mode: cache the old value of
2554 * data->start_class */
2555 StructCopy(data->start_class, &and_with,
2556 struct regnode_charclass_class);
2557 flags &= ~SCF_DO_STCLASS_AND;
2558 StructCopy(&this_class, data->start_class,
2559 struct regnode_charclass_class);
2560 flags |= SCF_DO_STCLASS_OR;
2561 data->start_class->flags |= ANYOF_EOS;
2563 } else { /* Non-zero len */
2564 if (flags & SCF_DO_STCLASS_OR) {
2565 cl_or(pRExC_state, data->start_class, &this_class);
2566 cl_and(data->start_class, &and_with);
2568 else if (flags & SCF_DO_STCLASS_AND)
2569 cl_and(data->start_class, &this_class);
2570 flags &= ~SCF_DO_STCLASS;
2572 if (!scan) /* It was not CURLYX, but CURLY. */
2574 if ( /* ? quantifier ok, except for (?{ ... }) */
2575 (next_is_eval || !(mincount == 0 && maxcount == 1))
2576 && (minnext == 0) && (deltanext == 0)
2577 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
2578 && maxcount <= REG_INFTY/3 /* Complement check for big count */
2579 && ckWARN(WARN_REGEXP))
2582 "Quantifier unexpected on zero-length expression");
2585 min += minnext * mincount;
2586 is_inf_internal |= ((maxcount == REG_INFTY
2587 && (minnext + deltanext) > 0)
2588 || deltanext == I32_MAX);
2589 is_inf |= is_inf_internal;
2590 delta += (minnext + deltanext) * maxcount - minnext * mincount;
2592 /* Try powerful optimization CURLYX => CURLYN. */
2593 if ( OP(oscan) == CURLYX && data
2594 && data->flags & SF_IN_PAR
2595 && !(data->flags & SF_HAS_EVAL)
2596 && !deltanext && minnext == 1 ) {
2597 /* Try to optimize to CURLYN. */
2598 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
2599 regnode * const nxt1 = nxt;
2606 if (!strchr((const char*)PL_simple,OP(nxt))
2607 && !(PL_regkind[OP(nxt)] == EXACT
2608 && STR_LEN(nxt) == 1))
2614 if (OP(nxt) != CLOSE)
2616 /* Now we know that nxt2 is the only contents: */
2617 oscan->flags = (U8)ARG(nxt);
2619 OP(nxt1) = NOTHING; /* was OPEN. */
2621 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
2622 NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
2623 NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
2624 OP(nxt) = OPTIMIZED; /* was CLOSE. */
2625 OP(nxt + 1) = OPTIMIZED; /* was count. */
2626 NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
2631 /* Try optimization CURLYX => CURLYM. */
2632 if ( OP(oscan) == CURLYX && data
2633 && !(data->flags & SF_HAS_PAR)
2634 && !(data->flags & SF_HAS_EVAL)
2635 && !deltanext /* atom is fixed width */
2636 && minnext != 0 /* CURLYM can't handle zero width */
2638 /* XXXX How to optimize if data == 0? */
2639 /* Optimize to a simpler form. */
2640 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
2644 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
2645 && (OP(nxt2) != WHILEM))
2647 OP(nxt2) = SUCCEED; /* Whas WHILEM */
2648 /* Need to optimize away parenths. */
2649 if (data->flags & SF_IN_PAR) {
2650 /* Set the parenth number. */
2651 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
2653 if (OP(nxt) != CLOSE)
2654 FAIL("Panic opt close");
2655 oscan->flags = (U8)ARG(nxt);
2656 OP(nxt1) = OPTIMIZED; /* was OPEN. */
2657 OP(nxt) = OPTIMIZED; /* was CLOSE. */
2659 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
2660 OP(nxt + 1) = OPTIMIZED; /* was count. */
2661 NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
2662 NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
2665 while ( nxt1 && (OP(nxt1) != WHILEM)) {
2666 regnode *nnxt = regnext(nxt1);
2669 if (reg_off_by_arg[OP(nxt1)])
2670 ARG_SET(nxt1, nxt2 - nxt1);
2671 else if (nxt2 - nxt1 < U16_MAX)
2672 NEXT_OFF(nxt1) = nxt2 - nxt1;
2674 OP(nxt) = NOTHING; /* Cannot beautify */
2679 /* Optimize again: */
2680 study_chunk(pRExC_state, &nxt1, &deltanext, nxt,
2686 else if ((OP(oscan) == CURLYX)
2687 && (flags & SCF_WHILEM_VISITED_POS)
2688 /* See the comment on a similar expression above.
2689 However, this time it not a subexpression
2690 we care about, but the expression itself. */
2691 && (maxcount == REG_INFTY)
2692 && data && ++data->whilem_c < 16) {
2693 /* This stays as CURLYX, we can put the count/of pair. */
2694 /* Find WHILEM (as in regexec.c) */
2695 regnode *nxt = oscan + NEXT_OFF(oscan);
2697 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
2699 PREVOPER(nxt)->flags = (U8)(data->whilem_c
2700 | (RExC_whilem_seen << 4)); /* On WHILEM */
2702 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
2704 if (flags & SCF_DO_SUBSTR) {
2705 SV *last_str = NULL;
2706 int counted = mincount != 0;
2708 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
2709 #if defined(SPARC64_GCC_WORKAROUND)
2712 const char *s = NULL;
2715 if (pos_before >= data->last_start_min)
2718 b = data->last_start_min;
2721 s = SvPV_const(data->last_found, l);
2722 old = b - data->last_start_min;
2725 I32 b = pos_before >= data->last_start_min
2726 ? pos_before : data->last_start_min;
2728 const char * const s = SvPV_const(data->last_found, l);
2729 I32 old = b - data->last_start_min;
2733 old = utf8_hop((U8*)s, old) - (U8*)s;
2736 /* Get the added string: */
2737 last_str = newSVpvn(s + old, l);
2739 SvUTF8_on(last_str);
2740 if (deltanext == 0 && pos_before == b) {
2741 /* What was added is a constant string */
2743 SvGROW(last_str, (mincount * l) + 1);
2744 repeatcpy(SvPVX(last_str) + l,
2745 SvPVX_const(last_str), l, mincount - 1);
2746 SvCUR_set(last_str, SvCUR(last_str) * mincount);
2747 /* Add additional parts. */
2748 SvCUR_set(data->last_found,
2749 SvCUR(data->last_found) - l);
2750 sv_catsv(data->last_found, last_str);
2752 SV * sv = data->last_found;
2754 SvUTF8(sv) && SvMAGICAL(sv) ?
2755 mg_find(sv, PERL_MAGIC_utf8) : NULL;
2756 if (mg && mg->mg_len >= 0)
2757 mg->mg_len += CHR_SVLEN(last_str);
2759 data->last_end += l * (mincount - 1);
2762 /* start offset must point into the last copy */
2763 data->last_start_min += minnext * (mincount - 1);
2764 data->last_start_max += is_inf ? I32_MAX
2765 : (maxcount - 1) * (minnext + data->pos_delta);
2768 /* It is counted once already... */
2769 data->pos_min += minnext * (mincount - counted);
2770 data->pos_delta += - counted * deltanext +
2771 (minnext + deltanext) * maxcount - minnext * mincount;
2772 if (mincount != maxcount) {
2773 /* Cannot extend fixed substrings found inside
2775 scan_commit(pRExC_state,data);
2776 if (mincount && last_str) {
2777 SV * const sv = data->last_found;
2778 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
2779 mg_find(sv, PERL_MAGIC_utf8) : NULL;
2783 sv_setsv(sv, last_str);
2784 data->last_end = data->pos_min;
2785 data->last_start_min =
2786 data->pos_min - CHR_SVLEN(last_str);
2787 data->last_start_max = is_inf
2789 : data->pos_min + data->pos_delta
2790 - CHR_SVLEN(last_str);
2792 data->longest = &(data->longest_float);
2794 SvREFCNT_dec(last_str);
2796 if (data && (fl & SF_HAS_EVAL))
2797 data->flags |= SF_HAS_EVAL;
2798 optimize_curly_tail:
2799 if (OP(oscan) != CURLYX) {
2800 while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
2802 NEXT_OFF(oscan) += NEXT_OFF(next);
2805 default: /* REF and CLUMP only? */
2806 if (flags & SCF_DO_SUBSTR) {
2807 scan_commit(pRExC_state,data); /* Cannot expect anything... */
2808 data->longest = &(data->longest_float);
2810 is_inf = is_inf_internal = 1;
2811 if (flags & SCF_DO_STCLASS_OR)
2812 cl_anything(pRExC_state, data->start_class);
2813 flags &= ~SCF_DO_STCLASS;
2817 else if (strchr((const char*)PL_simple,OP(scan))) {
2820 if (flags & SCF_DO_SUBSTR) {
2821 scan_commit(pRExC_state,data);
2825 if (flags & SCF_DO_STCLASS) {
2826 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
2828 /* Some of the logic below assumes that switching
2829 locale on will only add false positives. */
2830 switch (PL_regkind[OP(scan)]) {
2834 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
2835 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
2836 cl_anything(pRExC_state, data->start_class);
2839 if (OP(scan) == SANY)
2841 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
2842 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
2843 || (data->start_class->flags & ANYOF_CLASS));
2844 cl_anything(pRExC_state, data->start_class);
2846 if (flags & SCF_DO_STCLASS_AND || !value)
2847 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
2850 if (flags & SCF_DO_STCLASS_AND)
2851 cl_and(data->start_class,
2852 (struct regnode_charclass_class*)scan);
2854 cl_or(pRExC_state, data->start_class,
2855 (struct regnode_charclass_class*)scan);
2858 if (flags & SCF_DO_STCLASS_AND) {
2859 if (!(data->start_class->flags & ANYOF_LOCALE)) {
2860 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
2861 for (value = 0; value < 256; value++)
2862 if (!isALNUM(value))
2863 ANYOF_BITMAP_CLEAR(data->start_class, value);
2867 if (data->start_class->flags & ANYOF_LOCALE)
2868 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
2870 for (value = 0; value < 256; value++)
2872 ANYOF_BITMAP_SET(data->start_class, value);
2877 if (flags & SCF_DO_STCLASS_AND) {
2878 if (data->start_class->flags & ANYOF_LOCALE)
2879 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
2882 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
2883 data->start_class->flags |= ANYOF_LOCALE;
2887 if (flags & SCF_DO_STCLASS_AND) {
2888 if (!(data->start_class->flags & ANYOF_LOCALE)) {
2889 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
2890 for (value = 0; value < 256; value++)
2892 ANYOF_BITMAP_CLEAR(data->start_class, value);
2896 if (data->start_class->flags & ANYOF_LOCALE)
2897 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
2899 for (value = 0; value < 256; value++)
2900 if (!isALNUM(value))
2901 ANYOF_BITMAP_SET(data->start_class, value);
2906 if (flags & SCF_DO_STCLASS_AND) {
2907 if (data->start_class->flags & ANYOF_LOCALE)
2908 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
2911 data->start_class->flags |= ANYOF_LOCALE;
2912 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
2916 if (flags & SCF_DO_STCLASS_AND) {
2917 if (!(data->start_class->flags & ANYOF_LOCALE)) {
2918 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
2919 for (value = 0; value < 256; value++)
2920 if (!isSPACE(value))
2921 ANYOF_BITMAP_CLEAR(data->start_class, value);
2925 if (data->start_class->flags & ANYOF_LOCALE)
2926 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
2928 for (value = 0; value < 256; value++)
2930 ANYOF_BITMAP_SET(data->start_class, value);
2935 if (flags & SCF_DO_STCLASS_AND) {
2936 if (data->start_class->flags & ANYOF_LOCALE)
2937 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
2940 data->start_class->flags |= ANYOF_LOCALE;
2941 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
2945 if (flags & SCF_DO_STCLASS_AND) {
2946 if (!(data->start_class->flags & ANYOF_LOCALE)) {
2947 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
2948 for (value = 0; value < 256; value++)
2950 ANYOF_BITMAP_CLEAR(data->start_class, value);
2954 if (data->start_class->flags & ANYOF_LOCALE)
2955 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
2957 for (value = 0; value < 256; value++)
2958 if (!isSPACE(value))
2959 ANYOF_BITMAP_SET(data->start_class, value);
2964 if (flags & SCF_DO_STCLASS_AND) {
2965 if (data->start_class->flags & ANYOF_LOCALE) {
2966 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
2967 for (value = 0; value < 256; value++)
2968 if (!isSPACE(value))
2969 ANYOF_BITMAP_CLEAR(data->start_class, value);
2973 data->start_class->flags |= ANYOF_LOCALE;
2974 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
2978 if (flags & SCF_DO_STCLASS_AND) {
2979 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
2980 for (value = 0; value < 256; value++)
2981 if (!isDIGIT(value))
2982 ANYOF_BITMAP_CLEAR(data->start_class, value);
2985 if (data->start_class->flags & ANYOF_LOCALE)
2986 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
2988 for (value = 0; value < 256; value++)
2990 ANYOF_BITMAP_SET(data->start_class, value);
2995 if (flags & SCF_DO_STCLASS_AND) {
2996 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
2997 for (value = 0; value < 256; value++)
2999 ANYOF_BITMAP_CLEAR(data->start_class, value);
3002 if (data->start_class->flags & ANYOF_LOCALE)
3003 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3005 for (value = 0; value < 256; value++)
3006 if (!isDIGIT(value))
3007 ANYOF_BITMAP_SET(data->start_class, value);
3012 if (flags & SCF_DO_STCLASS_OR)
3013 cl_and(data->start_class, &and_with);
3014 flags &= ~SCF_DO_STCLASS;
3017 else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3018 data->flags |= (OP(scan) == MEOL
3022 else if ( PL_regkind[OP(scan)] == BRANCHJ
3023 /* Lookbehind, or need to calculate parens/evals/stclass: */
3024 && (scan->flags || data || (flags & SCF_DO_STCLASS))
3025 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
3026 /* Lookahead/lookbehind */
3027 I32 deltanext, minnext, fake = 0;
3029 struct regnode_charclass_class intrnl;
3032 data_fake.flags = 0;
3034 data_fake.whilem_c = data->whilem_c;
3035 data_fake.last_closep = data->last_closep;
3038 data_fake.last_closep = &fake;
3039 if ( flags & SCF_DO_STCLASS && !scan->flags
3040 && OP(scan) == IFMATCH ) { /* Lookahead */
3041 cl_init(pRExC_state, &intrnl);
3042 data_fake.start_class = &intrnl;
3043 f |= SCF_DO_STCLASS_AND;
3045 if (flags & SCF_WHILEM_VISITED_POS)
3046 f |= SCF_WHILEM_VISITED_POS;
3047 next = regnext(scan);
3048 nscan = NEXTOPER(NEXTOPER(scan));
3049 minnext = study_chunk(pRExC_state, &nscan, &deltanext, last, &data_fake, f,depth+1);
3052 vFAIL("Variable length lookbehind not implemented");
3054 else if (minnext > U8_MAX) {
3055 vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3057 scan->flags = (U8)minnext;
3060 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3062 if (data_fake.flags & SF_HAS_EVAL)
3063 data->flags |= SF_HAS_EVAL;
3064 data->whilem_c = data_fake.whilem_c;
3066 if (f & SCF_DO_STCLASS_AND) {
3067 const int was = (data->start_class->flags & ANYOF_EOS);
3069 cl_and(data->start_class, &intrnl);
3071 data->start_class->flags |= ANYOF_EOS;
3074 else if (OP(scan) == OPEN) {
3077 else if (OP(scan) == CLOSE) {
3078 if ((I32)ARG(scan) == is_par) {
3079 next = regnext(scan);
3081 if ( next && (OP(next) != WHILEM) && next < last)
3082 is_par = 0; /* Disable optimization */
3085 *(data->last_closep) = ARG(scan);
3087 else if (OP(scan) == EVAL) {
3089 data->flags |= SF_HAS_EVAL;
3091 else if (OP(scan) == LOGICAL && scan->flags == 2) { /* Embedded follows */
3092 if (flags & SCF_DO_SUBSTR) {
3093 scan_commit(pRExC_state,data);
3094 data->longest = &(data->longest_float);
3096 is_inf = is_inf_internal = 1;
3097 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3098 cl_anything(pRExC_state, data->start_class);
3099 flags &= ~SCF_DO_STCLASS;
3101 /* Else: zero-length, ignore. */
3102 scan = regnext(scan);
3107 *deltap = is_inf_internal ? I32_MAX : delta;
3108 if (flags & SCF_DO_SUBSTR && is_inf)
3109 data->pos_delta = I32_MAX - data->pos_min;
3110 if (is_par > U8_MAX)
3112 if (is_par && pars==1 && data) {
3113 data->flags |= SF_IN_PAR;
3114 data->flags &= ~SF_HAS_PAR;
3116 else if (pars && data) {
3117 data->flags |= SF_HAS_PAR;
3118 data->flags &= ~SF_IN_PAR;
3120 if (flags & SCF_DO_STCLASS_OR)
3121 cl_and(data->start_class, &and_with);
3122 if (flags & SCF_EXACT_TRIE)
3123 data->flags |= SCF_EXACT_TRIE;
3128 S_add_data(RExC_state_t *pRExC_state, I32 n, const char *s)
3130 if (RExC_rx->data) {
3131 Renewc(RExC_rx->data,
3132 sizeof(*RExC_rx->data) + sizeof(void*) * (RExC_rx->data->count + n - 1),
3133 char, struct reg_data);
3134 Renew(RExC_rx->data->what, RExC_rx->data->count + n, U8);
3135 RExC_rx->data->count += n;
3138 Newxc(RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1),
3139 char, struct reg_data);
3140 Newx(RExC_rx->data->what, n, U8);
3141 RExC_rx->data->count = n;
3143 Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8);
3144 return RExC_rx->data->count - n;
3147 #ifndef PERL_IN_XSUB_RE
3149 Perl_reginitcolors(pTHX)
3152 const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
3154 char *t = savepv(s);
3158 t = strchr(t, '\t');
3164 PL_colors[i] = t = (char *)"";
3169 PL_colors[i++] = (char *)"";
3177 - pregcomp - compile a regular expression into internal code
3179 * We can't allocate space until we know how big the compiled form will be,
3180 * but we can't compile it (and thus know how big it is) until we've got a
3181 * place to put the code. So we cheat: we compile it twice, once with code
3182 * generation turned off and size counting turned on, and once "for real".
3183 * This also means that we don't allocate space until we are sure that the
3184 * thing really will compile successfully, and we never have to move the
3185 * code and thus invalidate pointers into it. (Note that it has to be in
3186 * one piece because free() must be able to free it all.) [NB: not true in perl]
3188 * Beware that the optimization-preparation code in here knows about some
3189 * of the structure of the compiled regexp. [I'll say.]
3192 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
3203 RExC_state_t RExC_state;
3204 RExC_state_t * const pRExC_state = &RExC_state;
3205 #ifdef TRIE_STUDY_OPT
3207 RExC_state_t copyRExC_state;
3210 GET_RE_DEBUG_FLAGS_DECL;
3213 FAIL("NULL regexp argument");
3215 RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
3218 DEBUG_r(if (!PL_colorset) reginitcolors());
3220 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s \"%s%*s%s\"\n",
3221 PL_colors[4],PL_colors[5],PL_colors[0],
3222 (int)(xend - exp), RExC_precomp, PL_colors[1]);
3224 RExC_flags = pm->op_pmflags;
3228 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
3229 RExC_seen_evals = 0;
3232 /* First pass: determine size, legality. */
3239 RExC_emit = &PL_regdummy;
3240 RExC_whilem_seen = 0;
3241 #if 0 /* REGC() is (currently) a NOP at the first pass.
3242 * Clever compilers notice this and complain. --jhi */
3243 REGC((U8)REG_MAGIC, (char*)RExC_emit);
3245 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
3246 if (reg(pRExC_state, 0, &flags,1) == NULL) {
3247 RExC_precomp = NULL;
3250 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Required "));
3251 DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "size %"IVdf" nodes ", (IV)RExC_size));
3252 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nStarting second pass (creation)\n"));
3255 RExC_lastparse=NULL;
3259 /* Small enough for pointer-storage convention?
3260 If extralen==0, this means that we will not need long jumps. */
3261 if (RExC_size >= 0x10000L && RExC_extralen)
3262 RExC_size += RExC_extralen;
3265 if (RExC_whilem_seen > 15)
3266 RExC_whilem_seen = 15;
3268 /* Allocate space and initialize. */
3269 Newxc(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
3272 FAIL("Regexp out of space");
3275 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
3276 Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
3279 r->prelen = xend - exp;
3280 r->precomp = savepvn(RExC_precomp, r->prelen);
3282 #ifdef PERL_OLD_COPY_ON_WRITE
3283 r->saved_copy = NULL;
3285 r->reganch = pm->op_pmflags & PMf_COMPILETIME;
3286 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
3287 r->lastparen = 0; /* mg.c reads this. */
3289 r->substrs = 0; /* Useful during FAIL. */
3290 r->startp = 0; /* Useful during FAIL. */
3291 r->endp = 0; /* Useful during FAIL. */
3293 Newxz(r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
3295 r->offsets[0] = RExC_size;
3297 DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
3298 "%s %"UVuf" bytes for offset annotations.\n",
3299 r->offsets ? "Got" : "Couldn't get",
3300 (UV)((2*RExC_size+1) * sizeof(U32))));
3304 /* Second pass: emit code. */
3305 RExC_flags = pm->op_pmflags; /* don't let top level (?i) bleed */
3310 RExC_emit_start = r->program;
3311 RExC_emit = r->program;
3312 /* Store the count of eval-groups for security checks: */
3313 RExC_emit->next_off = (U16)((RExC_seen_evals > U16_MAX) ? U16_MAX : RExC_seen_evals);
3314 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
3316 if (reg(pRExC_state, 0, &flags,1) == NULL)
3318 /* XXXX To minimize changes to RE engine we always allocate
3319 3-units-long substrs field. */
3320 Newx(r->substrs, 1, struct reg_substr_data);
3323 Zero(r->substrs, 1, struct reg_substr_data);
3324 StructCopy(&zero_scan_data, &data, scan_data_t);
3326 #ifdef TRIE_STUDY_OPT
3328 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
3329 RExC_state=copyRExC_state;
3330 if (data.longest_fixed)
3331 SvREFCNT_dec(data.longest_fixed);
3332 if (data.longest_float)
3333 SvREFCNT_dec(data.longest_float);
3334 if (data.last_found)
3335 SvREFCNT_dec(data.last_found);
3337 copyRExC_state=RExC_state;
3340 /* Dig out information for optimizations. */
3341 r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
3342 pm->op_pmflags = RExC_flags;
3344 r->reganch |= ROPT_UTF8; /* Unicode in it? */
3345 r->regstclass = NULL;
3346 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
3347 r->reganch |= ROPT_NAUGHTY;
3348 scan = r->program + 1; /* First BRANCH. */
3350 /* XXXX Should not we check for something else? Usually it is OPEN1... */
3351 if (OP(scan) != BRANCH) { /* Only one top-level choice. */
3353 STRLEN longest_float_length, longest_fixed_length;
3354 struct regnode_charclass_class ch_class; /* pointed to by data */
3356 I32 last_close = 0; /* pointed to by data */
3359 /* Skip introductions and multiplicators >= 1. */
3360 while ((OP(first) == OPEN && (sawopen = 1)) ||
3361 /* An OR of *one* alternative - should not happen now. */
3362 (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
3363 /* for now we can't handle lookbehind IFMATCH*/
3364 (OP(first) == IFMATCH && !first->flags) ||
3365 (OP(first) == PLUS) ||
3366 (OP(first) == MINMOD) ||
3367 /* An {n,m} with n>0 */
3368 (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) )
3370 DEBUG_PEEP("first:",first,0);
3371 if (OP(first) == PLUS)
3374 first += regarglen[OP(first)];
3375 if (OP(first) == IFMATCH) {
3376 first = NEXTOPER(first);
3377 first += EXTRA_STEP_2ARGS;
3378 } else /*xxx possible optimisation for /(?=)/*/
3379 first = NEXTOPER(first);
3382 /* Starting-point info. */
3384 /* Ignore EXACT as we deal with it later. */
3385 if (PL_regkind[OP(first)] == EXACT) {
3386 if (OP(first) == EXACT)
3387 NOOP; /* Empty, get anchored substr later. */
3388 else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
3389 r->regstclass = first;
3392 else if (OP(first) == TRIE &&
3393 ((reg_trie_data *)r->data->data[ ARG(first) ])->minlen>0)
3395 /* this can happen only on restudy */
3396 struct regnode_1 *trie_op;
3397 Newxz(trie_op,1,struct regnode_1);
3398 StructCopy(first,trie_op,struct regnode_1);
3399 make_trie_failtable(pRExC_state, (regnode *)first, (regnode *)trie_op, 0);
3400 r->regstclass = (regnode *)trie_op;
3403 else if (strchr((const char*)PL_simple,OP(first)))
3404 r->regstclass = first;
3405 else if (PL_regkind[OP(first)] == BOUND ||
3406 PL_regkind[OP(first)] == NBOUND)
3407 r->regstclass = first;
3408 else if (PL_regkind[OP(first)] == BOL) {
3409 r->reganch |= (OP(first) == MBOL
3411 : (OP(first) == SBOL
3414 first = NEXTOPER(first);
3417 else if (OP(first) == GPOS) {
3418 r->reganch |= ROPT_ANCH_GPOS;
3419 first = NEXTOPER(first);
3422 else if (!sawopen && (OP(first) == STAR &&
3423 PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
3424 !(r->reganch & ROPT_ANCH) )
3426 /* turn .* into ^.* with an implied $*=1 */
3428 (OP(NEXTOPER(first)) == REG_ANY)
3431 r->reganch |= type | ROPT_IMPLICIT;
3432 first = NEXTOPER(first);
3435 if (sawplus && (!sawopen || !RExC_sawback)
3436 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
3437 /* x+ must match at the 1st pos of run of x's */
3438 r->reganch |= ROPT_SKIP;
3440 /* Scan is after the zeroth branch, first is atomic matcher. */
3441 #ifdef TRIE_STUDY_OPT
3444 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
3445 (IV)(first - scan + 1))
3449 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
3450 (IV)(first - scan + 1))
3456 * If there's something expensive in the r.e., find the
3457 * longest literal string that must appear and make it the
3458 * regmust. Resolve ties in favor of later strings, since
3459 * the regstart check works with the beginning of the r.e.
3460 * and avoiding duplication strengthens checking. Not a
3461 * strong reason, but sufficient in the absence of others.
3462 * [Now we resolve ties in favor of the earlier string if
3463 * it happens that c_offset_min has been invalidated, since the
3464 * earlier string may buy us something the later one won't.]
3468 data.longest_fixed = newSVpvs("");
3469 data.longest_float = newSVpvs("");
3470 data.last_found = newSVpvs("");
3471 data.longest = &(data.longest_fixed);
3473 if (!r->regstclass) {
3474 cl_init(pRExC_state, &ch_class);
3475 data.start_class = &ch_class;
3476 stclass_flag = SCF_DO_STCLASS_AND;
3477 } else /* XXXX Check for BOUND? */
3479 data.last_closep = &last_close;
3481 minlen = study_chunk(pRExC_state, &first, &fake, scan + RExC_size, /* Up to end */
3482 &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
3484 #ifdef TRIE_STUDY_OPT
3485 if ( (data.flags & SCF_EXACT_TRIE) && ! restudied++ ) {
3490 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
3491 && data.last_start_min == 0 && data.last_end > 0
3492 && !RExC_seen_zerolen
3493 && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
3494 r->reganch |= ROPT_CHECK_ALL;
3495 scan_commit(pRExC_state, &data);
3496 SvREFCNT_dec(data.last_found);
3498 longest_float_length = CHR_SVLEN(data.longest_float);
3499 if (longest_float_length
3500 || (data.flags & SF_FL_BEFORE_EOL
3501 && (!(data.flags & SF_FL_BEFORE_MEOL)
3502 || (RExC_flags & PMf_MULTILINE)))) {
3505 if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
3506 && data.offset_fixed == data.offset_float_min
3507 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
3508 goto remove_float; /* As in (a)+. */
3510 if (SvUTF8(data.longest_float)) {
3511 r->float_utf8 = data.longest_float;
3512 r->float_substr = NULL;
3514 r->float_substr = data.longest_float;
3515 r->float_utf8 = NULL;
3517 r->float_min_offset = data.offset_float_min;
3518 r->float_max_offset = data.offset_float_max;
3519 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
3520 && (!(data.flags & SF_FL_BEFORE_MEOL)
3521 || (RExC_flags & PMf_MULTILINE)));
3522 fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
3526 r->float_substr = r->float_utf8 = NULL;
3527 SvREFCNT_dec(data.longest_float);
3528 longest_float_length = 0;
3531 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
3532 if (longest_fixed_length
3533 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
3534 && (!(data.flags & SF_FIX_BEFORE_MEOL)
3535 || (RExC_flags & PMf_MULTILINE)))) {
3538 if (SvUTF8(data.longest_fixed)) {
3539 r->anchored_utf8 = data.longest_fixed;
3540 r->anchored_substr = NULL;
3542 r->anchored_substr = data.longest_fixed;
3543 r->anchored_utf8 = NULL;
3545 r->anchored_offset = data.offset_fixed;
3546 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
3547 && (!(data.flags & SF_FIX_BEFORE_MEOL)
3548 || (RExC_flags & PMf_MULTILINE)));
3549 fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
3552 r->anchored_substr = r->anchored_utf8 = NULL;
3553 SvREFCNT_dec(data.longest_fixed);
3554 longest_fixed_length = 0;
3557 && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
3558 r->regstclass = NULL;
3559 if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
3561 && !(data.start_class->flags & ANYOF_EOS)
3562 && !cl_is_anything(data.start_class))
3564 const I32 n = add_data(pRExC_state, 1, "f");
3566 Newx(RExC_rx->data->data[n], 1,
3567 struct regnode_charclass_class);
3568 StructCopy(data.start_class,
3569 (struct regnode_charclass_class*)RExC_rx->data->data[n],
3570 struct regnode_charclass_class);
3571 r->regstclass = (regnode*)RExC_rx->data->data[n];
3572 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
3573 DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
3574 regprop(r, sv, (regnode*)data.start_class);
3575 PerlIO_printf(Perl_debug_log,
3576 "synthetic stclass \"%s\".\n",
3577 SvPVX_const(sv));});
3580 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
3581 if (longest_fixed_length > longest_float_length) {
3582 r->check_substr = r->anchored_substr;
3583 r->check_utf8 = r->anchored_utf8;
3584 r->check_offset_min = r->check_offset_max = r->anchored_offset;
3585 if (r->reganch & ROPT_ANCH_SINGLE)
3586 r->reganch |= ROPT_NOSCAN;
3589 r->check_substr = r->float_substr;
3590 r->check_utf8 = r->float_utf8;
3591 r->check_offset_min = data.offset_float_min;
3592 r->check_offset_max = data.offset_float_max;
3594 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
3595 This should be changed ASAP! */
3596 if ((r->check_substr || r->check_utf8) && !(r->reganch & ROPT_ANCH_GPOS)) {
3597 r->reganch |= RE_USE_INTUIT;
3598 if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
3599 r->reganch |= RE_INTUIT_TAIL;
3603 /* Several toplevels. Best we can is to set minlen. */
3605 struct regnode_charclass_class ch_class;
3608 DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "\n"));
3610 scan = r->program + 1;
3611 cl_init(pRExC_state, &ch_class);
3612 data.start_class = &ch_class;
3613 data.last_closep = &last_close;
3615 minlen = study_chunk(pRExC_state, &scan, &fake, scan + RExC_size,
3616 &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
3618 #ifdef TRIE_STUDY_OPT
3619 if ( (data.flags & SCF_EXACT_TRIE) && ! restudied++ ) {
3624 r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
3625 = r->float_substr = r->float_utf8 = NULL;
3626 if (!(data.start_class->flags & ANYOF_EOS)
3627 && !cl_is_anything(data.start_class))
3629 const I32 n = add_data(pRExC_state, 1, "f");
3631 Newx(RExC_rx->data->data[n], 1,
3632 struct regnode_charclass_class);
3633 StructCopy(data.start_class,
3634 (struct regnode_charclass_class*)RExC_rx->data->data[n],
3635 struct regnode_charclass_class);
3636 r->regstclass = (regnode*)RExC_rx->data->data[n];
3637 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
3638 DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
3639 regprop(r, sv, (regnode*)data.start_class);
3640 PerlIO_printf(Perl_debug_log,
3641 "synthetic stclass \"%s\".\n",
3642 SvPVX_const(sv));});
3647 if (RExC_seen & REG_SEEN_GPOS)
3648 r->reganch |= ROPT_GPOS_SEEN;
3649 if (RExC_seen & REG_SEEN_LOOKBEHIND)
3650 r->reganch |= ROPT_LOOKBEHIND_SEEN;
3651 if (RExC_seen & REG_SEEN_EVAL)
3652 r->reganch |= ROPT_EVAL_SEEN;
3653 if (RExC_seen & REG_SEEN_CANY)
3654 r->reganch |= ROPT_CANY_SEEN;
3655 Newxz(r->startp, RExC_npar, I32);
3656 Newxz(r->endp, RExC_npar, I32);
3658 DEBUG_r( RX_DEBUG_on(r) );
3660 PerlIO_printf(Perl_debug_log,"Final program:\n");
3667 #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
3668 int rem=(int)(RExC_end - RExC_parse); \
3677 if (RExC_lastparse!=RExC_parse) \
3678 PerlIO_printf(Perl_debug_log," >%.*s%-*s", \
3681 iscut ? "..." : "<" \
3684 PerlIO_printf(Perl_debug_log,"%16s",""); \
3689 num=REG_NODE_NUM(RExC_emit); \
3690 if (RExC_lastnum!=num) \
3691 PerlIO_printf(Perl_debug_log,"|%4d",num); \
3693 PerlIO_printf(Perl_debug_log,"|%4s",""); \
3694 PerlIO_printf(Perl_debug_log,"|%*s%-4s", \
3695 (int)((depth*2)), "", \
3699 RExC_lastparse=RExC_parse; \
3704 #define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
3705 DEBUG_PARSE_MSG((funcname)); \
3706 PerlIO_printf(Perl_debug_log,"%4s","\n"); \
3709 - reg - regular expression, i.e. main body or parenthesized thing
3711 * Caller must absorb opening parenthesis.
3713 * Combining parenthesis handling with the base level of regular expression
3714 * is a trifle forced, but the need to tie the tails of the branches to what
3715 * follows makes it hard to avoid.
3717 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
3719 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
3721 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
3725 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
3726 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
3729 register regnode *ret; /* Will be the head of the group. */
3730 register regnode *br;
3731 register regnode *lastbr;
3732 register regnode *ender = NULL;
3733 register I32 parno = 0;
3735 const I32 oregflags = RExC_flags;
3736 bool have_branch = 0;
3739 /* for (?g), (?gc), and (?o) warnings; warning
3740 about (?c) will warn about (?g) -- japhy */
3742 #define WASTED_O 0x01
3743 #define WASTED_G 0x02
3744 #define WASTED_C 0x04
3745 #define WASTED_GC (0x02|0x04)
3746 I32 wastedflags = 0x00;
3748 char * parse_start = RExC_parse; /* MJD */
3749 char * const oregcomp_parse = RExC_parse;
3751 GET_RE_DEBUG_FLAGS_DECL;
3752 DEBUG_PARSE("reg ");
3755 *flagp = 0; /* Tentatively. */
3758 /* Make an OPEN node, if parenthesized. */
3760 if (*RExC_parse == '?') { /* (?...) */
3761 U32 posflags = 0, negflags = 0;
3762 U32 *flagsp = &posflags;
3763 bool is_logical = 0;
3764 const char * const seqstart = RExC_parse;
3767 paren = *RExC_parse++;
3768 ret = NULL; /* For look-ahead/behind. */
3770 case '<': /* (?<...) */
3771 RExC_seen |= REG_SEEN_LOOKBEHIND;
3772 if (*RExC_parse == '!')
3774 if (*RExC_parse != '=' && *RExC_parse != '!')
3777 case '=': /* (?=...) */
3778 case '!': /* (?!...) */
3779 RExC_seen_zerolen++;
3780 case ':': /* (?:...) */
3781 case '>': /* (?>...) */
3783 case '$': /* (?$...) */
3784 case '@': /* (?@...) */
3785 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
3787 case '#': /* (?#...) */
3788 while (*RExC_parse && *RExC_parse != ')')
3790 if (*RExC_parse != ')')
3791 FAIL("Sequence (?#... not terminated");
3792 nextchar(pRExC_state);
3795 case 'p': /* (?p...) */
3796 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
3797 vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
3799 case '?': /* (??...) */
3801 if (*RExC_parse != '{')
3803 paren = *RExC_parse++;
3805 case '{': /* (?{...}) */
3807 I32 count = 1, n = 0;
3809 char *s = RExC_parse;
3811 RExC_seen_zerolen++;
3812 RExC_seen |= REG_SEEN_EVAL;
3813 while (count && (c = *RExC_parse)) {
3824 if (*RExC_parse != ')') {
3826 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
3830 OP_4tree *sop, *rop;
3831 SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
3834 Perl_save_re_context(aTHX);
3835 rop = sv_compile_2op(sv, &sop, "re", &pad);
3836 sop->op_private |= OPpREFCOUNTED;
3837 /* re_dup will OpREFCNT_inc */
3838 OpREFCNT_set(sop, 1);
3841 n = add_data(pRExC_state, 3, "nop");
3842 RExC_rx->data->data[n] = (void*)rop;
3843 RExC_rx->data->data[n+1] = (void*)sop;
3844 RExC_rx->data->data[n+2] = (void*)pad;
3847 else { /* First pass */
3848 if (PL_reginterp_cnt < ++RExC_seen_evals
3850 /* No compiled RE interpolated, has runtime
3851 components ===> unsafe. */
3852 FAIL("Eval-group not allowed at runtime, use re 'eval'");
3853 if (PL_tainting && PL_tainted)
3854 FAIL("Eval-group in insecure regular expression");
3855 #if PERL_VERSION > 8
3856 if (IN_PERL_COMPILETIME)
3861 nextchar(pRExC_state);
3863 ret = reg_node(pRExC_state, LOGICAL);
3866 REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
3867 /* deal with the length of this later - MJD */
3870 ret = reganode(pRExC_state, EVAL, n);
3871 Set_Node_Length(ret, RExC_parse - parse_start + 1);
3872 Set_Node_Offset(ret, parse_start);
3875 case '(': /* (?(?{...})...) and (?(?=...)...) */
3877 if (RExC_parse[0] == '?') { /* (?(?...)) */
3878 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
3879 || RExC_parse[1] == '<'
3880 || RExC_parse[1] == '{') { /* Lookahead or eval. */
3883 ret = reg_node(pRExC_state, LOGICAL);
3886 REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
3890 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
3893 parno = atoi(RExC_parse++);
3895 while (isDIGIT(*RExC_parse))
3897 ret = reganode(pRExC_state, GROUPP, parno);
3899 if ((c = *nextchar(pRExC_state)) != ')')
3900 vFAIL("Switch condition not recognized");
3902 REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
3903 br = regbranch(pRExC_state, &flags, 1,depth+1);
3905 br = reganode(pRExC_state, LONGJMP, 0);
3907 REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
3908 c = *nextchar(pRExC_state);
3912 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
3913 regbranch(pRExC_state, &flags, 1,depth+1);
3914 REGTAIL(pRExC_state, ret, lastbr);
3917 c = *nextchar(pRExC_state);
3922 vFAIL("Switch (?(condition)... contains too many branches");
3923 ender = reg_node(pRExC_state, TAIL);
3924 REGTAIL(pRExC_state, br, ender);
3926 REGTAIL(pRExC_state, lastbr, ender);
3927 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
3930 REGTAIL(pRExC_state, ret, ender);
3934 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
3938 RExC_parse--; /* for vFAIL to print correctly */
3939 vFAIL("Sequence (? incomplete");
3943 parse_flags: /* (?i) */
3944 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
3945 /* (?g), (?gc) and (?o) are useless here
3946 and must be globally applied -- japhy */
3948 if (*RExC_parse == 'o' || *RExC_parse == 'g') {
3949 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
3950 const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
3951 if (! (wastedflags & wflagbit) ) {
3952 wastedflags |= wflagbit;
3955 "Useless (%s%c) - %suse /%c modifier",
3956 flagsp == &negflags ? "?-" : "?",
3958 flagsp == &negflags ? "don't " : "",
3964 else if (*RExC_parse == 'c') {
3965 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
3966 if (! (wastedflags & WASTED_C) ) {
3967 wastedflags |= WASTED_GC;
3970 "Useless (%sc) - %suse /gc modifier",
3971 flagsp == &negflags ? "?-" : "?",
3972 flagsp == &negflags ? "don't " : ""
3977 else { pmflag(flagsp, *RExC_parse); }
3981 if (*RExC_parse == '-') {
3983 wastedflags = 0; /* reset so (?g-c) warns twice */
3987 RExC_flags |= posflags;
3988 RExC_flags &= ~negflags;
3989 if (*RExC_parse == ':') {
3995 if (*RExC_parse != ')') {
3997 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
3999 nextchar(pRExC_state);
4007 ret = reganode(pRExC_state, OPEN, parno);
4008 Set_Node_Length(ret, 1); /* MJD */
4009 Set_Node_Offset(ret, RExC_parse); /* MJD */
4016 /* Pick up the branches, linking them together. */
4017 parse_start = RExC_parse; /* MJD */
4018 br = regbranch(pRExC_state, &flags, 1,depth+1);
4019 /* branch_len = (paren != 0); */
4023 if (*RExC_parse == '|') {
4024 if (!SIZE_ONLY && RExC_extralen) {
4025 reginsert(pRExC_state, BRANCHJ, br);
4028 reginsert(pRExC_state, BRANCH, br);
4029 Set_Node_Length(br, paren != 0);
4030 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
4034 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
4036 else if (paren == ':') {
4037 *flagp |= flags&SIMPLE;
4039 if (is_open) { /* Starts with OPEN. */
4040 REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
4042 else if (paren != '?') /* Not Conditional */
4044 *flagp |= flags & (SPSTART | HASWIDTH);
4046 while (*RExC_parse == '|') {
4047 if (!SIZE_ONLY && RExC_extralen) {
4048 ender = reganode(pRExC_state, LONGJMP,0);
4049 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
4052 RExC_extralen += 2; /* Account for LONGJMP. */
4053 nextchar(pRExC_state);
4054 br = regbranch(pRExC_state, &flags, 0, depth+1);
4058 REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
4062 *flagp |= flags&SPSTART;
4065 if (have_branch || paren != ':') {
4066 /* Make a closing node, and hook it on the end. */
4069 ender = reg_node(pRExC_state, TAIL);
4072 ender = reganode(pRExC_state, CLOSE, parno);
4073 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
4074 Set_Node_Length(ender,1); /* MJD */
4080 *flagp &= ~HASWIDTH;
4083 ender = reg_node(pRExC_state, SUCCEED);
4086 ender = reg_node(pRExC_state, END);
4089 REGTAIL_STUDY(pRExC_state, lastbr, ender);
4091 if (have_branch && !SIZE_ONLY) {
4092 /* Hook the tails of the branches to the closing node. */
4093 for (br = ret; br; br = regnext(br)) {
4094 const U8 op = PL_regkind[OP(br)];
4096 REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
4098 else if (op == BRANCHJ) {
4099 REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
4107 static const char parens[] = "=!<,>";
4109 if (paren && (p = strchr(parens, paren))) {
4110 U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
4111 int flag = (p - parens) > 1;
4114 node = SUSPEND, flag = 0;
4115 reginsert(pRExC_state, node,ret);
4116 Set_Node_Cur_Length(ret);
4117 Set_Node_Offset(ret, parse_start + 1);
4119 REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
4123 /* Check for proper termination. */
4125 RExC_flags = oregflags;
4126 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
4127 RExC_parse = oregcomp_parse;
4128 vFAIL("Unmatched (");
4131 else if (!paren && RExC_parse < RExC_end) {
4132 if (*RExC_parse == ')') {
4134 vFAIL("Unmatched )");
4137 FAIL("Junk on end of regexp"); /* "Can't happen". */
4145 - regbranch - one alternative of an | operator
4147 * Implements the concatenation operator.
4150 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
4153 register regnode *ret;
4154 register regnode *chain = NULL;
4155 register regnode *latest;
4156 I32 flags = 0, c = 0;
4157 GET_RE_DEBUG_FLAGS_DECL;
4158 DEBUG_PARSE("brnc");
4162 if (!SIZE_ONLY && RExC_extralen)
4163 ret = reganode(pRExC_state, BRANCHJ,0);
4165 ret = reg_node(pRExC_state, BRANCH);
4166 Set_Node_Length(ret, 1);
4170 if (!first && SIZE_ONLY)
4171 RExC_extralen += 1; /* BRANCHJ */
4173 *flagp = WORST; /* Tentatively. */
4176 nextchar(pRExC_state);
4177 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
4179 latest = regpiece(pRExC_state, &flags,depth+1);
4180 if (latest == NULL) {
4181 if (flags & TRYAGAIN)
4185 else if (ret == NULL)
4187 *flagp |= flags&HASWIDTH;
4188 if (chain == NULL) /* First piece. */
4189 *flagp |= flags&SPSTART;
4192 REGTAIL(pRExC_state, chain, latest);
4197 if (chain == NULL) { /* Loop ran zero times. */
4198 chain = reg_node(pRExC_state, NOTHING);
4203 *flagp |= flags&SIMPLE;
4210 - regpiece - something followed by possible [*+?]
4212 * Note that the branching code sequences used for ? and the general cases
4213 * of * and + are somewhat optimized: they use the same NOTHING node as
4214 * both the endmarker for their branch list and the body of the last branch.
4215 * It might seem that this node could be dispensed with entirely, but the
4216 * endmarker role is not redundant.
4219 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
4222 register regnode *ret;
4224 register char *next;
4226 const char * const origparse = RExC_parse;
4228 I32 max = REG_INFTY;
4230 GET_RE_DEBUG_FLAGS_DECL;
4231 DEBUG_PARSE("piec");
4233 ret = regatom(pRExC_state, &flags,depth+1);
4235 if (flags & TRYAGAIN)
4242 if (op == '{' && regcurly(RExC_parse)) {
4243 const char *maxpos = NULL;
4244 parse_start = RExC_parse; /* MJD */
4245 next = RExC_parse + 1;
4246 while (isDIGIT(*next) || *next == ',') {
4255 if (*next == '}') { /* got one */
4259 min = atoi(RExC_parse);
4263 maxpos = RExC_parse;
4265 if (!max && *maxpos != '0')
4266 max = REG_INFTY; /* meaning "infinity" */
4267 else if (max >= REG_INFTY)
4268 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
4270 nextchar(pRExC_state);
4273 if ((flags&SIMPLE)) {
4274 RExC_naughty += 2 + RExC_naughty / 2;
4275 reginsert(pRExC_state, CURLY, ret);
4276 Set_Node_Offset(ret, parse_start+1); /* MJD */
4277 Set_Node_Cur_Length(ret);
4280 regnode * const w = reg_node(pRExC_state, WHILEM);
4283 REGTAIL(pRExC_state, ret, w);
4284 if (!SIZE_ONLY && RExC_extralen) {
4285 reginsert(pRExC_state, LONGJMP,ret);
4286 reginsert(pRExC_state, NOTHING,ret);
4287 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
4289 reginsert(pRExC_state, CURLYX,ret);
4291 Set_Node_Offset(ret, parse_start+1);
4292 Set_Node_Length(ret,
4293 op == '{' ? (RExC_parse - parse_start) : 1);
4295 if (!SIZE_ONLY && RExC_extralen)
4296 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
4297 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
4299 RExC_whilem_seen++, RExC_extralen += 3;
4300 RExC_naughty += 4 + RExC_naughty; /* compound interest */
4308 if (max && max < min)
4309 vFAIL("Can't do {n,m} with n > m");
4311 ARG1_SET(ret, (U16)min);
4312 ARG2_SET(ret, (U16)max);
4324 #if 0 /* Now runtime fix should be reliable. */
4326 /* if this is reinstated, don't forget to put this back into perldiag:
4328 =item Regexp *+ operand could be empty at {#} in regex m/%s/
4330 (F) The part of the regexp subject to either the * or + quantifier
4331 could match an empty string. The {#} shows in the regular
4332 expression about where the problem was discovered.
4336 if (!(flags&HASWIDTH) && op != '?')
4337 vFAIL("Regexp *+ operand could be empty");
4340 parse_start = RExC_parse;
4341 nextchar(pRExC_state);
4343 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
4345 if (op == '*' && (flags&SIMPLE)) {
4346 reginsert(pRExC_state, STAR, ret);
4350 else if (op == '*') {
4354 else if (op == '+' && (flags&SIMPLE)) {
4355 reginsert(pRExC_state, PLUS, ret);
4359 else if (op == '+') {
4363 else if (op == '?') {
4368 if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
4370 "%.*s matches null string many times",
4371 (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
4375 if (*RExC_parse == '?') {
4376 nextchar(pRExC_state);
4377 reginsert(pRExC_state, MINMOD, ret);
4378 REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
4380 if (ISMULT2(RExC_parse)) {
4382 vFAIL("Nested quantifiers");
4389 - regatom - the lowest level
4391 * Optimization: gobbles an entire sequence of ordinary characters so that
4392 * it can turn them into a single node, which is smaller to store and
4393 * faster to run. Backslashed characters are exceptions, each becoming a
4394 * separate node; the code is simpler that way and it's not worth fixing.
4396 * [Yes, it is worth fixing, some scripts can run twice the speed.]
4397 * [It looks like its ok, as in S_study_chunk we merge adjacent EXACT nodes]
4400 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
4403 register regnode *ret = NULL;
4405 char *parse_start = RExC_parse;
4406 GET_RE_DEBUG_FLAGS_DECL;
4407 DEBUG_PARSE("atom");
4408 *flagp = WORST; /* Tentatively. */
4411 switch (*RExC_parse) {
4413 RExC_seen_zerolen++;
4414 nextchar(pRExC_state);
4415 if (RExC_flags & PMf_MULTILINE)
4416 ret = reg_node(pRExC_state, MBOL);
4417 else if (RExC_flags & PMf_SINGLELINE)
4418 ret = reg_node(pRExC_state, SBOL);
4420 ret = reg_node(pRExC_state, BOL);
4421 Set_Node_Length(ret, 1); /* MJD */
4424 nextchar(pRExC_state);
4426 RExC_seen_zerolen++;
4427 if (RExC_flags & PMf_MULTILINE)
4428 ret = reg_node(pRExC_state, MEOL);
4429 else if (RExC_flags & PMf_SINGLELINE)
4430 ret = reg_node(pRExC_state, SEOL);
4432 ret = reg_node(pRExC_state, EOL);
4433 Set_Node_Length(ret, 1); /* MJD */
4436 nextchar(pRExC_state);
4437 if (RExC_flags & PMf_SINGLELINE)
4438 ret = reg_node(pRExC_state, SANY);
4440 ret = reg_node(pRExC_state, REG_ANY);
4441 *flagp |= HASWIDTH|SIMPLE;
4443 Set_Node_Length(ret, 1); /* MJD */
4447 char * const oregcomp_parse = ++RExC_parse;
4448 ret = regclass(pRExC_state,depth+1);
4449 if (*RExC_parse != ']') {
4450 RExC_parse = oregcomp_parse;
4451 vFAIL("Unmatched [");
4453 nextchar(pRExC_state);
4454 *flagp |= HASWIDTH|SIMPLE;
4455 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
4459 nextchar(pRExC_state);
4460 ret = reg(pRExC_state, 1, &flags,depth+1);
4462 if (flags & TRYAGAIN) {
4463 if (RExC_parse == RExC_end) {
4464 /* Make parent create an empty node if needed. */
4472 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
4476 if (flags & TRYAGAIN) {
4480 vFAIL("Internal urp");
4481 /* Supposed to be caught earlier. */
4484 if (!regcurly(RExC_parse)) {
4493 vFAIL("Quantifier follows nothing");
4496 switch (*++RExC_parse) {
4498 RExC_seen_zerolen++;
4499 ret = reg_node(pRExC_state, SBOL);
4501 nextchar(pRExC_state);
4502 Set_Node_Length(ret, 2); /* MJD */
4505 ret = reg_node(pRExC_state, GPOS);
4506 RExC_seen |= REG_SEEN_GPOS;
4508 nextchar(pRExC_state);
4509 Set_Node_Length(ret, 2); /* MJD */
4512 ret = reg_node(pRExC_state, SEOL);
4514 RExC_seen_zerolen++; /* Do not optimize RE away */
4515 nextchar(pRExC_state);
4518 ret = reg_node(pRExC_state, EOS);
4520 RExC_seen_zerolen++; /* Do not optimize RE away */
4521 nextchar(pRExC_state);
4522 Set_Node_Length(ret, 2); /* MJD */
4525 ret = reg_node(pRExC_state, CANY);
4526 RExC_seen |= REG_SEEN_CANY;
4527 *flagp |= HASWIDTH|SIMPLE;
4528 nextchar(pRExC_state);
4529 Set_Node_Length(ret, 2); /* MJD */
4532 ret = reg_node(pRExC_state, CLUMP);
4534 nextchar(pRExC_state);
4535 Set_Node_Length(ret, 2); /* MJD */
4538 ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML : ALNUM));
4539 *flagp |= HASWIDTH|SIMPLE;
4540 nextchar(pRExC_state);
4541 Set_Node_Length(ret, 2); /* MJD */
4544 ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML : NALNUM));
4545 *flagp |= HASWIDTH|SIMPLE;
4546 nextchar(pRExC_state);
4547 Set_Node_Length(ret, 2); /* MJD */
4550 RExC_seen_zerolen++;
4551 RExC_seen |= REG_SEEN_LOOKBEHIND;
4552 ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL : BOUND));
4554 nextchar(pRExC_state);
4555 Set_Node_Length(ret, 2); /* MJD */
4558 RExC_seen_zerolen++;
4559 RExC_seen |= REG_SEEN_LOOKBEHIND;
4560 ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL : NBOUND));
4562 nextchar(pRExC_state);
4563 Set_Node_Length(ret, 2); /* MJD */
4566 ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL : SPACE));
4567 *flagp |= HASWIDTH|SIMPLE;
4568 nextchar(pRExC_state);
4569 Set_Node_Length(ret, 2); /* MJD */
4572 ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL : NSPACE));
4573 *flagp |= HASWIDTH|SIMPLE;
4574 nextchar(pRExC_state);
4575 Set_Node_Length(ret, 2); /* MJD */
4578 ret = reg_node(pRExC_state, DIGIT);
4579 *flagp |= HASWIDTH|SIMPLE;
4580 nextchar(pRExC_state);
4581 Set_Node_Length(ret, 2); /* MJD */
4584 ret = reg_node(pRExC_state, NDIGIT);
4585 *flagp |= HASWIDTH|SIMPLE;
4586 nextchar(pRExC_state);
4587 Set_Node_Length(ret, 2); /* MJD */
4592 char* const oldregxend = RExC_end;
4593 char* parse_start = RExC_parse - 2;
4595 if (RExC_parse[1] == '{') {
4596 /* a lovely hack--pretend we saw [\pX] instead */
4597 RExC_end = strchr(RExC_parse, '}');
4599 const U8 c = (U8)*RExC_parse;
4601 RExC_end = oldregxend;
4602 vFAIL2("Missing right brace on \\%c{}", c);
4607 RExC_end = RExC_parse + 2;
4608 if (RExC_end > oldregxend)
4609 RExC_end = oldregxend;
4613 ret = regclass(pRExC_state,depth+1);
4615 RExC_end = oldregxend;
4618 Set_Node_Offset(ret, parse_start + 2);
4619 Set_Node_Cur_Length(ret);
4620 nextchar(pRExC_state);
4621 *flagp |= HASWIDTH|SIMPLE;
4634 case '1': case '2': case '3': case '4':
4635 case '5': case '6': case '7': case '8': case '9':
4637 const I32 num = atoi(RExC_parse);
4639 if (num > 9 && num >= RExC_npar)
4642 char * const parse_start = RExC_parse - 1; /* MJD */
4643 while (isDIGIT(*RExC_parse))
4646 if (!SIZE_ONLY && num > (I32)RExC_rx->nparens)
4647 vFAIL("Reference to nonexistent group");
4649 ret = reganode(pRExC_state,
4650 (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
4654 /* override incorrect value set in reganode MJD */
4655 Set_Node_Offset(ret, parse_start+1);
4656 Set_Node_Cur_Length(ret); /* MJD */
4658 nextchar(pRExC_state);
4663 if (RExC_parse >= RExC_end)
4664 FAIL("Trailing \\");
4667 /* Do not generate "unrecognized" warnings here, we fall
4668 back into the quick-grab loop below */
4675 if (RExC_flags & PMf_EXTENDED) {
4676 while (RExC_parse < RExC_end && *RExC_parse != '\n')
4678 if (RExC_parse < RExC_end)
4684 register STRLEN len;
4689 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
4691 parse_start = RExC_parse - 1;
4697 ret = reg_node(pRExC_state,
4698 (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
4700 for (len = 0, p = RExC_parse - 1;
4701 len < 127 && p < RExC_end;
4704 char * const oldp = p;
4706 if (RExC_flags & PMf_EXTENDED)
4707 p = regwhite(p, RExC_end);
4754 ender = ASCII_TO_NATIVE('\033');
4758 ender = ASCII_TO_NATIVE('\007');
4763 char* const e = strchr(p, '}');
4767 vFAIL("Missing right brace on \\x{}");
4770 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
4771 | PERL_SCAN_DISALLOW_PREFIX;
4772 STRLEN numlen = e - p - 1;
4773 ender = grok_hex(p + 1, &numlen, &flags, NULL);
4780 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
4782 ender = grok_hex(p, &numlen, &flags, NULL);
4788 ender = UCHARAT(p++);
4789 ender = toCTRL(ender);
4791 case '0': case '1': case '2': case '3':case '4':
4792 case '5': case '6': case '7': case '8':case '9':
4794 (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
4797 ender = grok_oct(p, &numlen, &flags, NULL);
4807 FAIL("Trailing \\");
4810 if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
4811 vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
4812 goto normal_default;
4817 if (UTF8_IS_START(*p) && UTF) {
4819 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
4820 &numlen, UTF8_ALLOW_DEFAULT);
4827 if (RExC_flags & PMf_EXTENDED)
4828 p = regwhite(p, RExC_end);
4830 /* Prime the casefolded buffer. */
4831 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
4833 if (ISMULT2(p)) { /* Back off on ?+*. */
4838 /* Emit all the Unicode characters. */
4840 for (foldbuf = tmpbuf;
4842 foldlen -= numlen) {
4843 ender = utf8_to_uvchr(foldbuf, &numlen);
4845 const STRLEN unilen = reguni(pRExC_state, ender, s);
4848 /* In EBCDIC the numlen
4849 * and unilen can differ. */
4851 if (numlen >= foldlen)
4855 break; /* "Can't happen." */
4859 const STRLEN unilen = reguni(pRExC_state, ender, s);
4868 REGC((char)ender, s++);
4874 /* Emit all the Unicode characters. */
4876 for (foldbuf = tmpbuf;
4878 foldlen -= numlen) {
4879 ender = utf8_to_uvchr(foldbuf, &numlen);
4881 const STRLEN unilen = reguni(pRExC_state, ender, s);
4884 /* In EBCDIC the numlen
4885 * and unilen can differ. */
4887 if (numlen >= foldlen)
4895 const STRLEN unilen = reguni(pRExC_state, ender, s);
4904 REGC((char)ender, s++);
4908 Set_Node_Cur_Length(ret); /* MJD */
4909 nextchar(pRExC_state);
4911 /* len is STRLEN which is unsigned, need to copy to signed */
4914 vFAIL("Internal disaster");
4918 if (len == 1 && UNI_IS_INVARIANT(ender))
4922 RExC_size += STR_SZ(len);
4925 RExC_emit += STR_SZ(len);
4931 /* If the encoding pragma is in effect recode the text of
4932 * any EXACT-kind nodes. */
4933 if (PL_encoding && PL_regkind[OP(ret)] == EXACT) {
4934 const STRLEN oldlen = STR_LEN(ret);
4935 SV * const sv = sv_2mortal(newSVpvn(STRING(ret), oldlen));
4939 if (sv_utf8_downgrade(sv, TRUE)) {
4940 const char * const s = sv_recode_to_utf8(sv, PL_encoding);
4941 const STRLEN newlen = SvCUR(sv);
4946 GET_RE_DEBUG_FLAGS_DECL;
4947 DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
4948 (int)oldlen, STRING(ret),
4950 Copy(s, STRING(ret), newlen, char);
4951 STR_LEN(ret) += newlen - oldlen;
4952 RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
4954 RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
4962 S_regwhite(char *p, const char *e)
4967 else if (*p == '#') {
4970 } while (p < e && *p != '\n');
4978 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
4979 Character classes ([:foo:]) can also be negated ([:^foo:]).
4980 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
4981 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
4982 but trigger failures because they are currently unimplemented. */
4984 #define POSIXCC_DONE(c) ((c) == ':')
4985 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
4986 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
4989 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
4992 I32 namedclass = OOB_NAMEDCLASS;
4994 if (value == '[' && RExC_parse + 1 < RExC_end &&
4995 /* I smell either [: or [= or [. -- POSIX has been here, right? */
4996 POSIXCC(UCHARAT(RExC_parse))) {
4997 const char c = UCHARAT(RExC_parse);
4998 char* const s = RExC_parse++;
5000 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
5002 if (RExC_parse == RExC_end)
5003 /* Grandfather lone [:, [=, [. */
5006 const char* const t = RExC_parse++; /* skip over the c */
5009 if (UCHARAT(RExC_parse) == ']') {
5010 const char *posixcc = s + 1;
5011 RExC_parse++; /* skip over the ending ] */
5014 const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
5015 const I32 skip = t - posixcc;
5017 /* Initially switch on the length of the name. */
5020 if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
5021 namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
5024 /* Names all of length 5. */
5025 /* alnum alpha ascii blank cntrl digit graph lower
5026 print punct space upper */
5027 /* Offset 4 gives the best switch position. */
5028 switch (posixcc[4]) {
5030 if (memEQ(posixcc, "alph", 4)) /* alpha */
5031 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
5034 if (memEQ(posixcc, "spac", 4)) /* space */
5035 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
5038 if (memEQ(posixcc, "grap", 4)) /* graph */
5039 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
5042 if (memEQ(posixcc, "asci", 4)) /* ascii */
5043 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
5046 if (memEQ(posixcc, "blan", 4)) /* blank */
5047 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
5050 if (memEQ(posixcc, "cntr", 4)) /* cntrl */
5051 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
5054 if (memEQ(posixcc, "alnu", 4)) /* alnum */
5055 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
5058 if (memEQ(posixcc, "lowe", 4)) /* lower */
5059 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
5060 else if (memEQ(posixcc, "uppe", 4)) /* upper */
5061 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
5064 if (memEQ(posixcc, "digi", 4)) /* digit */
5065 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
5066 else if (memEQ(posixcc, "prin", 4)) /* print */
5067 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
5068 else if (memEQ(posixcc, "punc", 4)) /* punct */
5069 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
5074 if (memEQ(posixcc, "xdigit", 6))
5075 namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
5079 if (namedclass == OOB_NAMEDCLASS)
5080 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
5082 assert (posixcc[skip] == ':');
5083 assert (posixcc[skip+1] == ']');
5084 } else if (!SIZE_ONLY) {
5085 /* [[=foo=]] and [[.foo.]] are still future. */
5087 /* adjust RExC_parse so the warning shows after
5089 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
5091 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
5094 /* Maternal grandfather:
5095 * "[:" ending in ":" but not in ":]" */
5105 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
5108 if (POSIXCC(UCHARAT(RExC_parse))) {
5109 const char *s = RExC_parse;
5110 const char c = *s++;
5114 if (*s && c == *s && s[1] == ']') {
5115 if (ckWARN(WARN_REGEXP))
5117 "POSIX syntax [%c %c] belongs inside character classes",
5120 /* [[=foo=]] and [[.foo.]] are still future. */
5121 if (POSIXCC_NOTYET(c)) {
5122 /* adjust RExC_parse so the error shows after
5124 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
5126 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
5134 parse a class specification and produce either an ANYOF node that
5135 matches the pattern. If the pattern matches a single char only and
5136 that char is < 256 then we produce an EXACT node instead.
5139 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
5143 register UV nextvalue;
5144 register IV prevvalue = OOB_UNICODE;
5145 register IV range = 0;
5146 register regnode *ret;
5149 char *rangebegin = NULL;
5150 bool need_class = 0;
5153 bool optimize_invert = TRUE;
5154 AV* unicode_alternate = NULL;
5156 UV literal_endpoint = 0;
5158 UV stored = 0; /* number of chars stored in the class */
5160 regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
5161 case we need to change the emitted regop to an EXACT. */
5162 const char * orig_parse = RExC_parse;
5163 GET_RE_DEBUG_FLAGS_DECL;
5164 DEBUG_PARSE("clas");
5166 /* Assume we are going to generate an ANYOF node. */
5167 ret = reganode(pRExC_state, ANYOF, 0);
5170 ANYOF_FLAGS(ret) = 0;
5172 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
5176 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
5180 RExC_size += ANYOF_SKIP;
5181 listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
5184 RExC_emit += ANYOF_SKIP;
5186 ANYOF_FLAGS(ret) |= ANYOF_FOLD;
5188 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
5189 ANYOF_BITMAP_ZERO(ret);
5190 listsv = newSVpvs("# comment\n");
5193 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
5195 if (!SIZE_ONLY && POSIXCC(nextvalue))
5196 checkposixcc(pRExC_state);
5198 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
5199 if (UCHARAT(RExC_parse) == ']')
5202 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
5206 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
5209 rangebegin = RExC_parse;
5211 value = utf8n_to_uvchr((U8*)RExC_parse,
5212 RExC_end - RExC_parse,
5213 &numlen, UTF8_ALLOW_DEFAULT);
5214 RExC_parse += numlen;
5217 value = UCHARAT(RExC_parse++);
5219 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
5220 if (value == '[' && POSIXCC(nextvalue))
5221 namedclass = regpposixcc(pRExC_state, value);
5222 else if (value == '\\') {
5224 value = utf8n_to_uvchr((U8*)RExC_parse,
5225 RExC_end - RExC_parse,
5226 &numlen, UTF8_ALLOW_DEFAULT);
5227 RExC_parse += numlen;
5230 value = UCHARAT(RExC_parse++);
5231 /* Some compilers cannot handle switching on 64-bit integer
5232 * values, therefore value cannot be an UV. Yes, this will
5233 * be a problem later if we want switch on Unicode.
5234 * A similar issue a little bit later when switching on
5235 * namedclass. --jhi */
5236 switch ((I32)value) {
5237 case 'w': namedclass = ANYOF_ALNUM; break;
5238 case 'W': namedclass = ANYOF_NALNUM; break;
5239 case 's': namedclass = ANYOF_SPACE; break;
5240 case 'S': namedclass = ANYOF_NSPACE; break;
5241 case 'd': namedclass = ANYOF_DIGIT; break;
5242 case 'D': namedclass = ANYOF_NDIGIT; break;
5247 if (RExC_parse >= RExC_end)
5248 vFAIL2("Empty \\%c{}", (U8)value);
5249 if (*RExC_parse == '{') {
5250 const U8 c = (U8)value;
5251 e = strchr(RExC_parse++, '}');
5253 vFAIL2("Missing right brace on \\%c{}", c);
5254 while (isSPACE(UCHARAT(RExC_parse)))
5256 if (e == RExC_parse)
5257 vFAIL2("Empty \\%c{}", c);
5259 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
5267 if (UCHARAT(RExC_parse) == '^') {
5270 value = value == 'p' ? 'P' : 'p'; /* toggle */
5271 while (isSPACE(UCHARAT(RExC_parse))) {
5276 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
5277 (value=='p' ? '+' : '!'), (int)n, RExC_parse);
5280 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
5281 namedclass = ANYOF_MAX; /* no official name, but it's named */
5284 case 'n': value = '\n'; break;
5285 case 'r': value = '\r'; break;
5286 case 't': value = '\t'; break;
5287 case 'f': value = '\f'; break;
5288 case 'b': value = '\b'; break;
5289 case 'e': value = ASCII_TO_NATIVE('\033');break;
5290 case 'a': value = ASCII_TO_NATIVE('\007');break;
5292 if (*RExC_parse == '{') {
5293 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
5294 | PERL_SCAN_DISALLOW_PREFIX;
5295 char * const e = strchr(RExC_parse++, '}');
5297 vFAIL("Missing right brace on \\x{}");
5299 numlen = e - RExC_parse;
5300 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
5304 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
5306 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
5307 RExC_parse += numlen;
5311 value = UCHARAT(RExC_parse++);
5312 value = toCTRL(value);
5314 case '0': case '1': case '2': case '3': case '4':
5315 case '5': case '6': case '7': case '8': case '9':
5319 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
5320 RExC_parse += numlen;
5324 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
5326 "Unrecognized escape \\%c in character class passed through",
5330 } /* end of \blah */
5336 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
5338 if (!SIZE_ONLY && !need_class)
5339 ANYOF_CLASS_ZERO(ret);
5343 /* a bad range like a-\d, a-[:digit:] ? */
5346 if (ckWARN(WARN_REGEXP)) {
5348 RExC_parse >= rangebegin ?
5349 RExC_parse - rangebegin : 0;
5351 "False [] range \"%*.*s\"",
5354 if (prevvalue < 256) {
5355 ANYOF_BITMAP_SET(ret, prevvalue);
5356 ANYOF_BITMAP_SET(ret, '-');
5359 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
5360 Perl_sv_catpvf(aTHX_ listsv,
5361 "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
5365 range = 0; /* this was not a true range */
5369 const char *what = NULL;
5372 if (namedclass > OOB_NAMEDCLASS)
5373 optimize_invert = FALSE;
5374 /* Possible truncation here but in some 64-bit environments
5375 * the compiler gets heartburn about switch on 64-bit values.
5376 * A similar issue a little earlier when switching on value.
5378 switch ((I32)namedclass) {
5381 ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
5383 for (value = 0; value < 256; value++)
5385 ANYOF_BITMAP_SET(ret, value);
5392 ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
5394 for (value = 0; value < 256; value++)
5395 if (!isALNUM(value))
5396 ANYOF_BITMAP_SET(ret, value);
5403 ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
5405 for (value = 0; value < 256; value++)
5406 if (isALNUMC(value))
5407 ANYOF_BITMAP_SET(ret, value);
5414 ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
5416 for (value = 0; value < 256; value++)
5417 if (!isALNUMC(value))
5418 ANYOF_BITMAP_SET(ret, value);
5425 ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
5427 for (value = 0; value < 256; value++)
5429 ANYOF_BITMAP_SET(ret, value);
5436 ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
5438 for (value = 0; value < 256; value++)
5439 if (!isALPHA(value))
5440 ANYOF_BITMAP_SET(ret, value);
5447 ANYOF_CLASS_SET(ret, ANYOF_ASCII);
5450 for (value = 0; value < 128; value++)
5451 ANYOF_BITMAP_SET(ret, value);
5453 for (value = 0; value < 256; value++) {
5455 ANYOF_BITMAP_SET(ret, value);
5464 ANYOF_CLASS_SET(ret, ANYOF_NASCII);
5467 for (value = 128; value < 256; value++)
5468 ANYOF_BITMAP_SET(ret, value);
5470 for (value = 0; value < 256; value++) {
5471 if (!isASCII(value))
5472 ANYOF_BITMAP_SET(ret, value);
5481 ANYOF_CLASS_SET(ret, ANYOF_BLANK);
5483 for (value = 0; value < 256; value++)
5485 ANYOF_BITMAP_SET(ret, value);
5492 ANYOF_CLASS_SET(ret, ANYOF_NBLANK);
5494 for (value = 0; value < 256; value++)
5495 if (!isBLANK(value))
5496 ANYOF_BITMAP_SET(ret, value);
5503 ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
5505 for (value = 0; value < 256; value++)
5507 ANYOF_BITMAP_SET(ret, value);
5514 ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
5516 for (value = 0; value < 256; value++)
5517 if (!isCNTRL(value))
5518 ANYOF_BITMAP_SET(ret, value);
5525 ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
5527 /* consecutive digits assumed */
5528 for (value = '0'; value <= '9'; value++)
5529 ANYOF_BITMAP_SET(ret, value);
5536 ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
5538 /* consecutive digits assumed */
5539 for (value = 0; value < '0'; value++)
5540 ANYOF_BITMAP_SET(ret, value);
5541 for (value = '9' + 1; value < 256; value++)
5542 ANYOF_BITMAP_SET(ret, value);
5549 ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
5551 for (value = 0; value < 256; value++)
5553 ANYOF_BITMAP_SET(ret, value);
5560 ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
5562 for (value = 0; value < 256; value++)
5563 if (!isGRAPH(value))
5564 ANYOF_BITMAP_SET(ret, value);
5571 ANYOF_CLASS_SET(ret, ANYOF_LOWER);
5573 for (value = 0; value < 256; value++)
5575 ANYOF_BITMAP_SET(ret, value);
5582 ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
5584 for (value = 0; value < 256; value++)
5585 if (!isLOWER(value))
5586 ANYOF_BITMAP_SET(ret, value);
5593 ANYOF_CLASS_SET(ret, ANYOF_PRINT);
5595 for (value = 0; value < 256; value++)
5597 ANYOF_BITMAP_SET(ret, value);
5604 ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
5606 for (value = 0; value < 256; value++)
5607 if (!isPRINT(value))
5608 ANYOF_BITMAP_SET(ret, value);
5615 ANYOF_CLASS_SET(ret, ANYOF_PSXSPC);
5617 for (value = 0; value < 256; value++)
5618 if (isPSXSPC(value))
5619 ANYOF_BITMAP_SET(ret, value);
5626 ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC);
5628 for (value = 0; value < 256; value++)
5629 if (!isPSXSPC(value))
5630 ANYOF_BITMAP_SET(ret, value);
5637 ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
5639 for (value = 0; value < 256; value++)
5641 ANYOF_BITMAP_SET(ret, value);
5648 ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
5650 for (value = 0; value < 256; value++)
5651 if (!isPUNCT(value))
5652 ANYOF_BITMAP_SET(ret, value);
5659 ANYOF_CLASS_SET(ret, ANYOF_SPACE);
5661 for (value = 0; value < 256; value++)
5663 ANYOF_BITMAP_SET(ret, value);
5670 ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
5672 for (value = 0; value < 256; value++)
5673 if (!isSPACE(value))
5674 ANYOF_BITMAP_SET(ret, value);
5681 ANYOF_CLASS_SET(ret, ANYOF_UPPER);
5683 for (value = 0; value < 256; value++)
5685 ANYOF_BITMAP_SET(ret, value);
5692 ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
5694 for (value = 0; value < 256; value++)
5695 if (!isUPPER(value))
5696 ANYOF_BITMAP_SET(ret, value);
5703 ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
5705 for (value = 0; value < 256; value++)
5706 if (isXDIGIT(value))
5707 ANYOF_BITMAP_SET(ret, value);
5714 ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
5716 for (value = 0; value < 256; value++)
5717 if (!isXDIGIT(value))
5718 ANYOF_BITMAP_SET(ret, value);
5724 /* this is to handle \p and \P */
5727 vFAIL("Invalid [::] class");
5731 /* Strings such as "+utf8::isWord\n" */
5732 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
5735 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
5738 } /* end of namedclass \blah */
5741 if (prevvalue > (IV)value) /* b-a */ {
5742 const int w = RExC_parse - rangebegin;
5743 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
5744 range = 0; /* not a valid range */
5748 prevvalue = value; /* save the beginning of the range */
5749 if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
5750 RExC_parse[1] != ']') {
5753 /* a bad range like \w-, [:word:]- ? */
5754 if (namedclass > OOB_NAMEDCLASS) {
5755 if (ckWARN(WARN_REGEXP)) {
5757 RExC_parse >= rangebegin ?
5758 RExC_parse - rangebegin : 0;
5760 "False [] range \"%*.*s\"",
5764 ANYOF_BITMAP_SET(ret, '-');
5766 range = 1; /* yeah, it's a range! */
5767 continue; /* but do it the next time */
5771 /* now is the next time */
5772 /*stored += (value - prevvalue + 1);*/
5774 if (prevvalue < 256) {
5775 const IV ceilvalue = value < 256 ? value : 255;
5778 /* In EBCDIC [\x89-\x91] should include
5779 * the \x8e but [i-j] should not. */
5780 if (literal_endpoint == 2 &&
5781 ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
5782 (isUPPER(prevvalue) && isUPPER(ceilvalue))))
5784 if (isLOWER(prevvalue)) {
5785 for (i = prevvalue; i <= ceilvalue; i++)
5787 ANYOF_BITMAP_SET(ret, i);
5789 for (i = prevvalue; i <= ceilvalue; i++)
5791 ANYOF_BITMAP_SET(ret, i);
5796 for (i = prevvalue; i <= ceilvalue; i++) {
5797 if (!ANYOF_BITMAP_TEST(ret,i)) {
5799 ANYOF_BITMAP_SET(ret, i);
5803 if (value > 255 || UTF) {
5804 const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
5805 const UV natvalue = NATIVE_TO_UNI(value);
5806 stored+=2; /* can't optimize this class */
5807 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
5808 if (prevnatvalue < natvalue) { /* what about > ? */
5809 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
5810 prevnatvalue, natvalue);
5812 else if (prevnatvalue == natvalue) {
5813 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
5815 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
5817 const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
5819 /* If folding and foldable and a single
5820 * character, insert also the folded version
5821 * to the charclass. */
5823 if (foldlen == (STRLEN)UNISKIP(f))
5824 Perl_sv_catpvf(aTHX_ listsv,
5827 /* Any multicharacter foldings
5828 * require the following transform:
5829 * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
5830 * where E folds into "pq" and F folds
5831 * into "rst", all other characters
5832 * fold to single characters. We save
5833 * away these multicharacter foldings,
5834 * to be later saved as part of the
5835 * additional "s" data. */
5838 if (!unicode_alternate)
5839 unicode_alternate = newAV();
5840 sv = newSVpvn((char*)foldbuf, foldlen);
5842 av_push(unicode_alternate, sv);
5846 /* If folding and the value is one of the Greek
5847 * sigmas insert a few more sigmas to make the
5848 * folding rules of the sigmas to work right.
5849 * Note that not all the possible combinations
5850 * are handled here: some of them are handled
5851 * by the standard folding rules, and some of
5852 * them (literal or EXACTF cases) are handled
5853 * during runtime in regexec.c:S_find_byclass(). */
5854 if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
5855 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
5856 (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
5857 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
5858 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
5860 else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
5861 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
5862 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
5867 literal_endpoint = 0;
5871 range = 0; /* this range (if it was one) is done now */
5875 ANYOF_FLAGS(ret) |= ANYOF_LARGE;
5877 RExC_size += ANYOF_CLASS_ADD_SKIP;
5879 RExC_emit += ANYOF_CLASS_ADD_SKIP;
5885 /****** !SIZE_ONLY AFTER HERE *********/
5887 if( stored == 1 && value < 256
5888 && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) )
5890 /* optimize single char class to an EXACT node
5891 but *only* when its not a UTF/high char */
5892 const char * cur_parse= RExC_parse;
5893 RExC_emit = (regnode *)orig_emit;
5894 RExC_parse = (char *)orig_parse;
5895 ret = reg_node(pRExC_state,
5896 (U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
5897 RExC_parse = (char *)cur_parse;
5898 *STRING(ret)= (char)value;
5900 RExC_emit += STR_SZ(1);
5903 /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
5904 if ( /* If the only flag is folding (plus possibly inversion). */
5905 ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
5907 for (value = 0; value < 256; ++value) {
5908 if (ANYOF_BITMAP_TEST(ret, value)) {
5909 UV fold = PL_fold[value];
5912 ANYOF_BITMAP_SET(ret, fold);
5915 ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
5918 /* optimize inverted simple patterns (e.g. [^a-z]) */
5919 if (optimize_invert &&
5920 /* If the only flag is inversion. */
5921 (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
5922 for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
5923 ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
5924 ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
5927 AV * const av = newAV();
5929 /* The 0th element stores the character class description
5930 * in its textual form: used later (regexec.c:Perl_regclass_swash())
5931 * to initialize the appropriate swash (which gets stored in
5932 * the 1st element), and also useful for dumping the regnode.
5933 * The 2nd element stores the multicharacter foldings,
5934 * used later (regexec.c:S_reginclass()). */
5935 av_store(av, 0, listsv);
5936 av_store(av, 1, NULL);
5937 av_store(av, 2, (SV*)unicode_alternate);
5938 rv = newRV_noinc((SV*)av);
5939 n = add_data(pRExC_state, 1, "s");
5940 RExC_rx->data->data[n] = (void*)rv;
5947 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
5949 char* const retval = RExC_parse++;
5952 if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
5953 RExC_parse[2] == '#') {
5954 while (*RExC_parse != ')') {
5955 if (RExC_parse == RExC_end)
5956 FAIL("Sequence (?#... not terminated");
5962 if (RExC_flags & PMf_EXTENDED) {
5963 if (isSPACE(*RExC_parse)) {
5967 else if (*RExC_parse == '#') {
5968 while (RExC_parse < RExC_end)
5969 if (*RExC_parse++ == '\n') break;
5978 - reg_node - emit a node
5980 STATIC regnode * /* Location. */
5981 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
5984 register regnode *ptr;
5985 regnode * const ret = RExC_emit;
5986 GET_RE_DEBUG_FLAGS_DECL;
5989 SIZE_ALIGN(RExC_size);
5993 NODE_ALIGN_FILL(ret);
5995 FILL_ADVANCE_NODE(ptr, op);
5996 if (RExC_offsets) { /* MJD */
5997 MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
5998 "reg_node", __LINE__,
6000 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
6001 ? "Overwriting end of array!\n" : "OK",
6002 (UV)(RExC_emit - RExC_emit_start),
6003 (UV)(RExC_parse - RExC_start),
6004 (UV)RExC_offsets[0]));
6005 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
6014 - reganode - emit a node with an argument
6016 STATIC regnode * /* Location. */
6017 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
6020 register regnode *ptr;
6021 regnode * const ret = RExC_emit;
6022 GET_RE_DEBUG_FLAGS_DECL;
6025 SIZE_ALIGN(RExC_size);
6030 NODE_ALIGN_FILL(ret);
6032 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
6033 if (RExC_offsets) { /* MJD */
6034 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
6038 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
6039 "Overwriting end of array!\n" : "OK",
6040 (UV)(RExC_emit - RExC_emit_start),
6041 (UV)(RExC_parse - RExC_start),
6042 (UV)RExC_offsets[0]));
6043 Set_Cur_Node_Offset;
6052 - reguni - emit (if appropriate) a Unicode character
6055 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
6058 return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
6062 - reginsert - insert an operator in front of already-emitted operand
6064 * Means relocating the operand.
6067 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd)
6070 register regnode *src;
6071 register regnode *dst;
6072 register regnode *place;
6073 const int offset = regarglen[(U8)op];
6074 GET_RE_DEBUG_FLAGS_DECL;
6075 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
6078 RExC_size += NODE_STEP_REGNODE + offset;
6083 RExC_emit += NODE_STEP_REGNODE + offset;
6085 while (src > opnd) {
6086 StructCopy(--src, --dst, regnode);
6087 if (RExC_offsets) { /* MJD 20010112 */
6088 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
6092 (UV)(dst - RExC_emit_start) > RExC_offsets[0]
6093 ? "Overwriting end of array!\n" : "OK",
6094 (UV)(src - RExC_emit_start),
6095 (UV)(dst - RExC_emit_start),
6096 (UV)RExC_offsets[0]));
6097 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
6098 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
6103 place = opnd; /* Op node, where operand used to be. */
6104 if (RExC_offsets) { /* MJD */
6105 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
6109 (UV)(place - RExC_emit_start) > RExC_offsets[0]
6110 ? "Overwriting end of array!\n" : "OK",
6111 (UV)(place - RExC_emit_start),
6112 (UV)(RExC_parse - RExC_start),
6114 Set_Node_Offset(place, RExC_parse);
6115 Set_Node_Length(place, 1);
6117 src = NEXTOPER(place);
6118 FILL_ADVANCE_NODE(place, op);
6119 Zero(src, offset, regnode);
6123 - regtail - set the next-pointer at the end of a node chain of p to val.
6124 - SEE ALSO: regtail_study
6126 /* TODO: All three parms should be const */
6128 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
6131 register regnode *scan;
6132 GET_RE_DEBUG_FLAGS_DECL;
6137 /* Find last node. */
6140 regnode * const temp = regnext(scan);
6142 SV * const mysv=sv_newmortal();
6143 DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
6144 regprop(RExC_rx, mysv, scan);
6145 PerlIO_printf(Perl_debug_log, "~ %s (%d)\n",
6146 SvPV_nolen_const(mysv), REG_NODE_NUM(scan));
6153 if (reg_off_by_arg[OP(scan)]) {
6154 ARG_SET(scan, val - scan);
6157 NEXT_OFF(scan) = val - scan;
6163 - regtail_study - set the next-pointer at the end of a node chain of p to val.
6164 - Look for optimizable sequences at the same time.
6165 - currently only looks for EXACT chains.
6167 This is expermental code. The idea is to use this routine to perform
6168 in place optimizations on branches and groups as they are constructed,
6169 with the long term intention of removing optimization from study_chunk so
6170 that it is purely analytical.
6172 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
6173 to control which is which.
6176 /* TODO: All four parms should be const */
6179 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
6182 register regnode *scan;
6184 #ifdef EXPERIMENTAL_INPLACESCAN
6188 GET_RE_DEBUG_FLAGS_DECL;
6194 /* Find last node. */
6198 regnode * const temp = regnext(scan);
6199 #ifdef EXPERIMENTAL_INPLACESCAN
6200 if (PL_regkind[OP(scan)] == EXACT)
6201 if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
6209 if( exact == PSEUDO )
6211 else if ( exact != OP(scan) )
6220 SV * const mysv=sv_newmortal();
6221 DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
6222 regprop(RExC_rx, mysv, scan);
6223 PerlIO_printf(Perl_debug_log, "~ %s (%s) (%d)\n",
6224 SvPV_nolen_const(mysv),
6226 REG_NODE_NUM(scan));
6233 SV * const mysv_val=sv_newmortal();
6234 DEBUG_PARSE_MSG("");
6235 regprop(RExC_rx, mysv_val, val);
6236 PerlIO_printf(Perl_debug_log, "~ attach to %s (%d) offset to %d\n",
6237 SvPV_nolen_const(mysv_val),
6242 if (reg_off_by_arg[OP(scan)]) {
6243 ARG_SET(scan, val - scan);
6246 NEXT_OFF(scan) = val - scan;
6254 - regcurly - a little FSA that accepts {\d+,?\d*}
6257 S_regcurly(register const char *s)
6276 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
6279 Perl_regdump(pTHX_ const regexp *r)
6283 SV * const sv = sv_newmortal();
6285 (void)dumpuntil(r, r->program, r->program + 1, NULL, sv, 0);
6287 /* Header fields of interest. */
6288 if (r->anchored_substr)
6289 PerlIO_printf(Perl_debug_log,
6290 "anchored \"%s%.*s%s\"%s at %"IVdf" ",
6292 (int)(SvCUR(r->anchored_substr) - (SvTAIL(r->anchored_substr)!=0)),
6293 SvPVX_const(r->anchored_substr),
6295 SvTAIL(r->anchored_substr) ? "$" : "",
6296 (IV)r->anchored_offset);
6297 else if (r->anchored_utf8)
6298 PerlIO_printf(Perl_debug_log,
6299 "anchored utf8 \"%s%.*s%s\"%s at %"IVdf" ",
6301 (int)(SvCUR(r->anchored_utf8) - (SvTAIL(r->anchored_utf8)!=0)),
6302 SvPVX_const(r->anchored_utf8),
6304 SvTAIL(r->anchored_utf8) ? "$" : "",
6305 (IV)r->anchored_offset);
6306 if (r->float_substr)
6307 PerlIO_printf(Perl_debug_log,
6308 "floating \"%s%.*s%s\"%s at %"IVdf"..%"UVuf" ",
6310 (int)(SvCUR(r->float_substr) - (SvTAIL(r->float_substr)!=0)),
6311 SvPVX_const(r->float_substr),
6313 SvTAIL(r->float_substr) ? "$" : "",
6314 (IV)r->float_min_offset, (UV)r->float_max_offset);
6315 else if (r->float_utf8)
6316 PerlIO_printf(Perl_debug_log,
6317 "floating utf8 \"%s%.*s%s\"%s at %"IVdf"..%"UVuf" ",
6319 (int)(SvCUR(r->float_utf8) - (SvTAIL(r->float_utf8)!=0)),
6320 SvPVX_const(r->float_utf8),
6322 SvTAIL(r->float_utf8) ? "$" : "",
6323 (IV)r->float_min_offset, (UV)r->float_max_offset);
6324 if (r->check_substr || r->check_utf8)
6325 PerlIO_printf(Perl_debug_log,
6326 r->check_substr == r->float_substr
6327 && r->check_utf8 == r->float_utf8
6328 ? "(checking floating" : "(checking anchored");
6329 if (r->reganch & ROPT_NOSCAN)
6330 PerlIO_printf(Perl_debug_log, " noscan");
6331 if (r->reganch & ROPT_CHECK_ALL)
6332 PerlIO_printf(Perl_debug_log, " isall");
6333 if (r->check_substr || r->check_utf8)
6334 PerlIO_printf(Perl_debug_log, ") ");
6336 if (r->regstclass) {
6337 regprop(r, sv, r->regstclass);
6338 PerlIO_printf(Perl_debug_log, "stclass \"%s\" ", SvPVX_const(sv));
6340 if (r->reganch & ROPT_ANCH) {
6341 PerlIO_printf(Perl_debug_log, "anchored");
6342 if (r->reganch & ROPT_ANCH_BOL)
6343 PerlIO_printf(Perl_debug_log, "(BOL)");
6344 if (r->reganch & ROPT_ANCH_MBOL)
6345 PerlIO_printf(Perl_debug_log, "(MBOL)");
6346 if (r->reganch & ROPT_ANCH_SBOL)
6347 PerlIO_printf(Perl_debug_log, "(SBOL)");
6348 if (r->reganch & ROPT_ANCH_GPOS)
6349 PerlIO_printf(Perl_debug_log, "(GPOS)");
6350 PerlIO_putc(Perl_debug_log, ' ');
6352 if (r->reganch & ROPT_GPOS_SEEN)
6353 PerlIO_printf(Perl_debug_log, "GPOS ");
6354 if (r->reganch & ROPT_SKIP)
6355 PerlIO_printf(Perl_debug_log, "plus ");
6356 if (r->reganch & ROPT_IMPLICIT)
6357 PerlIO_printf(Perl_debug_log, "implicit ");
6358 PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
6359 if (r->reganch & ROPT_EVAL_SEEN)
6360 PerlIO_printf(Perl_debug_log, "with eval ");
6361 PerlIO_printf(Perl_debug_log, "\n");
6363 const U32 len = r->offsets[0];
6364 GET_RE_DEBUG_FLAGS_DECL;
6367 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
6368 for (i = 1; i <= len; i++) {
6369 if (r->offsets[i*2-1] || r->offsets[i*2])
6370 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
6371 i, (UV)r->offsets[i*2-1], (UV)r->offsets[i*2]);
6373 PerlIO_printf(Perl_debug_log, "\n");
6377 PERL_UNUSED_CONTEXT;
6379 #endif /* DEBUGGING */
6383 - regprop - printable representation of opcode
6386 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
6392 sv_setpvn(sv, "", 0);
6393 if (OP(o) >= reg_num) /* regnode.type is unsigned */
6394 /* It would be nice to FAIL() here, but this may be called from
6395 regexec.c, and it would be hard to supply pRExC_state. */
6396 Perl_croak(aTHX_ "Corrupted regexp opcode");
6397 sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
6399 k = PL_regkind[OP(o)];
6402 SV * const dsv = sv_2mortal(newSVpvs(""));
6403 /* Using is_utf8_string() is a crude hack but it may
6404 * be the best for now since we have no flag "this EXACTish
6405 * node was UTF-8" --jhi */
6406 const bool do_utf8 = is_utf8_string((U8*)STRING(o), STR_LEN(o));
6407 const char * const s = do_utf8 ?
6408 pv_uni_display(dsv, (U8*)STRING(o), STR_LEN(o), 60,
6409 UNI_DISPLAY_REGEX) :
6411 const int len = do_utf8 ?
6414 Perl_sv_catpvf(aTHX_ sv, " <%s%.*s%s>",
6418 } else if (k == TRIE) {
6419 Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
6420 /* print the details of the trie in dumpuntil instead, as
6421 * prog->data isn't available here */
6422 } else if (k == CURLY) {
6423 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
6424 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
6425 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
6427 else if (k == WHILEM && o->flags) /* Ordinal/of */
6428 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
6429 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP )
6430 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
6431 else if (k == LOGICAL)
6432 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
6433 else if (k == ANYOF) {
6434 int i, rangestart = -1;
6435 const U8 flags = ANYOF_FLAGS(o);
6437 /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
6438 static const char * const anyofs[] = {
6471 if (flags & ANYOF_LOCALE)
6472 sv_catpvs(sv, "{loc}");
6473 if (flags & ANYOF_FOLD)
6474 sv_catpvs(sv, "{i}");
6475 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
6476 if (flags & ANYOF_INVERT)
6478 for (i = 0; i <= 256; i++) {
6479 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
6480 if (rangestart == -1)
6482 } else if (rangestart != -1) {
6483 if (i <= rangestart + 3)
6484 for (; rangestart < i; rangestart++)
6485 put_byte(sv, rangestart);
6487 put_byte(sv, rangestart);
6489 put_byte(sv, i - 1);
6495 if (o->flags & ANYOF_CLASS)
6496 for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
6497 if (ANYOF_CLASS_TEST(o,i))
6498 sv_catpv(sv, anyofs[i]);
6500 if (flags & ANYOF_UNICODE)
6501 sv_catpvs(sv, "{unicode}");
6502 else if (flags & ANYOF_UNICODE_ALL)
6503 sv_catpvs(sv, "{unicode_all}");
6507 SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
6511 U8 s[UTF8_MAXBYTES_CASE+1];
6513 for (i = 0; i <= 256; i++) { /* just the first 256 */
6514 uvchr_to_utf8(s, i);
6516 if (i < 256 && swash_fetch(sw, s, TRUE)) {
6517 if (rangestart == -1)
6519 } else if (rangestart != -1) {
6520 if (i <= rangestart + 3)
6521 for (; rangestart < i; rangestart++) {
6522 const U8 * const e = uvchr_to_utf8(s,rangestart);
6524 for(p = s; p < e; p++)
6528 const U8 *e = uvchr_to_utf8(s,rangestart);
6530 for (p = s; p < e; p++)
6533 e = uvchr_to_utf8(s, i-1);
6534 for (p = s; p < e; p++)
6541 sv_catpvs(sv, "..."); /* et cetera */
6545 char *s = savesvpv(lv);
6546 char * const origs = s;
6548 while (*s && *s != '\n')
6552 const char * const t = ++s;
6570 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
6572 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
6573 Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
6575 PERL_UNUSED_CONTEXT;
6576 PERL_UNUSED_ARG(sv);
6578 #endif /* DEBUGGING */
6582 Perl_re_intuit_string(pTHX_ regexp *prog)
6583 { /* Assume that RE_INTUIT is set */
6585 GET_RE_DEBUG_FLAGS_DECL;
6586 PERL_UNUSED_CONTEXT;
6590 const char * const s = SvPV_nolen_const(prog->check_substr
6591 ? prog->check_substr : prog->check_utf8);
6593 if (!PL_colorset) reginitcolors();
6594 PerlIO_printf(Perl_debug_log,
6595 "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
6597 prog->check_substr ? "" : "utf8 ",
6598 PL_colors[5],PL_colors[0],
6601 (strlen(s) > 60 ? "..." : ""));
6604 return prog->check_substr ? prog->check_substr : prog->check_utf8;
6608 Perl_pregfree(pTHX_ struct regexp *r)
6612 SV * const dsv = PERL_DEBUG_PAD_ZERO(0);
6614 GET_RE_DEBUG_FLAGS_DECL;
6616 if (!r || (--r->refcnt > 0))
6618 DEBUG_COMPILE_r(if (RX_DEBUG(r)){
6619 const char * const s = (r->reganch & ROPT_UTF8)
6620 ? pv_uni_display(dsv, (U8*)r->precomp, r->prelen, 60, UNI_DISPLAY_REGEX)
6621 : pv_display(dsv, r->precomp, r->prelen, 0, 60);
6622 const int len = SvCUR(dsv);
6625 PerlIO_printf(Perl_debug_log,
6626 "%sFreeing REx:%s %s%*.*s%s%s\n",
6627 PL_colors[4],PL_colors[5],PL_colors[0],
6630 len > 60 ? "..." : "");
6633 /* gcov results gave these as non-null 100% of the time, so there's no
6634 optimisation in checking them before calling Safefree */
6635 Safefree(r->precomp);
6636 Safefree(r->offsets); /* 20010421 MJD */
6637 RX_MATCH_COPY_FREE(r);
6638 #ifdef PERL_OLD_COPY_ON_WRITE
6640 SvREFCNT_dec(r->saved_copy);
6643 if (r->anchored_substr)
6644 SvREFCNT_dec(r->anchored_substr);
6645 if (r->anchored_utf8)
6646 SvREFCNT_dec(r->anchored_utf8);
6647 if (r->float_substr)
6648 SvREFCNT_dec(r->float_substr);
6650 SvREFCNT_dec(r->float_utf8);
6651 Safefree(r->substrs);
6654 int n = r->data->count;
6655 PAD* new_comppad = NULL;
6660 /* If you add a ->what type here, update the comment in regcomp.h */
6661 switch (r->data->what[n]) {
6663 SvREFCNT_dec((SV*)r->data->data[n]);
6666 Safefree(r->data->data[n]);
6669 new_comppad = (AV*)r->data->data[n];
6672 if (new_comppad == NULL)
6673 Perl_croak(aTHX_ "panic: pregfree comppad");
6674 PAD_SAVE_LOCAL(old_comppad,
6675 /* Watch out for global destruction's random ordering. */
6676 (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
6679 refcnt = OpREFCNT_dec((OP_4tree*)r->data->data[n]);
6682 op_free((OP_4tree*)r->data->data[n]);
6684 PAD_RESTORE_LOCAL(old_comppad);
6685 SvREFCNT_dec((SV*)new_comppad);
6691 { /* Aho Corasick add-on structure for a trie node.
6692 Used in stclass optimization only */
6694 reg_ac_data *aho=(reg_ac_data*)r->data->data[n];
6696 refcount = --aho->refcount;
6699 Safefree(aho->states);
6700 Safefree(aho->fail);
6701 aho->trie=NULL; /* not necessary to free this as it is
6702 handled by the 't' case */
6703 Safefree(r->data->data[n]); /* do this last!!!! */
6704 Safefree(r->regstclass);
6710 /* trie structure. */
6712 reg_trie_data *trie=(reg_trie_data*)r->data->data[n];
6714 refcount = --trie->refcount;
6717 Safefree(trie->charmap);
6718 if (trie->widecharmap)
6719 SvREFCNT_dec((SV*)trie->widecharmap);
6720 Safefree(trie->states);
6721 Safefree(trie->trans);
6723 Safefree(trie->bitmap);
6725 Safefree(trie->wordlen);
6729 SvREFCNT_dec((SV*)trie->words);
6730 if (trie->revcharmap)
6731 SvREFCNT_dec((SV*)trie->revcharmap);
6734 Safefree(r->data->data[n]); /* do this last!!!! */
6739 Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
6742 Safefree(r->data->what);
6745 Safefree(r->startp);
6750 #ifndef PERL_IN_XSUB_RE
6752 - regnext - dig the "next" pointer out of a node
6755 Perl_regnext(pTHX_ register regnode *p)
6758 register I32 offset;
6760 if (p == &PL_regdummy)
6763 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
6772 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
6775 STRLEN l1 = strlen(pat1);
6776 STRLEN l2 = strlen(pat2);
6779 const char *message;
6785 Copy(pat1, buf, l1 , char);
6786 Copy(pat2, buf + l1, l2 , char);
6787 buf[l1 + l2] = '\n';
6788 buf[l1 + l2 + 1] = '\0';
6790 /* ANSI variant takes additional second argument */
6791 va_start(args, pat2);
6795 msv = vmess(buf, &args);
6797 message = SvPV_const(msv,l1);
6800 Copy(message, buf, l1 , char);
6801 buf[l1-1] = '\0'; /* Overwrite \n */
6802 Perl_croak(aTHX_ "%s", buf);
6805 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
6807 #ifndef PERL_IN_XSUB_RE
6809 Perl_save_re_context(pTHX)
6813 struct re_save_state *state;
6815 SAVEVPTR(PL_curcop);
6816 SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
6818 state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
6819 PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
6820 SSPUSHINT(SAVEt_RE_STATE);
6822 Copy(&PL_reg_state, state, 1, struct re_save_state);
6824 PL_reg_start_tmp = 0;
6825 PL_reg_start_tmpl = 0;
6826 PL_reg_oldsaved = NULL;
6827 PL_reg_oldsavedlen = 0;
6829 PL_reg_leftiter = 0;
6830 PL_reg_poscache = NULL;
6831 PL_reg_poscache_size = 0;
6832 #ifdef PERL_OLD_COPY_ON_WRITE
6836 /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
6838 const REGEXP * const rx = PM_GETRE(PL_curpm);
6841 for (i = 1; i <= rx->nparens; i++) {
6842 char digits[TYPE_CHARS(long)];
6843 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
6844 GV *const *const gvp
6845 = (GV**)hv_fetch(PL_defstash, digits, len, 0);
6848 GV * const gv = *gvp;
6849 if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
6859 clear_re(pTHX_ void *r)
6862 ReREFCNT_dec((regexp *)r);
6868 S_put_byte(pTHX_ SV *sv, int c)
6870 if (isCNTRL(c) || c == 255 || !isPRINT(c))
6871 Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
6872 else if (c == '-' || c == ']' || c == '\\' || c == '^')
6873 Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
6875 Perl_sv_catpvf(aTHX_ sv, "%c", c);
6878 #define CLEAR_OPTSTART \
6879 if (optstart) STMT_START { \
6880 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%d nodes)\n", node - optstart)); \
6884 #define DUMPUNTIL(a,b,c,d,e,f) CLEAR_OPTSTART; node=dumpuntil(a,b,c,d,e,f);
6886 STATIC const regnode *
6887 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
6888 const regnode *last, SV* sv, I32 l)
6891 register U8 op = EXACT; /* Arbitrary non-END op. */
6892 register const regnode *next;
6893 const regnode *optstart= NULL;
6894 GET_RE_DEBUG_FLAGS_DECL;
6896 while (op != END && (!last || node < last)) {
6897 /* While that wasn't END last time... */
6903 next = regnext((regnode *)node);
6906 if (OP(node) == OPTIMIZED) {
6907 if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
6914 regprop(r, sv, node);
6915 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
6916 (int)(2*l + 1), "", SvPVX_const(sv));
6918 if (OP(node) != OPTIMIZED) {
6919 if (next == NULL) /* Next ptr. */
6920 PerlIO_printf(Perl_debug_log, "(0)");
6922 PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
6923 (void)PerlIO_putc(Perl_debug_log, '\n');
6927 if (PL_regkind[(U8)op] == BRANCHJ) {
6930 register const regnode *nnode = (OP(next) == LONGJMP
6931 ? regnext((regnode *)next)
6933 if (last && nnode > last)
6935 DUMPUNTIL(r, start, NEXTOPER(NEXTOPER(node)), nnode, sv, l + 1);
6938 else if (PL_regkind[(U8)op] == BRANCH) {
6940 DUMPUNTIL(r, start, NEXTOPER(node), next, sv, l + 1);
6942 else if ( PL_regkind[(U8)op] == TRIE ) {
6943 const I32 n = ARG(node);
6944 const reg_trie_data * const trie = (reg_trie_data*)r->data->data[n];
6945 const I32 arry_len = av_len(trie->words)+1;
6947 PerlIO_printf(Perl_debug_log,
6948 "%*s[StS:%"UVuf" Wds:%d Cs:%d Uq:%d #Sts:%"IVdf" Mn:%d Mx:%d",
6952 TRIE_WORDCOUNT(trie),
6953 (int)TRIE_CHARCOUNT(trie),
6954 trie->uniquecharcount,
6955 (IV)TRIE_LASTSTATE(trie)-1,
6962 sv_setpvn(sv, "", 0);
6963 for (i = 0; i <= 256; i++) {
6964 if (i < 256 && TRIE_BITMAP_TEST(trie,i)) {
6965 if (rangestart == -1)
6967 } else if (rangestart != -1) {
6968 if (i <= rangestart + 3)
6969 for (; rangestart < i; rangestart++)
6970 put_byte(sv, rangestart);
6972 put_byte(sv, rangestart);
6974 put_byte(sv, i - 1);
6979 PerlIO_printf(Perl_debug_log, " Stcls:%s]\n", SvPVX_const(sv));
6981 PerlIO_printf(Perl_debug_log, " No-Stcls]\n");
6983 for (word_idx=0; word_idx < arry_len; word_idx++) {
6984 SV ** const elem_ptr = av_fetch(trie->words,word_idx,0);
6986 PerlIO_printf(Perl_debug_log, "%*s<%s%s%s>\n",
6989 SvPV_nolen_const(*elem_ptr),
6995 node = NEXTOPER(node);
6996 node += regarglen[(U8)op];
6999 else if ( op == CURLY) { /* "next" might be very big: optimizer */
7000 DUMPUNTIL(r, start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
7001 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1, sv, l + 1);
7003 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
7005 DUMPUNTIL(r, start, NEXTOPER(node) + EXTRA_STEP_2ARGS,
7008 else if ( op == PLUS || op == STAR) {
7009 DUMPUNTIL(r, start, NEXTOPER(node), NEXTOPER(node) + 1, sv, l + 1);
7011 else if (op == ANYOF) {
7012 /* arglen 1 + class block */
7013 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
7014 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
7015 node = NEXTOPER(node);
7017 else if (PL_regkind[(U8)op] == EXACT) {
7018 /* Literal string, where present. */
7019 node += NODE_SZ_STR(node) - 1;
7020 node = NEXTOPER(node);
7023 node = NEXTOPER(node);
7024 node += regarglen[(U8)op];
7026 if (op == CURLYX || op == OPEN)
7028 else if (op == WHILEM)
7035 #endif /* DEBUGGING */
7039 * c-indentation-style: bsd
7041 * indent-tabs-mode: t
7044 * ex: set ts=8 sts=4 sw=4 noet: