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. */
120 regnode **parens; /* offsets of each paren */
122 HV *charnames; /* cache of named sequences */
123 HV *paren_names; /* Paren names */
125 char *starttry; /* -Dr: where regtry was called. */
126 #define RExC_starttry (pRExC_state->starttry)
129 const char *lastparse;
131 #define RExC_lastparse (pRExC_state->lastparse)
132 #define RExC_lastnum (pRExC_state->lastnum)
136 #define RExC_flags (pRExC_state->flags)
137 #define RExC_precomp (pRExC_state->precomp)
138 #define RExC_rx (pRExC_state->rx)
139 #define RExC_start (pRExC_state->start)
140 #define RExC_end (pRExC_state->end)
141 #define RExC_parse (pRExC_state->parse)
142 #define RExC_whilem_seen (pRExC_state->whilem_seen)
143 #define RExC_offsets (pRExC_state->rx->offsets) /* I am not like the others */
144 #define RExC_emit (pRExC_state->emit)
145 #define RExC_emit_start (pRExC_state->emit_start)
146 #define RExC_naughty (pRExC_state->naughty)
147 #define RExC_sawback (pRExC_state->sawback)
148 #define RExC_seen (pRExC_state->seen)
149 #define RExC_size (pRExC_state->size)
150 #define RExC_npar (pRExC_state->npar)
151 #define RExC_extralen (pRExC_state->extralen)
152 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
153 #define RExC_seen_evals (pRExC_state->seen_evals)
154 #define RExC_utf8 (pRExC_state->utf8)
155 #define RExC_charnames (pRExC_state->charnames)
156 #define RExC_parens (pRExC_state->parens)
157 #define RExC_paren_names (pRExC_state->paren_names)
159 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
160 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
161 ((*s) == '{' && regcurly(s)))
164 #undef SPSTART /* dratted cpp namespace... */
167 * Flags to be passed up and down.
169 #define WORST 0 /* Worst case. */
170 #define HASWIDTH 0x1 /* Known to match non-null strings. */
171 #define SIMPLE 0x2 /* Simple enough to be STAR/PLUS operand. */
172 #define SPSTART 0x4 /* Starts with * or +. */
173 #define TRYAGAIN 0x8 /* Weeded out a declaration. */
175 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
177 /* whether trie related optimizations are enabled */
178 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
179 #define TRIE_STUDY_OPT
180 #define FULL_TRIE_STUDY
185 /* About scan_data_t.
187 During optimisation we recurse through the regexp program performing
188 various inplace (keyhole style) optimisations. In addition study_chunk
189 and scan_commit populate this data structure with information about
190 what strings MUST appear in the pattern. We look for the longest
191 string that must appear for at a fixed location, and we look for the
192 longest string that may appear at a floating location. So for instance
197 Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
198 strings (because they follow a .* construct). study_chunk will identify
199 both FOO and BAR as being the longest fixed and floating strings respectively.
201 The strings can be composites, for instance
205 will result in a composite fixed substring 'foo'.
207 For each string some basic information is maintained:
209 - offset or min_offset
210 This is the position the string must appear at, or not before.
211 It also implicitly (when combined with minlenp) tells us how many
212 character must match before the string we are searching.
213 Likewise when combined with minlenp and the length of the string
214 tells us how many characters must appear after the string we have
218 Only used for floating strings. This is the rightmost point that
219 the string can appear at. Ifset to I32 max it indicates that the
220 string can occur infinitely far to the right.
223 A pointer to the minimum length of the pattern that the string
224 was found inside. This is important as in the case of positive
225 lookahead or positive lookbehind we can have multiple patterns
230 The minimum length of the pattern overall is 3, the minimum length
231 of the lookahead part is 3, but the minimum length of the part that
232 will actually match is 1. So 'FOO's minimum length is 3, but the
233 minimum length for the F is 1. This is important as the minimum length
234 is used to determine offsets in front of and behind the string being
235 looked for. Since strings can be composites this is the length of the
236 pattern at the time it was commited with a scan_commit. Note that
237 the length is calculated by study_chunk, so that the minimum lengths
238 are not known until the full pattern has been compiled, thus the
239 pointer to the value.
243 In the case of lookbehind the string being searched for can be
244 offset past the start point of the final matching string.
245 If this value was just blithely removed from the min_offset it would
246 invalidate some of the calculations for how many chars must match
247 before or after (as they are derived from min_offset and minlen and
248 the length of the string being searched for).
249 When the final pattern is compiled and the data is moved from the
250 scan_data_t structure into the regexp structure the information
251 about lookbehind is factored in, with the information that would
252 have been lost precalculated in the end_shift field for the
255 The fields pos_min and pos_delta are used to store the minimum offset
256 and the delta to the maximum offset at the current point in the pattern.
260 typedef struct scan_data_t {
261 /*I32 len_min; unused */
262 /*I32 len_delta; unused */
266 I32 last_end; /* min value, <0 unless valid. */
269 SV **longest; /* Either &l_fixed, or &l_float. */
270 SV *longest_fixed; /* longest fixed string found in pattern */
271 I32 offset_fixed; /* offset where it starts */
272 I32 *minlen_fixed; /* pointer to the minlen relevent to the string */
273 I32 lookbehind_fixed; /* is the position of the string modfied by LB */
274 SV *longest_float; /* longest floating string found in pattern */
275 I32 offset_float_min; /* earliest point in string it can appear */
276 I32 offset_float_max; /* latest point in string it can appear */
277 I32 *minlen_float; /* pointer to the minlen relevent to the string */
278 I32 lookbehind_float; /* is the position of the string modified by LB */
282 struct regnode_charclass_class *start_class;
286 * Forward declarations for pregcomp()'s friends.
289 static const scan_data_t zero_scan_data =
290 { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
292 #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
293 #define SF_BEFORE_SEOL 0x0001
294 #define SF_BEFORE_MEOL 0x0002
295 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
296 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
299 # define SF_FIX_SHIFT_EOL (0+2)
300 # define SF_FL_SHIFT_EOL (0+4)
302 # define SF_FIX_SHIFT_EOL (+2)
303 # define SF_FL_SHIFT_EOL (+4)
306 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
307 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
309 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
310 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
311 #define SF_IS_INF 0x0040
312 #define SF_HAS_PAR 0x0080
313 #define SF_IN_PAR 0x0100
314 #define SF_HAS_EVAL 0x0200
315 #define SCF_DO_SUBSTR 0x0400
316 #define SCF_DO_STCLASS_AND 0x0800
317 #define SCF_DO_STCLASS_OR 0x1000
318 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
319 #define SCF_WHILEM_VISITED_POS 0x2000
321 #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */
324 #define UTF (RExC_utf8 != 0)
325 #define LOC ((RExC_flags & PMf_LOCALE) != 0)
326 #define FOLD ((RExC_flags & PMf_FOLD) != 0)
328 #define OOB_UNICODE 12345678
329 #define OOB_NAMEDCLASS -1
331 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
332 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
335 /* length of regex to show in messages that don't mark a position within */
336 #define RegexLengthToShowInErrorMessages 127
339 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
340 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
341 * op/pragma/warn/regcomp.
343 #define MARKER1 "<-- HERE" /* marker as it appears in the description */
344 #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
346 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
349 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
350 * arg. Show regex, up to a maximum length. If it's too long, chop and add
353 #define FAIL(msg) STMT_START { \
354 const char *ellipses = ""; \
355 IV len = RExC_end - RExC_precomp; \
358 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
359 if (len > RegexLengthToShowInErrorMessages) { \
360 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
361 len = RegexLengthToShowInErrorMessages - 10; \
364 Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
365 msg, (int)len, RExC_precomp, ellipses); \
369 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
371 #define Simple_vFAIL(m) STMT_START { \
372 const IV offset = RExC_parse - RExC_precomp; \
373 Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
374 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
378 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
380 #define vFAIL(m) STMT_START { \
382 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
387 * Like Simple_vFAIL(), but accepts two arguments.
389 #define Simple_vFAIL2(m,a1) STMT_START { \
390 const IV offset = RExC_parse - RExC_precomp; \
391 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \
392 (int)offset, RExC_precomp, RExC_precomp + offset); \
396 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
398 #define vFAIL2(m,a1) STMT_START { \
400 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
401 Simple_vFAIL2(m, a1); \
406 * Like Simple_vFAIL(), but accepts three arguments.
408 #define Simple_vFAIL3(m, a1, a2) STMT_START { \
409 const IV offset = RExC_parse - RExC_precomp; \
410 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \
411 (int)offset, RExC_precomp, RExC_precomp + offset); \
415 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
417 #define vFAIL3(m,a1,a2) STMT_START { \
419 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx); \
420 Simple_vFAIL3(m, a1, a2); \
424 * Like Simple_vFAIL(), but accepts four arguments.
426 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \
427 const IV offset = RExC_parse - RExC_precomp; \
428 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, \
429 (int)offset, RExC_precomp, RExC_precomp + offset); \
432 #define vWARN(loc,m) STMT_START { \
433 const IV offset = loc - RExC_precomp; \
434 Perl_warner(aTHX_ packWARN(WARN_REGEXP), "%s" REPORT_LOCATION, \
435 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
438 #define vWARNdep(loc,m) STMT_START { \
439 const IV offset = loc - RExC_precomp; \
440 Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
441 "%s" REPORT_LOCATION, \
442 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
446 #define vWARN2(loc, m, a1) STMT_START { \
447 const IV offset = loc - RExC_precomp; \
448 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
449 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
452 #define vWARN3(loc, m, a1, a2) STMT_START { \
453 const IV offset = loc - RExC_precomp; \
454 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
455 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
458 #define vWARN4(loc, m, a1, a2, a3) STMT_START { \
459 const IV offset = loc - RExC_precomp; \
460 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
461 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
464 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \
465 const IV offset = loc - RExC_precomp; \
466 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
467 a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
471 /* Allow for side effects in s */
472 #define REGC(c,s) STMT_START { \
473 if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
476 /* Macros for recording node offsets. 20001227 mjd@plover.com
477 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
478 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
479 * Element 0 holds the number n.
480 * Position is 1 indexed.
483 #define Set_Node_Offset_To_R(node,byte) STMT_START { \
485 MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \
486 __LINE__, (node), (int)(byte))); \
488 Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
490 RExC_offsets[2*(node)-1] = (byte); \
495 #define Set_Node_Offset(node,byte) \
496 Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
497 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
499 #define Set_Node_Length_To_R(node,len) STMT_START { \
501 MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \
502 __LINE__, (int)(node), (int)(len))); \
504 Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
506 RExC_offsets[2*(node)] = (len); \
511 #define Set_Node_Length(node,len) \
512 Set_Node_Length_To_R((node)-RExC_emit_start, len)
513 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
514 #define Set_Node_Cur_Length(node) \
515 Set_Node_Length(node, RExC_parse - parse_start)
517 /* Get offsets and lengths */
518 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
519 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
521 #define Set_Node_Offset_Length(node,offset,len) STMT_START { \
522 Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \
523 Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \
527 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
528 #define EXPERIMENTAL_INPLACESCAN
531 #define DEBUG_STUDYDATA(data,depth) \
532 DEBUG_OPTIMISE_MORE_r(if(data){ \
533 PerlIO_printf(Perl_debug_log, \
534 "%*s"/* Len:%"IVdf"/%"IVdf" */" Pos:%"IVdf"/%"IVdf \
535 " Flags: %"IVdf" Whilem_c: %"IVdf" Lcp: %"IVdf" ", \
536 (int)(depth)*2, "", \
537 (IV)((data)->pos_min), \
538 (IV)((data)->pos_delta), \
539 (IV)((data)->flags), \
540 (IV)((data)->whilem_c), \
541 (IV)((data)->last_closep ? *((data)->last_closep) : -1) \
543 if ((data)->last_found) \
544 PerlIO_printf(Perl_debug_log, \
545 "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
546 " %sFloat: '%s' @ %"IVdf"/%"IVdf"", \
547 SvPVX_const((data)->last_found), \
548 (IV)((data)->last_end), \
549 (IV)((data)->last_start_min), \
550 (IV)((data)->last_start_max), \
551 ((data)->longest && \
552 (data)->longest==&((data)->longest_fixed)) ? "*" : "", \
553 SvPVX_const((data)->longest_fixed), \
554 (IV)((data)->offset_fixed), \
555 ((data)->longest && \
556 (data)->longest==&((data)->longest_float)) ? "*" : "", \
557 SvPVX_const((data)->longest_float), \
558 (IV)((data)->offset_float_min), \
559 (IV)((data)->offset_float_max) \
561 PerlIO_printf(Perl_debug_log,"\n"); \
564 static void clear_re(pTHX_ void *r);
566 /* Mark that we cannot extend a found fixed substring at this point.
567 Update the longest found anchored substring and the longest found
568 floating substrings if needed. */
571 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp)
573 const STRLEN l = CHR_SVLEN(data->last_found);
574 const STRLEN old_l = CHR_SVLEN(*data->longest);
575 GET_RE_DEBUG_FLAGS_DECL;
577 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
578 SvSetMagicSV(*data->longest, data->last_found);
579 if (*data->longest == data->longest_fixed) {
580 data->offset_fixed = l ? data->last_start_min : data->pos_min;
581 if (data->flags & SF_BEFORE_EOL)
583 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
585 data->flags &= ~SF_FIX_BEFORE_EOL;
586 data->minlen_fixed=minlenp;
587 data->lookbehind_fixed=0;
590 data->offset_float_min = l ? data->last_start_min : data->pos_min;
591 data->offset_float_max = (l
592 ? data->last_start_max
593 : data->pos_min + data->pos_delta);
594 if ((U32)data->offset_float_max > (U32)I32_MAX)
595 data->offset_float_max = I32_MAX;
596 if (data->flags & SF_BEFORE_EOL)
598 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
600 data->flags &= ~SF_FL_BEFORE_EOL;
601 data->minlen_float=minlenp;
602 data->lookbehind_float=0;
605 SvCUR_set(data->last_found, 0);
607 SV * const sv = data->last_found;
608 if (SvUTF8(sv) && SvMAGICAL(sv)) {
609 MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
615 data->flags &= ~SF_BEFORE_EOL;
616 DEBUG_STUDYDATA(data,0);
619 /* Can match anything (initialization) */
621 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
623 ANYOF_CLASS_ZERO(cl);
624 ANYOF_BITMAP_SETALL(cl);
625 cl->flags = ANYOF_EOS|ANYOF_UNICODE_ALL;
627 cl->flags |= ANYOF_LOCALE;
630 /* Can match anything (initialization) */
632 S_cl_is_anything(const struct regnode_charclass_class *cl)
636 for (value = 0; value <= ANYOF_MAX; value += 2)
637 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
639 if (!(cl->flags & ANYOF_UNICODE_ALL))
641 if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
646 /* Can match anything (initialization) */
648 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
650 Zero(cl, 1, struct regnode_charclass_class);
652 cl_anything(pRExC_state, cl);
656 S_cl_init_zero(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
658 Zero(cl, 1, struct regnode_charclass_class);
660 cl_anything(pRExC_state, cl);
662 cl->flags |= ANYOF_LOCALE;
665 /* 'And' a given class with another one. Can create false positives */
666 /* We assume that cl is not inverted */
668 S_cl_and(struct regnode_charclass_class *cl,
669 const struct regnode_charclass_class *and_with)
671 if (!(and_with->flags & ANYOF_CLASS)
672 && !(cl->flags & ANYOF_CLASS)
673 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
674 && !(and_with->flags & ANYOF_FOLD)
675 && !(cl->flags & ANYOF_FOLD)) {
678 if (and_with->flags & ANYOF_INVERT)
679 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
680 cl->bitmap[i] &= ~and_with->bitmap[i];
682 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
683 cl->bitmap[i] &= and_with->bitmap[i];
684 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
685 if (!(and_with->flags & ANYOF_EOS))
686 cl->flags &= ~ANYOF_EOS;
688 if (cl->flags & ANYOF_UNICODE_ALL && and_with->flags & ANYOF_UNICODE &&
689 !(and_with->flags & ANYOF_INVERT)) {
690 cl->flags &= ~ANYOF_UNICODE_ALL;
691 cl->flags |= ANYOF_UNICODE;
692 ARG_SET(cl, ARG(and_with));
694 if (!(and_with->flags & ANYOF_UNICODE_ALL) &&
695 !(and_with->flags & ANYOF_INVERT))
696 cl->flags &= ~ANYOF_UNICODE_ALL;
697 if (!(and_with->flags & (ANYOF_UNICODE|ANYOF_UNICODE_ALL)) &&
698 !(and_with->flags & ANYOF_INVERT))
699 cl->flags &= ~ANYOF_UNICODE;
702 /* 'OR' a given class with another one. Can create false positives */
703 /* We assume that cl is not inverted */
705 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
707 if (or_with->flags & ANYOF_INVERT) {
709 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
710 * <= (B1 | !B2) | (CL1 | !CL2)
711 * which is wasteful if CL2 is small, but we ignore CL2:
712 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
713 * XXXX Can we handle case-fold? Unclear:
714 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
715 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
717 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
718 && !(or_with->flags & ANYOF_FOLD)
719 && !(cl->flags & ANYOF_FOLD) ) {
722 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
723 cl->bitmap[i] |= ~or_with->bitmap[i];
724 } /* XXXX: logic is complicated otherwise */
726 cl_anything(pRExC_state, cl);
729 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
730 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
731 && (!(or_with->flags & ANYOF_FOLD)
732 || (cl->flags & ANYOF_FOLD)) ) {
735 /* OR char bitmap and class bitmap separately */
736 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
737 cl->bitmap[i] |= or_with->bitmap[i];
738 if (or_with->flags & ANYOF_CLASS) {
739 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
740 cl->classflags[i] |= or_with->classflags[i];
741 cl->flags |= ANYOF_CLASS;
744 else { /* XXXX: logic is complicated, leave it along for a moment. */
745 cl_anything(pRExC_state, cl);
748 if (or_with->flags & ANYOF_EOS)
749 cl->flags |= ANYOF_EOS;
751 if (cl->flags & ANYOF_UNICODE && or_with->flags & ANYOF_UNICODE &&
752 ARG(cl) != ARG(or_with)) {
753 cl->flags |= ANYOF_UNICODE_ALL;
754 cl->flags &= ~ANYOF_UNICODE;
756 if (or_with->flags & ANYOF_UNICODE_ALL) {
757 cl->flags |= ANYOF_UNICODE_ALL;
758 cl->flags &= ~ANYOF_UNICODE;
762 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
763 #define TRIE_LIST_CUR(state) ( TRIE_LIST_ITEM( state, 0 ).forid )
764 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
765 #define TRIE_LIST_USED(idx) ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
771 dump_trie_interim_list(trie,next_alloc)
772 dump_trie_interim_table(trie,next_alloc)
774 These routines dump out a trie in a somewhat readable format.
775 The _interim_ variants are used for debugging the interim
776 tables that are used to generate the final compressed
777 representation which is what dump_trie expects.
779 Part of the reason for their existance is to provide a form
780 of documentation as to how the different representations function.
786 Dumps the final compressed table form of the trie to Perl_debug_log.
787 Used for debugging make_trie().
791 S_dump_trie(pTHX_ const struct _reg_trie_data *trie,U32 depth)
794 SV *sv=sv_newmortal();
795 int colwidth= trie->widecharmap ? 6 : 4;
796 GET_RE_DEBUG_FLAGS_DECL;
799 PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
800 (int)depth * 2 + 2,"",
801 "Match","Base","Ofs" );
803 for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
804 SV ** const tmp = av_fetch( trie->revcharmap, state, 0);
806 PerlIO_printf( Perl_debug_log, "%*s",
808 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
809 PL_colors[0], PL_colors[1],
810 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
811 PERL_PV_ESCAPE_FIRSTCHAR
816 PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
817 (int)depth * 2 + 2,"");
819 for( state = 0 ; state < trie->uniquecharcount ; state++ )
820 PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
821 PerlIO_printf( Perl_debug_log, "\n");
823 for( state = 1 ; state < trie->statecount ; state++ ) {
824 const U32 base = trie->states[ state ].trans.base;
826 PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
828 if ( trie->states[ state ].wordnum ) {
829 PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
831 PerlIO_printf( Perl_debug_log, "%6s", "" );
834 PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
839 while( ( base + ofs < trie->uniquecharcount ) ||
840 ( base + ofs - trie->uniquecharcount < trie->lasttrans
841 && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
844 PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
846 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
847 if ( ( base + ofs >= trie->uniquecharcount ) &&
848 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
849 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
851 PerlIO_printf( Perl_debug_log, "%*"UVXf,
853 (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
855 PerlIO_printf( Perl_debug_log, "%*s",colwidth," ." );
859 PerlIO_printf( Perl_debug_log, "]");
862 PerlIO_printf( Perl_debug_log, "\n" );
866 dump_trie_interim_list(trie,next_alloc)
867 Dumps a fully constructed but uncompressed trie in list form.
868 List tries normally only are used for construction when the number of
869 possible chars (trie->uniquecharcount) is very high.
870 Used for debugging make_trie().
873 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc,U32 depth)
876 SV *sv=sv_newmortal();
877 int colwidth= trie->widecharmap ? 6 : 4;
878 GET_RE_DEBUG_FLAGS_DECL;
879 /* print out the table precompression. */
880 PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
881 (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
882 "------:-----+-----------------\n" );
884 for( state=1 ; state < next_alloc ; state ++ ) {
887 PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
888 (int)depth * 2 + 2,"", (UV)state );
889 if ( ! trie->states[ state ].wordnum ) {
890 PerlIO_printf( Perl_debug_log, "%5s| ","");
892 PerlIO_printf( Perl_debug_log, "W%4x| ",
893 trie->states[ state ].wordnum
896 for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
897 SV ** const tmp = av_fetch( trie->revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
899 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
901 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
902 PL_colors[0], PL_colors[1],
903 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
904 PERL_PV_ESCAPE_FIRSTCHAR
906 TRIE_LIST_ITEM(state,charid).forid,
907 (UV)TRIE_LIST_ITEM(state,charid).newstate
910 PerlIO_printf(Perl_debug_log, "\n%*s| ",
911 (int)((depth * 2) + 14), "");
914 PerlIO_printf( Perl_debug_log, "\n");
919 dump_trie_interim_table(trie,next_alloc)
920 Dumps a fully constructed but uncompressed trie in table form.
921 This is the normal DFA style state transition table, with a few
922 twists to facilitate compression later.
923 Used for debugging make_trie().
926 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie, U32 next_alloc, U32 depth)
930 SV *sv=sv_newmortal();
931 int colwidth= trie->widecharmap ? 6 : 4;
932 GET_RE_DEBUG_FLAGS_DECL;
935 print out the table precompression so that we can do a visual check
936 that they are identical.
939 PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
941 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
942 SV ** const tmp = av_fetch( trie->revcharmap, charid, 0);
944 PerlIO_printf( Perl_debug_log, "%*s",
946 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
947 PL_colors[0], PL_colors[1],
948 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
949 PERL_PV_ESCAPE_FIRSTCHAR
955 PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
957 for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
958 PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
961 PerlIO_printf( Perl_debug_log, "\n" );
963 for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
965 PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
966 (int)depth * 2 + 2,"",
967 (UV)TRIE_NODENUM( state ) );
969 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
970 UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
972 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
974 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
976 if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
977 PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
979 PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
980 trie->states[ TRIE_NODENUM( state ) ].wordnum );
987 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
988 startbranch: the first branch in the whole branch sequence
989 first : start branch of sequence of branch-exact nodes.
990 May be the same as startbranch
991 last : Thing following the last branch.
992 May be the same as tail.
993 tail : item following the branch sequence
994 count : words in the sequence
995 flags : currently the OP() type we will be building one of /EXACT(|F|Fl)/
998 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1000 A trie is an N'ary tree where the branches are determined by digital
1001 decomposition of the key. IE, at the root node you look up the 1st character and
1002 follow that branch repeat until you find the end of the branches. Nodes can be
1003 marked as "accepting" meaning they represent a complete word. Eg:
1007 would convert into the following structure. Numbers represent states, letters
1008 following numbers represent valid transitions on the letter from that state, if
1009 the number is in square brackets it represents an accepting state, otherwise it
1010 will be in parenthesis.
1012 +-h->+-e->[3]-+-r->(8)-+-s->[9]
1016 (1) +-i->(6)-+-s->[7]
1018 +-s->(3)-+-h->(4)-+-e->[5]
1020 Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1022 This shows that when matching against the string 'hers' we will begin at state 1
1023 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1024 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1025 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1026 single traverse. We store a mapping from accepting to state to which word was
1027 matched, and then when we have multiple possibilities we try to complete the
1028 rest of the regex in the order in which they occured in the alternation.
1030 The only prior NFA like behaviour that would be changed by the TRIE support is
1031 the silent ignoring of duplicate alternations which are of the form:
1033 / (DUPE|DUPE) X? (?{ ... }) Y /x
1035 Thus EVAL blocks follwing a trie may be called a different number of times with
1036 and without the optimisation. With the optimisations dupes will be silently
1037 ignored. This inconsistant behaviour of EVAL type nodes is well established as
1038 the following demonstrates:
1040 'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1042 which prints out 'word' three times, but
1044 'words'=~/(word|word|word)(?{ print $1 })S/
1046 which doesnt print it out at all. This is due to other optimisations kicking in.
1048 Example of what happens on a structural level:
1050 The regexp /(ac|ad|ab)+/ will produce the folowing debug output:
1052 1: CURLYM[1] {1,32767}(18)
1063 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1064 and should turn into:
1066 1: CURLYM[1] {1,32767}(18)
1068 [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1076 Cases where tail != last would be like /(?foo|bar)baz/:
1086 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1087 and would end up looking like:
1090 [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1097 d = uvuni_to_utf8_flags(d, uv, 0);
1099 is the recommended Unicode-aware way of saying
1104 #define TRIE_STORE_REVCHAR \
1106 SV *tmp = newSVpvs(""); \
1107 if (UTF) SvUTF8_on(tmp); \
1108 Perl_sv_catpvf( aTHX_ tmp, "%c", (int)uvc ); \
1109 av_push( TRIE_REVCHARMAP(trie), tmp ); \
1112 #define TRIE_READ_CHAR STMT_START { \
1116 if ( foldlen > 0 ) { \
1117 uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags ); \
1122 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1123 uvc = to_uni_fold( uvc, foldbuf, &foldlen ); \
1124 foldlen -= UNISKIP( uvc ); \
1125 scan = foldbuf + UNISKIP( uvc ); \
1128 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1138 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \
1139 if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \
1140 U32 ging = TRIE_LIST_LEN( state ) *= 2; \
1141 Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1143 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \
1144 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns; \
1145 TRIE_LIST_CUR( state )++; \
1148 #define TRIE_LIST_NEW(state) STMT_START { \
1149 Newxz( trie->states[ state ].trans.list, \
1150 4, reg_trie_trans_le ); \
1151 TRIE_LIST_CUR( state ) = 1; \
1152 TRIE_LIST_LEN( state ) = 4; \
1155 #define TRIE_HANDLE_WORD(state) STMT_START { \
1156 U16 dupe= trie->states[ state ].wordnum; \
1157 regnode * const noper_next = regnext( noper ); \
1159 if (trie->wordlen) \
1160 trie->wordlen[ curword ] = wordlen; \
1162 /* store the word for dumping */ \
1164 if (OP(noper) != NOTHING) \
1165 tmp = newSVpvn(STRING(noper), STR_LEN(noper)); \
1167 tmp = newSVpvn( "", 0 ); \
1168 if ( UTF ) SvUTF8_on( tmp ); \
1169 av_push( trie->words, tmp ); \
1174 if ( noper_next < tail ) { \
1176 Newxz( trie->jump, word_count + 1, U16); \
1177 trie->jump[curword] = (U16)(tail - noper_next); \
1179 jumper = noper_next; \
1181 nextbranch= regnext(cur); \
1185 /* So it's a dupe. This means we need to maintain a */\
1186 /* linked-list from the first to the next. */\
1187 /* we only allocate the nextword buffer when there */\
1188 /* a dupe, so first time we have to do the allocation */\
1189 if (!trie->nextword) \
1190 Newxz( trie->nextword, word_count + 1, U16); \
1191 while ( trie->nextword[dupe] ) \
1192 dupe= trie->nextword[dupe]; \
1193 trie->nextword[dupe]= curword; \
1195 /* we haven't inserted this word yet. */ \
1196 trie->states[ state ].wordnum = curword; \
1201 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special) \
1202 ( ( base + charid >= ucharcount \
1203 && base + charid < ubound \
1204 && state == trie->trans[ base - ucharcount + charid ].check \
1205 && trie->trans[ base - ucharcount + charid ].next ) \
1206 ? trie->trans[ base - ucharcount + charid ].next \
1207 : ( state==1 ? special : 0 ) \
1211 #define MADE_JUMP_TRIE 2
1212 #define MADE_EXACT_TRIE 4
1215 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1218 /* first pass, loop through and scan words */
1219 reg_trie_data *trie;
1221 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1226 regnode *jumper = NULL;
1227 regnode *nextbranch = NULL;
1228 /* we just use folder as a flag in utf8 */
1229 const U8 * const folder = ( flags == EXACTF
1231 : ( flags == EXACTFL
1237 const U32 data_slot = add_data( pRExC_state, 1, "t" );
1238 SV *re_trie_maxbuff;
1240 /* these are only used during construction but are useful during
1241 * debugging so we store them in the struct when debugging.
1243 STRLEN trie_charcount=0;
1244 AV *trie_revcharmap;
1246 GET_RE_DEBUG_FLAGS_DECL;
1248 PERL_UNUSED_ARG(depth);
1251 Newxz( trie, 1, reg_trie_data );
1253 trie->startstate = 1;
1254 trie->wordcount = word_count;
1255 RExC_rx->data->data[ data_slot ] = (void*)trie;
1256 Newxz( trie->charmap, 256, U16 );
1257 if (!(UTF && folder))
1258 Newxz( trie->bitmap, ANYOF_BITMAP_SIZE, char );
1260 trie->words = newAV();
1262 TRIE_REVCHARMAP(trie) = newAV();
1264 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1265 if (!SvIOK(re_trie_maxbuff)) {
1266 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1269 PerlIO_printf( Perl_debug_log,
1270 "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1271 (int)depth * 2 + 2, "",
1272 REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
1273 REG_NODE_NUM(last), REG_NODE_NUM(tail),
1276 /* -- First loop and Setup --
1278 We first traverse the branches and scan each word to determine if it
1279 contains widechars, and how many unique chars there are, this is
1280 important as we have to build a table with at least as many columns as we
1283 We use an array of integers to represent the character codes 0..255
1284 (trie->charmap) and we use a an HV* to store unicode characters. We use the
1285 native representation of the character value as the key and IV's for the
1288 *TODO* If we keep track of how many times each character is used we can
1289 remap the columns so that the table compression later on is more
1290 efficient in terms of memory by ensuring most common value is in the
1291 middle and the least common are on the outside. IMO this would be better
1292 than a most to least common mapping as theres a decent chance the most
1293 common letter will share a node with the least common, meaning the node
1294 will not be compressable. With a middle is most common approach the worst
1295 case is when we have the least common nodes twice.
1299 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1300 regnode * const noper = NEXTOPER( cur );
1301 const U8 *uc = (U8*)STRING( noper );
1302 const U8 * const e = uc + STR_LEN( noper );
1304 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1305 const U8 *scan = (U8*)NULL;
1306 U32 wordlen = 0; /* required init */
1309 if (OP(noper) == NOTHING) {
1314 TRIE_BITMAP_SET(trie,*uc);
1315 if ( folder ) TRIE_BITMAP_SET(trie,folder[ *uc ]);
1317 for ( ; uc < e ; uc += len ) {
1318 TRIE_CHARCOUNT(trie)++;
1322 if ( !trie->charmap[ uvc ] ) {
1323 trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1325 trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1330 if ( !trie->widecharmap )
1331 trie->widecharmap = newHV();
1333 svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1336 Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1338 if ( !SvTRUE( *svpp ) ) {
1339 sv_setiv( *svpp, ++trie->uniquecharcount );
1344 if( cur == first ) {
1347 } else if (chars < trie->minlen) {
1349 } else if (chars > trie->maxlen) {
1353 } /* end first pass */
1354 DEBUG_TRIE_COMPILE_r(
1355 PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1356 (int)depth * 2 + 2,"",
1357 ( trie->widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1358 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1359 (int)trie->minlen, (int)trie->maxlen )
1361 Newxz( trie->wordlen, word_count, U32 );
1364 We now know what we are dealing with in terms of unique chars and
1365 string sizes so we can calculate how much memory a naive
1366 representation using a flat table will take. If it's over a reasonable
1367 limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1368 conservative but potentially much slower representation using an array
1371 At the end we convert both representations into the same compressed
1372 form that will be used in regexec.c for matching with. The latter
1373 is a form that cannot be used to construct with but has memory
1374 properties similar to the list form and access properties similar
1375 to the table form making it both suitable for fast searches and
1376 small enough that its feasable to store for the duration of a program.
1378 See the comment in the code where the compressed table is produced
1379 inplace from the flat tabe representation for an explanation of how
1380 the compression works.
1385 if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1387 Second Pass -- Array Of Lists Representation
1389 Each state will be represented by a list of charid:state records
1390 (reg_trie_trans_le) the first such element holds the CUR and LEN
1391 points of the allocated array. (See defines above).
1393 We build the initial structure using the lists, and then convert
1394 it into the compressed table form which allows faster lookups
1395 (but cant be modified once converted).
1398 STRLEN transcount = 1;
1400 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1401 "%*sCompiling trie using list compiler\n",
1402 (int)depth * 2 + 2, ""));
1404 Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state );
1408 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1410 regnode * const noper = NEXTOPER( cur );
1411 U8 *uc = (U8*)STRING( noper );
1412 const U8 * const e = uc + STR_LEN( noper );
1413 U32 state = 1; /* required init */
1414 U16 charid = 0; /* sanity init */
1415 U8 *scan = (U8*)NULL; /* sanity init */
1416 STRLEN foldlen = 0; /* required init */
1417 U32 wordlen = 0; /* required init */
1418 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1420 if (OP(noper) != NOTHING) {
1421 for ( ; uc < e ; uc += len ) {
1426 charid = trie->charmap[ uvc ];
1428 SV** const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0);
1432 charid=(U16)SvIV( *svpp );
1435 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1442 if ( !trie->states[ state ].trans.list ) {
1443 TRIE_LIST_NEW( state );
1445 for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1446 if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1447 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1452 newstate = next_alloc++;
1453 TRIE_LIST_PUSH( state, charid, newstate );
1458 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1462 TRIE_HANDLE_WORD(state);
1464 } /* end second pass */
1466 /* next alloc is the NEXT state to be allocated */
1467 trie->statecount = next_alloc;
1468 Renew( trie->states, next_alloc, reg_trie_state );
1470 /* and now dump it out before we compress it */
1471 DEBUG_TRIE_COMPILE_MORE_r(
1472 dump_trie_interim_list(trie,next_alloc,depth+1)
1475 Newxz( trie->trans, transcount ,reg_trie_trans );
1482 for( state=1 ; state < next_alloc ; state ++ ) {
1486 DEBUG_TRIE_COMPILE_MORE_r(
1487 PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1491 if (trie->states[state].trans.list) {
1492 U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1496 for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1497 const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1498 if ( forid < minid ) {
1500 } else if ( forid > maxid ) {
1504 if ( transcount < tp + maxid - minid + 1) {
1506 Renew( trie->trans, transcount, reg_trie_trans );
1507 Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1509 base = trie->uniquecharcount + tp - minid;
1510 if ( maxid == minid ) {
1512 for ( ; zp < tp ; zp++ ) {
1513 if ( ! trie->trans[ zp ].next ) {
1514 base = trie->uniquecharcount + zp - minid;
1515 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1516 trie->trans[ zp ].check = state;
1522 trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1523 trie->trans[ tp ].check = state;
1528 for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1529 const U32 tid = base - trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1530 trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1531 trie->trans[ tid ].check = state;
1533 tp += ( maxid - minid + 1 );
1535 Safefree(trie->states[ state ].trans.list);
1538 DEBUG_TRIE_COMPILE_MORE_r(
1539 PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1542 trie->states[ state ].trans.base=base;
1544 trie->lasttrans = tp + 1;
1548 Second Pass -- Flat Table Representation.
1550 we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1551 We know that we will need Charcount+1 trans at most to store the data
1552 (one row per char at worst case) So we preallocate both structures
1553 assuming worst case.
1555 We then construct the trie using only the .next slots of the entry
1558 We use the .check field of the first entry of the node temporarily to
1559 make compression both faster and easier by keeping track of how many non
1560 zero fields are in the node.
1562 Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1565 There are two terms at use here: state as a TRIE_NODEIDX() which is a
1566 number representing the first entry of the node, and state as a
1567 TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1568 TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1569 are 2 entrys per node. eg:
1577 The table is internally in the right hand, idx form. However as we also
1578 have to deal with the states array which is indexed by nodenum we have to
1579 use TRIE_NODENUM() to convert.
1582 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1583 "%*sCompiling trie using table compiler\n",
1584 (int)depth * 2 + 2, ""));
1586 Newxz( trie->trans, ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1,
1588 Newxz( trie->states, TRIE_CHARCOUNT(trie) + 2, reg_trie_state );
1589 next_alloc = trie->uniquecharcount + 1;
1592 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1594 regnode * const noper = NEXTOPER( cur );
1595 const U8 *uc = (U8*)STRING( noper );
1596 const U8 * const e = uc + STR_LEN( noper );
1598 U32 state = 1; /* required init */
1600 U16 charid = 0; /* sanity init */
1601 U32 accept_state = 0; /* sanity init */
1602 U8 *scan = (U8*)NULL; /* sanity init */
1604 STRLEN foldlen = 0; /* required init */
1605 U32 wordlen = 0; /* required init */
1606 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1608 if ( OP(noper) != NOTHING ) {
1609 for ( ; uc < e ; uc += len ) {
1614 charid = trie->charmap[ uvc ];
1616 SV* const * const svpp = hv_fetch( trie->widecharmap, (char*)&uvc, sizeof( UV ), 0);
1617 charid = svpp ? (U16)SvIV(*svpp) : 0;
1621 if ( !trie->trans[ state + charid ].next ) {
1622 trie->trans[ state + charid ].next = next_alloc;
1623 trie->trans[ state ].check++;
1624 next_alloc += trie->uniquecharcount;
1626 state = trie->trans[ state + charid ].next;
1628 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1630 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1633 accept_state = TRIE_NODENUM( state );
1634 TRIE_HANDLE_WORD(accept_state);
1636 } /* end second pass */
1638 /* and now dump it out before we compress it */
1639 DEBUG_TRIE_COMPILE_MORE_r(
1640 dump_trie_interim_table(trie,next_alloc,depth+1)
1645 * Inplace compress the table.*
1647 For sparse data sets the table constructed by the trie algorithm will
1648 be mostly 0/FAIL transitions or to put it another way mostly empty.
1649 (Note that leaf nodes will not contain any transitions.)
1651 This algorithm compresses the tables by eliminating most such
1652 transitions, at the cost of a modest bit of extra work during lookup:
1654 - Each states[] entry contains a .base field which indicates the
1655 index in the state[] array wheres its transition data is stored.
1657 - If .base is 0 there are no valid transitions from that node.
1659 - If .base is nonzero then charid is added to it to find an entry in
1662 -If trans[states[state].base+charid].check!=state then the
1663 transition is taken to be a 0/Fail transition. Thus if there are fail
1664 transitions at the front of the node then the .base offset will point
1665 somewhere inside the previous nodes data (or maybe even into a node
1666 even earlier), but the .check field determines if the transition is
1670 The following process inplace converts the table to the compressed
1671 table: We first do not compress the root node 1,and mark its all its
1672 .check pointers as 1 and set its .base pointer as 1 as well. This
1673 allows to do a DFA construction from the compressed table later, and
1674 ensures that any .base pointers we calculate later are greater than
1677 - We set 'pos' to indicate the first entry of the second node.
1679 - We then iterate over the columns of the node, finding the first and
1680 last used entry at l and m. We then copy l..m into pos..(pos+m-l),
1681 and set the .check pointers accordingly, and advance pos
1682 appropriately and repreat for the next node. Note that when we copy
1683 the next pointers we have to convert them from the original
1684 NODEIDX form to NODENUM form as the former is not valid post
1687 - If a node has no transitions used we mark its base as 0 and do not
1688 advance the pos pointer.
1690 - If a node only has one transition we use a second pointer into the
1691 structure to fill in allocated fail transitions from other states.
1692 This pointer is independent of the main pointer and scans forward
1693 looking for null transitions that are allocated to a state. When it
1694 finds one it writes the single transition into the "hole". If the
1695 pointer doesnt find one the single transition is appended as normal.
1697 - Once compressed we can Renew/realloc the structures to release the
1700 See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
1701 specifically Fig 3.47 and the associated pseudocode.
1705 const U32 laststate = TRIE_NODENUM( next_alloc );
1708 trie->statecount = laststate;
1710 for ( state = 1 ; state < laststate ; state++ ) {
1712 const U32 stateidx = TRIE_NODEIDX( state );
1713 const U32 o_used = trie->trans[ stateidx ].check;
1714 U32 used = trie->trans[ stateidx ].check;
1715 trie->trans[ stateidx ].check = 0;
1717 for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
1718 if ( flag || trie->trans[ stateidx + charid ].next ) {
1719 if ( trie->trans[ stateidx + charid ].next ) {
1721 for ( ; zp < pos ; zp++ ) {
1722 if ( ! trie->trans[ zp ].next ) {
1726 trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
1727 trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1728 trie->trans[ zp ].check = state;
1729 if ( ++zp > pos ) pos = zp;
1736 trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
1738 trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
1739 trie->trans[ pos ].check = state;
1744 trie->lasttrans = pos + 1;
1745 Renew( trie->states, laststate, reg_trie_state);
1746 DEBUG_TRIE_COMPILE_MORE_r(
1747 PerlIO_printf( Perl_debug_log,
1748 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
1749 (int)depth * 2 + 2,"",
1750 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
1753 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
1756 } /* end table compress */
1758 DEBUG_TRIE_COMPILE_MORE_r(
1759 PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
1760 (int)depth * 2 + 2, "",
1761 (UV)trie->statecount,
1762 (UV)trie->lasttrans)
1764 /* resize the trans array to remove unused space */
1765 Renew( trie->trans, trie->lasttrans, reg_trie_trans);
1767 /* and now dump out the compressed format */
1768 DEBUG_TRIE_COMPILE_r(
1769 dump_trie(trie,depth+1)
1772 { /* Modify the program and insert the new TRIE node*/
1774 U8 nodetype =(U8)(flags & 0xFF);
1778 regnode *optimize = NULL;
1780 U32 mjd_nodelen = 0;
1783 This means we convert either the first branch or the first Exact,
1784 depending on whether the thing following (in 'last') is a branch
1785 or not and whther first is the startbranch (ie is it a sub part of
1786 the alternation or is it the whole thing.)
1787 Assuming its a sub part we conver the EXACT otherwise we convert
1788 the whole branch sequence, including the first.
1790 /* Find the node we are going to overwrite */
1791 if ( first == startbranch && OP( last ) != BRANCH ) {
1792 /* whole branch chain */
1795 const regnode *nop = NEXTOPER( convert );
1796 mjd_offset= Node_Offset((nop));
1797 mjd_nodelen= Node_Length((nop));
1800 /* branch sub-chain */
1801 convert = NEXTOPER( first );
1802 NEXT_OFF( first ) = (U16)(last - first);
1804 mjd_offset= Node_Offset((convert));
1805 mjd_nodelen= Node_Length((convert));
1809 PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
1810 (int)depth * 2 + 2, "",
1811 (UV)mjd_offset, (UV)mjd_nodelen)
1814 /* But first we check to see if there is a common prefix we can
1815 split out as an EXACT and put in front of the TRIE node. */
1816 trie->startstate= 1;
1817 if ( trie->bitmap && !trie->widecharmap && !trie->jump ) {
1819 for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
1823 const U32 base = trie->states[ state ].trans.base;
1825 if ( trie->states[state].wordnum )
1828 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1829 if ( ( base + ofs >= trie->uniquecharcount ) &&
1830 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1831 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1833 if ( ++count > 1 ) {
1834 SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), ofs, 0);
1835 const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
1836 if ( state == 1 ) break;
1838 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
1840 PerlIO_printf(Perl_debug_log,
1841 "%*sNew Start State=%"UVuf" Class: [",
1842 (int)depth * 2 + 2, "",
1845 SV ** const tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
1846 const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
1848 TRIE_BITMAP_SET(trie,*ch);
1850 TRIE_BITMAP_SET(trie, folder[ *ch ]);
1852 PerlIO_printf(Perl_debug_log, (char*)ch)
1856 TRIE_BITMAP_SET(trie,*ch);
1858 TRIE_BITMAP_SET(trie,folder[ *ch ]);
1859 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
1865 SV **tmp = av_fetch( TRIE_REVCHARMAP(trie), idx, 0);
1866 const char *ch = SvPV_nolen_const( *tmp );
1868 PerlIO_printf( Perl_debug_log,
1869 "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
1870 (int)depth * 2 + 2, "",
1871 (UV)state, (UV)idx, ch)
1874 OP( convert ) = nodetype;
1875 str=STRING(convert);
1884 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
1890 regnode *n = convert+NODE_SZ_STR(convert);
1891 NEXT_OFF(convert) = NODE_SZ_STR(convert);
1892 trie->startstate = state;
1893 trie->minlen -= (state - 1);
1894 trie->maxlen -= (state - 1);
1896 regnode *fix = convert;
1898 Set_Node_Offset_Length(convert, mjd_offset, state - 1);
1899 while( ++fix < n ) {
1900 Set_Node_Offset_Length(fix, 0, 0);
1906 NEXT_OFF(convert) = (U16)(tail - convert);
1907 DEBUG_r(optimize= n);
1913 if ( trie->maxlen ) {
1914 NEXT_OFF( convert ) = (U16)(tail - convert);
1915 ARG_SET( convert, data_slot );
1916 /* Store the offset to the first unabsorbed branch in
1917 jump[0], which is otherwise unused by the jump logic.
1918 We use this when dumping a trie and during optimisation. */
1920 trie->jump[0] = (U16)(tail - nextbranch);
1923 if ( !trie->states[trie->startstate].wordnum && trie->bitmap &&
1924 ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
1926 OP( convert ) = TRIEC;
1927 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
1928 Safefree(trie->bitmap);
1931 OP( convert ) = TRIE;
1933 /* store the type in the flags */
1934 convert->flags = nodetype;
1938 + regarglen[ OP( convert ) ];
1940 /* XXX We really should free up the resource in trie now,
1941 as we won't use them - (which resources?) dmq */
1943 /* needed for dumping*/
1944 DEBUG_r(if (optimize) {
1945 regnode *opt = convert;
1946 while ( ++opt < optimize) {
1947 Set_Node_Offset_Length(opt,0,0);
1950 Try to clean up some of the debris left after the
1953 while( optimize < jumper ) {
1954 mjd_nodelen += Node_Length((optimize));
1955 OP( optimize ) = OPTIMIZED;
1956 Set_Node_Offset_Length(optimize,0,0);
1959 Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
1961 } /* end node insert */
1963 SvREFCNT_dec(TRIE_REVCHARMAP(trie));
1967 : trie->startstate>1
1973 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
1975 /* The Trie is constructed and compressed now so we can build a fail array now if its needed
1977 This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
1978 "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
1981 We find the fail state for each state in the trie, this state is the longest proper
1982 suffix of the current states 'word' that is also a proper prefix of another word in our
1983 trie. State 1 represents the word '' and is the thus the default fail state. This allows
1984 the DFA not to have to restart after its tried and failed a word at a given point, it
1985 simply continues as though it had been matching the other word in the first place.
1987 'abcdgu'=~/abcdefg|cdgu/
1988 When we get to 'd' we are still matching the first word, we would encounter 'g' which would
1989 fail, which would bring use to the state representing 'd' in the second word where we would
1990 try 'g' and succeed, prodceding to match 'cdgu'.
1992 /* add a fail transition */
1993 reg_trie_data *trie=(reg_trie_data *)RExC_rx->data->data[ARG(source)];
1995 const U32 ucharcount = trie->uniquecharcount;
1996 const U32 numstates = trie->statecount;
1997 const U32 ubound = trie->lasttrans + ucharcount;
2001 U32 base = trie->states[ 1 ].trans.base;
2004 const U32 data_slot = add_data( pRExC_state, 1, "T" );
2005 GET_RE_DEBUG_FLAGS_DECL;
2007 PERL_UNUSED_ARG(depth);
2011 ARG_SET( stclass, data_slot );
2012 Newxz( aho, 1, reg_ac_data );
2013 RExC_rx->data->data[ data_slot ] = (void*)aho;
2015 aho->states=(reg_trie_state *)savepvn((const char*)trie->states,
2016 numstates * sizeof(reg_trie_state));
2017 Newxz( q, numstates, U32);
2018 Newxz( aho->fail, numstates, U32 );
2021 /* initialize fail[0..1] to be 1 so that we always have
2022 a valid final fail state */
2023 fail[ 0 ] = fail[ 1 ] = 1;
2025 for ( charid = 0; charid < ucharcount ; charid++ ) {
2026 const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2028 q[ q_write ] = newstate;
2029 /* set to point at the root */
2030 fail[ q[ q_write++ ] ]=1;
2033 while ( q_read < q_write) {
2034 const U32 cur = q[ q_read++ % numstates ];
2035 base = trie->states[ cur ].trans.base;
2037 for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2038 const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2040 U32 fail_state = cur;
2043 fail_state = fail[ fail_state ];
2044 fail_base = aho->states[ fail_state ].trans.base;
2045 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2047 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2048 fail[ ch_state ] = fail_state;
2049 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2051 aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
2053 q[ q_write++ % numstates] = ch_state;
2057 /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2058 when we fail in state 1, this allows us to use the
2059 charclass scan to find a valid start char. This is based on the principle
2060 that theres a good chance the string being searched contains lots of stuff
2061 that cant be a start char.
2063 fail[ 0 ] = fail[ 1 ] = 0;
2064 DEBUG_TRIE_COMPILE_r({
2065 PerlIO_printf(Perl_debug_log, "%*sStclass Failtable (%"UVuf" states): 0",
2066 (int)(depth * 2), "", numstates
2068 for( q_read=1; q_read<numstates; q_read++ ) {
2069 PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2071 PerlIO_printf(Perl_debug_log, "\n");
2074 /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2079 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2080 * These need to be revisited when a newer toolchain becomes available.
2082 #if defined(__sparc64__) && defined(__GNUC__)
2083 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2084 # undef SPARC64_GCC_WORKAROUND
2085 # define SPARC64_GCC_WORKAROUND 1
2089 #define DEBUG_PEEP(str,scan,depth) \
2090 DEBUG_OPTIMISE_r({ \
2091 SV * const mysv=sv_newmortal(); \
2092 regnode *Next = regnext(scan); \
2093 regprop(RExC_rx, mysv, scan); \
2094 PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s [%d]\n", \
2095 (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2096 Next ? (REG_NODE_NUM(Next)) : 0 ); \
2103 #define JOIN_EXACT(scan,min,flags) \
2104 if (PL_regkind[OP(scan)] == EXACT) \
2105 join_exact(pRExC_state,(scan),(min),(flags),NULL,depth+1)
2108 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, I32 *min, U32 flags,regnode *val, U32 depth) {
2109 /* Merge several consecutive EXACTish nodes into one. */
2110 regnode *n = regnext(scan);
2112 regnode *next = scan + NODE_SZ_STR(scan);
2116 regnode *stop = scan;
2117 GET_RE_DEBUG_FLAGS_DECL;
2119 PERL_UNUSED_ARG(depth);
2121 #ifndef EXPERIMENTAL_INPLACESCAN
2122 PERL_UNUSED_ARG(flags);
2123 PERL_UNUSED_ARG(val);
2125 DEBUG_PEEP("join",scan,depth);
2127 /* Skip NOTHING, merge EXACT*. */
2129 ( PL_regkind[OP(n)] == NOTHING ||
2130 (stringok && (OP(n) == OP(scan))))
2132 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX) {
2134 if (OP(n) == TAIL || n > next)
2136 if (PL_regkind[OP(n)] == NOTHING) {
2137 DEBUG_PEEP("skip:",n,depth);
2138 NEXT_OFF(scan) += NEXT_OFF(n);
2139 next = n + NODE_STEP_REGNODE;
2146 else if (stringok) {
2147 const unsigned int oldl = STR_LEN(scan);
2148 regnode * const nnext = regnext(n);
2150 DEBUG_PEEP("merg",n,depth);
2153 if (oldl + STR_LEN(n) > U8_MAX)
2155 NEXT_OFF(scan) += NEXT_OFF(n);
2156 STR_LEN(scan) += STR_LEN(n);
2157 next = n + NODE_SZ_STR(n);
2158 /* Now we can overwrite *n : */
2159 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2167 #ifdef EXPERIMENTAL_INPLACESCAN
2168 if (flags && !NEXT_OFF(n)) {
2169 DEBUG_PEEP("atch", val, depth);
2170 if (reg_off_by_arg[OP(n)]) {
2171 ARG_SET(n, val - n);
2174 NEXT_OFF(n) = val - n;
2181 if (UTF && ( OP(scan) == EXACTF ) && ( STR_LEN(scan) >= 6 ) ) {
2183 Two problematic code points in Unicode casefolding of EXACT nodes:
2185 U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2186 U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2192 U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
2193 U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
2195 This means that in case-insensitive matching (or "loose matching",
2196 as Unicode calls it), an EXACTF of length six (the UTF-8 encoded byte
2197 length of the above casefolded versions) can match a target string
2198 of length two (the byte length of UTF-8 encoded U+0390 or U+03B0).
2199 This would rather mess up the minimum length computation.
2201 What we'll do is to look for the tail four bytes, and then peek
2202 at the preceding two bytes to see whether we need to decrease
2203 the minimum length by four (six minus two).
2205 Thanks to the design of UTF-8, there cannot be false matches:
2206 A sequence of valid UTF-8 bytes cannot be a subsequence of
2207 another valid sequence of UTF-8 bytes.
2210 char * const s0 = STRING(scan), *s, *t;
2211 char * const s1 = s0 + STR_LEN(scan) - 1;
2212 char * const s2 = s1 - 4;
2213 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2214 const char t0[] = "\xaf\x49\xaf\x42";
2216 const char t0[] = "\xcc\x88\xcc\x81";
2218 const char * const t1 = t0 + 3;
2221 s < s2 && (t = ninstr(s, s1, t0, t1));
2224 if (((U8)t[-1] == 0x68 && (U8)t[-2] == 0xB4) ||
2225 ((U8)t[-1] == 0x46 && (U8)t[-2] == 0xB5))
2227 if (((U8)t[-1] == 0xB9 && (U8)t[-2] == 0xCE) ||
2228 ((U8)t[-1] == 0x85 && (U8)t[-2] == 0xCF))
2236 n = scan + NODE_SZ_STR(scan);
2238 if (PL_regkind[OP(n)] != NOTHING || OP(n) == NOTHING) {
2245 DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2249 /* REx optimizer. Converts nodes into quickier variants "in place".
2250 Finds fixed substrings. */
2252 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2253 to the position after last scanned or to NULL. */
2258 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2259 I32 *minlenp, I32 *deltap,
2260 regnode *last, scan_data_t *data, U32 flags, U32 depth)
2261 /* scanp: Start here (read-write). */
2262 /* deltap: Write maxlen-minlen here. */
2263 /* last: Stop before this one. */
2266 I32 min = 0, pars = 0, code;
2267 regnode *scan = *scanp, *next;
2269 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2270 int is_inf_internal = 0; /* The studied chunk is infinite */
2271 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2272 scan_data_t data_fake;
2273 struct regnode_charclass_class and_with; /* Valid if flags & SCF_DO_STCLASS_OR */
2274 SV *re_trie_maxbuff = NULL;
2275 regnode *first_non_open = scan;
2278 GET_RE_DEBUG_FLAGS_DECL;
2280 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2283 while (first_non_open && OP(first_non_open) == OPEN)
2284 first_non_open=regnext(first_non_open);
2288 while (scan && OP(scan) != END && scan < last) {
2289 /* Peephole optimizer: */
2290 DEBUG_STUDYDATA(data,depth);
2291 DEBUG_PEEP("Peep",scan,depth);
2292 JOIN_EXACT(scan,&min,0);
2294 /* Follow the next-chain of the current node and optimize
2295 away all the NOTHINGs from it. */
2296 if (OP(scan) != CURLYX) {
2297 const int max = (reg_off_by_arg[OP(scan)]
2299 /* I32 may be smaller than U16 on CRAYs! */
2300 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
2301 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
2305 /* Skip NOTHING and LONGJMP. */
2306 while ((n = regnext(n))
2307 && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
2308 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
2309 && off + noff < max)
2311 if (reg_off_by_arg[OP(scan)])
2314 NEXT_OFF(scan) = off;
2319 /* The principal pseudo-switch. Cannot be a switch, since we
2320 look into several different things. */
2321 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
2322 || OP(scan) == IFTHEN || OP(scan) == SUSPEND) {
2323 next = regnext(scan);
2325 /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
2327 if (OP(next) == code || code == IFTHEN || code == SUSPEND) {
2328 /* NOTE - There is similar code to this block below for handling
2329 TRIE nodes on a re-study. If you change stuff here check there
2331 I32 max1 = 0, min1 = I32_MAX, num = 0;
2332 struct regnode_charclass_class accum;
2333 regnode * const startbranch=scan;
2335 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
2336 scan_commit(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
2337 if (flags & SCF_DO_STCLASS)
2338 cl_init_zero(pRExC_state, &accum);
2340 while (OP(scan) == code) {
2341 I32 deltanext, minnext, f = 0, fake;
2342 struct regnode_charclass_class this_class;
2345 data_fake.flags = 0;
2347 data_fake.whilem_c = data->whilem_c;
2348 data_fake.last_closep = data->last_closep;
2351 data_fake.last_closep = &fake;
2352 next = regnext(scan);
2353 scan = NEXTOPER(scan);
2355 scan = NEXTOPER(scan);
2356 if (flags & SCF_DO_STCLASS) {
2357 cl_init(pRExC_state, &this_class);
2358 data_fake.start_class = &this_class;
2359 f = SCF_DO_STCLASS_AND;
2361 if (flags & SCF_WHILEM_VISITED_POS)
2362 f |= SCF_WHILEM_VISITED_POS;
2364 /* we suppose the run is continuous, last=next...*/
2365 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
2366 next, &data_fake, f,depth+1);
2369 if (max1 < minnext + deltanext)
2370 max1 = minnext + deltanext;
2371 if (deltanext == I32_MAX)
2372 is_inf = is_inf_internal = 1;
2374 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
2377 if (data_fake.flags & SF_HAS_EVAL)
2378 data->flags |= SF_HAS_EVAL;
2379 data->whilem_c = data_fake.whilem_c;
2381 if (flags & SCF_DO_STCLASS)
2382 cl_or(pRExC_state, &accum, &this_class);
2383 if (code == SUSPEND)
2386 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
2388 if (flags & SCF_DO_SUBSTR) {
2389 data->pos_min += min1;
2390 data->pos_delta += max1 - min1;
2391 if (max1 != min1 || is_inf)
2392 data->longest = &(data->longest_float);
2395 delta += max1 - min1;
2396 if (flags & SCF_DO_STCLASS_OR) {
2397 cl_or(pRExC_state, data->start_class, &accum);
2399 cl_and(data->start_class, &and_with);
2400 flags &= ~SCF_DO_STCLASS;
2403 else if (flags & SCF_DO_STCLASS_AND) {
2405 cl_and(data->start_class, &accum);
2406 flags &= ~SCF_DO_STCLASS;
2409 /* Switch to OR mode: cache the old value of
2410 * data->start_class */
2411 StructCopy(data->start_class, &and_with,
2412 struct regnode_charclass_class);
2413 flags &= ~SCF_DO_STCLASS_AND;
2414 StructCopy(&accum, data->start_class,
2415 struct regnode_charclass_class);
2416 flags |= SCF_DO_STCLASS_OR;
2417 data->start_class->flags |= ANYOF_EOS;
2421 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
2424 Assuming this was/is a branch we are dealing with: 'scan' now
2425 points at the item that follows the branch sequence, whatever
2426 it is. We now start at the beginning of the sequence and look
2433 which would be constructed from a pattern like /A|LIST|OF|WORDS/
2435 If we can find such a subseqence we need to turn the first
2436 element into a trie and then add the subsequent branch exact
2437 strings to the trie.
2441 1. patterns where the whole set of branch can be converted.
2443 2. patterns where only a subset can be converted.
2445 In case 1 we can replace the whole set with a single regop
2446 for the trie. In case 2 we need to keep the start and end
2449 'BRANCH EXACT; BRANCH EXACT; BRANCH X'
2450 becomes BRANCH TRIE; BRANCH X;
2452 There is an additional case, that being where there is a
2453 common prefix, which gets split out into an EXACT like node
2454 preceding the TRIE node.
2456 If x(1..n)==tail then we can do a simple trie, if not we make
2457 a "jump" trie, such that when we match the appropriate word
2458 we "jump" to the appopriate tail node. Essentailly we turn
2459 a nested if into a case structure of sorts.
2464 if (!re_trie_maxbuff) {
2465 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
2466 if (!SvIOK(re_trie_maxbuff))
2467 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
2469 if ( SvIV(re_trie_maxbuff)>=0 ) {
2471 regnode *first = (regnode *)NULL;
2472 regnode *last = (regnode *)NULL;
2473 regnode *tail = scan;
2478 SV * const mysv = sv_newmortal(); /* for dumping */
2480 /* var tail is used because there may be a TAIL
2481 regop in the way. Ie, the exacts will point to the
2482 thing following the TAIL, but the last branch will
2483 point at the TAIL. So we advance tail. If we
2484 have nested (?:) we may have to move through several
2488 while ( OP( tail ) == TAIL ) {
2489 /* this is the TAIL generated by (?:) */
2490 tail = regnext( tail );
2495 regprop(RExC_rx, mysv, tail );
2496 PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
2497 (int)depth * 2 + 2, "",
2498 "Looking for TRIE'able sequences. Tail node is: ",
2499 SvPV_nolen_const( mysv )
2505 step through the branches, cur represents each
2506 branch, noper is the first thing to be matched
2507 as part of that branch and noper_next is the
2508 regnext() of that node. if noper is an EXACT
2509 and noper_next is the same as scan (our current
2510 position in the regex) then the EXACT branch is
2511 a possible optimization target. Once we have
2512 two or more consequetive such branches we can
2513 create a trie of the EXACT's contents and stich
2514 it in place. If the sequence represents all of
2515 the branches we eliminate the whole thing and
2516 replace it with a single TRIE. If it is a
2517 subsequence then we need to stitch it in. This
2518 means the first branch has to remain, and needs
2519 to be repointed at the item on the branch chain
2520 following the last branch optimized. This could
2521 be either a BRANCH, in which case the
2522 subsequence is internal, or it could be the
2523 item following the branch sequence in which
2524 case the subsequence is at the end.
2528 /* dont use tail as the end marker for this traverse */
2529 for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
2530 regnode * const noper = NEXTOPER( cur );
2531 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
2532 regnode * const noper_next = regnext( noper );
2536 regprop(RExC_rx, mysv, cur);
2537 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
2538 (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
2540 regprop(RExC_rx, mysv, noper);
2541 PerlIO_printf( Perl_debug_log, " -> %s",
2542 SvPV_nolen_const(mysv));
2545 regprop(RExC_rx, mysv, noper_next );
2546 PerlIO_printf( Perl_debug_log,"\t=> %s\t",
2547 SvPV_nolen_const(mysv));
2549 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
2550 REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
2552 if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
2553 : PL_regkind[ OP( noper ) ] == EXACT )
2554 || OP(noper) == NOTHING )
2556 && noper_next == tail
2561 if ( !first || optype == NOTHING ) {
2562 if (!first) first = cur;
2563 optype = OP( noper );
2569 make_trie( pRExC_state,
2570 startbranch, first, cur, tail, count,
2573 if ( PL_regkind[ OP( noper ) ] == EXACT
2575 && noper_next == tail
2580 optype = OP( noper );
2590 regprop(RExC_rx, mysv, cur);
2591 PerlIO_printf( Perl_debug_log,
2592 "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
2593 "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
2597 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
2598 #ifdef TRIE_STUDY_OPT
2599 if ( ((made == MADE_EXACT_TRIE &&
2600 startbranch == first)
2601 || ( first_non_open == first )) &&
2603 flags |= SCF_TRIE_RESTUDY;
2611 else if ( code == BRANCHJ ) { /* single branch is optimized. */
2612 scan = NEXTOPER(NEXTOPER(scan));
2613 } else /* single branch is optimized. */
2614 scan = NEXTOPER(scan);
2617 else if (OP(scan) == EXACT) {
2618 I32 l = STR_LEN(scan);
2621 const U8 * const s = (U8*)STRING(scan);
2622 l = utf8_length(s, s + l);
2623 uc = utf8_to_uvchr(s, NULL);
2625 uc = *((U8*)STRING(scan));
2628 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
2629 /* The code below prefers earlier match for fixed
2630 offset, later match for variable offset. */
2631 if (data->last_end == -1) { /* Update the start info. */
2632 data->last_start_min = data->pos_min;
2633 data->last_start_max = is_inf
2634 ? I32_MAX : data->pos_min + data->pos_delta;
2636 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
2638 SvUTF8_on(data->last_found);
2640 SV * const sv = data->last_found;
2641 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
2642 mg_find(sv, PERL_MAGIC_utf8) : NULL;
2643 if (mg && mg->mg_len >= 0)
2644 mg->mg_len += utf8_length((U8*)STRING(scan),
2645 (U8*)STRING(scan)+STR_LEN(scan));
2647 data->last_end = data->pos_min + l;
2648 data->pos_min += l; /* As in the first entry. */
2649 data->flags &= ~SF_BEFORE_EOL;
2651 if (flags & SCF_DO_STCLASS_AND) {
2652 /* Check whether it is compatible with what we know already! */
2656 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2657 && !ANYOF_BITMAP_TEST(data->start_class, uc)
2658 && (!(data->start_class->flags & ANYOF_FOLD)
2659 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2662 ANYOF_CLASS_ZERO(data->start_class);
2663 ANYOF_BITMAP_ZERO(data->start_class);
2665 ANYOF_BITMAP_SET(data->start_class, uc);
2666 data->start_class->flags &= ~ANYOF_EOS;
2668 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
2670 else if (flags & SCF_DO_STCLASS_OR) {
2671 /* false positive possible if the class is case-folded */
2673 ANYOF_BITMAP_SET(data->start_class, uc);
2675 data->start_class->flags |= ANYOF_UNICODE_ALL;
2676 data->start_class->flags &= ~ANYOF_EOS;
2677 cl_and(data->start_class, &and_with);
2679 flags &= ~SCF_DO_STCLASS;
2681 else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
2682 I32 l = STR_LEN(scan);
2683 UV uc = *((U8*)STRING(scan));
2685 /* Search for fixed substrings supports EXACT only. */
2686 if (flags & SCF_DO_SUBSTR) {
2688 scan_commit(pRExC_state, data, minlenp);
2691 const U8 * const s = (U8 *)STRING(scan);
2692 l = utf8_length(s, s + l);
2693 uc = utf8_to_uvchr(s, NULL);
2696 if (flags & SCF_DO_SUBSTR)
2698 if (flags & SCF_DO_STCLASS_AND) {
2699 /* Check whether it is compatible with what we know already! */
2703 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
2704 && !ANYOF_BITMAP_TEST(data->start_class, uc)
2705 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold[uc])))
2707 ANYOF_CLASS_ZERO(data->start_class);
2708 ANYOF_BITMAP_ZERO(data->start_class);
2710 ANYOF_BITMAP_SET(data->start_class, uc);
2711 data->start_class->flags &= ~ANYOF_EOS;
2712 data->start_class->flags |= ANYOF_FOLD;
2713 if (OP(scan) == EXACTFL)
2714 data->start_class->flags |= ANYOF_LOCALE;
2717 else if (flags & SCF_DO_STCLASS_OR) {
2718 if (data->start_class->flags & ANYOF_FOLD) {
2719 /* false positive possible if the class is case-folded.
2720 Assume that the locale settings are the same... */
2722 ANYOF_BITMAP_SET(data->start_class, uc);
2723 data->start_class->flags &= ~ANYOF_EOS;
2725 cl_and(data->start_class, &and_with);
2727 flags &= ~SCF_DO_STCLASS;
2729 else if (strchr((const char*)PL_varies,OP(scan))) {
2730 I32 mincount, maxcount, minnext, deltanext, fl = 0;
2731 I32 f = flags, pos_before = 0;
2732 regnode * const oscan = scan;
2733 struct regnode_charclass_class this_class;
2734 struct regnode_charclass_class *oclass = NULL;
2735 I32 next_is_eval = 0;
2737 switch (PL_regkind[OP(scan)]) {
2738 case WHILEM: /* End of (?:...)* . */
2739 scan = NEXTOPER(scan);
2742 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
2743 next = NEXTOPER(scan);
2744 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
2746 maxcount = REG_INFTY;
2747 next = regnext(scan);
2748 scan = NEXTOPER(scan);
2752 if (flags & SCF_DO_SUBSTR)
2757 if (flags & SCF_DO_STCLASS) {
2759 maxcount = REG_INFTY;
2760 next = regnext(scan);
2761 scan = NEXTOPER(scan);
2764 is_inf = is_inf_internal = 1;
2765 scan = regnext(scan);
2766 if (flags & SCF_DO_SUBSTR) {
2767 scan_commit(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
2768 data->longest = &(data->longest_float);
2770 goto optimize_curly_tail;
2772 mincount = ARG1(scan);
2773 maxcount = ARG2(scan);
2774 next = regnext(scan);
2775 if (OP(scan) == CURLYX) {
2776 I32 lp = (data ? *(data->last_closep) : 0);
2777 scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
2779 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
2780 next_is_eval = (OP(scan) == EVAL);
2782 if (flags & SCF_DO_SUBSTR) {
2783 if (mincount == 0) scan_commit(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
2784 pos_before = data->pos_min;
2788 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
2790 data->flags |= SF_IS_INF;
2792 if (flags & SCF_DO_STCLASS) {
2793 cl_init(pRExC_state, &this_class);
2794 oclass = data->start_class;
2795 data->start_class = &this_class;
2796 f |= SCF_DO_STCLASS_AND;
2797 f &= ~SCF_DO_STCLASS_OR;
2799 /* These are the cases when once a subexpression
2800 fails at a particular position, it cannot succeed
2801 even after backtracking at the enclosing scope.
2803 XXXX what if minimal match and we are at the
2804 initial run of {n,m}? */
2805 if ((mincount != maxcount - 1) && (maxcount != REG_INFTY))
2806 f &= ~SCF_WHILEM_VISITED_POS;
2808 /* This will finish on WHILEM, setting scan, or on NULL: */
2809 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext, last, data,
2811 ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
2813 if (flags & SCF_DO_STCLASS)
2814 data->start_class = oclass;
2815 if (mincount == 0 || minnext == 0) {
2816 if (flags & SCF_DO_STCLASS_OR) {
2817 cl_or(pRExC_state, data->start_class, &this_class);
2819 else if (flags & SCF_DO_STCLASS_AND) {
2820 /* Switch to OR mode: cache the old value of
2821 * data->start_class */
2822 StructCopy(data->start_class, &and_with,
2823 struct regnode_charclass_class);
2824 flags &= ~SCF_DO_STCLASS_AND;
2825 StructCopy(&this_class, data->start_class,
2826 struct regnode_charclass_class);
2827 flags |= SCF_DO_STCLASS_OR;
2828 data->start_class->flags |= ANYOF_EOS;
2830 } else { /* Non-zero len */
2831 if (flags & SCF_DO_STCLASS_OR) {
2832 cl_or(pRExC_state, data->start_class, &this_class);
2833 cl_and(data->start_class, &and_with);
2835 else if (flags & SCF_DO_STCLASS_AND)
2836 cl_and(data->start_class, &this_class);
2837 flags &= ~SCF_DO_STCLASS;
2839 if (!scan) /* It was not CURLYX, but CURLY. */
2841 if ( /* ? quantifier ok, except for (?{ ... }) */
2842 (next_is_eval || !(mincount == 0 && maxcount == 1))
2843 && (minnext == 0) && (deltanext == 0)
2844 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
2845 && maxcount <= REG_INFTY/3 /* Complement check for big count */
2846 && ckWARN(WARN_REGEXP))
2849 "Quantifier unexpected on zero-length expression");
2852 min += minnext * mincount;
2853 is_inf_internal |= ((maxcount == REG_INFTY
2854 && (minnext + deltanext) > 0)
2855 || deltanext == I32_MAX);
2856 is_inf |= is_inf_internal;
2857 delta += (minnext + deltanext) * maxcount - minnext * mincount;
2859 /* Try powerful optimization CURLYX => CURLYN. */
2860 if ( OP(oscan) == CURLYX && data
2861 && data->flags & SF_IN_PAR
2862 && !(data->flags & SF_HAS_EVAL)
2863 && !deltanext && minnext == 1 ) {
2864 /* Try to optimize to CURLYN. */
2865 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
2866 regnode * const nxt1 = nxt;
2873 if (!strchr((const char*)PL_simple,OP(nxt))
2874 && !(PL_regkind[OP(nxt)] == EXACT
2875 && STR_LEN(nxt) == 1))
2881 if (OP(nxt) != CLOSE)
2883 /* Now we know that nxt2 is the only contents: */
2884 oscan->flags = (U8)ARG(nxt);
2886 OP(nxt1) = NOTHING; /* was OPEN. */
2888 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
2889 NEXT_OFF(nxt1+ 1) = 0; /* just for consistancy. */
2890 NEXT_OFF(nxt2) = 0; /* just for consistancy with CURLY. */
2891 OP(nxt) = OPTIMIZED; /* was CLOSE. */
2892 OP(nxt + 1) = OPTIMIZED; /* was count. */
2893 NEXT_OFF(nxt+ 1) = 0; /* just for consistancy. */
2898 /* Try optimization CURLYX => CURLYM. */
2899 if ( OP(oscan) == CURLYX && data
2900 && !(data->flags & SF_HAS_PAR)
2901 && !(data->flags & SF_HAS_EVAL)
2902 && !deltanext /* atom is fixed width */
2903 && minnext != 0 /* CURLYM can't handle zero width */
2905 /* XXXX How to optimize if data == 0? */
2906 /* Optimize to a simpler form. */
2907 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
2911 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
2912 && (OP(nxt2) != WHILEM))
2914 OP(nxt2) = SUCCEED; /* Whas WHILEM */
2915 /* Need to optimize away parenths. */
2916 if (data->flags & SF_IN_PAR) {
2917 /* Set the parenth number. */
2918 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
2920 if (OP(nxt) != CLOSE)
2921 FAIL("Panic opt close");
2922 oscan->flags = (U8)ARG(nxt);
2923 OP(nxt1) = OPTIMIZED; /* was OPEN. */
2924 OP(nxt) = OPTIMIZED; /* was CLOSE. */
2926 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
2927 OP(nxt + 1) = OPTIMIZED; /* was count. */
2928 NEXT_OFF(nxt1 + 1) = 0; /* just for consistancy. */
2929 NEXT_OFF(nxt + 1) = 0; /* just for consistancy. */
2932 while ( nxt1 && (OP(nxt1) != WHILEM)) {
2933 regnode *nnxt = regnext(nxt1);
2936 if (reg_off_by_arg[OP(nxt1)])
2937 ARG_SET(nxt1, nxt2 - nxt1);
2938 else if (nxt2 - nxt1 < U16_MAX)
2939 NEXT_OFF(nxt1) = nxt2 - nxt1;
2941 OP(nxt) = NOTHING; /* Cannot beautify */
2946 /* Optimize again: */
2947 study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
2953 else if ((OP(oscan) == CURLYX)
2954 && (flags & SCF_WHILEM_VISITED_POS)
2955 /* See the comment on a similar expression above.
2956 However, this time it not a subexpression
2957 we care about, but the expression itself. */
2958 && (maxcount == REG_INFTY)
2959 && data && ++data->whilem_c < 16) {
2960 /* This stays as CURLYX, we can put the count/of pair. */
2961 /* Find WHILEM (as in regexec.c) */
2962 regnode *nxt = oscan + NEXT_OFF(oscan);
2964 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
2966 PREVOPER(nxt)->flags = (U8)(data->whilem_c
2967 | (RExC_whilem_seen << 4)); /* On WHILEM */
2969 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
2971 if (flags & SCF_DO_SUBSTR) {
2972 SV *last_str = NULL;
2973 int counted = mincount != 0;
2975 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
2976 #if defined(SPARC64_GCC_WORKAROUND)
2979 const char *s = NULL;
2982 if (pos_before >= data->last_start_min)
2985 b = data->last_start_min;
2988 s = SvPV_const(data->last_found, l);
2989 old = b - data->last_start_min;
2992 I32 b = pos_before >= data->last_start_min
2993 ? pos_before : data->last_start_min;
2995 const char * const s = SvPV_const(data->last_found, l);
2996 I32 old = b - data->last_start_min;
3000 old = utf8_hop((U8*)s, old) - (U8*)s;
3003 /* Get the added string: */
3004 last_str = newSVpvn(s + old, l);
3006 SvUTF8_on(last_str);
3007 if (deltanext == 0 && pos_before == b) {
3008 /* What was added is a constant string */
3010 SvGROW(last_str, (mincount * l) + 1);
3011 repeatcpy(SvPVX(last_str) + l,
3012 SvPVX_const(last_str), l, mincount - 1);
3013 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3014 /* Add additional parts. */
3015 SvCUR_set(data->last_found,
3016 SvCUR(data->last_found) - l);
3017 sv_catsv(data->last_found, last_str);
3019 SV * sv = data->last_found;
3021 SvUTF8(sv) && SvMAGICAL(sv) ?
3022 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3023 if (mg && mg->mg_len >= 0)
3024 mg->mg_len += CHR_SVLEN(last_str);
3026 data->last_end += l * (mincount - 1);
3029 /* start offset must point into the last copy */
3030 data->last_start_min += minnext * (mincount - 1);
3031 data->last_start_max += is_inf ? I32_MAX
3032 : (maxcount - 1) * (minnext + data->pos_delta);
3035 /* It is counted once already... */
3036 data->pos_min += minnext * (mincount - counted);
3037 data->pos_delta += - counted * deltanext +
3038 (minnext + deltanext) * maxcount - minnext * mincount;
3039 if (mincount != maxcount) {
3040 /* Cannot extend fixed substrings found inside
3042 scan_commit(pRExC_state,data,minlenp);
3043 if (mincount && last_str) {
3044 SV * const sv = data->last_found;
3045 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3046 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3050 sv_setsv(sv, last_str);
3051 data->last_end = data->pos_min;
3052 data->last_start_min =
3053 data->pos_min - CHR_SVLEN(last_str);
3054 data->last_start_max = is_inf
3056 : data->pos_min + data->pos_delta
3057 - CHR_SVLEN(last_str);
3059 data->longest = &(data->longest_float);
3061 SvREFCNT_dec(last_str);
3063 if (data && (fl & SF_HAS_EVAL))
3064 data->flags |= SF_HAS_EVAL;
3065 optimize_curly_tail:
3066 if (OP(oscan) != CURLYX) {
3067 while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3069 NEXT_OFF(oscan) += NEXT_OFF(next);
3072 default: /* REF and CLUMP only? */
3073 if (flags & SCF_DO_SUBSTR) {
3074 scan_commit(pRExC_state,data,minlenp); /* Cannot expect anything... */
3075 data->longest = &(data->longest_float);
3077 is_inf = is_inf_internal = 1;
3078 if (flags & SCF_DO_STCLASS_OR)
3079 cl_anything(pRExC_state, data->start_class);
3080 flags &= ~SCF_DO_STCLASS;
3084 else if (strchr((const char*)PL_simple,OP(scan))) {
3087 if (flags & SCF_DO_SUBSTR) {
3088 scan_commit(pRExC_state,data,minlenp);
3092 if (flags & SCF_DO_STCLASS) {
3093 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3095 /* Some of the logic below assumes that switching
3096 locale on will only add false positives. */
3097 switch (PL_regkind[OP(scan)]) {
3101 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
3102 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3103 cl_anything(pRExC_state, data->start_class);
3106 if (OP(scan) == SANY)
3108 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
3109 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
3110 || (data->start_class->flags & ANYOF_CLASS));
3111 cl_anything(pRExC_state, data->start_class);
3113 if (flags & SCF_DO_STCLASS_AND || !value)
3114 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
3117 if (flags & SCF_DO_STCLASS_AND)
3118 cl_and(data->start_class,
3119 (struct regnode_charclass_class*)scan);
3121 cl_or(pRExC_state, data->start_class,
3122 (struct regnode_charclass_class*)scan);
3125 if (flags & SCF_DO_STCLASS_AND) {
3126 if (!(data->start_class->flags & ANYOF_LOCALE)) {
3127 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3128 for (value = 0; value < 256; value++)
3129 if (!isALNUM(value))
3130 ANYOF_BITMAP_CLEAR(data->start_class, value);
3134 if (data->start_class->flags & ANYOF_LOCALE)
3135 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3137 for (value = 0; value < 256; value++)
3139 ANYOF_BITMAP_SET(data->start_class, value);
3144 if (flags & SCF_DO_STCLASS_AND) {
3145 if (data->start_class->flags & ANYOF_LOCALE)
3146 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
3149 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
3150 data->start_class->flags |= ANYOF_LOCALE;
3154 if (flags & SCF_DO_STCLASS_AND) {
3155 if (!(data->start_class->flags & ANYOF_LOCALE)) {
3156 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3157 for (value = 0; value < 256; value++)
3159 ANYOF_BITMAP_CLEAR(data->start_class, value);
3163 if (data->start_class->flags & ANYOF_LOCALE)
3164 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3166 for (value = 0; value < 256; value++)
3167 if (!isALNUM(value))
3168 ANYOF_BITMAP_SET(data->start_class, value);
3173 if (flags & SCF_DO_STCLASS_AND) {
3174 if (data->start_class->flags & ANYOF_LOCALE)
3175 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
3178 data->start_class->flags |= ANYOF_LOCALE;
3179 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
3183 if (flags & SCF_DO_STCLASS_AND) {
3184 if (!(data->start_class->flags & ANYOF_LOCALE)) {
3185 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3186 for (value = 0; value < 256; value++)
3187 if (!isSPACE(value))
3188 ANYOF_BITMAP_CLEAR(data->start_class, value);
3192 if (data->start_class->flags & ANYOF_LOCALE)
3193 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3195 for (value = 0; value < 256; value++)
3197 ANYOF_BITMAP_SET(data->start_class, value);
3202 if (flags & SCF_DO_STCLASS_AND) {
3203 if (data->start_class->flags & ANYOF_LOCALE)
3204 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
3207 data->start_class->flags |= ANYOF_LOCALE;
3208 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
3212 if (flags & SCF_DO_STCLASS_AND) {
3213 if (!(data->start_class->flags & ANYOF_LOCALE)) {
3214 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3215 for (value = 0; value < 256; value++)
3217 ANYOF_BITMAP_CLEAR(data->start_class, value);
3221 if (data->start_class->flags & ANYOF_LOCALE)
3222 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3224 for (value = 0; value < 256; value++)
3225 if (!isSPACE(value))
3226 ANYOF_BITMAP_SET(data->start_class, value);
3231 if (flags & SCF_DO_STCLASS_AND) {
3232 if (data->start_class->flags & ANYOF_LOCALE) {
3233 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
3234 for (value = 0; value < 256; value++)
3235 if (!isSPACE(value))
3236 ANYOF_BITMAP_CLEAR(data->start_class, value);
3240 data->start_class->flags |= ANYOF_LOCALE;
3241 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
3245 if (flags & SCF_DO_STCLASS_AND) {
3246 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
3247 for (value = 0; value < 256; value++)
3248 if (!isDIGIT(value))
3249 ANYOF_BITMAP_CLEAR(data->start_class, value);
3252 if (data->start_class->flags & ANYOF_LOCALE)
3253 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
3255 for (value = 0; value < 256; value++)
3257 ANYOF_BITMAP_SET(data->start_class, value);
3262 if (flags & SCF_DO_STCLASS_AND) {
3263 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
3264 for (value = 0; value < 256; value++)
3266 ANYOF_BITMAP_CLEAR(data->start_class, value);
3269 if (data->start_class->flags & ANYOF_LOCALE)
3270 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
3272 for (value = 0; value < 256; value++)
3273 if (!isDIGIT(value))
3274 ANYOF_BITMAP_SET(data->start_class, value);
3279 if (flags & SCF_DO_STCLASS_OR)
3280 cl_and(data->start_class, &and_with);
3281 flags &= ~SCF_DO_STCLASS;
3284 else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
3285 data->flags |= (OP(scan) == MEOL
3289 else if ( PL_regkind[OP(scan)] == BRANCHJ
3290 /* Lookbehind, or need to calculate parens/evals/stclass: */
3291 && (scan->flags || data || (flags & SCF_DO_STCLASS))
3292 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
3293 if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3294 || OP(scan) == UNLESSM )
3296 /* Negative Lookahead/lookbehind
3297 In this case we can't do fixed string optimisation.
3300 I32 deltanext, minnext, fake = 0;
3302 struct regnode_charclass_class intrnl;
3305 data_fake.flags = 0;
3307 data_fake.whilem_c = data->whilem_c;
3308 data_fake.last_closep = data->last_closep;
3311 data_fake.last_closep = &fake;
3312 if ( flags & SCF_DO_STCLASS && !scan->flags
3313 && OP(scan) == IFMATCH ) { /* Lookahead */
3314 cl_init(pRExC_state, &intrnl);
3315 data_fake.start_class = &intrnl;
3316 f |= SCF_DO_STCLASS_AND;
3318 if (flags & SCF_WHILEM_VISITED_POS)
3319 f |= SCF_WHILEM_VISITED_POS;
3320 next = regnext(scan);
3321 nscan = NEXTOPER(NEXTOPER(scan));
3322 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext, last, &data_fake, f,depth+1);
3325 vFAIL("Variable length lookbehind not implemented");
3327 else if (minnext > (I32)U8_MAX) {
3328 vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3330 scan->flags = (U8)minnext;
3333 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3335 if (data_fake.flags & SF_HAS_EVAL)
3336 data->flags |= SF_HAS_EVAL;
3337 data->whilem_c = data_fake.whilem_c;
3339 if (f & SCF_DO_STCLASS_AND) {
3340 const int was = (data->start_class->flags & ANYOF_EOS);
3342 cl_and(data->start_class, &intrnl);
3344 data->start_class->flags |= ANYOF_EOS;
3347 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
3349 /* Positive Lookahead/lookbehind
3350 In this case we can do fixed string optimisation,
3351 but we must be careful about it. Note in the case of
3352 lookbehind the positions will be offset by the minimum
3353 length of the pattern, something we won't know about
3354 until after the recurse.
3356 I32 deltanext, fake = 0;
3358 struct regnode_charclass_class intrnl;
3360 /* We use SAVEFREEPV so that when the full compile
3361 is finished perl will clean up the allocated
3362 minlens when its all done. This was we don't
3363 have to worry about freeing them when we know
3364 they wont be used, which would be a pain.
3367 Newx( minnextp, 1, I32 );
3368 SAVEFREEPV(minnextp);
3371 StructCopy(data, &data_fake, scan_data_t);
3372 if ((flags & SCF_DO_SUBSTR) && data->last_found) {
3375 scan_commit(pRExC_state, &data_fake,minlenp);
3376 data_fake.last_found=newSVsv(data->last_found);
3380 data_fake.last_closep = &fake;
3381 data_fake.flags = 0;
3383 data_fake.flags |= SF_IS_INF;
3384 if ( flags & SCF_DO_STCLASS && !scan->flags
3385 && OP(scan) == IFMATCH ) { /* Lookahead */
3386 cl_init(pRExC_state, &intrnl);
3387 data_fake.start_class = &intrnl;
3388 f |= SCF_DO_STCLASS_AND;
3390 if (flags & SCF_WHILEM_VISITED_POS)
3391 f |= SCF_WHILEM_VISITED_POS;
3392 next = regnext(scan);
3393 nscan = NEXTOPER(NEXTOPER(scan));
3395 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext, last, &data_fake, f,depth+1);
3398 vFAIL("Variable length lookbehind not implemented");
3400 else if (*minnextp > (I32)U8_MAX) {
3401 vFAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
3403 scan->flags = (U8)*minnextp;
3409 if (f & SCF_DO_STCLASS_AND) {
3410 const int was = (data->start_class->flags & ANYOF_EOS);
3412 cl_and(data->start_class, &intrnl);
3414 data->start_class->flags |= ANYOF_EOS;
3417 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3419 if (data_fake.flags & SF_HAS_EVAL)
3420 data->flags |= SF_HAS_EVAL;
3421 data->whilem_c = data_fake.whilem_c;
3422 if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
3423 if (RExC_rx->minlen<*minnextp)
3424 RExC_rx->minlen=*minnextp;
3425 scan_commit(pRExC_state, &data_fake, minnextp);
3426 SvREFCNT_dec(data_fake.last_found);
3428 if ( data_fake.minlen_fixed != minlenp )
3430 data->offset_fixed= data_fake.offset_fixed;
3431 data->minlen_fixed= data_fake.minlen_fixed;
3432 data->lookbehind_fixed+= scan->flags;
3434 if ( data_fake.minlen_float != minlenp )
3436 data->minlen_float= data_fake.minlen_float;
3437 data->offset_float_min=data_fake.offset_float_min;
3438 data->offset_float_max=data_fake.offset_float_max;
3439 data->lookbehind_float+= scan->flags;
3448 else if (OP(scan) == OPEN) {
3451 else if (OP(scan) == CLOSE) {
3452 if ((I32)ARG(scan) == is_par) {
3453 next = regnext(scan);
3455 if ( next && (OP(next) != WHILEM) && next < last)
3456 is_par = 0; /* Disable optimization */
3459 *(data->last_closep) = ARG(scan);
3461 else if (OP(scan) == EVAL) {
3463 data->flags |= SF_HAS_EVAL;
3465 else if ( (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
3466 || OP(scan)==RECURSE) /* recursion */
3468 if (OP(scan)==RECURSE) {
3469 ARG2L_SET( scan, RExC_parens[ARG(scan)-1] - scan );
3471 if (flags & SCF_DO_SUBSTR) {
3472 scan_commit(pRExC_state,data,minlenp);
3473 data->longest = &(data->longest_float);
3475 is_inf = is_inf_internal = 1;
3476 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3477 cl_anything(pRExC_state, data->start_class);
3478 flags &= ~SCF_DO_STCLASS;
3480 #ifdef TRIE_STUDY_OPT
3481 #ifdef FULL_TRIE_STUDY
3482 else if (PL_regkind[OP(scan)] == TRIE) {
3483 /* NOTE - There is similar code to this block above for handling
3484 BRANCH nodes on the initial study. If you change stuff here
3486 regnode *tail= regnext(scan);
3487 reg_trie_data *trie = (reg_trie_data*)RExC_rx->data->data[ ARG(scan) ];
3488 I32 max1 = 0, min1 = I32_MAX;
3489 struct regnode_charclass_class accum;
3491 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
3492 scan_commit(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
3493 if (flags & SCF_DO_STCLASS)
3494 cl_init_zero(pRExC_state, &accum);
3500 const regnode *nextbranch= NULL;
3503 for ( word=1 ; word <= trie->wordcount ; word++)
3505 I32 deltanext=0, minnext=0, f = 0, fake;
3506 struct regnode_charclass_class this_class;
3508 data_fake.flags = 0;
3510 data_fake.whilem_c = data->whilem_c;
3511 data_fake.last_closep = data->last_closep;
3514 data_fake.last_closep = &fake;
3516 if (flags & SCF_DO_STCLASS) {
3517 cl_init(pRExC_state, &this_class);
3518 data_fake.start_class = &this_class;
3519 f = SCF_DO_STCLASS_AND;
3521 if (flags & SCF_WHILEM_VISITED_POS)
3522 f |= SCF_WHILEM_VISITED_POS;
3524 if (trie->jump[word]) {
3526 nextbranch = tail - trie->jump[0];
3527 scan= tail - trie->jump[word];
3528 /* We go from the jump point to the branch that follows
3529 it. Note this means we need the vestigal unused branches
3530 even though they arent otherwise used.
3532 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3533 (regnode *)nextbranch, &data_fake, f,depth+1);
3535 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
3536 nextbranch= regnext((regnode*)nextbranch);
3538 if (min1 > (I32)(minnext + trie->minlen))
3539 min1 = minnext + trie->minlen;
3540 if (max1 < (I32)(minnext + deltanext + trie->maxlen))
3541 max1 = minnext + deltanext + trie->maxlen;
3542 if (deltanext == I32_MAX)
3543 is_inf = is_inf_internal = 1;
3545 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3549 if (data_fake.flags & SF_HAS_EVAL)
3550 data->flags |= SF_HAS_EVAL;
3551 data->whilem_c = data_fake.whilem_c;
3553 if (flags & SCF_DO_STCLASS)
3554 cl_or(pRExC_state, &accum, &this_class);
3557 if (flags & SCF_DO_SUBSTR) {
3558 data->pos_min += min1;
3559 data->pos_delta += max1 - min1;
3560 if (max1 != min1 || is_inf)
3561 data->longest = &(data->longest_float);
3564 delta += max1 - min1;
3565 if (flags & SCF_DO_STCLASS_OR) {
3566 cl_or(pRExC_state, data->start_class, &accum);
3568 cl_and(data->start_class, &and_with);
3569 flags &= ~SCF_DO_STCLASS;
3572 else if (flags & SCF_DO_STCLASS_AND) {
3574 cl_and(data->start_class, &accum);
3575 flags &= ~SCF_DO_STCLASS;
3578 /* Switch to OR mode: cache the old value of
3579 * data->start_class */
3580 StructCopy(data->start_class, &and_with,
3581 struct regnode_charclass_class);
3582 flags &= ~SCF_DO_STCLASS_AND;
3583 StructCopy(&accum, data->start_class,
3584 struct regnode_charclass_class);
3585 flags |= SCF_DO_STCLASS_OR;
3586 data->start_class->flags |= ANYOF_EOS;
3593 else if (PL_regkind[OP(scan)] == TRIE) {
3594 reg_trie_data *trie = (reg_trie_data*)RExC_rx->data->data[ ARG(scan) ];
3597 min += trie->minlen;
3598 delta += (trie->maxlen - trie->minlen);
3599 flags &= ~SCF_DO_STCLASS; /* xxx */
3600 if (flags & SCF_DO_SUBSTR) {
3601 scan_commit(pRExC_state,data,minlenp); /* Cannot expect anything... */
3602 data->pos_min += trie->minlen;
3603 data->pos_delta += (trie->maxlen - trie->minlen);
3604 if (trie->maxlen != trie->minlen)
3605 data->longest = &(data->longest_float);
3607 if (trie->jump) /* no more substrings -- for now /grr*/
3608 flags &= ~SCF_DO_SUBSTR;
3610 #endif /* old or new */
3611 #endif /* TRIE_STUDY_OPT */
3612 /* Else: zero-length, ignore. */
3613 scan = regnext(scan);
3618 *deltap = is_inf_internal ? I32_MAX : delta;
3619 if (flags & SCF_DO_SUBSTR && is_inf)
3620 data->pos_delta = I32_MAX - data->pos_min;
3621 if (is_par > (I32)U8_MAX)
3623 if (is_par && pars==1 && data) {
3624 data->flags |= SF_IN_PAR;
3625 data->flags &= ~SF_HAS_PAR;
3627 else if (pars && data) {
3628 data->flags |= SF_HAS_PAR;
3629 data->flags &= ~SF_IN_PAR;
3631 if (flags & SCF_DO_STCLASS_OR)
3632 cl_and(data->start_class, &and_with);
3633 if (flags & SCF_TRIE_RESTUDY)
3634 data->flags |= SCF_TRIE_RESTUDY;
3636 DEBUG_STUDYDATA(data,depth);
3642 S_add_data(RExC_state_t *pRExC_state, I32 n, const char *s)
3644 if (RExC_rx->data) {
3645 const U32 count = RExC_rx->data->count;
3646 Renewc(RExC_rx->data,
3647 sizeof(*RExC_rx->data) + sizeof(void*) * (count + n - 1),
3648 char, struct reg_data);
3649 Renew(RExC_rx->data->what, count + n, U8);
3650 RExC_rx->data->count += n;
3653 Newxc(RExC_rx->data, sizeof(*RExC_rx->data) + sizeof(void*) * (n - 1),
3654 char, struct reg_data);
3655 Newx(RExC_rx->data->what, n, U8);
3656 RExC_rx->data->count = n;
3658 Copy(s, RExC_rx->data->what + RExC_rx->data->count - n, n, U8);
3659 return RExC_rx->data->count - n;
3662 #ifndef PERL_IN_XSUB_RE
3664 Perl_reginitcolors(pTHX)
3667 const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
3669 char *t = savepv(s);
3673 t = strchr(t, '\t');
3679 PL_colors[i] = t = (char *)"";
3684 PL_colors[i++] = (char *)"";
3691 #ifdef TRIE_STUDY_OPT
3692 #define CHECK_RESTUDY_GOTO \
3694 (data.flags & SCF_TRIE_RESTUDY) \
3698 #define CHECK_RESTUDY_GOTO
3702 - pregcomp - compile a regular expression into internal code
3704 * We can't allocate space until we know how big the compiled form will be,
3705 * but we can't compile it (and thus know how big it is) until we've got a
3706 * place to put the code. So we cheat: we compile it twice, once with code
3707 * generation turned off and size counting turned on, and once "for real".
3708 * This also means that we don't allocate space until we are sure that the
3709 * thing really will compile successfully, and we never have to move the
3710 * code and thus invalidate pointers into it. (Note that it has to be in
3711 * one piece because free() must be able to free it all.) [NB: not true in perl]
3713 * Beware that the optimization-preparation code in here knows about some
3714 * of the structure of the compiled regexp. [I'll say.]
3719 #ifndef PERL_IN_XSUB_RE
3720 #define RE_ENGINE_PTR &PL_core_reg_engine
3722 extern const struct regexp_engine my_reg_engine;
3723 #define RE_ENGINE_PTR &my_reg_engine
3725 /* these make a few things look better, to avoid indentation */
3726 #define BEGIN_BLOCK {
3730 Perl_pregcomp(pTHX_ char *exp, char *xend, PMOP *pm)
3733 GET_RE_DEBUG_FLAGS_DECL;
3734 DEBUG_r(if (!PL_colorset) reginitcolors());
3735 #ifndef PERL_IN_XSUB_RE
3737 /* Dispatch a request to compile a regexp to correct
3739 HV * const table = GvHV(PL_hintgv);
3741 SV **ptr= hv_fetchs(table, "regcomp", FALSE);
3742 if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
3743 const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
3745 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
3748 return CALLREGCOMP_ENG(eng, exp, xend, pm);
3762 RExC_state_t RExC_state;
3763 RExC_state_t * const pRExC_state = &RExC_state;
3764 #ifdef TRIE_STUDY_OPT
3766 RExC_state_t copyRExC_state;
3769 FAIL("NULL regexp argument");
3771 RExC_utf8 = pm->op_pmdynflags & PMdf_CMP_UTF8;
3775 SV *dsv= sv_newmortal();
3776 RE_PV_QUOTED_DECL(s, RExC_utf8,
3777 dsv, RExC_precomp, (xend - exp), 60);
3778 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
3779 PL_colors[4],PL_colors[5],s);
3781 RExC_flags = pm->op_pmflags;
3785 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
3786 RExC_seen_evals = 0;
3789 /* First pass: determine size, legality. */
3796 RExC_emit = &PL_regdummy;
3797 RExC_whilem_seen = 0;
3798 RExC_charnames = NULL;
3800 RExC_paren_names = NULL;
3802 #if 0 /* REGC() is (currently) a NOP at the first pass.
3803 * Clever compilers notice this and complain. --jhi */
3804 REGC((U8)REG_MAGIC, (char*)RExC_emit);
3806 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n"));
3807 if (reg(pRExC_state, 0, &flags,1) == NULL) {
3808 RExC_precomp = NULL;
3812 PerlIO_printf(Perl_debug_log,
3813 "Required size %"IVdf" nodes\n"
3814 "Starting second pass (creation)\n",
3817 RExC_lastparse=NULL;
3819 /* Small enough for pointer-storage convention?
3820 If extralen==0, this means that we will not need long jumps. */
3821 if (RExC_size >= 0x10000L && RExC_extralen)
3822 RExC_size += RExC_extralen;
3825 if (RExC_whilem_seen > 15)
3826 RExC_whilem_seen = 15;
3828 /* Allocate space and zero-initialize. Note, the two step process
3829 of zeroing when in debug mode, thus anything assigned has to
3830 happen after that */
3831 Newxc(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode),
3834 FAIL("Regexp out of space");
3836 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
3837 Zero(r, sizeof(regexp) + (unsigned)RExC_size * sizeof(regnode), char);
3839 /* initialization begins here */
3840 r->engine= RE_ENGINE_PTR;
3842 r->prelen = xend - exp;
3843 r->precomp = savepvn(RExC_precomp, r->prelen);
3845 #ifdef PERL_OLD_COPY_ON_WRITE
3846 r->saved_copy = NULL;
3848 r->reganch = pm->op_pmflags & PMf_COMPILETIME;
3849 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
3850 r->lastparen = 0; /* mg.c reads this. */
3852 r->substrs = 0; /* Useful during FAIL. */
3853 r->startp = 0; /* Useful during FAIL. */
3857 if (RExC_seen & REG_SEEN_RECURSE) {
3858 Newx(RExC_parens, RExC_npar,regnode *);
3859 SAVEFREEPV(RExC_parens);
3862 /* Useful during FAIL. */
3863 Newxz(r->offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
3865 r->offsets[0] = RExC_size;
3867 DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
3868 "%s %"UVuf" bytes for offset annotations.\n",
3869 r->offsets ? "Got" : "Couldn't get",
3870 (UV)((2*RExC_size+1) * sizeof(U32))));
3874 /* Second pass: emit code. */
3875 RExC_flags = pm->op_pmflags; /* don't let top level (?i) bleed */
3880 RExC_emit_start = r->program;
3881 RExC_emit = r->program;
3882 /* Store the count of eval-groups for security checks: */
3883 RExC_emit->next_off = (RExC_seen_evals > (I32)U16_MAX) ? U16_MAX : (U16)RExC_seen_evals;
3884 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
3886 if (reg(pRExC_state, 0, &flags,1) == NULL)
3889 /* XXXX To minimize changes to RE engine we always allocate
3890 3-units-long substrs field. */
3891 Newx(r->substrs, 1, struct reg_substr_data);
3894 r->minlen = minlen = sawplus = sawopen = 0;
3895 Zero(r->substrs, 1, struct reg_substr_data);
3896 StructCopy(&zero_scan_data, &data, scan_data_t);
3898 #ifdef TRIE_STUDY_OPT
3900 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
3901 RExC_state=copyRExC_state;
3902 if (data.last_found) {
3903 SvREFCNT_dec(data.longest_fixed);
3904 SvREFCNT_dec(data.longest_float);
3905 SvREFCNT_dec(data.last_found);
3908 copyRExC_state=RExC_state;
3912 /* Dig out information for optimizations. */
3913 r->reganch = pm->op_pmflags & PMf_COMPILETIME; /* Again? */
3914 pm->op_pmflags = RExC_flags;
3916 r->reganch |= ROPT_UTF8; /* Unicode in it? */
3917 r->regstclass = NULL;
3918 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
3919 r->reganch |= ROPT_NAUGHTY;
3920 scan = r->program + 1; /* First BRANCH. */
3922 /* testing for BRANCH here tells us whether there is "must appear"
3923 data in the pattern. If there is then we can use it for optimisations */
3924 if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */
3926 STRLEN longest_float_length, longest_fixed_length;
3927 struct regnode_charclass_class ch_class; /* pointed to by data */
3929 I32 last_close = 0; /* pointed to by data */
3932 /* Skip introductions and multiplicators >= 1. */
3933 while ((OP(first) == OPEN && (sawopen = 1)) ||
3934 /* An OR of *one* alternative - should not happen now. */
3935 (OP(first) == BRANCH && OP(regnext(first)) != BRANCH) ||
3936 /* for now we can't handle lookbehind IFMATCH*/
3937 (OP(first) == IFMATCH && !first->flags) ||
3938 (OP(first) == PLUS) ||
3939 (OP(first) == MINMOD) ||
3940 /* An {n,m} with n>0 */
3941 (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) )
3944 if (OP(first) == PLUS)
3947 first += regarglen[OP(first)];
3948 if (OP(first) == IFMATCH) {
3949 first = NEXTOPER(first);
3950 first += EXTRA_STEP_2ARGS;
3951 } else /* XXX possible optimisation for /(?=)/ */
3952 first = NEXTOPER(first);
3955 /* Starting-point info. */
3957 DEBUG_PEEP("first:",first,0);
3958 /* Ignore EXACT as we deal with it later. */
3959 if (PL_regkind[OP(first)] == EXACT) {
3960 if (OP(first) == EXACT)
3961 NOOP; /* Empty, get anchored substr later. */
3962 else if ((OP(first) == EXACTF || OP(first) == EXACTFL))
3963 r->regstclass = first;
3966 else if (PL_regkind[OP(first)] == TRIE &&
3967 ((reg_trie_data *)r->data->data[ ARG(first) ])->minlen>0)
3970 /* this can happen only on restudy */
3971 if ( OP(first) == TRIE ) {
3972 struct regnode_1 *trieop;
3973 Newxz(trieop,1,struct regnode_1);
3974 StructCopy(first,trieop,struct regnode_1);
3975 trie_op=(regnode *)trieop;
3977 struct regnode_charclass *trieop;
3978 Newxz(trieop,1,struct regnode_charclass);
3979 StructCopy(first,trieop,struct regnode_charclass);
3980 trie_op=(regnode *)trieop;
3983 make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
3984 r->regstclass = trie_op;
3987 else if (strchr((const char*)PL_simple,OP(first)))
3988 r->regstclass = first;
3989 else if (PL_regkind[OP(first)] == BOUND ||
3990 PL_regkind[OP(first)] == NBOUND)
3991 r->regstclass = first;
3992 else if (PL_regkind[OP(first)] == BOL) {
3993 r->reganch |= (OP(first) == MBOL
3995 : (OP(first) == SBOL
3998 first = NEXTOPER(first);
4001 else if (OP(first) == GPOS) {
4002 r->reganch |= ROPT_ANCH_GPOS;
4003 first = NEXTOPER(first);
4006 else if (!sawopen && (OP(first) == STAR &&
4007 PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
4008 !(r->reganch & ROPT_ANCH) )
4010 /* turn .* into ^.* with an implied $*=1 */
4012 (OP(NEXTOPER(first)) == REG_ANY)
4015 r->reganch |= type | ROPT_IMPLICIT;
4016 first = NEXTOPER(first);
4019 if (sawplus && (!sawopen || !RExC_sawback)
4020 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
4021 /* x+ must match at the 1st pos of run of x's */
4022 r->reganch |= ROPT_SKIP;
4024 /* Scan is after the zeroth branch, first is atomic matcher. */
4025 #ifdef TRIE_STUDY_OPT
4028 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4029 (IV)(first - scan + 1))
4033 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
4034 (IV)(first - scan + 1))
4040 * If there's something expensive in the r.e., find the
4041 * longest literal string that must appear and make it the
4042 * regmust. Resolve ties in favor of later strings, since
4043 * the regstart check works with the beginning of the r.e.
4044 * and avoiding duplication strengthens checking. Not a
4045 * strong reason, but sufficient in the absence of others.
4046 * [Now we resolve ties in favor of the earlier string if
4047 * it happens that c_offset_min has been invalidated, since the
4048 * earlier string may buy us something the later one won't.]
4052 data.longest_fixed = newSVpvs("");
4053 data.longest_float = newSVpvs("");
4054 data.last_found = newSVpvs("");
4055 data.longest = &(data.longest_fixed);
4057 if (!r->regstclass) {
4058 cl_init(pRExC_state, &ch_class);
4059 data.start_class = &ch_class;
4060 stclass_flag = SCF_DO_STCLASS_AND;
4061 } else /* XXXX Check for BOUND? */
4063 data.last_closep = &last_close;
4065 minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
4066 &data, SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
4072 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
4073 && data.last_start_min == 0 && data.last_end > 0
4074 && !RExC_seen_zerolen
4075 && (!(RExC_seen & REG_SEEN_GPOS) || (r->reganch & ROPT_ANCH_GPOS)))
4076 r->reganch |= ROPT_CHECK_ALL;
4077 scan_commit(pRExC_state, &data,&minlen);
4078 SvREFCNT_dec(data.last_found);
4080 /* Note that code very similar to this but for anchored string
4081 follows immediately below, changes may need to be made to both.
4084 longest_float_length = CHR_SVLEN(data.longest_float);
4085 if (longest_float_length
4086 || (data.flags & SF_FL_BEFORE_EOL
4087 && (!(data.flags & SF_FL_BEFORE_MEOL)
4088 || (RExC_flags & PMf_MULTILINE))))
4092 if (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
4093 && data.offset_fixed == data.offset_float_min
4094 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float))
4095 goto remove_float; /* As in (a)+. */
4097 /* copy the information about the longest float from the reg_scan_data
4098 over to the program. */
4099 if (SvUTF8(data.longest_float)) {
4100 r->float_utf8 = data.longest_float;
4101 r->float_substr = NULL;
4103 r->float_substr = data.longest_float;
4104 r->float_utf8 = NULL;
4106 /* float_end_shift is how many chars that must be matched that
4107 follow this item. We calculate it ahead of time as once the
4108 lookbehind offset is added in we lose the ability to correctly
4110 ml = data.minlen_float ? *(data.minlen_float)
4111 : (I32)longest_float_length;
4112 r->float_end_shift = ml - data.offset_float_min
4113 - longest_float_length + (SvTAIL(data.longest_float) != 0)
4114 + data.lookbehind_float;
4115 r->float_min_offset = data.offset_float_min - data.lookbehind_float;
4116 r->float_max_offset = data.offset_float_max;
4117 if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
4118 r->float_max_offset -= data.lookbehind_float;
4120 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
4121 && (!(data.flags & SF_FL_BEFORE_MEOL)
4122 || (RExC_flags & PMf_MULTILINE)));
4123 fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
4127 r->float_substr = r->float_utf8 = NULL;
4128 SvREFCNT_dec(data.longest_float);
4129 longest_float_length = 0;
4132 /* Note that code very similar to this but for floating string
4133 is immediately above, changes may need to be made to both.
4136 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
4137 if (longest_fixed_length
4138 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
4139 && (!(data.flags & SF_FIX_BEFORE_MEOL)
4140 || (RExC_flags & PMf_MULTILINE))))
4144 /* copy the information about the longest fixed
4145 from the reg_scan_data over to the program. */
4146 if (SvUTF8(data.longest_fixed)) {
4147 r->anchored_utf8 = data.longest_fixed;
4148 r->anchored_substr = NULL;
4150 r->anchored_substr = data.longest_fixed;
4151 r->anchored_utf8 = NULL;
4153 /* fixed_end_shift is how many chars that must be matched that
4154 follow this item. We calculate it ahead of time as once the
4155 lookbehind offset is added in we lose the ability to correctly
4157 ml = data.minlen_fixed ? *(data.minlen_fixed)
4158 : (I32)longest_fixed_length;
4159 r->anchored_end_shift = ml - data.offset_fixed
4160 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
4161 + data.lookbehind_fixed;
4162 r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
4164 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
4165 && (!(data.flags & SF_FIX_BEFORE_MEOL)
4166 || (RExC_flags & PMf_MULTILINE)));
4167 fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
4170 r->anchored_substr = r->anchored_utf8 = NULL;
4171 SvREFCNT_dec(data.longest_fixed);
4172 longest_fixed_length = 0;
4175 && (OP(r->regstclass) == REG_ANY || OP(r->regstclass) == SANY))
4176 r->regstclass = NULL;
4177 if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
4179 && !(data.start_class->flags & ANYOF_EOS)
4180 && !cl_is_anything(data.start_class))
4182 const I32 n = add_data(pRExC_state, 1, "f");
4184 Newx(RExC_rx->data->data[n], 1,
4185 struct regnode_charclass_class);
4186 StructCopy(data.start_class,
4187 (struct regnode_charclass_class*)RExC_rx->data->data[n],
4188 struct regnode_charclass_class);
4189 r->regstclass = (regnode*)RExC_rx->data->data[n];
4190 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
4191 DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
4192 regprop(r, sv, (regnode*)data.start_class);
4193 PerlIO_printf(Perl_debug_log,
4194 "synthetic stclass \"%s\".\n",
4195 SvPVX_const(sv));});
4198 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
4199 if (longest_fixed_length > longest_float_length) {
4200 r->check_end_shift = r->anchored_end_shift;
4201 r->check_substr = r->anchored_substr;
4202 r->check_utf8 = r->anchored_utf8;
4203 r->check_offset_min = r->check_offset_max = r->anchored_offset;
4204 if (r->reganch & ROPT_ANCH_SINGLE)
4205 r->reganch |= ROPT_NOSCAN;
4208 r->check_end_shift = r->float_end_shift;
4209 r->check_substr = r->float_substr;
4210 r->check_utf8 = r->float_utf8;
4211 r->check_offset_min = r->float_min_offset;
4212 r->check_offset_max = r->float_max_offset;
4214 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
4215 This should be changed ASAP! */
4216 if ((r->check_substr || r->check_utf8) && !(r->reganch & ROPT_ANCH_GPOS)) {
4217 r->reganch |= RE_USE_INTUIT;
4218 if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
4219 r->reganch |= RE_INTUIT_TAIL;
4221 /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
4222 if ( (STRLEN)minlen < longest_float_length )
4223 minlen= longest_float_length;
4224 if ( (STRLEN)minlen < longest_fixed_length )
4225 minlen= longest_fixed_length;
4229 /* Several toplevels. Best we can is to set minlen. */
4231 struct regnode_charclass_class ch_class;
4234 DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "\n"));
4236 scan = r->program + 1;
4237 cl_init(pRExC_state, &ch_class);
4238 data.start_class = &ch_class;
4239 data.last_closep = &last_close;
4241 minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
4242 &data, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
4246 r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
4247 = r->float_substr = r->float_utf8 = NULL;
4248 if (!(data.start_class->flags & ANYOF_EOS)
4249 && !cl_is_anything(data.start_class))
4251 const I32 n = add_data(pRExC_state, 1, "f");
4253 Newx(RExC_rx->data->data[n], 1,
4254 struct regnode_charclass_class);
4255 StructCopy(data.start_class,
4256 (struct regnode_charclass_class*)RExC_rx->data->data[n],
4257 struct regnode_charclass_class);
4258 r->regstclass = (regnode*)RExC_rx->data->data[n];
4259 r->reganch &= ~ROPT_SKIP; /* Used in find_byclass(). */
4260 DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
4261 regprop(r, sv, (regnode*)data.start_class);
4262 PerlIO_printf(Perl_debug_log,
4263 "synthetic stclass \"%s\".\n",
4264 SvPVX_const(sv));});
4268 /* Guard against an embedded (?=) or (?<=) with a longer minlen than
4269 the "real" pattern. */
4270 if (r->minlen < minlen)
4273 if (RExC_seen & REG_SEEN_GPOS)
4274 r->reganch |= ROPT_GPOS_SEEN;
4275 if (RExC_seen & REG_SEEN_LOOKBEHIND)
4276 r->reganch |= ROPT_LOOKBEHIND_SEEN;
4277 if (RExC_seen & REG_SEEN_EVAL)
4278 r->reganch |= ROPT_EVAL_SEEN;
4279 if (RExC_seen & REG_SEEN_CANY)
4280 r->reganch |= ROPT_CANY_SEEN;
4281 if (RExC_paren_names)
4282 r->paren_names = (HV*)SvREFCNT_inc(RExC_paren_names);
4284 r->paren_names = NULL;
4286 Newxz(r->startp, RExC_npar, I32);
4287 Newxz(r->endp, RExC_npar, I32);
4289 DEBUG_r( RX_DEBUG_on(r) );
4291 PerlIO_printf(Perl_debug_log,"Final program:\n");
4294 DEBUG_OFFSETS_r(if (r->offsets) {
4295 const U32 len = r->offsets[0];
4297 GET_RE_DEBUG_FLAGS_DECL;
4298 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)r->offsets[0]);
4299 for (i = 1; i <= len; i++) {
4300 if (r->offsets[i*2-1] || r->offsets[i*2])
4301 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
4302 (UV)i, (UV)r->offsets[i*2-1], (UV)r->offsets[i*2]);
4304 PerlIO_printf(Perl_debug_log, "\n");
4310 #undef CORE_ONLY_BLOCK
4312 #undef RE_ENGINE_PTR
4314 #ifndef PERL_IN_XSUB_RE
4316 Perl_reg_named_buff_sv(pTHX_ SV* namesv)
4318 I32 parno = 0; /* no match */
4320 const REGEXP * const rx = PM_GETRE(PL_curpm);
4321 if (rx && rx->paren_names) {
4322 HE *he_str = hv_fetch_ent( rx->paren_names, namesv, 0, 0 );
4325 SV* sv_dat=HeVAL(he_str);
4326 I32 *nums=(I32*)SvPVX(sv_dat);
4327 for ( i=0; i<SvIVX(sv_dat); i++ ) {
4328 if ((I32)(rx->lastparen) >= nums[i] &&
4329 rx->endp[nums[i]] != -1)
4342 SV *sv= sv_newmortal();
4343 Perl_sv_setpvf(aTHX_ sv, "%"IVdf,(IV)parno);
4344 gv_paren= Perl_gv_fetchsv(aTHX_ sv, GV_ADD, SVt_PVGV);
4345 return GvSVn(gv_paren);
4350 /* Scans the name of a named buffer from the pattern.
4351 * If flags is REG_RSN_RETURN_NULL returns null.
4352 * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
4353 * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
4354 * to the parsed name as looked up in the RExC_paren_names hash.
4355 * If there is an error throws a vFAIL().. type exception.
4358 #define REG_RSN_RETURN_NULL 0
4359 #define REG_RSN_RETURN_NAME 1
4360 #define REG_RSN_RETURN_DATA 2
4363 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags) {
4364 char *name_start = RExC_parse;
4367 while( isIDFIRST_uni(utf8n_to_uvchr((U8*)RExC_parse,
4368 RExC_end - RExC_parse, &numlen, UTF8_ALLOW_DEFAULT)))
4370 RExC_parse += numlen;
4373 while( isIDFIRST(*RExC_parse) )
4377 SV* sv_name = sv_2mortal(Perl_newSVpvn(aTHX_ name_start,
4378 (int)(RExC_parse - name_start)));
4381 if ( flags == REG_RSN_RETURN_NAME)
4383 else if (flags==REG_RSN_RETURN_DATA) {
4386 if ( ! sv_name ) /* should not happen*/
4387 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
4388 if (RExC_paren_names)
4389 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
4391 sv_dat = HeVAL(he_str);
4393 vFAIL("Reference to nonexistent named group");
4397 Perl_croak(aTHX_ "panic: bad flag in reg_scan_name");
4404 #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
4405 int rem=(int)(RExC_end - RExC_parse); \
4414 if (RExC_lastparse!=RExC_parse) \
4415 PerlIO_printf(Perl_debug_log," >%.*s%-*s", \
4418 iscut ? "..." : "<" \
4421 PerlIO_printf(Perl_debug_log,"%16s",""); \
4426 num=REG_NODE_NUM(RExC_emit); \
4427 if (RExC_lastnum!=num) \
4428 PerlIO_printf(Perl_debug_log,"|%4d",num); \
4430 PerlIO_printf(Perl_debug_log,"|%4s",""); \
4431 PerlIO_printf(Perl_debug_log,"|%*s%-4s", \
4432 (int)((depth*2)), "", \
4436 RExC_lastparse=RExC_parse; \
4441 #define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
4442 DEBUG_PARSE_MSG((funcname)); \
4443 PerlIO_printf(Perl_debug_log,"%4s","\n"); \
4445 #define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({ \
4446 DEBUG_PARSE_MSG((funcname)); \
4447 PerlIO_printf(Perl_debug_log,fmt "\n",args); \
4450 - reg - regular expression, i.e. main body or parenthesized thing
4452 * Caller must absorb opening parenthesis.
4454 * Combining parenthesis handling with the base level of regular expression
4455 * is a trifle forced, but the need to tie the tails of the branches to what
4456 * follows makes it hard to avoid.
4458 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
4460 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
4462 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
4466 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
4467 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
4470 register regnode *ret; /* Will be the head of the group. */
4471 register regnode *br;
4472 register regnode *lastbr;
4473 register regnode *ender = NULL;
4474 register I32 parno = 0;
4476 const I32 oregflags = RExC_flags;
4477 bool have_branch = 0;
4480 /* for (?g), (?gc), and (?o) warnings; warning
4481 about (?c) will warn about (?g) -- japhy */
4483 #define WASTED_O 0x01
4484 #define WASTED_G 0x02
4485 #define WASTED_C 0x04
4486 #define WASTED_GC (0x02|0x04)
4487 I32 wastedflags = 0x00;
4489 char * parse_start = RExC_parse; /* MJD */
4490 char * const oregcomp_parse = RExC_parse;
4492 GET_RE_DEBUG_FLAGS_DECL;
4493 DEBUG_PARSE("reg ");
4496 *flagp = 0; /* Tentatively. */
4499 /* Make an OPEN node, if parenthesized. */
4501 if (*RExC_parse == '?') { /* (?...) */
4502 U32 posflags = 0, negflags = 0;
4503 U32 *flagsp = &posflags;
4504 bool is_logical = 0;
4505 const char * const seqstart = RExC_parse;
4508 paren = *RExC_parse++;
4509 ret = NULL; /* For look-ahead/behind. */
4512 case '<': /* (?<...) */
4513 if (*RExC_parse == '!')
4515 else if (*RExC_parse != '=')
4520 case '\'': /* (?'...') */
4521 name_start= RExC_parse;
4522 svname = reg_scan_name(pRExC_state,
4523 SIZE_ONLY ? /* reverse test from the others */
4524 REG_RSN_RETURN_NAME :
4525 REG_RSN_RETURN_NULL);
4526 if (RExC_parse == name_start)
4528 if (*RExC_parse != paren)
4529 vFAIL2("Sequence (?%c... not terminated",
4530 paren=='>' ? '<' : paren);
4534 if (!svname) /* shouldnt happen */
4536 "panic: reg_scan_name returned NULL");
4537 if (!RExC_paren_names) {
4538 RExC_paren_names= newHV();
4539 sv_2mortal((SV*)RExC_paren_names);
4541 he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
4543 sv_dat = HeVAL(he_str);
4545 /* croak baby croak */
4547 "panic: paren_name hash element allocation failed");
4548 } else if ( SvPOK(sv_dat) ) {
4549 IV count=SvIV(sv_dat);
4550 I32 *pv=(I32*)SvGROW(sv_dat,SvCUR(sv_dat)+sizeof(I32)+1);
4551 SvCUR_set(sv_dat,SvCUR(sv_dat)+sizeof(I32));
4552 pv[count]=RExC_npar;
4555 (void)SvUPGRADE(sv_dat,SVt_PVNV);
4556 sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
4561 /*sv_dump(sv_dat);*/
4563 nextchar(pRExC_state);
4565 goto capturing_parens;
4567 RExC_seen |= REG_SEEN_LOOKBEHIND;
4569 case '=': /* (?=...) */
4570 case '!': /* (?!...) */
4571 RExC_seen_zerolen++;
4572 case ':': /* (?:...) */
4573 case '>': /* (?>...) */
4575 case '$': /* (?$...) */
4576 case '@': /* (?@...) */
4577 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
4579 case '#': /* (?#...) */
4580 while (*RExC_parse && *RExC_parse != ')')
4582 if (*RExC_parse != ')')
4583 FAIL("Sequence (?#... not terminated");
4584 nextchar(pRExC_state);
4587 case '0' : /* (?0) */
4588 case 'R' : /* (?R) */
4589 if (*RExC_parse != ')')
4590 FAIL("Sequence (?R) not terminated");
4591 reg_node(pRExC_state, SRECURSE);
4592 break; /* (?PARNO) */
4593 { /* named and numeric backreferences */
4596 case '&': /* (?&NAME) */
4597 parse_start = RExC_parse - 1;
4599 SV *sv_dat = reg_scan_name(pRExC_state,
4600 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
4601 num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
4603 goto gen_recurse_regop;
4605 case '1': case '2': case '3': case '4': /* (?1) */
4606 case '5': case '6': case '7': case '8': case '9':
4608 num = atoi(RExC_parse);
4609 parse_start = RExC_parse - 1; /* MJD */
4610 while (isDIGIT(*RExC_parse))
4612 if (*RExC_parse!=')')
4613 vFAIL("Expecting close bracket");
4616 ret = reganode(pRExC_state, RECURSE, num);
4618 if (num > (I32)RExC_rx->nparens) {
4620 vFAIL("Reference to nonexistent group");
4624 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
4625 "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
4629 RExC_seen |= REG_SEEN_RECURSE;
4630 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
4631 Set_Node_Offset(ret, parse_start); /* MJD */
4633 nextchar(pRExC_state);
4635 } /* named and numeric backreferences */
4638 case 'p': /* (?p...) */
4639 if (SIZE_ONLY && ckWARN2(WARN_DEPRECATED, WARN_REGEXP))
4640 vWARNdep(RExC_parse, "(?p{}) is deprecated - use (??{})");
4642 case '?': /* (??...) */
4644 if (*RExC_parse != '{')
4646 paren = *RExC_parse++;
4648 case '{': /* (?{...}) */
4650 I32 count = 1, n = 0;
4652 char *s = RExC_parse;
4654 RExC_seen_zerolen++;
4655 RExC_seen |= REG_SEEN_EVAL;
4656 while (count && (c = *RExC_parse)) {
4667 if (*RExC_parse != ')') {
4669 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
4673 OP_4tree *sop, *rop;
4674 SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
4677 Perl_save_re_context(aTHX);
4678 rop = sv_compile_2op(sv, &sop, "re", &pad);
4679 sop->op_private |= OPpREFCOUNTED;
4680 /* re_dup will OpREFCNT_inc */
4681 OpREFCNT_set(sop, 1);
4684 n = add_data(pRExC_state, 3, "nop");
4685 RExC_rx->data->data[n] = (void*)rop;
4686 RExC_rx->data->data[n+1] = (void*)sop;
4687 RExC_rx->data->data[n+2] = (void*)pad;
4690 else { /* First pass */
4691 if (PL_reginterp_cnt < ++RExC_seen_evals
4693 /* No compiled RE interpolated, has runtime
4694 components ===> unsafe. */
4695 FAIL("Eval-group not allowed at runtime, use re 'eval'");
4696 if (PL_tainting && PL_tainted)
4697 FAIL("Eval-group in insecure regular expression");
4698 #if PERL_VERSION > 8
4699 if (IN_PERL_COMPILETIME)
4704 nextchar(pRExC_state);
4706 ret = reg_node(pRExC_state, LOGICAL);
4709 REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
4710 /* deal with the length of this later - MJD */
4713 ret = reganode(pRExC_state, EVAL, n);
4714 Set_Node_Length(ret, RExC_parse - parse_start + 1);
4715 Set_Node_Offset(ret, parse_start);
4718 case '(': /* (?(?{...})...) and (?(?=...)...) */
4721 if (RExC_parse[0] == '?') { /* (?(?...)) */
4722 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
4723 || RExC_parse[1] == '<'
4724 || RExC_parse[1] == '{') { /* Lookahead or eval. */
4727 ret = reg_node(pRExC_state, LOGICAL);
4730 REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
4734 else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
4735 || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
4737 char ch = RExC_parse[0] == '<' ? '>' : '\'';
4738 char *name_start= RExC_parse++;
4740 SV *sv_dat=reg_scan_name(pRExC_state,
4741 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
4742 if (RExC_parse == name_start || *RExC_parse != ch)
4743 vFAIL2("Sequence (?(%c... not terminated",
4744 (ch == '>' ? '<' : ch));
4747 num = add_data( pRExC_state, 1, "S" );
4748 RExC_rx->data->data[num]=(void*)sv_dat;
4749 SvREFCNT_inc(sv_dat);
4751 ret = reganode(pRExC_state,NGROUPP,num);
4752 goto insert_if_check_paren;
4754 else if (RExC_parse[0] == 'D' &&
4755 RExC_parse[1] == 'E' &&
4756 RExC_parse[2] == 'F' &&
4757 RExC_parse[3] == 'I' &&
4758 RExC_parse[4] == 'N' &&
4759 RExC_parse[5] == 'E')
4761 ret = reganode(pRExC_state,DEFINEP,0);
4764 goto insert_if_check_paren;
4766 else if (RExC_parse[0] == 'R') {
4769 if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
4770 parno = atoi(RExC_parse++);
4771 while (isDIGIT(*RExC_parse))
4773 } else if (RExC_parse[0] == '&') {
4776 sv_dat = reg_scan_name(pRExC_state,
4777 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
4778 parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
4780 ret = reganode(pRExC_state,RECURSEP,parno);
4781 goto insert_if_check_paren;
4783 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
4786 parno = atoi(RExC_parse++);
4788 while (isDIGIT(*RExC_parse))
4790 ret = reganode(pRExC_state, GROUPP, parno);
4792 insert_if_check_paren:
4793 if ((c = *nextchar(pRExC_state)) != ')')
4794 vFAIL("Switch condition not recognized");
4796 REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
4797 br = regbranch(pRExC_state, &flags, 1,depth+1);
4799 br = reganode(pRExC_state, LONGJMP, 0);
4801 REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
4802 c = *nextchar(pRExC_state);
4807 vFAIL("(?(DEFINE)....) does not allow branches");
4808 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
4809 regbranch(pRExC_state, &flags, 1,depth+1);
4810 REGTAIL(pRExC_state, ret, lastbr);
4813 c = *nextchar(pRExC_state);
4818 vFAIL("Switch (?(condition)... contains too many branches");
4819 ender = reg_node(pRExC_state, TAIL);
4820 REGTAIL(pRExC_state, br, ender);
4822 REGTAIL(pRExC_state, lastbr, ender);
4823 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
4826 REGTAIL(pRExC_state, ret, ender);
4830 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
4834 RExC_parse--; /* for vFAIL to print correctly */
4835 vFAIL("Sequence (? incomplete");
4839 parse_flags: /* (?i) */
4840 while (*RExC_parse && strchr("iogcmsx", *RExC_parse)) {
4841 /* (?g), (?gc) and (?o) are useless here
4842 and must be globally applied -- japhy */
4844 if (*RExC_parse == 'o' || *RExC_parse == 'g') {
4845 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
4846 const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
4847 if (! (wastedflags & wflagbit) ) {
4848 wastedflags |= wflagbit;
4851 "Useless (%s%c) - %suse /%c modifier",
4852 flagsp == &negflags ? "?-" : "?",
4854 flagsp == &negflags ? "don't " : "",
4860 else if (*RExC_parse == 'c') {
4861 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
4862 if (! (wastedflags & WASTED_C) ) {
4863 wastedflags |= WASTED_GC;
4866 "Useless (%sc) - %suse /gc modifier",
4867 flagsp == &negflags ? "?-" : "?",
4868 flagsp == &negflags ? "don't " : ""
4873 else { pmflag(flagsp, *RExC_parse); }
4877 if (*RExC_parse == '-') {
4879 wastedflags = 0; /* reset so (?g-c) warns twice */
4883 RExC_flags |= posflags;
4884 RExC_flags &= ~negflags;
4885 if (*RExC_parse == ':') {
4891 if (*RExC_parse != ')') {
4893 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
4895 nextchar(pRExC_state);
4904 ret = reganode(pRExC_state, OPEN, parno);
4905 if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
4906 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
4907 "Setting paren #%"IVdf" to %d\n", (IV)parno, REG_NODE_NUM(ret)));
4908 RExC_parens[parno-1]= ret;
4911 Set_Node_Length(ret, 1); /* MJD */
4912 Set_Node_Offset(ret, RExC_parse); /* MJD */
4919 /* Pick up the branches, linking them together. */
4920 parse_start = RExC_parse; /* MJD */
4921 br = regbranch(pRExC_state, &flags, 1,depth+1);
4922 /* branch_len = (paren != 0); */
4926 if (*RExC_parse == '|') {
4927 if (!SIZE_ONLY && RExC_extralen) {
4928 reginsert(pRExC_state, BRANCHJ, br, depth+1);
4931 reginsert(pRExC_state, BRANCH, br, depth+1);
4932 Set_Node_Length(br, paren != 0);
4933 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
4937 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
4939 else if (paren == ':') {
4940 *flagp |= flags&SIMPLE;
4942 if (is_open) { /* Starts with OPEN. */
4943 REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
4945 else if (paren != '?') /* Not Conditional */
4947 *flagp |= flags & (SPSTART | HASWIDTH);
4949 while (*RExC_parse == '|') {
4950 if (!SIZE_ONLY && RExC_extralen) {
4951 ender = reganode(pRExC_state, LONGJMP,0);
4952 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
4955 RExC_extralen += 2; /* Account for LONGJMP. */
4956 nextchar(pRExC_state);
4957 br = regbranch(pRExC_state, &flags, 0, depth+1);
4961 REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
4965 *flagp |= flags&SPSTART;
4968 if (have_branch || paren != ':') {
4969 /* Make a closing node, and hook it on the end. */
4972 ender = reg_node(pRExC_state, TAIL);
4975 ender = reganode(pRExC_state, CLOSE, parno);
4976 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
4977 Set_Node_Length(ender,1); /* MJD */
4983 *flagp &= ~HASWIDTH;
4986 ender = reg_node(pRExC_state, SUCCEED);
4989 ender = reg_node(pRExC_state, END);
4992 REGTAIL(pRExC_state, lastbr, ender);
4994 if (have_branch && !SIZE_ONLY) {
4996 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
4998 /* Hook the tails of the branches to the closing node. */
4999 for (br = ret; br; br = regnext(br)) {
5000 const U8 op = PL_regkind[OP(br)];
5002 REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
5004 else if (op == BRANCHJ) {
5005 REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
5013 static const char parens[] = "=!<,>";
5015 if (paren && (p = strchr(parens, paren))) {
5016 U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
5017 int flag = (p - parens) > 1;
5020 node = SUSPEND, flag = 0;
5021 reginsert(pRExC_state, node,ret, depth+1);
5022 Set_Node_Cur_Length(ret);
5023 Set_Node_Offset(ret, parse_start + 1);
5025 REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
5029 /* Check for proper termination. */
5031 RExC_flags = oregflags;
5032 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
5033 RExC_parse = oregcomp_parse;
5034 vFAIL("Unmatched (");
5037 else if (!paren && RExC_parse < RExC_end) {
5038 if (*RExC_parse == ')') {
5040 vFAIL("Unmatched )");
5043 FAIL("Junk on end of regexp"); /* "Can't happen". */
5051 - regbranch - one alternative of an | operator
5053 * Implements the concatenation operator.
5056 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
5059 register regnode *ret;
5060 register regnode *chain = NULL;
5061 register regnode *latest;
5062 I32 flags = 0, c = 0;
5063 GET_RE_DEBUG_FLAGS_DECL;
5064 DEBUG_PARSE("brnc");
5068 if (!SIZE_ONLY && RExC_extralen)
5069 ret = reganode(pRExC_state, BRANCHJ,0);
5071 ret = reg_node(pRExC_state, BRANCH);
5072 Set_Node_Length(ret, 1);
5076 if (!first && SIZE_ONLY)
5077 RExC_extralen += 1; /* BRANCHJ */
5079 *flagp = WORST; /* Tentatively. */
5082 nextchar(pRExC_state);
5083 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
5085 latest = regpiece(pRExC_state, &flags,depth+1);
5086 if (latest == NULL) {
5087 if (flags & TRYAGAIN)
5091 else if (ret == NULL)
5093 *flagp |= flags&HASWIDTH;
5094 if (chain == NULL) /* First piece. */
5095 *flagp |= flags&SPSTART;
5098 REGTAIL(pRExC_state, chain, latest);
5103 if (chain == NULL) { /* Loop ran zero times. */
5104 chain = reg_node(pRExC_state, NOTHING);
5109 *flagp |= flags&SIMPLE;
5116 - regpiece - something followed by possible [*+?]
5118 * Note that the branching code sequences used for ? and the general cases
5119 * of * and + are somewhat optimized: they use the same NOTHING node as
5120 * both the endmarker for their branch list and the body of the last branch.
5121 * It might seem that this node could be dispensed with entirely, but the
5122 * endmarker role is not redundant.
5125 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
5128 register regnode *ret;
5130 register char *next;
5132 const char * const origparse = RExC_parse;
5134 I32 max = REG_INFTY;
5136 const char *maxpos = NULL;
5137 GET_RE_DEBUG_FLAGS_DECL;
5138 DEBUG_PARSE("piec");
5140 ret = regatom(pRExC_state, &flags,depth+1);
5142 if (flags & TRYAGAIN)
5149 if (op == '{' && regcurly(RExC_parse)) {
5151 parse_start = RExC_parse; /* MJD */
5152 next = RExC_parse + 1;
5153 while (isDIGIT(*next) || *next == ',') {
5162 if (*next == '}') { /* got one */
5166 min = atoi(RExC_parse);
5170 maxpos = RExC_parse;
5172 if (!max && *maxpos != '0')
5173 max = REG_INFTY; /* meaning "infinity" */
5174 else if (max >= REG_INFTY)
5175 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
5177 nextchar(pRExC_state);
5180 if ((flags&SIMPLE)) {
5181 RExC_naughty += 2 + RExC_naughty / 2;
5182 reginsert(pRExC_state, CURLY, ret, depth+1);
5183 Set_Node_Offset(ret, parse_start+1); /* MJD */
5184 Set_Node_Cur_Length(ret);
5187 regnode * const w = reg_node(pRExC_state, WHILEM);
5190 REGTAIL(pRExC_state, ret, w);
5191 if (!SIZE_ONLY && RExC_extralen) {
5192 reginsert(pRExC_state, LONGJMP,ret, depth+1);
5193 reginsert(pRExC_state, NOTHING,ret, depth+1);
5194 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
5196 reginsert(pRExC_state, CURLYX,ret, depth+1);
5198 Set_Node_Offset(ret, parse_start+1);
5199 Set_Node_Length(ret,
5200 op == '{' ? (RExC_parse - parse_start) : 1);
5202 if (!SIZE_ONLY && RExC_extralen)
5203 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
5204 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
5206 RExC_whilem_seen++, RExC_extralen += 3;
5207 RExC_naughty += 4 + RExC_naughty; /* compound interest */
5215 if (max && max < min)
5216 vFAIL("Can't do {n,m} with n > m");
5218 ARG1_SET(ret, (U16)min);
5219 ARG2_SET(ret, (U16)max);
5231 #if 0 /* Now runtime fix should be reliable. */
5233 /* if this is reinstated, don't forget to put this back into perldiag:
5235 =item Regexp *+ operand could be empty at {#} in regex m/%s/
5237 (F) The part of the regexp subject to either the * or + quantifier
5238 could match an empty string. The {#} shows in the regular
5239 expression about where the problem was discovered.
5243 if (!(flags&HASWIDTH) && op != '?')
5244 vFAIL("Regexp *+ operand could be empty");
5247 parse_start = RExC_parse;
5248 nextchar(pRExC_state);
5250 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
5252 if (op == '*' && (flags&SIMPLE)) {
5253 reginsert(pRExC_state, STAR, ret, depth+1);
5257 else if (op == '*') {
5261 else if (op == '+' && (flags&SIMPLE)) {
5262 reginsert(pRExC_state, PLUS, ret, depth+1);
5266 else if (op == '+') {
5270 else if (op == '?') {
5275 if (!SIZE_ONLY && !(flags&HASWIDTH) && max > REG_INFTY/3 && ckWARN(WARN_REGEXP)) {
5277 "%.*s matches null string many times",
5278 (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
5282 if (RExC_parse < RExC_end && *RExC_parse == '?') {
5283 nextchar(pRExC_state);
5284 reginsert(pRExC_state, MINMOD, ret, depth+1);
5285 REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
5287 #ifndef REG_ALLOW_MINMOD_SUSPEND
5290 if (RExC_parse < RExC_end && *RExC_parse == '+') {
5292 nextchar(pRExC_state);
5293 ender = reg_node(pRExC_state, SUCCEED);
5294 REGTAIL(pRExC_state, ret, ender);
5295 reginsert(pRExC_state, SUSPEND, ret, depth+1);
5297 ender = reg_node(pRExC_state, TAIL);
5298 REGTAIL(pRExC_state, ret, ender);
5302 if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
5304 vFAIL("Nested quantifiers");
5311 /* reg_namedseq(pRExC_state,UVp)
5313 This is expected to be called by a parser routine that has
5314 recognized'\N' and needs to handle the rest. RExC_parse is
5315 expected to point at the first char following the N at the time
5318 If valuep is non-null then it is assumed that we are parsing inside
5319 of a charclass definition and the first codepoint in the resolved
5320 string is returned via *valuep and the routine will return NULL.
5321 In this mode if a multichar string is returned from the charnames
5322 handler a warning will be issued, and only the first char in the
5323 sequence will be examined. If the string returned is zero length
5324 then the value of *valuep is undefined and NON-NULL will
5325 be returned to indicate failure. (This will NOT be a valid pointer
5328 If value is null then it is assumed that we are parsing normal text
5329 and inserts a new EXACT node into the program containing the resolved
5330 string and returns a pointer to the new node. If the string is
5331 zerolength a NOTHING node is emitted.
5333 On success RExC_parse is set to the char following the endbrace.
5334 Parsing failures will generate a fatal errorvia vFAIL(...)
5336 NOTE: We cache all results from the charnames handler locally in
5337 the RExC_charnames hash (created on first use) to prevent a charnames
5338 handler from playing silly-buggers and returning a short string and
5339 then a long string for a given pattern. Since the regexp program
5340 size is calculated during an initial parse this would result
5341 in a buffer overrun so we cache to prevent the charname result from
5342 changing during the course of the parse.
5346 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep)
5348 char * name; /* start of the content of the name */
5349 char * endbrace; /* endbrace following the name */
5352 STRLEN len; /* this has various purposes throughout the code */
5353 bool cached = 0; /* if this is true then we shouldn't refcount dev sv_str */
5354 regnode *ret = NULL;
5356 if (*RExC_parse != '{') {
5357 vFAIL("Missing braces on \\N{}");
5359 name = RExC_parse+1;
5360 endbrace = strchr(RExC_parse, '}');
5363 vFAIL("Missing right brace on \\N{}");
5365 RExC_parse = endbrace + 1;
5368 /* RExC_parse points at the beginning brace,
5369 endbrace points at the last */
5370 if ( name[0]=='U' && name[1]=='+' ) {
5371 /* its a "unicode hex" notation {U+89AB} */
5372 I32 fl = PERL_SCAN_ALLOW_UNDERSCORES
5373 | PERL_SCAN_DISALLOW_PREFIX
5374 | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
5376 len = (STRLEN)(endbrace - name - 2);
5377 cp = grok_hex(name + 2, &len, &fl, NULL);
5378 if ( len != (STRLEN)(endbrace - name - 2) ) {
5387 sv_str= Perl_newSVpvf_nocontext("%c",(int)cp);
5389 /* fetch the charnames handler for this scope */
5390 HV * const table = GvHV(PL_hintgv);
5392 hv_fetchs(table, "charnames", FALSE) :
5394 SV *cv= cvp ? *cvp : NULL;
5397 /* create an SV with the name as argument */
5398 sv_name = newSVpvn(name, endbrace - name);
5400 if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
5401 vFAIL2("Constant(\\N{%s}) unknown: "
5402 "(possibly a missing \"use charnames ...\")",
5405 if (!cvp || !SvOK(*cvp)) { /* when $^H{charnames} = undef; */
5406 vFAIL2("Constant(\\N{%s}): "
5407 "$^H{charnames} is not defined",SvPVX(sv_name));
5412 if (!RExC_charnames) {
5413 /* make sure our cache is allocated */
5414 RExC_charnames = newHV();
5415 sv_2mortal((SV*)RExC_charnames);
5417 /* see if we have looked this one up before */
5418 he_str = hv_fetch_ent( RExC_charnames, sv_name, 0, 0 );
5420 sv_str = HeVAL(he_str);
5433 count= call_sv(cv, G_SCALAR);
5435 if (count == 1) { /* XXXX is this right? dmq */
5437 SvREFCNT_inc_simple_void(sv_str);
5445 if ( !sv_str || !SvOK(sv_str) ) {
5446 vFAIL2("Constant(\\N{%s}): Call to &{$^H{charnames}} "
5447 "did not return a defined value",SvPVX(sv_name));
5449 if (hv_store_ent( RExC_charnames, sv_name, sv_str, 0))
5454 char *p = SvPV(sv_str, len);
5457 if ( SvUTF8(sv_str) ) {
5458 *valuep = utf8_to_uvchr((U8*)p, &numlen);
5462 We have to turn on utf8 for high bit chars otherwise
5463 we get failures with
5465 "ss" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
5466 "SS" =~ /[\N{LATIN SMALL LETTER SHARP S}]/i
5468 This is different from what \x{} would do with the same
5469 codepoint, where the condition is > 0xFF.
5476 /* warn if we havent used the whole string? */
5478 if (numlen<len && SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5480 "Ignoring excess chars from \\N{%s} in character class",
5484 } else if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
5486 "Ignoring zero length \\N{%s} in character class",
5491 SvREFCNT_dec(sv_name);
5493 SvREFCNT_dec(sv_str);
5494 return len ? NULL : (regnode *)&len;
5495 } else if(SvCUR(sv_str)) {
5500 char * parse_start = name-3; /* needed for the offsets */
5501 GET_RE_DEBUG_FLAGS_DECL; /* needed for the offsets */
5503 ret = reg_node(pRExC_state,
5504 (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
5507 if ( RExC_utf8 && !SvUTF8(sv_str) ) {
5508 sv_utf8_upgrade(sv_str);
5509 } else if ( !RExC_utf8 && SvUTF8(sv_str) ) {
5513 p = SvPV(sv_str, len);
5515 /* len is the length written, charlen is the size the char read */
5516 for ( len = 0; p < pend; p += charlen ) {
5518 UV uvc = utf8_to_uvchr((U8*)p, &charlen);
5520 STRLEN foldlen,numlen;
5521 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
5522 uvc = toFOLD_uni(uvc, tmpbuf, &foldlen);
5523 /* Emit all the Unicode characters. */
5525 for (foldbuf = tmpbuf;
5529 uvc = utf8_to_uvchr(foldbuf, &numlen);
5531 const STRLEN unilen = reguni(pRExC_state, uvc, s);
5534 /* In EBCDIC the numlen
5535 * and unilen can differ. */
5537 if (numlen >= foldlen)
5541 break; /* "Can't happen." */
5544 const STRLEN unilen = reguni(pRExC_state, uvc, s);
5556 RExC_size += STR_SZ(len);
5559 RExC_emit += STR_SZ(len);
5561 Set_Node_Cur_Length(ret); /* MJD */
5563 nextchar(pRExC_state);
5565 ret = reg_node(pRExC_state,NOTHING);
5568 SvREFCNT_dec(sv_str);
5571 SvREFCNT_dec(sv_name);
5580 - regatom - the lowest level
5582 * Optimization: gobbles an entire sequence of ordinary characters so that
5583 * it can turn them into a single node, which is smaller to store and
5584 * faster to run. Backslashed characters are exceptions, each becoming a
5585 * separate node; the code is simpler that way and it's not worth fixing.
5587 * [Yes, it is worth fixing, some scripts can run twice the speed.]
5588 * [It looks like its ok, as in S_study_chunk we merge adjacent EXACT nodes]
5591 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
5594 register regnode *ret = NULL;
5596 char *parse_start = RExC_parse;
5597 GET_RE_DEBUG_FLAGS_DECL;
5598 DEBUG_PARSE("atom");
5599 *flagp = WORST; /* Tentatively. */
5602 switch (*RExC_parse) {
5604 RExC_seen_zerolen++;
5605 nextchar(pRExC_state);
5606 if (RExC_flags & PMf_MULTILINE)
5607 ret = reg_node(pRExC_state, MBOL);
5608 else if (RExC_flags & PMf_SINGLELINE)
5609 ret = reg_node(pRExC_state, SBOL);
5611 ret = reg_node(pRExC_state, BOL);
5612 Set_Node_Length(ret, 1); /* MJD */
5615 nextchar(pRExC_state);
5617 RExC_seen_zerolen++;
5618 if (RExC_flags & PMf_MULTILINE)
5619 ret = reg_node(pRExC_state, MEOL);
5620 else if (RExC_flags & PMf_SINGLELINE)
5621 ret = reg_node(pRExC_state, SEOL);
5623 ret = reg_node(pRExC_state, EOL);
5624 Set_Node_Length(ret, 1); /* MJD */
5627 nextchar(pRExC_state);
5628 if (RExC_flags & PMf_SINGLELINE)
5629 ret = reg_node(pRExC_state, SANY);
5631 ret = reg_node(pRExC_state, REG_ANY);
5632 *flagp |= HASWIDTH|SIMPLE;
5634 Set_Node_Length(ret, 1); /* MJD */
5638 char * const oregcomp_parse = ++RExC_parse;
5639 ret = regclass(pRExC_state,depth+1);
5640 if (*RExC_parse != ']') {
5641 RExC_parse = oregcomp_parse;
5642 vFAIL("Unmatched [");
5644 nextchar(pRExC_state);
5645 *flagp |= HASWIDTH|SIMPLE;
5646 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
5650 nextchar(pRExC_state);
5651 ret = reg(pRExC_state, 1, &flags,depth+1);
5653 if (flags & TRYAGAIN) {
5654 if (RExC_parse == RExC_end) {
5655 /* Make parent create an empty node if needed. */
5663 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE);
5667 if (flags & TRYAGAIN) {
5671 vFAIL("Internal urp");
5672 /* Supposed to be caught earlier. */
5675 if (!regcurly(RExC_parse)) {
5684 vFAIL("Quantifier follows nothing");
5687 switch (*++RExC_parse) {
5689 RExC_seen_zerolen++;
5690 ret = reg_node(pRExC_state, SBOL);
5692 nextchar(pRExC_state);
5693 Set_Node_Length(ret, 2); /* MJD */
5696 ret = reg_node(pRExC_state, GPOS);
5697 RExC_seen |= REG_SEEN_GPOS;
5699 nextchar(pRExC_state);
5700 Set_Node_Length(ret, 2); /* MJD */
5703 ret = reg_node(pRExC_state, SEOL);
5705 RExC_seen_zerolen++; /* Do not optimize RE away */
5706 nextchar(pRExC_state);
5709 ret = reg_node(pRExC_state, EOS);
5711 RExC_seen_zerolen++; /* Do not optimize RE away */
5712 nextchar(pRExC_state);
5713 Set_Node_Length(ret, 2); /* MJD */
5716 ret = reg_node(pRExC_state, CANY);
5717 RExC_seen |= REG_SEEN_CANY;
5718 *flagp |= HASWIDTH|SIMPLE;
5719 nextchar(pRExC_state);
5720 Set_Node_Length(ret, 2); /* MJD */
5723 ret = reg_node(pRExC_state, CLUMP);
5725 nextchar(pRExC_state);
5726 Set_Node_Length(ret, 2); /* MJD */
5729 ret = reg_node(pRExC_state, (U8)(LOC ? ALNUML : ALNUM));
5730 *flagp |= HASWIDTH|SIMPLE;
5731 nextchar(pRExC_state);
5732 Set_Node_Length(ret, 2); /* MJD */
5735 ret = reg_node(pRExC_state, (U8)(LOC ? NALNUML : NALNUM));
5736 *flagp |= HASWIDTH|SIMPLE;
5737 nextchar(pRExC_state);
5738 Set_Node_Length(ret, 2); /* MJD */
5741 RExC_seen_zerolen++;
5742 RExC_seen |= REG_SEEN_LOOKBEHIND;
5743 ret = reg_node(pRExC_state, (U8)(LOC ? BOUNDL : BOUND));
5745 nextchar(pRExC_state);
5746 Set_Node_Length(ret, 2); /* MJD */
5749 RExC_seen_zerolen++;
5750 RExC_seen |= REG_SEEN_LOOKBEHIND;
5751 ret = reg_node(pRExC_state, (U8)(LOC ? NBOUNDL : NBOUND));
5753 nextchar(pRExC_state);
5754 Set_Node_Length(ret, 2); /* MJD */
5757 ret = reg_node(pRExC_state, (U8)(LOC ? SPACEL : SPACE));
5758 *flagp |= HASWIDTH|SIMPLE;
5759 nextchar(pRExC_state);
5760 Set_Node_Length(ret, 2); /* MJD */
5763 ret = reg_node(pRExC_state, (U8)(LOC ? NSPACEL : NSPACE));
5764 *flagp |= HASWIDTH|SIMPLE;
5765 nextchar(pRExC_state);
5766 Set_Node_Length(ret, 2); /* MJD */
5769 ret = reg_node(pRExC_state, DIGIT);
5770 *flagp |= HASWIDTH|SIMPLE;
5771 nextchar(pRExC_state);
5772 Set_Node_Length(ret, 2); /* MJD */
5775 ret = reg_node(pRExC_state, NDIGIT);
5776 *flagp |= HASWIDTH|SIMPLE;
5777 nextchar(pRExC_state);
5778 Set_Node_Length(ret, 2); /* MJD */
5783 char* const oldregxend = RExC_end;
5784 char* parse_start = RExC_parse - 2;
5786 if (RExC_parse[1] == '{') {
5787 /* a lovely hack--pretend we saw [\pX] instead */
5788 RExC_end = strchr(RExC_parse, '}');
5790 const U8 c = (U8)*RExC_parse;
5792 RExC_end = oldregxend;
5793 vFAIL2("Missing right brace on \\%c{}", c);
5798 RExC_end = RExC_parse + 2;
5799 if (RExC_end > oldregxend)
5800 RExC_end = oldregxend;
5804 ret = regclass(pRExC_state,depth+1);
5806 RExC_end = oldregxend;
5809 Set_Node_Offset(ret, parse_start + 2);
5810 Set_Node_Cur_Length(ret);
5811 nextchar(pRExC_state);
5812 *flagp |= HASWIDTH|SIMPLE;
5816 /* Handle \N{NAME} here and not below because it can be
5817 multicharacter. join_exact() will join them up later on.
5818 Also this makes sure that things like /\N{BLAH}+/ and
5819 \N{BLAH} being multi char Just Happen. dmq*/
5821 ret= reg_namedseq(pRExC_state, NULL);
5823 case 'k': /* Handle \k<NAME> and \k'NAME' */
5825 char ch= RExC_parse[1];
5826 if (ch != '<' && ch != '\'') {
5828 vWARN( RExC_parse + 1,
5829 "Possible broken named back reference treated as literal k");
5833 char* name_start = (RExC_parse += 2);
5835 SV *sv_dat = reg_scan_name(pRExC_state,
5836 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
5837 ch= (ch == '<') ? '>' : '\'';
5839 if (RExC_parse == name_start || *RExC_parse != ch)
5840 vFAIL2("Sequence \\k%c... not terminated",
5841 (ch == '>' ? '<' : ch));
5844 ret = reganode(pRExC_state,
5845 (U8)(FOLD ? (LOC ? NREFFL : NREFF) : NREF),
5851 num = add_data( pRExC_state, 1, "S" );
5853 RExC_rx->data->data[num]=(void*)sv_dat;
5854 SvREFCNT_inc(sv_dat);
5856 /* override incorrect value set in reganode MJD */
5857 Set_Node_Offset(ret, parse_start+1);
5858 Set_Node_Cur_Length(ret); /* MJD */
5859 nextchar(pRExC_state);
5874 case '1': case '2': case '3': case '4':
5875 case '5': case '6': case '7': case '8': case '9':
5877 const I32 num = atoi(RExC_parse);
5879 if (num > 9 && num >= RExC_npar)
5882 char * const parse_start = RExC_parse - 1; /* MJD */
5883 while (isDIGIT(*RExC_parse))
5886 if (!SIZE_ONLY && num > (I32)RExC_rx->nparens)
5887 vFAIL("Reference to nonexistent group");
5889 ret = reganode(pRExC_state,
5890 (U8)(FOLD ? (LOC ? REFFL : REFF) : REF),
5894 /* override incorrect value set in reganode MJD */
5895 Set_Node_Offset(ret, parse_start+1);
5896 Set_Node_Cur_Length(ret); /* MJD */
5898 nextchar(pRExC_state);
5903 if (RExC_parse >= RExC_end)
5904 FAIL("Trailing \\");
5907 /* Do not generate "unrecognized" warnings here, we fall
5908 back into the quick-grab loop below */
5915 if (RExC_flags & PMf_EXTENDED) {
5916 while (RExC_parse < RExC_end && *RExC_parse != '\n')
5918 if (RExC_parse < RExC_end)
5924 register STRLEN len;
5929 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
5931 parse_start = RExC_parse - 1;
5937 ret = reg_node(pRExC_state,
5938 (U8)(FOLD ? (LOC ? EXACTFL : EXACTF) : EXACT));
5940 for (len = 0, p = RExC_parse - 1;
5941 len < 127 && p < RExC_end;
5944 char * const oldp = p;
5946 if (RExC_flags & PMf_EXTENDED)
5947 p = regwhite(p, RExC_end);
5995 ender = ASCII_TO_NATIVE('\033');
5999 ender = ASCII_TO_NATIVE('\007');
6004 char* const e = strchr(p, '}');
6008 vFAIL("Missing right brace on \\x{}");
6011 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
6012 | PERL_SCAN_DISALLOW_PREFIX;
6013 STRLEN numlen = e - p - 1;
6014 ender = grok_hex(p + 1, &numlen, &flags, NULL);
6021 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
6023 ender = grok_hex(p, &numlen, &flags, NULL);
6029 ender = UCHARAT(p++);
6030 ender = toCTRL(ender);
6032 case '0': case '1': case '2': case '3':case '4':
6033 case '5': case '6': case '7': case '8':case '9':
6035 (isDIGIT(p[1]) && atoi(p) >= RExC_npar) ) {
6038 ender = grok_oct(p, &numlen, &flags, NULL);
6048 FAIL("Trailing \\");
6051 if (!SIZE_ONLY&& isALPHA(*p) && ckWARN(WARN_REGEXP))
6052 vWARN2(p + 1, "Unrecognized escape \\%c passed through", UCHARAT(p));
6053 goto normal_default;
6058 if (UTF8_IS_START(*p) && UTF) {
6060 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
6061 &numlen, UTF8_ALLOW_DEFAULT);
6068 if (RExC_flags & PMf_EXTENDED)
6069 p = regwhite(p, RExC_end);
6071 /* Prime the casefolded buffer. */
6072 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
6074 if (ISMULT2(p)) { /* Back off on ?+*. */
6079 /* Emit all the Unicode characters. */
6081 for (foldbuf = tmpbuf;
6083 foldlen -= numlen) {
6084 ender = utf8_to_uvchr(foldbuf, &numlen);
6086 const STRLEN unilen = reguni(pRExC_state, ender, s);
6089 /* In EBCDIC the numlen
6090 * and unilen can differ. */
6092 if (numlen >= foldlen)
6096 break; /* "Can't happen." */
6100 const STRLEN unilen = reguni(pRExC_state, ender, s);
6109 REGC((char)ender, s++);
6115 /* Emit all the Unicode characters. */
6117 for (foldbuf = tmpbuf;
6119 foldlen -= numlen) {
6120 ender = utf8_to_uvchr(foldbuf, &numlen);
6122 const STRLEN unilen = reguni(pRExC_state, ender, s);
6125 /* In EBCDIC the numlen
6126 * and unilen can differ. */
6128 if (numlen >= foldlen)
6136 const STRLEN unilen = reguni(pRExC_state, ender, s);
6145 REGC((char)ender, s++);
6149 Set_Node_Cur_Length(ret); /* MJD */
6150 nextchar(pRExC_state);
6152 /* len is STRLEN which is unsigned, need to copy to signed */
6155 vFAIL("Internal disaster");
6159 if (len == 1 && UNI_IS_INVARIANT(ender))
6163 RExC_size += STR_SZ(len);
6166 RExC_emit += STR_SZ(len);
6172 /* If the encoding pragma is in effect recode the text of
6173 * any EXACT-kind nodes. */
6174 if (ret && PL_encoding && PL_regkind[OP(ret)] == EXACT) {
6175 const STRLEN oldlen = STR_LEN(ret);
6176 SV * const sv = sv_2mortal(newSVpvn(STRING(ret), oldlen));
6180 if (sv_utf8_downgrade(sv, TRUE)) {
6181 const char * const s = sv_recode_to_utf8(sv, PL_encoding);
6182 const STRLEN newlen = SvCUR(sv);
6187 GET_RE_DEBUG_FLAGS_DECL;
6188 DEBUG_COMPILE_r(PerlIO_printf(Perl_debug_log, "recode %*s to %*s\n",
6189 (int)oldlen, STRING(ret),
6191 Copy(s, STRING(ret), newlen, char);
6192 STR_LEN(ret) += newlen - oldlen;
6193 RExC_emit += STR_SZ(newlen) - STR_SZ(oldlen);
6195 RExC_size += STR_SZ(newlen) - STR_SZ(oldlen);
6203 S_regwhite(char *p, const char *e)
6208 else if (*p == '#') {
6211 } while (p < e && *p != '\n');
6219 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
6220 Character classes ([:foo:]) can also be negated ([:^foo:]).
6221 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
6222 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
6223 but trigger failures because they are currently unimplemented. */
6225 #define POSIXCC_DONE(c) ((c) == ':')
6226 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
6227 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
6230 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
6233 I32 namedclass = OOB_NAMEDCLASS;
6235 if (value == '[' && RExC_parse + 1 < RExC_end &&
6236 /* I smell either [: or [= or [. -- POSIX has been here, right? */
6237 POSIXCC(UCHARAT(RExC_parse))) {
6238 const char c = UCHARAT(RExC_parse);
6239 char* const s = RExC_parse++;
6241 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
6243 if (RExC_parse == RExC_end)
6244 /* Grandfather lone [:, [=, [. */
6247 const char* const t = RExC_parse++; /* skip over the c */
6250 if (UCHARAT(RExC_parse) == ']') {
6251 const char *posixcc = s + 1;
6252 RExC_parse++; /* skip over the ending ] */
6255 const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
6256 const I32 skip = t - posixcc;
6258 /* Initially switch on the length of the name. */
6261 if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
6262 namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
6265 /* Names all of length 5. */
6266 /* alnum alpha ascii blank cntrl digit graph lower
6267 print punct space upper */
6268 /* Offset 4 gives the best switch position. */
6269 switch (posixcc[4]) {
6271 if (memEQ(posixcc, "alph", 4)) /* alpha */
6272 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
6275 if (memEQ(posixcc, "spac", 4)) /* space */
6276 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
6279 if (memEQ(posixcc, "grap", 4)) /* graph */
6280 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
6283 if (memEQ(posixcc, "asci", 4)) /* ascii */
6284 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
6287 if (memEQ(posixcc, "blan", 4)) /* blank */
6288 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
6291 if (memEQ(posixcc, "cntr", 4)) /* cntrl */
6292 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
6295 if (memEQ(posixcc, "alnu", 4)) /* alnum */
6296 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
6299 if (memEQ(posixcc, "lowe", 4)) /* lower */
6300 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
6301 else if (memEQ(posixcc, "uppe", 4)) /* upper */
6302 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
6305 if (memEQ(posixcc, "digi", 4)) /* digit */
6306 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
6307 else if (memEQ(posixcc, "prin", 4)) /* print */
6308 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
6309 else if (memEQ(posixcc, "punc", 4)) /* punct */
6310 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
6315 if (memEQ(posixcc, "xdigit", 6))
6316 namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
6320 if (namedclass == OOB_NAMEDCLASS)
6321 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
6323 assert (posixcc[skip] == ':');
6324 assert (posixcc[skip+1] == ']');
6325 } else if (!SIZE_ONLY) {
6326 /* [[=foo=]] and [[.foo.]] are still future. */
6328 /* adjust RExC_parse so the warning shows after
6330 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
6332 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
6335 /* Maternal grandfather:
6336 * "[:" ending in ":" but not in ":]" */
6346 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
6349 if (POSIXCC(UCHARAT(RExC_parse))) {
6350 const char *s = RExC_parse;
6351 const char c = *s++;
6355 if (*s && c == *s && s[1] == ']') {
6356 if (ckWARN(WARN_REGEXP))
6358 "POSIX syntax [%c %c] belongs inside character classes",
6361 /* [[=foo=]] and [[.foo.]] are still future. */
6362 if (POSIXCC_NOTYET(c)) {
6363 /* adjust RExC_parse so the error shows after
6365 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
6367 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
6375 parse a class specification and produce either an ANYOF node that
6376 matches the pattern. If the pattern matches a single char only and
6377 that char is < 256 then we produce an EXACT node instead.
6380 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
6383 register UV value = 0;
6384 register UV nextvalue;
6385 register IV prevvalue = OOB_UNICODE;
6386 register IV range = 0;
6387 register regnode *ret;
6390 char *rangebegin = NULL;
6391 bool need_class = 0;
6394 bool optimize_invert = TRUE;
6395 AV* unicode_alternate = NULL;
6397 UV literal_endpoint = 0;
6399 UV stored = 0; /* number of chars stored in the class */
6401 regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
6402 case we need to change the emitted regop to an EXACT. */
6403 const char * orig_parse = RExC_parse;
6404 GET_RE_DEBUG_FLAGS_DECL;
6406 PERL_UNUSED_ARG(depth);
6409 DEBUG_PARSE("clas");
6411 /* Assume we are going to generate an ANYOF node. */
6412 ret = reganode(pRExC_state, ANYOF, 0);
6415 ANYOF_FLAGS(ret) = 0;
6417 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
6421 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
6425 RExC_size += ANYOF_SKIP;
6426 listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
6429 RExC_emit += ANYOF_SKIP;
6431 ANYOF_FLAGS(ret) |= ANYOF_FOLD;
6433 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
6434 ANYOF_BITMAP_ZERO(ret);
6435 listsv = newSVpvs("# comment\n");
6438 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
6440 if (!SIZE_ONLY && POSIXCC(nextvalue))
6441 checkposixcc(pRExC_state);
6443 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
6444 if (UCHARAT(RExC_parse) == ']')
6448 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
6452 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
6455 rangebegin = RExC_parse;
6457 value = utf8n_to_uvchr((U8*)RExC_parse,
6458 RExC_end - RExC_parse,
6459 &numlen, UTF8_ALLOW_DEFAULT);
6460 RExC_parse += numlen;
6463 value = UCHARAT(RExC_parse++);
6465 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
6466 if (value == '[' && POSIXCC(nextvalue))
6467 namedclass = regpposixcc(pRExC_state, value);
6468 else if (value == '\\') {
6470 value = utf8n_to_uvchr((U8*)RExC_parse,
6471 RExC_end - RExC_parse,
6472 &numlen, UTF8_ALLOW_DEFAULT);
6473 RExC_parse += numlen;
6476 value = UCHARAT(RExC_parse++);
6477 /* Some compilers cannot handle switching on 64-bit integer
6478 * values, therefore value cannot be an UV. Yes, this will
6479 * be a problem later if we want switch on Unicode.
6480 * A similar issue a little bit later when switching on
6481 * namedclass. --jhi */
6482 switch ((I32)value) {
6483 case 'w': namedclass = ANYOF_ALNUM; break;
6484 case 'W': namedclass = ANYOF_NALNUM; break;
6485 case 's': namedclass = ANYOF_SPACE; break;
6486 case 'S': namedclass = ANYOF_NSPACE; break;
6487 case 'd': namedclass = ANYOF_DIGIT; break;
6488 case 'D': namedclass = ANYOF_NDIGIT; break;
6489 case 'N': /* Handle \N{NAME} in class */
6491 /* We only pay attention to the first char of
6492 multichar strings being returned. I kinda wonder
6493 if this makes sense as it does change the behaviour
6494 from earlier versions, OTOH that behaviour was broken
6496 UV v; /* value is register so we cant & it /grrr */
6497 if (reg_namedseq(pRExC_state, &v)) {
6507 if (RExC_parse >= RExC_end)
6508 vFAIL2("Empty \\%c{}", (U8)value);
6509 if (*RExC_parse == '{') {
6510 const U8 c = (U8)value;
6511 e = strchr(RExC_parse++, '}');
6513 vFAIL2("Missing right brace on \\%c{}", c);
6514 while (isSPACE(UCHARAT(RExC_parse)))
6516 if (e == RExC_parse)
6517 vFAIL2("Empty \\%c{}", c);
6519 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
6527 if (UCHARAT(RExC_parse) == '^') {
6530 value = value == 'p' ? 'P' : 'p'; /* toggle */
6531 while (isSPACE(UCHARAT(RExC_parse))) {
6536 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
6537 (value=='p' ? '+' : '!'), (int)n, RExC_parse);
6540 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
6541 namedclass = ANYOF_MAX; /* no official name, but it's named */
6544 case 'n': value = '\n'; break;
6545 case 'r': value = '\r'; break;
6546 case 't': value = '\t'; break;
6547 case 'f': value = '\f'; break;
6548 case 'b': value = '\b'; break;
6549 case 'e': value = ASCII_TO_NATIVE('\033');break;
6550 case 'a': value = ASCII_TO_NATIVE('\007');break;
6552 if (*RExC_parse == '{') {
6553 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
6554 | PERL_SCAN_DISALLOW_PREFIX;
6555 char * const e = strchr(RExC_parse++, '}');
6557 vFAIL("Missing right brace on \\x{}");
6559 numlen = e - RExC_parse;
6560 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
6564 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
6566 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
6567 RExC_parse += numlen;
6571 value = UCHARAT(RExC_parse++);
6572 value = toCTRL(value);
6574 case '0': case '1': case '2': case '3': case '4':
6575 case '5': case '6': case '7': case '8': case '9':
6579 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
6580 RExC_parse += numlen;
6584 if (!SIZE_ONLY && isALPHA(value) && ckWARN(WARN_REGEXP))
6586 "Unrecognized escape \\%c in character class passed through",
6590 } /* end of \blah */
6596 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
6598 if (!SIZE_ONLY && !need_class)
6599 ANYOF_CLASS_ZERO(ret);
6603 /* a bad range like a-\d, a-[:digit:] ? */
6606 if (ckWARN(WARN_REGEXP)) {
6608 RExC_parse >= rangebegin ?
6609 RExC_parse - rangebegin : 0;
6611 "False [] range \"%*.*s\"",
6614 if (prevvalue < 256) {
6615 ANYOF_BITMAP_SET(ret, prevvalue);
6616 ANYOF_BITMAP_SET(ret, '-');
6619 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
6620 Perl_sv_catpvf(aTHX_ listsv,
6621 "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
6625 range = 0; /* this was not a true range */
6629 const char *what = NULL;
6632 if (namedclass > OOB_NAMEDCLASS)
6633 optimize_invert = FALSE;
6634 /* Possible truncation here but in some 64-bit environments
6635 * the compiler gets heartburn about switch on 64-bit values.
6636 * A similar issue a little earlier when switching on value.
6638 switch ((I32)namedclass) {
6641 ANYOF_CLASS_SET(ret, ANYOF_ALNUM);
6643 for (value = 0; value < 256; value++)
6645 ANYOF_BITMAP_SET(ret, value);
6652 ANYOF_CLASS_SET(ret, ANYOF_NALNUM);
6654 for (value = 0; value < 256; value++)
6655 if (!isALNUM(value))
6656 ANYOF_BITMAP_SET(ret, value);
6663 ANYOF_CLASS_SET(ret, ANYOF_ALNUMC);
6665 for (value = 0; value < 256; value++)
6666 if (isALNUMC(value))
6667 ANYOF_BITMAP_SET(ret, value);
6674 ANYOF_CLASS_SET(ret, ANYOF_NALNUMC);
6676 for (value = 0; value < 256; value++)
6677 if (!isALNUMC(value))
6678 ANYOF_BITMAP_SET(ret, value);
6685 ANYOF_CLASS_SET(ret, ANYOF_ALPHA);
6687 for (value = 0; value < 256; value++)
6689 ANYOF_BITMAP_SET(ret, value);
6696 ANYOF_CLASS_SET(ret, ANYOF_NALPHA);
6698 for (value = 0; value < 256; value++)
6699 if (!isALPHA(value))
6700 ANYOF_BITMAP_SET(ret, value);
6707 ANYOF_CLASS_SET(ret, ANYOF_ASCII);
6710 for (value = 0; value < 128; value++)
6711 ANYOF_BITMAP_SET(ret, value);
6713 for (value = 0; value < 256; value++) {
6715 ANYOF_BITMAP_SET(ret, value);
6724 ANYOF_CLASS_SET(ret, ANYOF_NASCII);
6727 for (value = 128; value < 256; value++)
6728 ANYOF_BITMAP_SET(ret, value);
6730 for (value = 0; value < 256; value++) {
6731 if (!isASCII(value))
6732 ANYOF_BITMAP_SET(ret, value);
6741 ANYOF_CLASS_SET(ret, ANYOF_BLANK);
6743 for (value = 0; value < 256; value++)
6745 ANYOF_BITMAP_SET(ret, value);
6752 ANYOF_CLASS_SET(ret, ANYOF_NBLANK);
6754 for (value = 0; value < 256; value++)
6755 if (!isBLANK(value))
6756 ANYOF_BITMAP_SET(ret, value);
6763 ANYOF_CLASS_SET(ret, ANYOF_CNTRL);
6765 for (value = 0; value < 256; value++)
6767 ANYOF_BITMAP_SET(ret, value);
6774 ANYOF_CLASS_SET(ret, ANYOF_NCNTRL);
6776 for (value = 0; value < 256; value++)
6777 if (!isCNTRL(value))
6778 ANYOF_BITMAP_SET(ret, value);
6785 ANYOF_CLASS_SET(ret, ANYOF_DIGIT);
6787 /* consecutive digits assumed */
6788 for (value = '0'; value <= '9'; value++)
6789 ANYOF_BITMAP_SET(ret, value);
6796 ANYOF_CLASS_SET(ret, ANYOF_NDIGIT);
6798 /* consecutive digits assumed */
6799 for (value = 0; value < '0'; value++)
6800 ANYOF_BITMAP_SET(ret, value);
6801 for (value = '9' + 1; value < 256; value++)
6802 ANYOF_BITMAP_SET(ret, value);
6809 ANYOF_CLASS_SET(ret, ANYOF_GRAPH);
6811 for (value = 0; value < 256; value++)
6813 ANYOF_BITMAP_SET(ret, value);
6820 ANYOF_CLASS_SET(ret, ANYOF_NGRAPH);
6822 for (value = 0; value < 256; value++)
6823 if (!isGRAPH(value))
6824 ANYOF_BITMAP_SET(ret, value);
6831 ANYOF_CLASS_SET(ret, ANYOF_LOWER);
6833 for (value = 0; value < 256; value++)
6835 ANYOF_BITMAP_SET(ret, value);
6842 ANYOF_CLASS_SET(ret, ANYOF_NLOWER);
6844 for (value = 0; value < 256; value++)
6845 if (!isLOWER(value))
6846 ANYOF_BITMAP_SET(ret, value);
6853 ANYOF_CLASS_SET(ret, ANYOF_PRINT);
6855 for (value = 0; value < 256; value++)
6857 ANYOF_BITMAP_SET(ret, value);
6864 ANYOF_CLASS_SET(ret, ANYOF_NPRINT);
6866 for (value = 0; value < 256; value++)
6867 if (!isPRINT(value))
6868 ANYOF_BITMAP_SET(ret, value);
6875 ANYOF_CLASS_SET(ret, ANYOF_PSXSPC);
6877 for (value = 0; value < 256; value++)
6878 if (isPSXSPC(value))
6879 ANYOF_BITMAP_SET(ret, value);
6886 ANYOF_CLASS_SET(ret, ANYOF_NPSXSPC);
6888 for (value = 0; value < 256; value++)
6889 if (!isPSXSPC(value))
6890 ANYOF_BITMAP_SET(ret, value);
6897 ANYOF_CLASS_SET(ret, ANYOF_PUNCT);
6899 for (value = 0; value < 256; value++)
6901 ANYOF_BITMAP_SET(ret, value);
6908 ANYOF_CLASS_SET(ret, ANYOF_NPUNCT);
6910 for (value = 0; value < 256; value++)
6911 if (!isPUNCT(value))
6912 ANYOF_BITMAP_SET(ret, value);
6919 ANYOF_CLASS_SET(ret, ANYOF_SPACE);
6921 for (value = 0; value < 256; value++)
6923 ANYOF_BITMAP_SET(ret, value);
6930 ANYOF_CLASS_SET(ret, ANYOF_NSPACE);
6932 for (value = 0; value < 256; value++)
6933 if (!isSPACE(value))
6934 ANYOF_BITMAP_SET(ret, value);
6941 ANYOF_CLASS_SET(ret, ANYOF_UPPER);
6943 for (value = 0; value < 256; value++)
6945 ANYOF_BITMAP_SET(ret, value);
6952 ANYOF_CLASS_SET(ret, ANYOF_NUPPER);
6954 for (value = 0; value < 256; value++)
6955 if (!isUPPER(value))
6956 ANYOF_BITMAP_SET(ret, value);
6963 ANYOF_CLASS_SET(ret, ANYOF_XDIGIT);
6965 for (value = 0; value < 256; value++)
6966 if (isXDIGIT(value))
6967 ANYOF_BITMAP_SET(ret, value);
6974 ANYOF_CLASS_SET(ret, ANYOF_NXDIGIT);
6976 for (value = 0; value < 256; value++)
6977 if (!isXDIGIT(value))
6978 ANYOF_BITMAP_SET(ret, value);
6984 /* this is to handle \p and \P */
6987 vFAIL("Invalid [::] class");
6991 /* Strings such as "+utf8::isWord\n" */
6992 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
6995 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
6998 } /* end of namedclass \blah */
7001 if (prevvalue > (IV)value) /* b-a */ {
7002 const int w = RExC_parse - rangebegin;
7003 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
7004 range = 0; /* not a valid range */
7008 prevvalue = value; /* save the beginning of the range */
7009 if (*RExC_parse == '-' && RExC_parse+1 < RExC_end &&
7010 RExC_parse[1] != ']') {
7013 /* a bad range like \w-, [:word:]- ? */
7014 if (namedclass > OOB_NAMEDCLASS) {
7015 if (ckWARN(WARN_REGEXP)) {
7017 RExC_parse >= rangebegin ?
7018 RExC_parse - rangebegin : 0;
7020 "False [] range \"%*.*s\"",
7024 ANYOF_BITMAP_SET(ret, '-');
7026 range = 1; /* yeah, it's a range! */
7027 continue; /* but do it the next time */
7031 /* now is the next time */
7032 /*stored += (value - prevvalue + 1);*/
7034 if (prevvalue < 256) {
7035 const IV ceilvalue = value < 256 ? value : 255;
7038 /* In EBCDIC [\x89-\x91] should include
7039 * the \x8e but [i-j] should not. */
7040 if (literal_endpoint == 2 &&
7041 ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
7042 (isUPPER(prevvalue) && isUPPER(ceilvalue))))
7044 if (isLOWER(prevvalue)) {
7045 for (i = prevvalue; i <= ceilvalue; i++)
7047 ANYOF_BITMAP_SET(ret, i);
7049 for (i = prevvalue; i <= ceilvalue; i++)
7051 ANYOF_BITMAP_SET(ret, i);
7056 for (i = prevvalue; i <= ceilvalue; i++) {
7057 if (!ANYOF_BITMAP_TEST(ret,i)) {
7059 ANYOF_BITMAP_SET(ret, i);
7063 if (value > 255 || UTF) {
7064 const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
7065 const UV natvalue = NATIVE_TO_UNI(value);
7066 stored+=2; /* can't optimize this class */
7067 ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
7068 if (prevnatvalue < natvalue) { /* what about > ? */
7069 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\t%04"UVxf"\n",
7070 prevnatvalue, natvalue);
7072 else if (prevnatvalue == natvalue) {
7073 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n", natvalue);
7075 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
7077 const UV f = to_uni_fold(natvalue, foldbuf, &foldlen);
7079 #ifdef EBCDIC /* RD t/uni/fold ff and 6b */
7080 if (RExC_precomp[0] == ':' &&
7081 RExC_precomp[1] == '[' &&
7082 (f == 0xDF || f == 0x92)) {
7083 f = NATIVE_TO_UNI(f);
7086 /* If folding and foldable and a single
7087 * character, insert also the folded version
7088 * to the charclass. */
7090 #ifdef EBCDIC /* RD tunifold ligatures s,t fb05, fb06 */
7091 if ((RExC_precomp[0] == ':' &&
7092 RExC_precomp[1] == '[' &&
7094 (value == 0xFB05 || value == 0xFB06))) ?
7095 foldlen == ((STRLEN)UNISKIP(f) - 1) :
7096 foldlen == (STRLEN)UNISKIP(f) )
7098 if (foldlen == (STRLEN)UNISKIP(f))
7100 Perl_sv_catpvf(aTHX_ listsv,
7103 /* Any multicharacter foldings
7104 * require the following transform:
7105 * [ABCDEF] -> (?:[ABCabcDEFd]|pq|rst)
7106 * where E folds into "pq" and F folds
7107 * into "rst", all other characters
7108 * fold to single characters. We save
7109 * away these multicharacter foldings,
7110 * to be later saved as part of the
7111 * additional "s" data. */
7114 if (!unicode_alternate)
7115 unicode_alternate = newAV();
7116 sv = newSVpvn((char*)foldbuf, foldlen);
7118 av_push(unicode_alternate, sv);
7122 /* If folding and the value is one of the Greek
7123 * sigmas insert a few more sigmas to make the
7124 * folding rules of the sigmas to work right.
7125 * Note that not all the possible combinations
7126 * are handled here: some of them are handled
7127 * by the standard folding rules, and some of
7128 * them (literal or EXACTF cases) are handled
7129 * during runtime in regexec.c:S_find_byclass(). */
7130 if (value == UNICODE_GREEK_SMALL_LETTER_FINAL_SIGMA) {
7131 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7132 (UV)UNICODE_GREEK_CAPITAL_LETTER_SIGMA);
7133 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7134 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7136 else if (value == UNICODE_GREEK_CAPITAL_LETTER_SIGMA)
7137 Perl_sv_catpvf(aTHX_ listsv, "%04"UVxf"\n",
7138 (UV)UNICODE_GREEK_SMALL_LETTER_SIGMA);
7143 literal_endpoint = 0;
7147 range = 0; /* this range (if it was one) is done now */
7151 ANYOF_FLAGS(ret) |= ANYOF_LARGE;
7153 RExC_size += ANYOF_CLASS_ADD_SKIP;
7155 RExC_emit += ANYOF_CLASS_ADD_SKIP;
7161 /****** !SIZE_ONLY AFTER HERE *********/
7163 if( stored == 1 && value < 256
7164 && !( ANYOF_FLAGS(ret) & ( ANYOF_FLAGS_ALL ^ ANYOF_FOLD ) )
7166 /* optimize single char class to an EXACT node
7167 but *only* when its not a UTF/high char */
7168 const char * cur_parse= RExC_parse;
7169 RExC_emit = (regnode *)orig_emit;
7170 RExC_parse = (char *)orig_parse;
7171 ret = reg_node(pRExC_state,
7172 (U8)((ANYOF_FLAGS(ret) & ANYOF_FOLD) ? EXACTF : EXACT));
7173 RExC_parse = (char *)cur_parse;
7174 *STRING(ret)= (char)value;
7176 RExC_emit += STR_SZ(1);
7179 /* optimize case-insensitive simple patterns (e.g. /[a-z]/i) */
7180 if ( /* If the only flag is folding (plus possibly inversion). */
7181 ((ANYOF_FLAGS(ret) & (ANYOF_FLAGS_ALL ^ ANYOF_INVERT)) == ANYOF_FOLD)
7183 for (value = 0; value < 256; ++value) {
7184 if (ANYOF_BITMAP_TEST(ret, value)) {
7185 UV fold = PL_fold[value];
7188 ANYOF_BITMAP_SET(ret, fold);
7191 ANYOF_FLAGS(ret) &= ~ANYOF_FOLD;
7194 /* optimize inverted simple patterns (e.g. [^a-z]) */
7195 if (optimize_invert &&
7196 /* If the only flag is inversion. */
7197 (ANYOF_FLAGS(ret) & ANYOF_FLAGS_ALL) == ANYOF_INVERT) {
7198 for (value = 0; value < ANYOF_BITMAP_SIZE; ++value)
7199 ANYOF_BITMAP(ret)[value] ^= ANYOF_FLAGS_ALL;
7200 ANYOF_FLAGS(ret) = ANYOF_UNICODE_ALL;
7203 AV * const av = newAV();
7205 /* The 0th element stores the character class description
7206 * in its textual form: used later (regexec.c:Perl_regclass_swash())
7207 * to initialize the appropriate swash (which gets stored in
7208 * the 1st element), and also useful for dumping the regnode.
7209 * The 2nd element stores the multicharacter foldings,
7210 * used later (regexec.c:S_reginclass()). */
7211 av_store(av, 0, listsv);
7212 av_store(av, 1, NULL);
7213 av_store(av, 2, (SV*)unicode_alternate);
7214 rv = newRV_noinc((SV*)av);
7215 n = add_data(pRExC_state, 1, "s");
7216 RExC_rx->data->data[n] = (void*)rv;
7223 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
7225 char* const retval = RExC_parse++;
7228 if (*RExC_parse == '(' && RExC_parse[1] == '?' &&
7229 RExC_parse[2] == '#') {
7230 while (*RExC_parse != ')') {
7231 if (RExC_parse == RExC_end)
7232 FAIL("Sequence (?#... not terminated");
7238 if (RExC_flags & PMf_EXTENDED) {
7239 if (isSPACE(*RExC_parse)) {
7243 else if (*RExC_parse == '#') {
7244 while (RExC_parse < RExC_end)
7245 if (*RExC_parse++ == '\n') break;
7254 - reg_node - emit a node
7256 STATIC regnode * /* Location. */
7257 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
7260 register regnode *ptr;
7261 regnode * const ret = RExC_emit;
7262 GET_RE_DEBUG_FLAGS_DECL;
7265 SIZE_ALIGN(RExC_size);
7269 NODE_ALIGN_FILL(ret);
7271 FILL_ADVANCE_NODE(ptr, op);
7272 if (RExC_offsets) { /* MJD */
7273 MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
7274 "reg_node", __LINE__,
7276 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
7277 ? "Overwriting end of array!\n" : "OK",
7278 (UV)(RExC_emit - RExC_emit_start),
7279 (UV)(RExC_parse - RExC_start),
7280 (UV)RExC_offsets[0]));
7281 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
7290 - reganode - emit a node with an argument
7292 STATIC regnode * /* Location. */
7293 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
7296 register regnode *ptr;
7297 regnode * const ret = RExC_emit;
7298 GET_RE_DEBUG_FLAGS_DECL;
7301 SIZE_ALIGN(RExC_size);
7306 assert(2==regarglen[op]+1);
7308 Anything larger than this has to allocate the extra amount.
7309 If we changed this to be:
7311 RExC_size += (1 + regarglen[op]);
7313 then it wouldn't matter. Its not clear what side effect
7314 might come from that so its not done so far.
7320 NODE_ALIGN_FILL(ret);
7322 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
7323 if (RExC_offsets) { /* MJD */
7324 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
7328 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
7329 "Overwriting end of array!\n" : "OK",
7330 (UV)(RExC_emit - RExC_emit_start),
7331 (UV)(RExC_parse - RExC_start),
7332 (UV)RExC_offsets[0]));
7333 Set_Cur_Node_Offset;
7342 - reguni - emit (if appropriate) a Unicode character
7345 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
7348 return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
7352 - reginsert - insert an operator in front of already-emitted operand
7354 * Means relocating the operand.
7357 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
7360 register regnode *src;
7361 register regnode *dst;
7362 register regnode *place;
7363 const int offset = regarglen[(U8)op];
7364 const int size = NODE_STEP_REGNODE + offset;
7365 GET_RE_DEBUG_FLAGS_DECL;
7366 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
7367 DEBUG_PARSE_FMT("inst"," - %s",reg_name[op]);
7378 for ( paren=0 ; paren < RExC_npar ; paren++ ) {
7379 if ( RExC_parens[paren] >= src )
7380 RExC_parens[paren] += size;
7384 while (src > opnd) {
7385 StructCopy(--src, --dst, regnode);
7386 if (RExC_offsets) { /* MJD 20010112 */
7387 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
7391 (UV)(dst - RExC_emit_start) > RExC_offsets[0]
7392 ? "Overwriting end of array!\n" : "OK",
7393 (UV)(src - RExC_emit_start),
7394 (UV)(dst - RExC_emit_start),
7395 (UV)RExC_offsets[0]));
7396 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
7397 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
7402 place = opnd; /* Op node, where operand used to be. */
7403 if (RExC_offsets) { /* MJD */
7404 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
7408 (UV)(place - RExC_emit_start) > RExC_offsets[0]
7409 ? "Overwriting end of array!\n" : "OK",
7410 (UV)(place - RExC_emit_start),
7411 (UV)(RExC_parse - RExC_start),
7412 (UV)RExC_offsets[0]));
7413 Set_Node_Offset(place, RExC_parse);
7414 Set_Node_Length(place, 1);
7416 src = NEXTOPER(place);
7417 FILL_ADVANCE_NODE(place, op);
7418 Zero(src, offset, regnode);
7422 - regtail - set the next-pointer at the end of a node chain of p to val.
7423 - SEE ALSO: regtail_study
7425 /* TODO: All three parms should be const */
7427 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7430 register regnode *scan;
7431 GET_RE_DEBUG_FLAGS_DECL;
7433 PERL_UNUSED_ARG(depth);
7439 /* Find last node. */
7442 regnode * const temp = regnext(scan);
7444 SV * const mysv=sv_newmortal();
7445 DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
7446 regprop(RExC_rx, mysv, scan);
7447 PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
7448 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
7449 (temp == NULL ? "->" : ""),
7450 (temp == NULL ? reg_name[OP(val)] : "")
7458 if (reg_off_by_arg[OP(scan)]) {
7459 ARG_SET(scan, val - scan);
7462 NEXT_OFF(scan) = val - scan;
7468 - regtail_study - set the next-pointer at the end of a node chain of p to val.
7469 - Look for optimizable sequences at the same time.
7470 - currently only looks for EXACT chains.
7472 This is expermental code. The idea is to use this routine to perform
7473 in place optimizations on branches and groups as they are constructed,
7474 with the long term intention of removing optimization from study_chunk so
7475 that it is purely analytical.
7477 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
7478 to control which is which.
7481 /* TODO: All four parms should be const */
7484 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
7487 register regnode *scan;
7489 #ifdef EXPERIMENTAL_INPLACESCAN
7493 GET_RE_DEBUG_FLAGS_DECL;
7499 /* Find last node. */
7503 regnode * const temp = regnext(scan);
7504 #ifdef EXPERIMENTAL_INPLACESCAN
7505 if (PL_regkind[OP(scan)] == EXACT)
7506 if (join_exact(pRExC_state,scan,&min,1,val,depth+1))
7514 if( exact == PSEUDO )
7516 else if ( exact != OP(scan) )
7525 SV * const mysv=sv_newmortal();
7526 DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
7527 regprop(RExC_rx, mysv, scan);
7528 PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
7529 SvPV_nolen_const(mysv),
7538 SV * const mysv_val=sv_newmortal();
7539 DEBUG_PARSE_MSG("");
7540 regprop(RExC_rx, mysv_val, val);
7541 PerlIO_printf(Perl_debug_log, "~ attach to %s (%d) offset to %d\n",
7542 SvPV_nolen_const(mysv_val),
7547 if (reg_off_by_arg[OP(scan)]) {
7548 ARG_SET(scan, val - scan);
7551 NEXT_OFF(scan) = val - scan;
7559 - regcurly - a little FSA that accepts {\d+,?\d*}
7562 S_regcurly(register const char *s)
7581 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
7584 Perl_regdump(pTHX_ const regexp *r)
7588 SV * const sv = sv_newmortal();
7589 SV *dsv= sv_newmortal();
7591 (void)dumpuntil(r, r->program, r->program + 1, NULL, NULL, sv, 0, 0);
7593 /* Header fields of interest. */
7594 if (r->anchored_substr) {
7595 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
7596 RE_SV_DUMPLEN(r->anchored_substr), 30);
7597 PerlIO_printf(Perl_debug_log,
7598 "anchored %s%s at %"IVdf" ",
7599 s, RE_SV_TAIL(r->anchored_substr),
7600 (IV)r->anchored_offset);
7601 } else if (r->anchored_utf8) {
7602 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
7603 RE_SV_DUMPLEN(r->anchored_utf8), 30);
7604 PerlIO_printf(Perl_debug_log,
7605 "anchored utf8 %s%s at %"IVdf" ",
7606 s, RE_SV_TAIL(r->anchored_utf8),
7607 (IV)r->anchored_offset);
7609 if (r->float_substr) {
7610 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
7611 RE_SV_DUMPLEN(r->float_substr), 30);
7612 PerlIO_printf(Perl_debug_log,
7613 "floating %s%s at %"IVdf"..%"UVuf" ",
7614 s, RE_SV_TAIL(r->float_substr),
7615 (IV)r->float_min_offset, (UV)r->float_max_offset);
7616 } else if (r->float_utf8) {
7617 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
7618 RE_SV_DUMPLEN(r->float_utf8), 30);
7619 PerlIO_printf(Perl_debug_log,
7620 "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
7621 s, RE_SV_TAIL(r->float_utf8),
7622 (IV)r->float_min_offset, (UV)r->float_max_offset);
7624 if (r->check_substr || r->check_utf8)
7625 PerlIO_printf(Perl_debug_log,
7627 (r->check_substr == r->float_substr
7628 && r->check_utf8 == r->float_utf8
7629 ? "(checking floating" : "(checking anchored"));
7630 if (r->reganch & ROPT_NOSCAN)
7631 PerlIO_printf(Perl_debug_log, " noscan");
7632 if (r->reganch & ROPT_CHECK_ALL)
7633 PerlIO_printf(Perl_debug_log, " isall");
7634 if (r->check_substr || r->check_utf8)
7635 PerlIO_printf(Perl_debug_log, ") ");
7637 if (r->regstclass) {
7638 regprop(r, sv, r->regstclass);
7639 PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
7641 if (r->reganch & ROPT_ANCH) {
7642 PerlIO_printf(Perl_debug_log, "anchored");
7643 if (r->reganch & ROPT_ANCH_BOL)
7644 PerlIO_printf(Perl_debug_log, "(BOL)");
7645 if (r->reganch & ROPT_ANCH_MBOL)
7646 PerlIO_printf(Perl_debug_log, "(MBOL)");
7647 if (r->reganch & ROPT_ANCH_SBOL)
7648 PerlIO_printf(Perl_debug_log, "(SBOL)");
7649 if (r->reganch & ROPT_ANCH_GPOS)
7650 PerlIO_printf(Perl_debug_log, "(GPOS)");
7651 PerlIO_putc(Perl_debug_log, ' ');
7653 if (r->reganch & ROPT_GPOS_SEEN)
7654 PerlIO_printf(Perl_debug_log, "GPOS ");
7655 if (r->reganch & ROPT_SKIP)
7656 PerlIO_printf(Perl_debug_log, "plus ");
7657 if (r->reganch & ROPT_IMPLICIT)
7658 PerlIO_printf(Perl_debug_log, "implicit ");
7659 PerlIO_printf(Perl_debug_log, "minlen %ld ", (long) r->minlen);
7660 if (r->reganch & ROPT_EVAL_SEEN)
7661 PerlIO_printf(Perl_debug_log, "with eval ");
7662 PerlIO_printf(Perl_debug_log, "\n");
7664 PERL_UNUSED_CONTEXT;
7666 #endif /* DEBUGGING */
7670 - regprop - printable representation of opcode
7673 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
7678 GET_RE_DEBUG_FLAGS_DECL;
7680 sv_setpvn(sv, "", 0);
7681 if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */
7682 /* It would be nice to FAIL() here, but this may be called from
7683 regexec.c, and it would be hard to supply pRExC_state. */
7684 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
7685 sv_catpv(sv, reg_name[OP(o)]); /* Take off const! */
7687 k = PL_regkind[OP(o)];
7690 SV * const dsv = sv_2mortal(newSVpvs(""));
7691 /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
7692 * is a crude hack but it may be the best for now since
7693 * we have no flag "this EXACTish node was UTF-8"
7695 const char * const s =
7696 pv_pretty(dsv, STRING(o), STR_LEN(o), 60,
7697 PL_colors[0], PL_colors[1],
7698 PERL_PV_ESCAPE_UNI_DETECT |
7699 PERL_PV_PRETTY_ELIPSES |
7702 Perl_sv_catpvf(aTHX_ sv, " %s", s );
7703 } else if (k == TRIE) {
7704 /* print the details of the trie in dumpuntil instead, as
7705 * prog->data isn't available here */
7706 const char op = OP(o);
7707 const I32 n = ARG(o);
7708 const reg_ac_data * const ac = IS_TRIE_AC(op) ?
7709 (reg_ac_data *)prog->data->data[n] :
7711 const reg_trie_data * const trie = !IS_TRIE_AC(op) ?
7712 (reg_trie_data*)prog->data->data[n] :
7715 Perl_sv_catpvf(aTHX_ sv, "-%s",reg_name[o->flags]);
7716 DEBUG_TRIE_COMPILE_r(
7717 Perl_sv_catpvf(aTHX_ sv,
7718 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
7719 (UV)trie->startstate,
7720 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
7721 (UV)trie->wordcount,
7724 (UV)TRIE_CHARCOUNT(trie),
7725 (UV)trie->uniquecharcount
7728 if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
7730 int rangestart = -1;
7731 U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
7732 Perl_sv_catpvf(aTHX_ sv, "[");
7733 for (i = 0; i <= 256; i++) {
7734 if (i < 256 && BITMAP_TEST(bitmap,i)) {
7735 if (rangestart == -1)
7737 } else if (rangestart != -1) {
7738 if (i <= rangestart + 3)
7739 for (; rangestart < i; rangestart++)
7740 put_byte(sv, rangestart);
7742 put_byte(sv, rangestart);
7744 put_byte(sv, i - 1);
7749 Perl_sv_catpvf(aTHX_ sv, "]");
7752 } else if (k == CURLY) {
7753 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
7754 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
7755 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
7757 else if (k == WHILEM && o->flags) /* Ordinal/of */
7758 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
7759 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP)
7760 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
7761 else if (k == RECURSE)
7762 Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
7763 else if (k == LOGICAL)
7764 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
7765 else if (k == ANYOF) {
7766 int i, rangestart = -1;
7767 const U8 flags = ANYOF_FLAGS(o);
7769 /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
7770 static const char * const anyofs[] = {
7803 if (flags & ANYOF_LOCALE)
7804 sv_catpvs(sv, "{loc}");
7805 if (flags & ANYOF_FOLD)
7806 sv_catpvs(sv, "{i}");
7807 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
7808 if (flags & ANYOF_INVERT)
7810 for (i = 0; i <= 256; i++) {
7811 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
7812 if (rangestart == -1)
7814 } else if (rangestart != -1) {
7815 if (i <= rangestart + 3)
7816 for (; rangestart < i; rangestart++)
7817 put_byte(sv, rangestart);
7819 put_byte(sv, rangestart);
7821 put_byte(sv, i - 1);
7827 if (o->flags & ANYOF_CLASS)
7828 for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
7829 if (ANYOF_CLASS_TEST(o,i))
7830 sv_catpv(sv, anyofs[i]);
7832 if (flags & ANYOF_UNICODE)
7833 sv_catpvs(sv, "{unicode}");
7834 else if (flags & ANYOF_UNICODE_ALL)
7835 sv_catpvs(sv, "{unicode_all}");
7839 SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
7843 U8 s[UTF8_MAXBYTES_CASE+1];
7845 for (i = 0; i <= 256; i++) { /* just the first 256 */
7846 uvchr_to_utf8(s, i);
7848 if (i < 256 && swash_fetch(sw, s, TRUE)) {
7849 if (rangestart == -1)
7851 } else if (rangestart != -1) {
7852 if (i <= rangestart + 3)
7853 for (; rangestart < i; rangestart++) {
7854 const U8 * const e = uvchr_to_utf8(s,rangestart);
7856 for(p = s; p < e; p++)
7860 const U8 *e = uvchr_to_utf8(s,rangestart);
7862 for (p = s; p < e; p++)
7865 e = uvchr_to_utf8(s, i-1);
7866 for (p = s; p < e; p++)
7873 sv_catpvs(sv, "..."); /* et cetera */
7877 char *s = savesvpv(lv);
7878 char * const origs = s;
7880 while (*s && *s != '\n')
7884 const char * const t = ++s;
7902 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
7904 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
7905 Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
7907 PERL_UNUSED_CONTEXT;
7908 PERL_UNUSED_ARG(sv);
7910 PERL_UNUSED_ARG(prog);
7911 #endif /* DEBUGGING */
7915 Perl_re_intuit_string(pTHX_ regexp *prog)
7916 { /* Assume that RE_INTUIT is set */
7918 GET_RE_DEBUG_FLAGS_DECL;
7919 PERL_UNUSED_CONTEXT;
7923 const char * const s = SvPV_nolen_const(prog->check_substr
7924 ? prog->check_substr : prog->check_utf8);
7926 if (!PL_colorset) reginitcolors();
7927 PerlIO_printf(Perl_debug_log,
7928 "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
7930 prog->check_substr ? "" : "utf8 ",
7931 PL_colors[5],PL_colors[0],
7934 (strlen(s) > 60 ? "..." : ""));
7937 return prog->check_substr ? prog->check_substr : prog->check_utf8;
7941 pregfree - free a regexp
7943 See regdupe below if you change anything here.
7947 Perl_pregfree(pTHX_ struct regexp *r)
7951 GET_RE_DEBUG_FLAGS_DECL;
7953 if (!r || (--r->refcnt > 0))
7959 SV *dsv= sv_newmortal();
7960 RE_PV_QUOTED_DECL(s, (r->reganch & ROPT_UTF8),
7961 dsv, r->precomp, r->prelen, 60);
7962 PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
7963 PL_colors[4],PL_colors[5],s);
7967 /* gcov results gave these as non-null 100% of the time, so there's no
7968 optimisation in checking them before calling Safefree */
7969 Safefree(r->precomp);
7970 Safefree(r->offsets); /* 20010421 MJD */
7971 RX_MATCH_COPY_FREE(r);
7972 #ifdef PERL_OLD_COPY_ON_WRITE
7974 SvREFCNT_dec(r->saved_copy);
7977 if (r->anchored_substr)
7978 SvREFCNT_dec(r->anchored_substr);
7979 if (r->anchored_utf8)
7980 SvREFCNT_dec(r->anchored_utf8);
7981 if (r->float_substr)
7982 SvREFCNT_dec(r->float_substr);
7984 SvREFCNT_dec(r->float_utf8);
7985 Safefree(r->substrs);
7988 SvREFCNT_dec(r->paren_names);
7990 int n = r->data->count;
7991 PAD* new_comppad = NULL;
7996 /* If you add a ->what type here, update the comment in regcomp.h */
7997 switch (r->data->what[n]) {
8000 SvREFCNT_dec((SV*)r->data->data[n]);
8003 Safefree(r->data->data[n]);
8006 new_comppad = (AV*)r->data->data[n];
8009 if (new_comppad == NULL)
8010 Perl_croak(aTHX_ "panic: pregfree comppad");
8011 PAD_SAVE_LOCAL(old_comppad,
8012 /* Watch out for global destruction's random ordering. */
8013 (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
8016 refcnt = OpREFCNT_dec((OP_4tree*)r->data->data[n]);
8019 op_free((OP_4tree*)r->data->data[n]);
8021 PAD_RESTORE_LOCAL(old_comppad);
8022 SvREFCNT_dec((SV*)new_comppad);
8028 { /* Aho Corasick add-on structure for a trie node.
8029 Used in stclass optimization only */
8031 reg_ac_data *aho=(reg_ac_data*)r->data->data[n];
8033 refcount = --aho->refcount;
8036 Safefree(aho->states);
8037 Safefree(aho->fail);
8038 aho->trie=NULL; /* not necessary to free this as it is
8039 handled by the 't' case */
8040 Safefree(r->data->data[n]); /* do this last!!!! */
8041 Safefree(r->regstclass);
8047 /* trie structure. */
8049 reg_trie_data *trie=(reg_trie_data*)r->data->data[n];
8051 refcount = --trie->refcount;
8054 Safefree(trie->charmap);
8055 if (trie->widecharmap)
8056 SvREFCNT_dec((SV*)trie->widecharmap);
8057 Safefree(trie->states);
8058 Safefree(trie->trans);
8060 Safefree(trie->bitmap);
8062 Safefree(trie->wordlen);
8064 Safefree(trie->jump);
8066 Safefree(trie->nextword);
8070 SvREFCNT_dec((SV*)trie->words);
8071 if (trie->revcharmap)
8072 SvREFCNT_dec((SV*)trie->revcharmap);
8075 Safefree(r->data->data[n]); /* do this last!!!! */
8080 Perl_croak(aTHX_ "panic: regfree data code '%c'", r->data->what[n]);
8083 Safefree(r->data->what);
8086 Safefree(r->startp);
8091 #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t))
8092 #define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8093 #define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t))
8094 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
8097 regdupe - duplicate a regexp.
8099 This routine is called by sv.c's re_dup and is expected to clone a
8100 given regexp structure. It is a no-op when not under USE_ITHREADS.
8101 (Originally this *was* re_dup() for change history see sv.c)
8103 See pregfree() above if you change anything here.
8105 #if defined(USE_ITHREADS)
8107 Perl_regdupe(pTHX_ const regexp *r, CLONE_PARAMS *param)
8112 struct reg_substr_datum *s;
8115 return (REGEXP *)NULL;
8117 if ((ret = (REGEXP *)ptr_table_fetch(PL_ptr_table, r)))
8120 len = r->offsets[0];
8121 npar = r->nparens+1;
8123 Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp);
8124 Copy(r->program, ret->program, len+1, regnode);
8126 Newx(ret->startp, npar, I32);
8127 Copy(r->startp, ret->startp, npar, I32);
8128 Newx(ret->endp, npar, I32);
8129 Copy(r->startp, ret->startp, npar, I32);
8131 Newx(ret->substrs, 1, struct reg_substr_data);
8132 for (s = ret->substrs->data, i = 0; i < 3; i++, s++) {
8133 s->min_offset = r->substrs->data[i].min_offset;
8134 s->max_offset = r->substrs->data[i].max_offset;
8135 s->end_shift = r->substrs->data[i].end_shift;
8136 s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
8137 s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
8140 ret->regstclass = NULL;
8143 const int count = r->data->count;
8146 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
8147 char, struct reg_data);
8148 Newx(d->what, count, U8);
8151 for (i = 0; i < count; i++) {
8152 d->what[i] = r->data->what[i];
8153 switch (d->what[i]) {
8154 /* legal options are one of: sfpont
8155 see also regcomp.h and pregfree() */
8158 d->data[i] = sv_dup_inc((SV *)r->data->data[i], param);
8161 d->data[i] = av_dup_inc((AV *)r->data->data[i], param);
8164 /* This is cheating. */
8165 Newx(d->data[i], 1, struct regnode_charclass_class);
8166 StructCopy(r->data->data[i], d->data[i],
8167 struct regnode_charclass_class);
8168 ret->regstclass = (regnode*)d->data[i];
8171 /* Compiled op trees are readonly, and can thus be
8172 shared without duplication. */
8174 d->data[i] = (void*)OpREFCNT_inc((OP*)r->data->data[i]);
8178 d->data[i] = r->data->data[i];
8181 d->data[i] = r->data->data[i];
8183 ((reg_trie_data*)d->data[i])->refcount++;
8187 d->data[i] = r->data->data[i];
8189 ((reg_ac_data*)d->data[i])->refcount++;
8191 /* Trie stclasses are readonly and can thus be shared
8192 * without duplication. We free the stclass in pregfree
8193 * when the corresponding reg_ac_data struct is freed.
8195 ret->regstclass= r->regstclass;
8198 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", r->data->what[i]);
8207 Newx(ret->offsets, 2*len+1, U32);
8208 Copy(r->offsets, ret->offsets, 2*len+1, U32);
8210 ret->precomp = SAVEPVN(r->precomp, r->prelen);
8211 ret->refcnt = r->refcnt;
8212 ret->minlen = r->minlen;
8213 ret->prelen = r->prelen;
8214 ret->nparens = r->nparens;
8215 ret->lastparen = r->lastparen;
8216 ret->lastcloseparen = r->lastcloseparen;
8217 ret->reganch = r->reganch;
8219 ret->sublen = r->sublen;
8221 ret->engine = r->engine;
8223 ret->paren_names = hv_dup_inc(r->paren_names, param);
8225 if (RX_MATCH_COPIED(ret))
8226 ret->subbeg = SAVEPVN(r->subbeg, r->sublen);
8229 #ifdef PERL_OLD_COPY_ON_WRITE
8230 ret->saved_copy = NULL;
8233 ptr_table_store(PL_ptr_table, r, ret);
8238 #ifndef PERL_IN_XSUB_RE
8240 - regnext - dig the "next" pointer out of a node
8243 Perl_regnext(pTHX_ register regnode *p)
8246 register I32 offset;
8248 if (p == &PL_regdummy)
8251 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
8260 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
8263 STRLEN l1 = strlen(pat1);
8264 STRLEN l2 = strlen(pat2);
8267 const char *message;
8273 Copy(pat1, buf, l1 , char);
8274 Copy(pat2, buf + l1, l2 , char);
8275 buf[l1 + l2] = '\n';
8276 buf[l1 + l2 + 1] = '\0';
8278 /* ANSI variant takes additional second argument */
8279 va_start(args, pat2);
8283 msv = vmess(buf, &args);
8285 message = SvPV_const(msv,l1);
8288 Copy(message, buf, l1 , char);
8289 buf[l1-1] = '\0'; /* Overwrite \n */
8290 Perl_croak(aTHX_ "%s", buf);
8293 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
8295 #ifndef PERL_IN_XSUB_RE
8297 Perl_save_re_context(pTHX)
8301 struct re_save_state *state;
8303 SAVEVPTR(PL_curcop);
8304 SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
8306 state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
8307 PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
8308 SSPUSHINT(SAVEt_RE_STATE);
8310 Copy(&PL_reg_state, state, 1, struct re_save_state);
8312 PL_reg_start_tmp = 0;
8313 PL_reg_start_tmpl = 0;
8314 PL_reg_oldsaved = NULL;
8315 PL_reg_oldsavedlen = 0;
8317 PL_reg_leftiter = 0;
8318 PL_reg_poscache = NULL;
8319 PL_reg_poscache_size = 0;
8320 #ifdef PERL_OLD_COPY_ON_WRITE
8324 /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
8326 const REGEXP * const rx = PM_GETRE(PL_curpm);
8329 for (i = 1; i <= rx->nparens; i++) {
8330 char digits[TYPE_CHARS(long)];
8331 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
8332 GV *const *const gvp
8333 = (GV**)hv_fetch(PL_defstash, digits, len, 0);
8336 GV * const gv = *gvp;
8337 if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
8347 clear_re(pTHX_ void *r)
8350 ReREFCNT_dec((regexp *)r);
8356 S_put_byte(pTHX_ SV *sv, int c)
8358 if (isCNTRL(c) || c == 255 || !isPRINT(c))
8359 Perl_sv_catpvf(aTHX_ sv, "\\%o", c);
8360 else if (c == '-' || c == ']' || c == '\\' || c == '^')
8361 Perl_sv_catpvf(aTHX_ sv, "\\%c", c);
8363 Perl_sv_catpvf(aTHX_ sv, "%c", c);
8367 #define CLEAR_OPTSTART \
8368 if (optstart) STMT_START { \
8369 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%d nodes)\n", node - optstart)); \
8373 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
8375 STATIC const regnode *
8376 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
8377 const regnode *last, const regnode *plast,
8378 SV* sv, I32 indent, U32 depth)
8381 register U8 op = PSEUDO; /* Arbitrary non-END op. */
8382 register const regnode *next;
8383 const regnode *optstart= NULL;
8384 GET_RE_DEBUG_FLAGS_DECL;
8386 #ifdef DEBUG_DUMPUNTIL
8387 PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
8388 last ? last-start : 0,plast ? plast-start : 0);
8391 if (plast && plast < last)
8394 while (PL_regkind[op] != END && (!last || node < last)) {
8395 /* While that wasn't END last time... */
8401 next = regnext((regnode *)node);
8404 if (OP(node) == OPTIMIZED) {
8405 if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
8412 regprop(r, sv, node);
8413 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
8414 (int)(2*indent + 1), "", SvPVX_const(sv));
8416 if (OP(node) != OPTIMIZED) {
8417 if (next == NULL) /* Next ptr. */
8418 PerlIO_printf(Perl_debug_log, "(0)");
8419 else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
8420 PerlIO_printf(Perl_debug_log, "(FAIL)");
8422 PerlIO_printf(Perl_debug_log, "(%"IVdf")", (IV)(next - start));
8424 /*if (PL_regkind[(U8)op] != TRIE)*/
8425 (void)PerlIO_putc(Perl_debug_log, '\n');
8429 if (PL_regkind[(U8)op] == BRANCHJ) {
8432 register const regnode *nnode = (OP(next) == LONGJMP
8433 ? regnext((regnode *)next)
8435 if (last && nnode > last)
8437 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
8440 else if (PL_regkind[(U8)op] == BRANCH) {
8442 DUMPUNTIL(NEXTOPER(node), next);
8444 else if ( PL_regkind[(U8)op] == TRIE ) {
8445 const char op = OP(node);
8446 const I32 n = ARG(node);
8447 const reg_ac_data * const ac = op>=AHOCORASICK ?
8448 (reg_ac_data *)r->data->data[n] :
8450 const reg_trie_data * const trie = op<AHOCORASICK ?
8451 (reg_trie_data*)r->data->data[n] :
8453 const regnode *nextbranch= NULL;
8455 sv_setpvn(sv, "", 0);
8456 for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
8457 SV ** const elem_ptr = av_fetch(trie->words,word_idx,0);
8459 PerlIO_printf(Perl_debug_log, "%*s%s ",
8460 (int)(2*(indent+3)), "",
8461 elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
8462 PL_colors[0], PL_colors[1],
8463 (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
8464 PERL_PV_PRETTY_ELIPSES |
8470 U16 dist= trie->jump[word_idx+1];
8471 PerlIO_printf(Perl_debug_log, "(%u)\n",(next - dist) - start);
8474 nextbranch= next - trie->jump[0];
8475 DUMPUNTIL(next - dist, nextbranch);
8477 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
8478 nextbranch= regnext((regnode *)nextbranch);
8480 PerlIO_printf(Perl_debug_log, "\n");
8483 if (last && next > last)
8488 else if ( op == CURLY ) { /* "next" might be very big: optimizer */
8489 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
8490 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
8492 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
8494 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
8496 else if ( op == PLUS || op == STAR) {
8497 DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
8499 else if (op == ANYOF) {
8500 /* arglen 1 + class block */
8501 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_LARGE)
8502 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
8503 node = NEXTOPER(node);
8505 else if (PL_regkind[(U8)op] == EXACT) {
8506 /* Literal string, where present. */
8507 node += NODE_SZ_STR(node) - 1;
8508 node = NEXTOPER(node);
8511 node = NEXTOPER(node);
8512 node += regarglen[(U8)op];
8514 if (op == CURLYX || op == OPEN)
8516 else if (op == WHILEM)
8520 #ifdef DEBUG_DUMPUNTIL
8521 PerlIO_printf(Perl_debug_log, "--- %d\n",indent);
8526 #endif /* DEBUGGING */
8530 * c-indentation-style: bsd
8532 * indent-tabs-mode: t
8535 * ex: set ts=8 sts=4 sw=4 noet: