5 * 'A fair jaw-cracker dwarf-language must be.' --Samwise Gamgee
7 * [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
10 /* This file contains functions for compiling a regular expression. See
11 * also regexec.c which funnily enough, contains functions for executing
12 * a regular expression.
14 * This file is also copied at build time to ext/re/re_comp.c, where
15 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16 * This causes the main functions to be compiled under new names and with
17 * debugging support added, which makes "use re 'debug'" work.
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21 * confused with the original package (see point 3 below). Thanks, Henry!
24 /* Additional note: this code is very heavily munged from Henry's version
25 * in places. In some spots I've traded clarity for efficiency, so don't
26 * blame Henry for some of the lack of readability.
29 /* The names of the functions have been changed from regcomp and
30 * regexec to pregcomp and pregexec in order to avoid conflicts
31 * with the POSIX routines of the same names.
34 #ifdef PERL_EXT_RE_BUILD
39 * pregcomp and pregexec -- regsub and regerror are not used in perl
41 * Copyright (c) 1986 by University of Toronto.
42 * Written by Henry Spencer. Not derived from licensed software.
44 * Permission is granted to anyone to use this software for any
45 * purpose on any computer system, and to redistribute it freely,
46 * subject to the following restrictions:
48 * 1. The author is not responsible for the consequences of use of
49 * this software, no matter how awful, even if they arise
52 * 2. The origin of this software must not be misrepresented, either
53 * by explicit claim or by omission.
55 * 3. Altered versions must be plainly marked as such, and must not
56 * be misrepresented as being the original software.
59 **** Alterations to Henry's code are...
61 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63 **** by Larry Wall and others
65 **** You may distribute under the terms of either the GNU General Public
66 **** License or the Artistic License, as specified in the README file.
69 * Beware that some of this code is subtly aware of the way operator
70 * precedence is structured in regular expressions. Serious changes in
71 * regular-expression syntax might require a total rethink.
74 #define PERL_IN_REGCOMP_C
77 #ifndef PERL_IN_XSUB_RE
82 #ifdef PERL_IN_XSUB_RE
88 #include "dquote_static.c"
89 #ifndef PERL_IN_XSUB_RE
90 # include "charclass_invlists.h"
98 # if defined(BUGGY_MSC6)
99 /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
100 # pragma optimize("a",off)
101 /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
102 # pragma optimize("w",on )
103 # endif /* BUGGY_MSC6 */
107 #define STATIC static
110 typedef struct RExC_state_t {
111 U32 flags; /* are we folding, multilining? */
112 char *precomp; /* uncompiled string. */
113 REGEXP *rx_sv; /* The SV that is the regexp. */
114 regexp *rx; /* perl core regexp structure */
115 regexp_internal *rxi; /* internal data for regexp object pprivate field */
116 char *start; /* Start of input for compile */
117 char *end; /* End of input for compile */
118 char *parse; /* Input-scan pointer. */
119 I32 whilem_seen; /* number of WHILEM in this expr */
120 regnode *emit_start; /* Start of emitted-code area */
121 regnode *emit_bound; /* First regnode outside of the allocated space */
122 regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */
123 I32 naughty; /* How bad is this pattern? */
124 I32 sawback; /* Did we see \1, ...? */
126 I32 size; /* Code size. */
127 I32 npar; /* Capture buffer count, (OPEN). */
128 I32 cpar; /* Capture buffer count, (CLOSE). */
129 I32 nestroot; /* root parens we are in - used by accept */
133 regnode **open_parens; /* pointers to open parens */
134 regnode **close_parens; /* pointers to close parens */
135 regnode *opend; /* END node in program */
136 I32 utf8; /* whether the pattern is utf8 or not */
137 I32 orig_utf8; /* whether the pattern was originally in utf8 */
138 /* XXX use this for future optimisation of case
139 * where pattern must be upgraded to utf8. */
140 I32 uni_semantics; /* If a d charset modifier should use unicode
141 rules, even if the pattern is not in
143 HV *paren_names; /* Paren names */
145 regnode **recurse; /* Recurse regops */
146 I32 recurse_count; /* Number of recurse regops */
149 I32 override_recoding;
151 char *starttry; /* -Dr: where regtry was called. */
152 #define RExC_starttry (pRExC_state->starttry)
155 const char *lastparse;
157 AV *paren_name_list; /* idx -> name */
158 #define RExC_lastparse (pRExC_state->lastparse)
159 #define RExC_lastnum (pRExC_state->lastnum)
160 #define RExC_paren_name_list (pRExC_state->paren_name_list)
164 #define RExC_flags (pRExC_state->flags)
165 #define RExC_precomp (pRExC_state->precomp)
166 #define RExC_rx_sv (pRExC_state->rx_sv)
167 #define RExC_rx (pRExC_state->rx)
168 #define RExC_rxi (pRExC_state->rxi)
169 #define RExC_start (pRExC_state->start)
170 #define RExC_end (pRExC_state->end)
171 #define RExC_parse (pRExC_state->parse)
172 #define RExC_whilem_seen (pRExC_state->whilem_seen)
173 #ifdef RE_TRACK_PATTERN_OFFSETS
174 #define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the others */
176 #define RExC_emit (pRExC_state->emit)
177 #define RExC_emit_start (pRExC_state->emit_start)
178 #define RExC_emit_bound (pRExC_state->emit_bound)
179 #define RExC_naughty (pRExC_state->naughty)
180 #define RExC_sawback (pRExC_state->sawback)
181 #define RExC_seen (pRExC_state->seen)
182 #define RExC_size (pRExC_state->size)
183 #define RExC_npar (pRExC_state->npar)
184 #define RExC_nestroot (pRExC_state->nestroot)
185 #define RExC_extralen (pRExC_state->extralen)
186 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
187 #define RExC_seen_evals (pRExC_state->seen_evals)
188 #define RExC_utf8 (pRExC_state->utf8)
189 #define RExC_uni_semantics (pRExC_state->uni_semantics)
190 #define RExC_orig_utf8 (pRExC_state->orig_utf8)
191 #define RExC_open_parens (pRExC_state->open_parens)
192 #define RExC_close_parens (pRExC_state->close_parens)
193 #define RExC_opend (pRExC_state->opend)
194 #define RExC_paren_names (pRExC_state->paren_names)
195 #define RExC_recurse (pRExC_state->recurse)
196 #define RExC_recurse_count (pRExC_state->recurse_count)
197 #define RExC_in_lookbehind (pRExC_state->in_lookbehind)
198 #define RExC_contains_locale (pRExC_state->contains_locale)
199 #define RExC_override_recoding (pRExC_state->override_recoding)
202 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
203 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
204 ((*s) == '{' && regcurly(s)))
207 #undef SPSTART /* dratted cpp namespace... */
210 * Flags to be passed up and down.
212 #define WORST 0 /* Worst case. */
213 #define HASWIDTH 0x01 /* Known to match non-null strings. */
215 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
216 * character, and if utf8, must be invariant. Note that this is not the same thing as REGNODE_SIMPLE */
218 #define SPSTART 0x04 /* Starts with * or +. */
219 #define TRYAGAIN 0x08 /* Weeded out a declaration. */
220 #define POSTPONED 0x10 /* (?1),(?&name), (??{...}) or similar */
222 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
224 /* whether trie related optimizations are enabled */
225 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
226 #define TRIE_STUDY_OPT
227 #define FULL_TRIE_STUDY
233 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
234 #define PBITVAL(paren) (1 << ((paren) & 7))
235 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
236 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
237 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
239 /* If not already in utf8, do a longjmp back to the beginning */
240 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
241 #define REQUIRE_UTF8 STMT_START { \
242 if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
245 /* About scan_data_t.
247 During optimisation we recurse through the regexp program performing
248 various inplace (keyhole style) optimisations. In addition study_chunk
249 and scan_commit populate this data structure with information about
250 what strings MUST appear in the pattern. We look for the longest
251 string that must appear at a fixed location, and we look for the
252 longest string that may appear at a floating location. So for instance
257 Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
258 strings (because they follow a .* construct). study_chunk will identify
259 both FOO and BAR as being the longest fixed and floating strings respectively.
261 The strings can be composites, for instance
265 will result in a composite fixed substring 'foo'.
267 For each string some basic information is maintained:
269 - offset or min_offset
270 This is the position the string must appear at, or not before.
271 It also implicitly (when combined with minlenp) tells us how many
272 characters must match before the string we are searching for.
273 Likewise when combined with minlenp and the length of the string it
274 tells us how many characters must appear after the string we have
278 Only used for floating strings. This is the rightmost point that
279 the string can appear at. If set to I32 max it indicates that the
280 string can occur infinitely far to the right.
283 A pointer to the minimum length of the pattern that the string
284 was found inside. This is important as in the case of positive
285 lookahead or positive lookbehind we can have multiple patterns
290 The minimum length of the pattern overall is 3, the minimum length
291 of the lookahead part is 3, but the minimum length of the part that
292 will actually match is 1. So 'FOO's minimum length is 3, but the
293 minimum length for the F is 1. This is important as the minimum length
294 is used to determine offsets in front of and behind the string being
295 looked for. Since strings can be composites this is the length of the
296 pattern at the time it was committed with a scan_commit. Note that
297 the length is calculated by study_chunk, so that the minimum lengths
298 are not known until the full pattern has been compiled, thus the
299 pointer to the value.
303 In the case of lookbehind the string being searched for can be
304 offset past the start point of the final matching string.
305 If this value was just blithely removed from the min_offset it would
306 invalidate some of the calculations for how many chars must match
307 before or after (as they are derived from min_offset and minlen and
308 the length of the string being searched for).
309 When the final pattern is compiled and the data is moved from the
310 scan_data_t structure into the regexp structure the information
311 about lookbehind is factored in, with the information that would
312 have been lost precalculated in the end_shift field for the
315 The fields pos_min and pos_delta are used to store the minimum offset
316 and the delta to the maximum offset at the current point in the pattern.
320 typedef struct scan_data_t {
321 /*I32 len_min; unused */
322 /*I32 len_delta; unused */
326 I32 last_end; /* min value, <0 unless valid. */
329 SV **longest; /* Either &l_fixed, or &l_float. */
330 SV *longest_fixed; /* longest fixed string found in pattern */
331 I32 offset_fixed; /* offset where it starts */
332 I32 *minlen_fixed; /* pointer to the minlen relevant to the string */
333 I32 lookbehind_fixed; /* is the position of the string modfied by LB */
334 SV *longest_float; /* longest floating string found in pattern */
335 I32 offset_float_min; /* earliest point in string it can appear */
336 I32 offset_float_max; /* latest point in string it can appear */
337 I32 *minlen_float; /* pointer to the minlen relevant to the string */
338 I32 lookbehind_float; /* is the position of the string modified by LB */
342 struct regnode_charclass_class *start_class;
346 * Forward declarations for pregcomp()'s friends.
349 static const scan_data_t zero_scan_data =
350 { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
352 #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
353 #define SF_BEFORE_SEOL 0x0001
354 #define SF_BEFORE_MEOL 0x0002
355 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
356 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
359 # define SF_FIX_SHIFT_EOL (0+2)
360 # define SF_FL_SHIFT_EOL (0+4)
362 # define SF_FIX_SHIFT_EOL (+2)
363 # define SF_FL_SHIFT_EOL (+4)
366 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
367 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
369 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
370 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
371 #define SF_IS_INF 0x0040
372 #define SF_HAS_PAR 0x0080
373 #define SF_IN_PAR 0x0100
374 #define SF_HAS_EVAL 0x0200
375 #define SCF_DO_SUBSTR 0x0400
376 #define SCF_DO_STCLASS_AND 0x0800
377 #define SCF_DO_STCLASS_OR 0x1000
378 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
379 #define SCF_WHILEM_VISITED_POS 0x2000
381 #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */
382 #define SCF_SEEN_ACCEPT 0x8000
384 #define UTF cBOOL(RExC_utf8)
385 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
386 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
387 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
388 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
389 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
390 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
391 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
393 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
395 #define OOB_UNICODE 12345678
396 #define OOB_NAMEDCLASS -1
398 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
399 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
402 /* length of regex to show in messages that don't mark a position within */
403 #define RegexLengthToShowInErrorMessages 127
406 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
407 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
408 * op/pragma/warn/regcomp.
410 #define MARKER1 "<-- HERE" /* marker as it appears in the description */
411 #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
413 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
416 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
417 * arg. Show regex, up to a maximum length. If it's too long, chop and add
420 #define _FAIL(code) STMT_START { \
421 const char *ellipses = ""; \
422 IV len = RExC_end - RExC_precomp; \
425 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
426 if (len > RegexLengthToShowInErrorMessages) { \
427 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
428 len = RegexLengthToShowInErrorMessages - 10; \
434 #define FAIL(msg) _FAIL( \
435 Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
436 msg, (int)len, RExC_precomp, ellipses))
438 #define FAIL2(msg,arg) _FAIL( \
439 Perl_croak(aTHX_ msg " in regex m/%.*s%s/", \
440 arg, (int)len, RExC_precomp, ellipses))
443 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
445 #define Simple_vFAIL(m) STMT_START { \
446 const IV offset = RExC_parse - RExC_precomp; \
447 Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
448 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
452 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
454 #define vFAIL(m) STMT_START { \
456 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
461 * Like Simple_vFAIL(), but accepts two arguments.
463 #define Simple_vFAIL2(m,a1) STMT_START { \
464 const IV offset = RExC_parse - RExC_precomp; \
465 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \
466 (int)offset, RExC_precomp, RExC_precomp + offset); \
470 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
472 #define vFAIL2(m,a1) STMT_START { \
474 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
475 Simple_vFAIL2(m, a1); \
480 * Like Simple_vFAIL(), but accepts three arguments.
482 #define Simple_vFAIL3(m, a1, a2) STMT_START { \
483 const IV offset = RExC_parse - RExC_precomp; \
484 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \
485 (int)offset, RExC_precomp, RExC_precomp + offset); \
489 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
491 #define vFAIL3(m,a1,a2) STMT_START { \
493 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
494 Simple_vFAIL3(m, a1, a2); \
498 * Like Simple_vFAIL(), but accepts four arguments.
500 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \
501 const IV offset = RExC_parse - RExC_precomp; \
502 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, \
503 (int)offset, RExC_precomp, RExC_precomp + offset); \
506 #define ckWARNreg(loc,m) STMT_START { \
507 const IV offset = loc - RExC_precomp; \
508 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
509 (int)offset, RExC_precomp, RExC_precomp + offset); \
512 #define ckWARNregdep(loc,m) STMT_START { \
513 const IV offset = loc - RExC_precomp; \
514 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
516 (int)offset, RExC_precomp, RExC_precomp + offset); \
519 #define ckWARN2regdep(loc,m, a1) STMT_START { \
520 const IV offset = loc - RExC_precomp; \
521 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
523 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
526 #define ckWARN2reg(loc, m, a1) STMT_START { \
527 const IV offset = loc - RExC_precomp; \
528 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
529 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
532 #define vWARN3(loc, m, a1, a2) STMT_START { \
533 const IV offset = loc - RExC_precomp; \
534 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
535 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
538 #define ckWARN3reg(loc, m, a1, a2) STMT_START { \
539 const IV offset = loc - RExC_precomp; \
540 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
541 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
544 #define vWARN4(loc, m, a1, a2, a3) STMT_START { \
545 const IV offset = loc - RExC_precomp; \
546 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
547 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
550 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START { \
551 const IV offset = loc - RExC_precomp; \
552 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
553 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
556 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \
557 const IV offset = loc - RExC_precomp; \
558 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
559 a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
563 /* Allow for side effects in s */
564 #define REGC(c,s) STMT_START { \
565 if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
568 /* Macros for recording node offsets. 20001227 mjd@plover.com
569 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
570 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
571 * Element 0 holds the number n.
572 * Position is 1 indexed.
574 #ifndef RE_TRACK_PATTERN_OFFSETS
575 #define Set_Node_Offset_To_R(node,byte)
576 #define Set_Node_Offset(node,byte)
577 #define Set_Cur_Node_Offset
578 #define Set_Node_Length_To_R(node,len)
579 #define Set_Node_Length(node,len)
580 #define Set_Node_Cur_Length(node)
581 #define Node_Offset(n)
582 #define Node_Length(n)
583 #define Set_Node_Offset_Length(node,offset,len)
584 #define ProgLen(ri) ri->u.proglen
585 #define SetProgLen(ri,x) ri->u.proglen = x
587 #define ProgLen(ri) ri->u.offsets[0]
588 #define SetProgLen(ri,x) ri->u.offsets[0] = x
589 #define Set_Node_Offset_To_R(node,byte) STMT_START { \
591 MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \
592 __LINE__, (int)(node), (int)(byte))); \
594 Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
596 RExC_offsets[2*(node)-1] = (byte); \
601 #define Set_Node_Offset(node,byte) \
602 Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
603 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
605 #define Set_Node_Length_To_R(node,len) STMT_START { \
607 MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \
608 __LINE__, (int)(node), (int)(len))); \
610 Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
612 RExC_offsets[2*(node)] = (len); \
617 #define Set_Node_Length(node,len) \
618 Set_Node_Length_To_R((node)-RExC_emit_start, len)
619 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
620 #define Set_Node_Cur_Length(node) \
621 Set_Node_Length(node, RExC_parse - parse_start)
623 /* Get offsets and lengths */
624 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
625 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
627 #define Set_Node_Offset_Length(node,offset,len) STMT_START { \
628 Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \
629 Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \
633 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
634 #define EXPERIMENTAL_INPLACESCAN
635 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
637 #define DEBUG_STUDYDATA(str,data,depth) \
638 DEBUG_OPTIMISE_MORE_r(if(data){ \
639 PerlIO_printf(Perl_debug_log, \
640 "%*s" str "Pos:%"IVdf"/%"IVdf \
641 " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s", \
642 (int)(depth)*2, "", \
643 (IV)((data)->pos_min), \
644 (IV)((data)->pos_delta), \
645 (UV)((data)->flags), \
646 (IV)((data)->whilem_c), \
647 (IV)((data)->last_closep ? *((data)->last_closep) : -1), \
648 is_inf ? "INF " : "" \
650 if ((data)->last_found) \
651 PerlIO_printf(Perl_debug_log, \
652 "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
653 " %sFloat: '%s' @ %"IVdf"/%"IVdf"", \
654 SvPVX_const((data)->last_found), \
655 (IV)((data)->last_end), \
656 (IV)((data)->last_start_min), \
657 (IV)((data)->last_start_max), \
658 ((data)->longest && \
659 (data)->longest==&((data)->longest_fixed)) ? "*" : "", \
660 SvPVX_const((data)->longest_fixed), \
661 (IV)((data)->offset_fixed), \
662 ((data)->longest && \
663 (data)->longest==&((data)->longest_float)) ? "*" : "", \
664 SvPVX_const((data)->longest_float), \
665 (IV)((data)->offset_float_min), \
666 (IV)((data)->offset_float_max) \
668 PerlIO_printf(Perl_debug_log,"\n"); \
671 static void clear_re(pTHX_ void *r);
673 /* Mark that we cannot extend a found fixed substring at this point.
674 Update the longest found anchored substring and the longest found
675 floating substrings if needed. */
678 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
680 const STRLEN l = CHR_SVLEN(data->last_found);
681 const STRLEN old_l = CHR_SVLEN(*data->longest);
682 GET_RE_DEBUG_FLAGS_DECL;
684 PERL_ARGS_ASSERT_SCAN_COMMIT;
686 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
687 SvSetMagicSV(*data->longest, data->last_found);
688 if (*data->longest == data->longest_fixed) {
689 data->offset_fixed = l ? data->last_start_min : data->pos_min;
690 if (data->flags & SF_BEFORE_EOL)
692 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
694 data->flags &= ~SF_FIX_BEFORE_EOL;
695 data->minlen_fixed=minlenp;
696 data->lookbehind_fixed=0;
698 else { /* *data->longest == data->longest_float */
699 data->offset_float_min = l ? data->last_start_min : data->pos_min;
700 data->offset_float_max = (l
701 ? data->last_start_max
702 : data->pos_min + data->pos_delta);
703 if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
704 data->offset_float_max = I32_MAX;
705 if (data->flags & SF_BEFORE_EOL)
707 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
709 data->flags &= ~SF_FL_BEFORE_EOL;
710 data->minlen_float=minlenp;
711 data->lookbehind_float=0;
714 SvCUR_set(data->last_found, 0);
716 SV * const sv = data->last_found;
717 if (SvUTF8(sv) && SvMAGICAL(sv)) {
718 MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
724 data->flags &= ~SF_BEFORE_EOL;
725 DEBUG_STUDYDATA("commit: ",data,0);
728 /* Can match anything (initialization) */
730 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
732 PERL_ARGS_ASSERT_CL_ANYTHING;
734 ANYOF_BITMAP_SETALL(cl);
735 cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
736 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
738 /* If any portion of the regex is to operate under locale rules,
739 * initialization includes it. The reason this isn't done for all regexes
740 * is that the optimizer was written under the assumption that locale was
741 * all-or-nothing. Given the complexity and lack of documentation in the
742 * optimizer, and that there are inadequate test cases for locale, so many
743 * parts of it may not work properly, it is safest to avoid locale unless
745 if (RExC_contains_locale) {
746 ANYOF_CLASS_SETALL(cl); /* /l uses class */
747 cl->flags |= ANYOF_LOCALE;
750 ANYOF_CLASS_ZERO(cl); /* Only /l uses class now */
754 /* Can match anything (initialization) */
756 S_cl_is_anything(const struct regnode_charclass_class *cl)
760 PERL_ARGS_ASSERT_CL_IS_ANYTHING;
762 for (value = 0; value <= ANYOF_MAX; value += 2)
763 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
765 if (!(cl->flags & ANYOF_UNICODE_ALL))
767 if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
772 /* Can match anything (initialization) */
774 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
776 PERL_ARGS_ASSERT_CL_INIT;
778 Zero(cl, 1, struct regnode_charclass_class);
780 cl_anything(pRExC_state, cl);
781 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
784 /* These two functions currently do the exact same thing */
785 #define cl_init_zero S_cl_init
787 /* 'AND' a given class with another one. Can create false positives. 'cl'
788 * should not be inverted. 'and_with->flags & ANYOF_CLASS' should be 0 if
789 * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
791 S_cl_and(struct regnode_charclass_class *cl,
792 const struct regnode_charclass_class *and_with)
794 PERL_ARGS_ASSERT_CL_AND;
796 assert(and_with->type == ANYOF);
798 /* I (khw) am not sure all these restrictions are necessary XXX */
799 if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
800 && !(ANYOF_CLASS_TEST_ANY_SET(cl))
801 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
802 && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
803 && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
806 if (and_with->flags & ANYOF_INVERT)
807 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
808 cl->bitmap[i] &= ~and_with->bitmap[i];
810 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
811 cl->bitmap[i] &= and_with->bitmap[i];
812 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
814 if (and_with->flags & ANYOF_INVERT) {
816 /* Here, the and'ed node is inverted. Get the AND of the flags that
817 * aren't affected by the inversion. Those that are affected are
818 * handled individually below */
819 U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
820 cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
821 cl->flags |= affected_flags;
823 /* We currently don't know how to deal with things that aren't in the
824 * bitmap, but we know that the intersection is no greater than what
825 * is already in cl, so let there be false positives that get sorted
826 * out after the synthetic start class succeeds, and the node is
827 * matched for real. */
829 /* The inversion of these two flags indicate that the resulting
830 * intersection doesn't have them */
831 if (and_with->flags & ANYOF_UNICODE_ALL) {
832 cl->flags &= ~ANYOF_UNICODE_ALL;
834 if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
835 cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
838 else { /* and'd node is not inverted */
839 U8 outside_bitmap_but_not_utf8; /* Temp variable */
841 if (! ANYOF_NONBITMAP(and_with)) {
843 /* Here 'and_with' doesn't match anything outside the bitmap
844 * (except possibly ANYOF_UNICODE_ALL), which means the
845 * intersection can't either, except for ANYOF_UNICODE_ALL, in
846 * which case we don't know what the intersection is, but it's no
847 * greater than what cl already has, so can just leave it alone,
848 * with possible false positives */
849 if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
850 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
851 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
854 else if (! ANYOF_NONBITMAP(cl)) {
856 /* Here, 'and_with' does match something outside the bitmap, and cl
857 * doesn't have a list of things to match outside the bitmap. If
858 * cl can match all code points above 255, the intersection will
859 * be those above-255 code points that 'and_with' matches. If cl
860 * can't match all Unicode code points, it means that it can't
861 * match anything outside the bitmap (since the 'if' that got us
862 * into this block tested for that), so we leave the bitmap empty.
864 if (cl->flags & ANYOF_UNICODE_ALL) {
865 ARG_SET(cl, ARG(and_with));
867 /* and_with's ARG may match things that don't require UTF8.
868 * And now cl's will too, in spite of this being an 'and'. See
869 * the comments below about the kludge */
870 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
874 /* Here, both 'and_with' and cl match something outside the
875 * bitmap. Currently we do not do the intersection, so just match
876 * whatever cl had at the beginning. */
880 /* Take the intersection of the two sets of flags. However, the
881 * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'. This is a
882 * kludge around the fact that this flag is not treated like the others
883 * which are initialized in cl_anything(). The way the optimizer works
884 * is that the synthetic start class (SSC) is initialized to match
885 * anything, and then the first time a real node is encountered, its
886 * values are AND'd with the SSC's with the result being the values of
887 * the real node. However, there are paths through the optimizer where
888 * the AND never gets called, so those initialized bits are set
889 * inappropriately, which is not usually a big deal, as they just cause
890 * false positives in the SSC, which will just mean a probably
891 * imperceptible slow down in execution. However this bit has a
892 * higher false positive consequence in that it can cause utf8.pm,
893 * utf8_heavy.pl ... to be loaded when not necessary, which is a much
894 * bigger slowdown and also causes significant extra memory to be used.
895 * In order to prevent this, the code now takes a different tack. The
896 * bit isn't set unless some part of the regular expression needs it,
897 * but once set it won't get cleared. This means that these extra
898 * modules won't get loaded unless there was some path through the
899 * pattern that would have required them anyway, and so any false
900 * positives that occur by not ANDing them out when they could be
901 * aren't as severe as they would be if we treated this bit like all
903 outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
904 & ANYOF_NONBITMAP_NON_UTF8;
905 cl->flags &= and_with->flags;
906 cl->flags |= outside_bitmap_but_not_utf8;
910 /* 'OR' a given class with another one. Can create false positives. 'cl'
911 * should not be inverted. 'or_with->flags & ANYOF_CLASS' should be 0 if
912 * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
914 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
916 PERL_ARGS_ASSERT_CL_OR;
918 if (or_with->flags & ANYOF_INVERT) {
920 /* Here, the or'd node is to be inverted. This means we take the
921 * complement of everything not in the bitmap, but currently we don't
922 * know what that is, so give up and match anything */
923 if (ANYOF_NONBITMAP(or_with)) {
924 cl_anything(pRExC_state, cl);
927 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
928 * <= (B1 | !B2) | (CL1 | !CL2)
929 * which is wasteful if CL2 is small, but we ignore CL2:
930 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
931 * XXXX Can we handle case-fold? Unclear:
932 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
933 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
935 else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
936 && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
937 && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
940 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
941 cl->bitmap[i] |= ~or_with->bitmap[i];
942 } /* XXXX: logic is complicated otherwise */
944 cl_anything(pRExC_state, cl);
947 /* And, we can just take the union of the flags that aren't affected
948 * by the inversion */
949 cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
951 /* For the remaining flags:
952 ANYOF_UNICODE_ALL and inverted means to not match anything above
953 255, which means that the union with cl should just be
954 what cl has in it, so can ignore this flag
955 ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
956 is 127-255 to match them, but then invert that, so the
957 union with cl should just be what cl has in it, so can
960 } else { /* 'or_with' is not inverted */
961 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
962 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
963 && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
964 || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
967 /* OR char bitmap and class bitmap separately */
968 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
969 cl->bitmap[i] |= or_with->bitmap[i];
970 if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
971 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
972 cl->classflags[i] |= or_with->classflags[i];
973 cl->flags |= ANYOF_CLASS;
976 else { /* XXXX: logic is complicated, leave it along for a moment. */
977 cl_anything(pRExC_state, cl);
980 if (ANYOF_NONBITMAP(or_with)) {
982 /* Use the added node's outside-the-bit-map match if there isn't a
983 * conflict. If there is a conflict (both nodes match something
984 * outside the bitmap, but what they match outside is not the same
985 * pointer, and hence not easily compared until XXX we extend
986 * inversion lists this far), give up and allow the start class to
987 * match everything outside the bitmap. If that stuff is all above
988 * 255, can just set UNICODE_ALL, otherwise caould be anything. */
989 if (! ANYOF_NONBITMAP(cl)) {
990 ARG_SET(cl, ARG(or_with));
992 else if (ARG(cl) != ARG(or_with)) {
994 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
995 cl_anything(pRExC_state, cl);
998 cl->flags |= ANYOF_UNICODE_ALL;
1003 /* Take the union */
1004 cl->flags |= or_with->flags;
1008 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1009 #define TRIE_LIST_CUR(state) ( TRIE_LIST_ITEM( state, 0 ).forid )
1010 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1011 #define TRIE_LIST_USED(idx) ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1016 dump_trie(trie,widecharmap,revcharmap)
1017 dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1018 dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1020 These routines dump out a trie in a somewhat readable format.
1021 The _interim_ variants are used for debugging the interim
1022 tables that are used to generate the final compressed
1023 representation which is what dump_trie expects.
1025 Part of the reason for their existence is to provide a form
1026 of documentation as to how the different representations function.
1031 Dumps the final compressed table form of the trie to Perl_debug_log.
1032 Used for debugging make_trie().
1036 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1037 AV *revcharmap, U32 depth)
1040 SV *sv=sv_newmortal();
1041 int colwidth= widecharmap ? 6 : 4;
1043 GET_RE_DEBUG_FLAGS_DECL;
1045 PERL_ARGS_ASSERT_DUMP_TRIE;
1047 PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1048 (int)depth * 2 + 2,"",
1049 "Match","Base","Ofs" );
1051 for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1052 SV ** const tmp = av_fetch( revcharmap, state, 0);
1054 PerlIO_printf( Perl_debug_log, "%*s",
1056 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1057 PL_colors[0], PL_colors[1],
1058 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1059 PERL_PV_ESCAPE_FIRSTCHAR
1064 PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1065 (int)depth * 2 + 2,"");
1067 for( state = 0 ; state < trie->uniquecharcount ; state++ )
1068 PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1069 PerlIO_printf( Perl_debug_log, "\n");
1071 for( state = 1 ; state < trie->statecount ; state++ ) {
1072 const U32 base = trie->states[ state ].trans.base;
1074 PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1076 if ( trie->states[ state ].wordnum ) {
1077 PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1079 PerlIO_printf( Perl_debug_log, "%6s", "" );
1082 PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1087 while( ( base + ofs < trie->uniquecharcount ) ||
1088 ( base + ofs - trie->uniquecharcount < trie->lasttrans
1089 && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1092 PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1094 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1095 if ( ( base + ofs >= trie->uniquecharcount ) &&
1096 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1097 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1099 PerlIO_printf( Perl_debug_log, "%*"UVXf,
1101 (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1103 PerlIO_printf( Perl_debug_log, "%*s",colwidth," ." );
1107 PerlIO_printf( Perl_debug_log, "]");
1110 PerlIO_printf( Perl_debug_log, "\n" );
1112 PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1113 for (word=1; word <= trie->wordcount; word++) {
1114 PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1115 (int)word, (int)(trie->wordinfo[word].prev),
1116 (int)(trie->wordinfo[word].len));
1118 PerlIO_printf(Perl_debug_log, "\n" );
1121 Dumps a fully constructed but uncompressed trie in list form.
1122 List tries normally only are used for construction when the number of
1123 possible chars (trie->uniquecharcount) is very high.
1124 Used for debugging make_trie().
1127 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1128 HV *widecharmap, AV *revcharmap, U32 next_alloc,
1132 SV *sv=sv_newmortal();
1133 int colwidth= widecharmap ? 6 : 4;
1134 GET_RE_DEBUG_FLAGS_DECL;
1136 PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1138 /* print out the table precompression. */
1139 PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1140 (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1141 "------:-----+-----------------\n" );
1143 for( state=1 ; state < next_alloc ; state ++ ) {
1146 PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1147 (int)depth * 2 + 2,"", (UV)state );
1148 if ( ! trie->states[ state ].wordnum ) {
1149 PerlIO_printf( Perl_debug_log, "%5s| ","");
1151 PerlIO_printf( Perl_debug_log, "W%4x| ",
1152 trie->states[ state ].wordnum
1155 for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1156 SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1158 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1160 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1161 PL_colors[0], PL_colors[1],
1162 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1163 PERL_PV_ESCAPE_FIRSTCHAR
1165 TRIE_LIST_ITEM(state,charid).forid,
1166 (UV)TRIE_LIST_ITEM(state,charid).newstate
1169 PerlIO_printf(Perl_debug_log, "\n%*s| ",
1170 (int)((depth * 2) + 14), "");
1173 PerlIO_printf( Perl_debug_log, "\n");
1178 Dumps a fully constructed but uncompressed trie in table form.
1179 This is the normal DFA style state transition table, with a few
1180 twists to facilitate compression later.
1181 Used for debugging make_trie().
1184 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1185 HV *widecharmap, AV *revcharmap, U32 next_alloc,
1190 SV *sv=sv_newmortal();
1191 int colwidth= widecharmap ? 6 : 4;
1192 GET_RE_DEBUG_FLAGS_DECL;
1194 PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1197 print out the table precompression so that we can do a visual check
1198 that they are identical.
1201 PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1203 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1204 SV ** const tmp = av_fetch( revcharmap, charid, 0);
1206 PerlIO_printf( Perl_debug_log, "%*s",
1208 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1209 PL_colors[0], PL_colors[1],
1210 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1211 PERL_PV_ESCAPE_FIRSTCHAR
1217 PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1219 for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1220 PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1223 PerlIO_printf( Perl_debug_log, "\n" );
1225 for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1227 PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
1228 (int)depth * 2 + 2,"",
1229 (UV)TRIE_NODENUM( state ) );
1231 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1232 UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1234 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1236 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1238 if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1239 PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1241 PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1242 trie->states[ TRIE_NODENUM( state ) ].wordnum );
1250 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1251 startbranch: the first branch in the whole branch sequence
1252 first : start branch of sequence of branch-exact nodes.
1253 May be the same as startbranch
1254 last : Thing following the last branch.
1255 May be the same as tail.
1256 tail : item following the branch sequence
1257 count : words in the sequence
1258 flags : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1259 depth : indent depth
1261 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1263 A trie is an N'ary tree where the branches are determined by digital
1264 decomposition of the key. IE, at the root node you look up the 1st character and
1265 follow that branch repeat until you find the end of the branches. Nodes can be
1266 marked as "accepting" meaning they represent a complete word. Eg:
1270 would convert into the following structure. Numbers represent states, letters
1271 following numbers represent valid transitions on the letter from that state, if
1272 the number is in square brackets it represents an accepting state, otherwise it
1273 will be in parenthesis.
1275 +-h->+-e->[3]-+-r->(8)-+-s->[9]
1279 (1) +-i->(6)-+-s->[7]
1281 +-s->(3)-+-h->(4)-+-e->[5]
1283 Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1285 This shows that when matching against the string 'hers' we will begin at state 1
1286 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1287 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1288 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1289 single traverse. We store a mapping from accepting to state to which word was
1290 matched, and then when we have multiple possibilities we try to complete the
1291 rest of the regex in the order in which they occured in the alternation.
1293 The only prior NFA like behaviour that would be changed by the TRIE support is
1294 the silent ignoring of duplicate alternations which are of the form:
1296 / (DUPE|DUPE) X? (?{ ... }) Y /x
1298 Thus EVAL blocks following a trie may be called a different number of times with
1299 and without the optimisation. With the optimisations dupes will be silently
1300 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1301 the following demonstrates:
1303 'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1305 which prints out 'word' three times, but
1307 'words'=~/(word|word|word)(?{ print $1 })S/
1309 which doesnt print it out at all. This is due to other optimisations kicking in.
1311 Example of what happens on a structural level:
1313 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1315 1: CURLYM[1] {1,32767}(18)
1326 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1327 and should turn into:
1329 1: CURLYM[1] {1,32767}(18)
1331 [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1339 Cases where tail != last would be like /(?foo|bar)baz/:
1349 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1350 and would end up looking like:
1353 [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1360 d = uvuni_to_utf8_flags(d, uv, 0);
1362 is the recommended Unicode-aware way of saying
1367 #define TRIE_STORE_REVCHAR \
1370 SV *zlopp = newSV(2); \
1371 unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \
1372 unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, uvc & 0xFF); \
1373 SvCUR_set(zlopp, kapow - flrbbbbb); \
1376 av_push(revcharmap, zlopp); \
1378 char ooooff = (char)uvc; \
1379 av_push(revcharmap, newSVpvn(&ooooff, 1)); \
1383 #define TRIE_READ_CHAR STMT_START { \
1387 if ( foldlen > 0 ) { \
1388 uvc = utf8n_to_uvuni( scan, UTF8_MAXLEN, &len, uniflags ); \
1393 len = UTF8SKIP(uc);\
1394 uvc = to_utf8_fold( uc, foldbuf, &foldlen); \
1395 foldlen -= UNISKIP( uvc ); \
1396 scan = foldbuf + UNISKIP( uvc ); \
1399 uvc = utf8n_to_uvuni( (const U8*)uc, UTF8_MAXLEN, &len, uniflags);\
1409 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \
1410 if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \
1411 U32 ging = TRIE_LIST_LEN( state ) *= 2; \
1412 Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1414 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \
1415 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns; \
1416 TRIE_LIST_CUR( state )++; \
1419 #define TRIE_LIST_NEW(state) STMT_START { \
1420 Newxz( trie->states[ state ].trans.list, \
1421 4, reg_trie_trans_le ); \
1422 TRIE_LIST_CUR( state ) = 1; \
1423 TRIE_LIST_LEN( state ) = 4; \
1426 #define TRIE_HANDLE_WORD(state) STMT_START { \
1427 U16 dupe= trie->states[ state ].wordnum; \
1428 regnode * const noper_next = regnext( noper ); \
1431 /* store the word for dumping */ \
1433 if (OP(noper) != NOTHING) \
1434 tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF); \
1436 tmp = newSVpvn_utf8( "", 0, UTF ); \
1437 av_push( trie_words, tmp ); \
1441 trie->wordinfo[curword].prev = 0; \
1442 trie->wordinfo[curword].len = wordlen; \
1443 trie->wordinfo[curword].accept = state; \
1445 if ( noper_next < tail ) { \
1447 trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1448 trie->jump[curword] = (U16)(noper_next - convert); \
1450 jumper = noper_next; \
1452 nextbranch= regnext(cur); \
1456 /* It's a dupe. Pre-insert into the wordinfo[].prev */\
1457 /* chain, so that when the bits of chain are later */\
1458 /* linked together, the dups appear in the chain */\
1459 trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1460 trie->wordinfo[dupe].prev = curword; \
1462 /* we haven't inserted this word yet. */ \
1463 trie->states[ state ].wordnum = curword; \
1468 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special) \
1469 ( ( base + charid >= ucharcount \
1470 && base + charid < ubound \
1471 && state == trie->trans[ base - ucharcount + charid ].check \
1472 && trie->trans[ base - ucharcount + charid ].next ) \
1473 ? trie->trans[ base - ucharcount + charid ].next \
1474 : ( state==1 ? special : 0 ) \
1478 #define MADE_JUMP_TRIE 2
1479 #define MADE_EXACT_TRIE 4
1482 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1485 /* first pass, loop through and scan words */
1486 reg_trie_data *trie;
1487 HV *widecharmap = NULL;
1488 AV *revcharmap = newAV();
1490 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1495 regnode *jumper = NULL;
1496 regnode *nextbranch = NULL;
1497 regnode *convert = NULL;
1498 U32 *prev_states; /* temp array mapping each state to previous one */
1499 /* we just use folder as a flag in utf8 */
1500 const U8 * folder = NULL;
1503 const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1504 AV *trie_words = NULL;
1505 /* along with revcharmap, this only used during construction but both are
1506 * useful during debugging so we store them in the struct when debugging.
1509 const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1510 STRLEN trie_charcount=0;
1512 SV *re_trie_maxbuff;
1513 GET_RE_DEBUG_FLAGS_DECL;
1515 PERL_ARGS_ASSERT_MAKE_TRIE;
1517 PERL_UNUSED_ARG(depth);
1523 case EXACTFU: folder = PL_fold_latin1; break;
1524 case EXACTF: folder = PL_fold; break;
1525 case EXACTFL: folder = PL_fold_locale; break;
1526 default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u", (unsigned) flags );
1529 trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1531 trie->startstate = 1;
1532 trie->wordcount = word_count;
1533 RExC_rxi->data->data[ data_slot ] = (void*)trie;
1534 trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1535 if (!(UTF && folder))
1536 trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1537 trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1538 trie->wordcount+1, sizeof(reg_trie_wordinfo));
1541 trie_words = newAV();
1544 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1545 if (!SvIOK(re_trie_maxbuff)) {
1546 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1549 PerlIO_printf( Perl_debug_log,
1550 "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1551 (int)depth * 2 + 2, "",
1552 REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
1553 REG_NODE_NUM(last), REG_NODE_NUM(tail),
1557 /* Find the node we are going to overwrite */
1558 if ( first == startbranch && OP( last ) != BRANCH ) {
1559 /* whole branch chain */
1562 /* branch sub-chain */
1563 convert = NEXTOPER( first );
1566 /* -- First loop and Setup --
1568 We first traverse the branches and scan each word to determine if it
1569 contains widechars, and how many unique chars there are, this is
1570 important as we have to build a table with at least as many columns as we
1573 We use an array of integers to represent the character codes 0..255
1574 (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1575 native representation of the character value as the key and IV's for the
1578 *TODO* If we keep track of how many times each character is used we can
1579 remap the columns so that the table compression later on is more
1580 efficient in terms of memory by ensuring the most common value is in the
1581 middle and the least common are on the outside. IMO this would be better
1582 than a most to least common mapping as theres a decent chance the most
1583 common letter will share a node with the least common, meaning the node
1584 will not be compressible. With a middle is most common approach the worst
1585 case is when we have the least common nodes twice.
1589 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1590 regnode * const noper = NEXTOPER( cur );
1591 const U8 *uc = (U8*)STRING( noper );
1592 const U8 * const e = uc + STR_LEN( noper );
1594 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1595 const U8 *scan = (U8*)NULL;
1596 U32 wordlen = 0; /* required init */
1598 bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1600 if (OP(noper) == NOTHING) {
1604 if ( set_bit ) /* bitmap only alloced when !(UTF&&Folding) */
1605 TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1606 regardless of encoding */
1608 for ( ; uc < e ; uc += len ) {
1609 TRIE_CHARCOUNT(trie)++;
1613 if ( !trie->charmap[ uvc ] ) {
1614 trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1616 trie->charmap[ folder[ uvc ] ] = trie->charmap[ uvc ];
1620 /* store the codepoint in the bitmap, and its folded
1622 TRIE_BITMAP_SET(trie,uvc);
1624 /* store the folded codepoint */
1625 if ( folder ) TRIE_BITMAP_SET(trie,folder[ uvc ]);
1628 /* store first byte of utf8 representation of
1629 variant codepoints */
1630 if (! UNI_IS_INVARIANT(uvc)) {
1631 TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1634 set_bit = 0; /* We've done our bit :-) */
1639 widecharmap = newHV();
1641 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1644 Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1646 if ( !SvTRUE( *svpp ) ) {
1647 sv_setiv( *svpp, ++trie->uniquecharcount );
1652 if( cur == first ) {
1655 } else if (chars < trie->minlen) {
1657 } else if (chars > trie->maxlen) {
1661 } /* end first pass */
1662 DEBUG_TRIE_COMPILE_r(
1663 PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1664 (int)depth * 2 + 2,"",
1665 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1666 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1667 (int)trie->minlen, (int)trie->maxlen )
1671 We now know what we are dealing with in terms of unique chars and
1672 string sizes so we can calculate how much memory a naive
1673 representation using a flat table will take. If it's over a reasonable
1674 limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1675 conservative but potentially much slower representation using an array
1678 At the end we convert both representations into the same compressed
1679 form that will be used in regexec.c for matching with. The latter
1680 is a form that cannot be used to construct with but has memory
1681 properties similar to the list form and access properties similar
1682 to the table form making it both suitable for fast searches and
1683 small enough that its feasable to store for the duration of a program.
1685 See the comment in the code where the compressed table is produced
1686 inplace from the flat tabe representation for an explanation of how
1687 the compression works.
1692 Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1695 if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1697 Second Pass -- Array Of Lists Representation
1699 Each state will be represented by a list of charid:state records
1700 (reg_trie_trans_le) the first such element holds the CUR and LEN
1701 points of the allocated array. (See defines above).
1703 We build the initial structure using the lists, and then convert
1704 it into the compressed table form which allows faster lookups
1705 (but cant be modified once converted).
1708 STRLEN transcount = 1;
1710 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1711 "%*sCompiling trie using list compiler\n",
1712 (int)depth * 2 + 2, ""));
1714 trie->states = (reg_trie_state *)
1715 PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1716 sizeof(reg_trie_state) );
1720 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1722 regnode * const noper = NEXTOPER( cur );
1723 U8 *uc = (U8*)STRING( noper );
1724 const U8 * const e = uc + STR_LEN( noper );
1725 U32 state = 1; /* required init */
1726 U16 charid = 0; /* sanity init */
1727 U8 *scan = (U8*)NULL; /* sanity init */
1728 STRLEN foldlen = 0; /* required init */
1729 U32 wordlen = 0; /* required init */
1730 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1732 if (OP(noper) != NOTHING) {
1733 for ( ; uc < e ; uc += len ) {
1738 charid = trie->charmap[ uvc ];
1740 SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1744 charid=(U16)SvIV( *svpp );
1747 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1754 if ( !trie->states[ state ].trans.list ) {
1755 TRIE_LIST_NEW( state );
1757 for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1758 if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1759 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1764 newstate = next_alloc++;
1765 prev_states[newstate] = state;
1766 TRIE_LIST_PUSH( state, charid, newstate );
1771 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1775 TRIE_HANDLE_WORD(state);
1777 } /* end second pass */
1779 /* next alloc is the NEXT state to be allocated */
1780 trie->statecount = next_alloc;
1781 trie->states = (reg_trie_state *)
1782 PerlMemShared_realloc( trie->states,
1784 * sizeof(reg_trie_state) );
1786 /* and now dump it out before we compress it */
1787 DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1788 revcharmap, next_alloc,
1792 trie->trans = (reg_trie_trans *)
1793 PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1800 for( state=1 ; state < next_alloc ; state ++ ) {
1804 DEBUG_TRIE_COMPILE_MORE_r(
1805 PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1809 if (trie->states[state].trans.list) {
1810 U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1814 for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1815 const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1816 if ( forid < minid ) {
1818 } else if ( forid > maxid ) {
1822 if ( transcount < tp + maxid - minid + 1) {
1824 trie->trans = (reg_trie_trans *)
1825 PerlMemShared_realloc( trie->trans,
1827 * sizeof(reg_trie_trans) );
1828 Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1830 base = trie->uniquecharcount + tp - minid;
1831 if ( maxid == minid ) {
1833 for ( ; zp < tp ; zp++ ) {
1834 if ( ! trie->trans[ zp ].next ) {
1835 base = trie->uniquecharcount + zp - minid;
1836 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1837 trie->trans[ zp ].check = state;
1843 trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1844 trie->trans[ tp ].check = state;
1849 for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1850 const U32 tid = base - trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1851 trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1852 trie->trans[ tid ].check = state;
1854 tp += ( maxid - minid + 1 );
1856 Safefree(trie->states[ state ].trans.list);
1859 DEBUG_TRIE_COMPILE_MORE_r(
1860 PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1863 trie->states[ state ].trans.base=base;
1865 trie->lasttrans = tp + 1;
1869 Second Pass -- Flat Table Representation.
1871 we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1872 We know that we will need Charcount+1 trans at most to store the data
1873 (one row per char at worst case) So we preallocate both structures
1874 assuming worst case.
1876 We then construct the trie using only the .next slots of the entry
1879 We use the .check field of the first entry of the node temporarily to
1880 make compression both faster and easier by keeping track of how many non
1881 zero fields are in the node.
1883 Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1886 There are two terms at use here: state as a TRIE_NODEIDX() which is a
1887 number representing the first entry of the node, and state as a
1888 TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1889 TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1890 are 2 entrys per node. eg:
1898 The table is internally in the right hand, idx form. However as we also
1899 have to deal with the states array which is indexed by nodenum we have to
1900 use TRIE_NODENUM() to convert.
1903 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1904 "%*sCompiling trie using table compiler\n",
1905 (int)depth * 2 + 2, ""));
1907 trie->trans = (reg_trie_trans *)
1908 PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1909 * trie->uniquecharcount + 1,
1910 sizeof(reg_trie_trans) );
1911 trie->states = (reg_trie_state *)
1912 PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1913 sizeof(reg_trie_state) );
1914 next_alloc = trie->uniquecharcount + 1;
1917 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1919 regnode * const noper = NEXTOPER( cur );
1920 const U8 *uc = (U8*)STRING( noper );
1921 const U8 * const e = uc + STR_LEN( noper );
1923 U32 state = 1; /* required init */
1925 U16 charid = 0; /* sanity init */
1926 U32 accept_state = 0; /* sanity init */
1927 U8 *scan = (U8*)NULL; /* sanity init */
1929 STRLEN foldlen = 0; /* required init */
1930 U32 wordlen = 0; /* required init */
1931 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1933 if ( OP(noper) != NOTHING ) {
1934 for ( ; uc < e ; uc += len ) {
1939 charid = trie->charmap[ uvc ];
1941 SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1942 charid = svpp ? (U16)SvIV(*svpp) : 0;
1946 if ( !trie->trans[ state + charid ].next ) {
1947 trie->trans[ state + charid ].next = next_alloc;
1948 trie->trans[ state ].check++;
1949 prev_states[TRIE_NODENUM(next_alloc)]
1950 = TRIE_NODENUM(state);
1951 next_alloc += trie->uniquecharcount;
1953 state = trie->trans[ state + charid ].next;
1955 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1957 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1960 accept_state = TRIE_NODENUM( state );
1961 TRIE_HANDLE_WORD(accept_state);
1963 } /* end second pass */
1965 /* and now dump it out before we compress it */
1966 DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1968 next_alloc, depth+1));
1972 * Inplace compress the table.*
1974 For sparse data sets the table constructed by the trie algorithm will
1975 be mostly 0/FAIL transitions or to put it another way mostly empty.
1976 (Note that leaf nodes will not contain any transitions.)
1978 This algorithm compresses the tables by eliminating most such
1979 transitions, at the cost of a modest bit of extra work during lookup:
1981 - Each states[] entry contains a .base field which indicates the
1982 index in the state[] array wheres its transition data is stored.
1984 - If .base is 0 there are no valid transitions from that node.
1986 - If .base is nonzero then charid is added to it to find an entry in
1989 -If trans[states[state].base+charid].check!=state then the
1990 transition is taken to be a 0/Fail transition. Thus if there are fail
1991 transitions at the front of the node then the .base offset will point
1992 somewhere inside the previous nodes data (or maybe even into a node
1993 even earlier), but the .check field determines if the transition is
1997 The following process inplace converts the table to the compressed
1998 table: We first do not compress the root node 1,and mark all its
1999 .check pointers as 1 and set its .base pointer as 1 as well. This
2000 allows us to do a DFA construction from the compressed table later,
2001 and ensures that any .base pointers we calculate later are greater
2004 - We set 'pos' to indicate the first entry of the second node.
2006 - We then iterate over the columns of the node, finding the first and
2007 last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2008 and set the .check pointers accordingly, and advance pos
2009 appropriately and repreat for the next node. Note that when we copy
2010 the next pointers we have to convert them from the original
2011 NODEIDX form to NODENUM form as the former is not valid post
2014 - If a node has no transitions used we mark its base as 0 and do not
2015 advance the pos pointer.
2017 - If a node only has one transition we use a second pointer into the
2018 structure to fill in allocated fail transitions from other states.
2019 This pointer is independent of the main pointer and scans forward
2020 looking for null transitions that are allocated to a state. When it
2021 finds one it writes the single transition into the "hole". If the
2022 pointer doesnt find one the single transition is appended as normal.
2024 - Once compressed we can Renew/realloc the structures to release the
2027 See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2028 specifically Fig 3.47 and the associated pseudocode.
2032 const U32 laststate = TRIE_NODENUM( next_alloc );
2035 trie->statecount = laststate;
2037 for ( state = 1 ; state < laststate ; state++ ) {
2039 const U32 stateidx = TRIE_NODEIDX( state );
2040 const U32 o_used = trie->trans[ stateidx ].check;
2041 U32 used = trie->trans[ stateidx ].check;
2042 trie->trans[ stateidx ].check = 0;
2044 for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2045 if ( flag || trie->trans[ stateidx + charid ].next ) {
2046 if ( trie->trans[ stateidx + charid ].next ) {
2048 for ( ; zp < pos ; zp++ ) {
2049 if ( ! trie->trans[ zp ].next ) {
2053 trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2054 trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2055 trie->trans[ zp ].check = state;
2056 if ( ++zp > pos ) pos = zp;
2063 trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2065 trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2066 trie->trans[ pos ].check = state;
2071 trie->lasttrans = pos + 1;
2072 trie->states = (reg_trie_state *)
2073 PerlMemShared_realloc( trie->states, laststate
2074 * sizeof(reg_trie_state) );
2075 DEBUG_TRIE_COMPILE_MORE_r(
2076 PerlIO_printf( Perl_debug_log,
2077 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2078 (int)depth * 2 + 2,"",
2079 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2082 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2085 } /* end table compress */
2087 DEBUG_TRIE_COMPILE_MORE_r(
2088 PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2089 (int)depth * 2 + 2, "",
2090 (UV)trie->statecount,
2091 (UV)trie->lasttrans)
2093 /* resize the trans array to remove unused space */
2094 trie->trans = (reg_trie_trans *)
2095 PerlMemShared_realloc( trie->trans, trie->lasttrans
2096 * sizeof(reg_trie_trans) );
2098 { /* Modify the program and insert the new TRIE node */
2099 U8 nodetype =(U8)(flags & 0xFF);
2103 regnode *optimize = NULL;
2104 #ifdef RE_TRACK_PATTERN_OFFSETS
2107 U32 mjd_nodelen = 0;
2108 #endif /* RE_TRACK_PATTERN_OFFSETS */
2109 #endif /* DEBUGGING */
2111 This means we convert either the first branch or the first Exact,
2112 depending on whether the thing following (in 'last') is a branch
2113 or not and whther first is the startbranch (ie is it a sub part of
2114 the alternation or is it the whole thing.)
2115 Assuming its a sub part we convert the EXACT otherwise we convert
2116 the whole branch sequence, including the first.
2118 /* Find the node we are going to overwrite */
2119 if ( first != startbranch || OP( last ) == BRANCH ) {
2120 /* branch sub-chain */
2121 NEXT_OFF( first ) = (U16)(last - first);
2122 #ifdef RE_TRACK_PATTERN_OFFSETS
2124 mjd_offset= Node_Offset((convert));
2125 mjd_nodelen= Node_Length((convert));
2128 /* whole branch chain */
2130 #ifdef RE_TRACK_PATTERN_OFFSETS
2133 const regnode *nop = NEXTOPER( convert );
2134 mjd_offset= Node_Offset((nop));
2135 mjd_nodelen= Node_Length((nop));
2139 PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2140 (int)depth * 2 + 2, "",
2141 (UV)mjd_offset, (UV)mjd_nodelen)
2144 /* But first we check to see if there is a common prefix we can
2145 split out as an EXACT and put in front of the TRIE node. */
2146 trie->startstate= 1;
2147 if ( trie->bitmap && !widecharmap && !trie->jump ) {
2149 for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2153 const U32 base = trie->states[ state ].trans.base;
2155 if ( trie->states[state].wordnum )
2158 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2159 if ( ( base + ofs >= trie->uniquecharcount ) &&
2160 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2161 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2163 if ( ++count > 1 ) {
2164 SV **tmp = av_fetch( revcharmap, ofs, 0);
2165 const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2166 if ( state == 1 ) break;
2168 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2170 PerlIO_printf(Perl_debug_log,
2171 "%*sNew Start State=%"UVuf" Class: [",
2172 (int)depth * 2 + 2, "",
2175 SV ** const tmp = av_fetch( revcharmap, idx, 0);
2176 const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2178 TRIE_BITMAP_SET(trie,*ch);
2180 TRIE_BITMAP_SET(trie, folder[ *ch ]);
2182 PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2186 TRIE_BITMAP_SET(trie,*ch);
2188 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2189 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2195 SV **tmp = av_fetch( revcharmap, idx, 0);
2197 char *ch = SvPV( *tmp, len );
2199 SV *sv=sv_newmortal();
2200 PerlIO_printf( Perl_debug_log,
2201 "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2202 (int)depth * 2 + 2, "",
2204 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
2205 PL_colors[0], PL_colors[1],
2206 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2207 PERL_PV_ESCAPE_FIRSTCHAR
2212 OP( convert ) = nodetype;
2213 str=STRING(convert);
2216 STR_LEN(convert) += len;
2222 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2227 trie->prefixlen = (state-1);
2229 regnode *n = convert+NODE_SZ_STR(convert);
2230 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2231 trie->startstate = state;
2232 trie->minlen -= (state - 1);
2233 trie->maxlen -= (state - 1);
2235 /* At least the UNICOS C compiler choked on this
2236 * being argument to DEBUG_r(), so let's just have
2239 #ifdef PERL_EXT_RE_BUILD
2245 regnode *fix = convert;
2246 U32 word = trie->wordcount;
2248 Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2249 while( ++fix < n ) {
2250 Set_Node_Offset_Length(fix, 0, 0);
2253 SV ** const tmp = av_fetch( trie_words, word, 0 );
2255 if ( STR_LEN(convert) <= SvCUR(*tmp) )
2256 sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2258 sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2266 NEXT_OFF(convert) = (U16)(tail - convert);
2267 DEBUG_r(optimize= n);
2273 if ( trie->maxlen ) {
2274 NEXT_OFF( convert ) = (U16)(tail - convert);
2275 ARG_SET( convert, data_slot );
2276 /* Store the offset to the first unabsorbed branch in
2277 jump[0], which is otherwise unused by the jump logic.
2278 We use this when dumping a trie and during optimisation. */
2280 trie->jump[0] = (U16)(nextbranch - convert);
2282 /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2283 * and there is a bitmap
2284 * and the first "jump target" node we found leaves enough room
2285 * then convert the TRIE node into a TRIEC node, with the bitmap
2286 * embedded inline in the opcode - this is hypothetically faster.
2288 if ( !trie->states[trie->startstate].wordnum
2290 && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2292 OP( convert ) = TRIEC;
2293 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2294 PerlMemShared_free(trie->bitmap);
2297 OP( convert ) = TRIE;
2299 /* store the type in the flags */
2300 convert->flags = nodetype;
2304 + regarglen[ OP( convert ) ];
2306 /* XXX We really should free up the resource in trie now,
2307 as we won't use them - (which resources?) dmq */
2309 /* needed for dumping*/
2310 DEBUG_r(if (optimize) {
2311 regnode *opt = convert;
2313 while ( ++opt < optimize) {
2314 Set_Node_Offset_Length(opt,0,0);
2317 Try to clean up some of the debris left after the
2320 while( optimize < jumper ) {
2321 mjd_nodelen += Node_Length((optimize));
2322 OP( optimize ) = OPTIMIZED;
2323 Set_Node_Offset_Length(optimize,0,0);
2326 Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2328 } /* end node insert */
2330 /* Finish populating the prev field of the wordinfo array. Walk back
2331 * from each accept state until we find another accept state, and if
2332 * so, point the first word's .prev field at the second word. If the
2333 * second already has a .prev field set, stop now. This will be the
2334 * case either if we've already processed that word's accept state,
2335 * or that state had multiple words, and the overspill words were
2336 * already linked up earlier.
2343 for (word=1; word <= trie->wordcount; word++) {
2345 if (trie->wordinfo[word].prev)
2347 state = trie->wordinfo[word].accept;
2349 state = prev_states[state];
2352 prev = trie->states[state].wordnum;
2356 trie->wordinfo[word].prev = prev;
2358 Safefree(prev_states);
2362 /* and now dump out the compressed format */
2363 DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2365 RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2367 RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2368 RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2370 SvREFCNT_dec(revcharmap);
2374 : trie->startstate>1
2380 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
2382 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2384 This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2385 "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2388 We find the fail state for each state in the trie, this state is the longest proper
2389 suffix of the current state's 'word' that is also a proper prefix of another word in our
2390 trie. State 1 represents the word '' and is thus the default fail state. This allows
2391 the DFA not to have to restart after its tried and failed a word at a given point, it
2392 simply continues as though it had been matching the other word in the first place.
2394 'abcdgu'=~/abcdefg|cdgu/
2395 When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2396 fail, which would bring us to the state representing 'd' in the second word where we would
2397 try 'g' and succeed, proceeding to match 'cdgu'.
2399 /* add a fail transition */
2400 const U32 trie_offset = ARG(source);
2401 reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2403 const U32 ucharcount = trie->uniquecharcount;
2404 const U32 numstates = trie->statecount;
2405 const U32 ubound = trie->lasttrans + ucharcount;
2409 U32 base = trie->states[ 1 ].trans.base;
2412 const U32 data_slot = add_data( pRExC_state, 1, "T" );
2413 GET_RE_DEBUG_FLAGS_DECL;
2415 PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2417 PERL_UNUSED_ARG(depth);
2421 ARG_SET( stclass, data_slot );
2422 aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2423 RExC_rxi->data->data[ data_slot ] = (void*)aho;
2424 aho->trie=trie_offset;
2425 aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2426 Copy( trie->states, aho->states, numstates, reg_trie_state );
2427 Newxz( q, numstates, U32);
2428 aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2431 /* initialize fail[0..1] to be 1 so that we always have
2432 a valid final fail state */
2433 fail[ 0 ] = fail[ 1 ] = 1;
2435 for ( charid = 0; charid < ucharcount ; charid++ ) {
2436 const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2438 q[ q_write ] = newstate;
2439 /* set to point at the root */
2440 fail[ q[ q_write++ ] ]=1;
2443 while ( q_read < q_write) {
2444 const U32 cur = q[ q_read++ % numstates ];
2445 base = trie->states[ cur ].trans.base;
2447 for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2448 const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2450 U32 fail_state = cur;
2453 fail_state = fail[ fail_state ];
2454 fail_base = aho->states[ fail_state ].trans.base;
2455 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2457 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2458 fail[ ch_state ] = fail_state;
2459 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2461 aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
2463 q[ q_write++ % numstates] = ch_state;
2467 /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2468 when we fail in state 1, this allows us to use the
2469 charclass scan to find a valid start char. This is based on the principle
2470 that theres a good chance the string being searched contains lots of stuff
2471 that cant be a start char.
2473 fail[ 0 ] = fail[ 1 ] = 0;
2474 DEBUG_TRIE_COMPILE_r({
2475 PerlIO_printf(Perl_debug_log,
2476 "%*sStclass Failtable (%"UVuf" states): 0",
2477 (int)(depth * 2), "", (UV)numstates
2479 for( q_read=1; q_read<numstates; q_read++ ) {
2480 PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2482 PerlIO_printf(Perl_debug_log, "\n");
2485 /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2490 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2491 * These need to be revisited when a newer toolchain becomes available.
2493 #if defined(__sparc64__) && defined(__GNUC__)
2494 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2495 # undef SPARC64_GCC_WORKAROUND
2496 # define SPARC64_GCC_WORKAROUND 1
2500 #define DEBUG_PEEP(str,scan,depth) \
2501 DEBUG_OPTIMISE_r({if (scan){ \
2502 SV * const mysv=sv_newmortal(); \
2503 regnode *Next = regnext(scan); \
2504 regprop(RExC_rx, mysv, scan); \
2505 PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2506 (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2507 Next ? (REG_NODE_NUM(Next)) : 0 ); \
2511 /* The below joins as many adjacent EXACTish nodes as possible into a single
2512 * one, and looks for problematic sequences of characters whose folds vs.
2513 * non-folds have sufficiently different lengths, that the optimizer would be
2514 * fooled into rejecting legitimate matches of them, and the trie construction
2515 * code can't cope with them. The joining is only done if:
2516 * 1) there is room in the current conglomerated node to entirely contain the
2518 * 2) they are the exact same node type
2520 * The adjacent nodes actually may be separated by NOTHING kind nodes, and
2521 * these get optimized out
2523 * If there are problematic code sequences, *min_subtract is set to the delta
2524 * that the minimum size of the node can be less than its actual size. And,
2525 * the node type of the result is changed to reflect that it contains these
2528 * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2529 * and contains LATIN SMALL LETTER SHARP S
2531 * This is as good a place as any to discuss the design of handling these
2532 * problematic sequences. It's been wrong in Perl for a very long time. There
2533 * are three code points in Unicode whose folded lengths differ so much from
2534 * the un-folded lengths that it causes problems for the optimizer and trie
2535 * construction. Why only these are problematic, and not others where lengths
2536 * also differ is something I (khw) do not understand. New versions of Unicode
2537 * might add more such code points. Hopefully the logic in fold_grind.t that
2538 * figures out what to test (in part by verifying that each size-combination
2539 * gets tested) will catch any that do come along, so they can be added to the
2540 * special handling below. The chances of new ones are actually rather small,
2541 * as most, if not all, of the world's scripts that have casefolding have
2542 * already been encoded by Unicode. Also, a number of Unicode's decisions were
2543 * made to allow compatibility with pre-existing standards, and almost all of
2544 * those have already been dealt with. These would otherwise be the most
2545 * likely candidates for generating further tricky sequences. In other words,
2546 * Unicode by itself is unlikely to add new ones unless it is for compatibility
2547 * with pre-existing standards, and there aren't many of those left.
2549 * The previous designs for dealing with these involved assigning a special
2550 * node for them. This approach doesn't work, as evidenced by this example:
2551 * "\xDFs" =~ /s\xDF/ui # Used to fail before these patches
2552 * Both these fold to "sss", but if the pattern is parsed to create a node of
2553 * that would match just the \xDF, it won't be able to handle the case where a
2554 * successful match would have to cross the node's boundary. The new approach
2555 * that hopefully generally solves the problem generates an EXACTFU_SS node
2558 * There are a number of components to the approach (a lot of work for just
2559 * three code points!):
2560 * 1) This routine examines each EXACTFish node that could contain the
2561 * problematic sequences. It returns in *min_subtract how much to
2562 * subtract from the the actual length of the string to get a real minimum
2563 * for one that could match it. This number is usually 0 except for the
2564 * problematic sequences. This delta is used by the caller to adjust the
2565 * min length of the match, and the delta between min and max, so that the
2566 * optimizer doesn't reject these possibilities based on size constraints.
2567 * 2) These sequences are not currently correctly handled by the trie code
2568 * either, so it changes the joined node type to ops that are not handled
2569 * by trie's, those new ops being EXACTFU_SS and EXACTFU_NO_TRIE.
2570 * 3) This is sufficient for the two Greek sequences (described below), but
2571 * the one involving the Sharp s (\xDF) needs more. The node type
2572 * EXACTFU_SS is used for an EXACTFU node that contains at least one "ss"
2573 * sequence in it. For non-UTF-8 patterns and strings, this is the only
2574 * case where there is a possible fold length change. That means that a
2575 * regular EXACTFU node without UTF-8 involvement doesn't have to concern
2576 * itself with length changes, and so can be processed faster. regexec.c
2577 * takes advantage of this. Generally, an EXACTFish node that is in UTF-8
2578 * is pre-folded by regcomp.c. This saves effort in regex matching.
2579 * However, probably mostly for historical reasons, the pre-folding isn't
2580 * done for non-UTF8 patterns (and it can't be for EXACTF and EXACTFL
2581 * nodes, as what they fold to isn't known until runtime.) The fold
2582 * possibilities for the non-UTF8 patterns are quite simple, except for
2583 * the sharp s. All the ones that don't involve a UTF-8 target string
2584 * are members of a fold-pair, and arrays are set up for all of them
2585 * that quickly find the other member of the pair. It might actually
2586 * be faster to pre-fold these, but it isn't currently done, except for
2587 * the sharp s. Code elsewhere in this file makes sure that it gets
2588 * folded to 'ss', even if the pattern isn't UTF-8. This avoids the
2589 * issues described in the next item.
2590 * 4) A problem remains for the sharp s in EXACTF nodes. Whether it matches
2591 * 'ss' or not is not knowable at compile time. It will match iff the
2592 * target string is in UTF-8, unlike the EXACTFU nodes, where it always
2593 * matches; and the EXACTFL and EXACTFA nodes where it never does. Thus
2594 * it can't be folded to "ss" at compile time, unlike EXACTFU does as
2595 * described in item 3). An assumption that the optimizer part of
2596 * regexec.c (probably unwittingly) makes is that a character in the
2597 * pattern corresponds to at most a single character in the target string.
2598 * (And I do mean character, and not byte here, unlike other parts of the
2599 * documentation that have never been updated to account for multibyte
2600 * Unicode.) This assumption is wrong only in this case, as all other
2601 * cases are either 1-1 folds when no UTF-8 is involved; or is true by
2602 * virtue of having this file pre-fold UTF-8 patterns. I'm
2603 * reluctant to try to change this assumption, so instead the code punts.
2604 * This routine examines EXACTF nodes for the sharp s, and returns a
2605 * boolean indicating whether or not the node is an EXACTF node that
2606 * contains a sharp s. When it is true, the caller sets a flag that later
2607 * causes the optimizer in this file to not set values for the floating
2608 * and fixed string lengths, and thus avoids the optimizer code in
2609 * regexec.c that makes the invalid assumption. Thus, there is no
2610 * optimization based on string lengths for EXACTF nodes that contain the
2611 * sharp s. This only happens for /id rules (which means the pattern
2615 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2616 if (PL_regkind[OP(scan)] == EXACT) \
2617 join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2620 S_join_exact(pTHX_ RExC_state_t *pRExC_state, regnode *scan, UV *min_subtract, bool *has_exactf_sharp_s, U32 flags,regnode *val, U32 depth) {
2621 /* Merge several consecutive EXACTish nodes into one. */
2622 regnode *n = regnext(scan);
2624 regnode *next = scan + NODE_SZ_STR(scan);
2628 regnode *stop = scan;
2629 GET_RE_DEBUG_FLAGS_DECL;
2631 PERL_UNUSED_ARG(depth);
2634 PERL_ARGS_ASSERT_JOIN_EXACT;
2635 #ifndef EXPERIMENTAL_INPLACESCAN
2636 PERL_UNUSED_ARG(flags);
2637 PERL_UNUSED_ARG(val);
2639 DEBUG_PEEP("join",scan,depth);
2641 /* Look through the subsequent nodes in the chain. Skip NOTHING, merge
2642 * EXACT ones that are mergeable to the current one. */
2644 && (PL_regkind[OP(n)] == NOTHING
2645 || (stringok && OP(n) == OP(scan)))
2647 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2650 if (OP(n) == TAIL || n > next)
2652 if (PL_regkind[OP(n)] == NOTHING) {
2653 DEBUG_PEEP("skip:",n,depth);
2654 NEXT_OFF(scan) += NEXT_OFF(n);
2655 next = n + NODE_STEP_REGNODE;
2662 else if (stringok) {
2663 const unsigned int oldl = STR_LEN(scan);
2664 regnode * const nnext = regnext(n);
2666 if (oldl + STR_LEN(n) > U8_MAX)
2669 DEBUG_PEEP("merg",n,depth);
2672 NEXT_OFF(scan) += NEXT_OFF(n);
2673 STR_LEN(scan) += STR_LEN(n);
2674 next = n + NODE_SZ_STR(n);
2675 /* Now we can overwrite *n : */
2676 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2684 #ifdef EXPERIMENTAL_INPLACESCAN
2685 if (flags && !NEXT_OFF(n)) {
2686 DEBUG_PEEP("atch", val, depth);
2687 if (reg_off_by_arg[OP(n)]) {
2688 ARG_SET(n, val - n);
2691 NEXT_OFF(n) = val - n;
2699 *has_exactf_sharp_s = FALSE;
2701 /* Here, all the adjacent mergeable EXACTish nodes have been merged. We
2702 * can now analyze for sequences of problematic code points. (Prior to
2703 * this final joining, sequences could have been split over boundaries, and
2704 * hence missed). The sequences only happen in folding, hence for any
2705 * non-EXACT EXACTish node */
2706 if (OP(scan) != EXACT) {
2708 U8 * s0 = (U8*) STRING(scan);
2709 U8 * const s_end = s0 + STR_LEN(scan);
2711 /* The below is perhaps overboard, but this allows us to save a test
2712 * each time through the loop at the expense of a mask. This is
2713 * because on both EBCDIC and ASCII machines, 'S' and 's' differ by a
2714 * single bit. On ASCII they are 32 apart; on EBCDIC, they are 64.
2715 * This uses an exclusive 'or' to find that bit and then inverts it to
2716 * form a mask, with just a single 0, in the bit position where 'S' and
2718 const U8 S_or_s_mask = ~ ('S' ^ 's');
2719 const U8 s_masked = 's' & S_or_s_mask;
2721 /* One pass is made over the node's string looking for all the
2722 * possibilities. to avoid some tests in the loop, there are two main
2723 * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2727 /* There are two problematic Greek code points in Unicode
2730 * U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2731 * U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2737 * U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
2738 * U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
2740 * This means that in case-insensitive matching (or "loose
2741 * matching", as Unicode calls it), an EXACTF of length six (the
2742 * UTF-8 encoded byte length of the above casefolded versions) can
2743 * match a target string of length two (the byte length of UTF-8
2744 * encoded U+0390 or U+03B0). This would rather mess up the
2745 * minimum length computation. (there are other code points that
2746 * also fold to these two sequences, but the delta is smaller)
2748 * If these sequences are found, the minimum length is decreased by
2749 * four (six minus two).
2751 * Similarly, 'ss' may match the single char and byte LATIN SMALL
2752 * LETTER SHARP S. We decrease the min length by 1 for each
2753 * occurrence of 'ss' found */
2755 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2756 # define U390_first_byte 0xb4
2757 const U8 U390_tail[] = "\x68\xaf\x49\xaf\x42";
2758 # define U3B0_first_byte 0xb5
2759 const U8 U3B0_tail[] = "\x46\xaf\x49\xaf\x42";
2761 # define U390_first_byte 0xce
2762 const U8 U390_tail[] = "\xb9\xcc\x88\xcc\x81";
2763 # define U3B0_first_byte 0xcf
2764 const U8 U3B0_tail[] = "\x85\xcc\x88\xcc\x81";
2766 const U8 len = sizeof(U390_tail); /* (-1 for NUL; +1 for 1st byte;
2767 yields a net of 0 */
2768 /* Examine the string for one of the problematic sequences */
2770 s < s_end - 1; /* Can stop 1 before the end, as minimum length
2771 * sequence we are looking for is 2 */
2775 /* Look for the first byte in each problematic sequence */
2777 /* We don't have to worry about other things that fold to
2778 * 's' (such as the long s, U+017F), as all above-latin1
2779 * code points have been pre-folded */
2783 /* Current character is an 's' or 'S'. If next one is
2784 * as well, we have the dreaded sequence */
2785 if (((*(s+1) & S_or_s_mask) == s_masked)
2786 /* These two node types don't have special handling
2788 && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2791 OP(scan) = EXACTFU_SS;
2792 s++; /* No need to look at this character again */
2796 case U390_first_byte:
2797 if (s_end - s >= len
2799 /* The 1's are because are skipping comparing the
2801 && memEQ(s + 1, U390_tail, len - 1))
2803 goto greek_sequence;
2807 case U3B0_first_byte:
2808 if (! (s_end - s >= len
2809 && memEQ(s + 1, U3B0_tail, len - 1)))
2816 /* This can't currently be handled by trie's, so change
2817 * the node type to indicate this. If EXACTFA and
2818 * EXACTFL were ever to be handled by trie's, this
2819 * would have to be changed. If this node has already
2820 * been changed to EXACTFU_SS in this loop, leave it as
2821 * is. (I (khw) think it doesn't matter in regexec.c
2822 * for UTF patterns, but no need to change it */
2823 if (OP(scan) == EXACTFU) {
2824 OP(scan) = EXACTFU_NO_TRIE;
2826 s += 6; /* We already know what this sequence is. Skip
2832 else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2834 /* Here, the pattern is not UTF-8. We need to look only for the
2835 * 'ss' sequence, and in the EXACTF case, the sharp s, which can be
2836 * in the final position. Otherwise we can stop looking 1 byte
2837 * earlier because have to find both the first and second 's' */
2838 const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2840 for (s = s0; s < upper; s++) {
2845 && ((*(s+1) & S_or_s_mask) == s_masked))
2849 /* EXACTF nodes need to know that the minimum
2850 * length changed so that a sharp s in the string
2851 * can match this ss in the pattern, but they
2852 * remain EXACTF nodes, as they are not trie'able,
2853 * so don't have to invent a new node type to
2854 * exclude them from the trie code */
2855 if (OP(scan) != EXACTF) {
2856 OP(scan) = EXACTFU_SS;
2861 case LATIN_SMALL_LETTER_SHARP_S:
2862 if (OP(scan) == EXACTF) {
2863 *has_exactf_sharp_s = TRUE;
2872 /* Allow dumping but overwriting the collection of skipped
2873 * ops and/or strings with fake optimized ops */
2874 n = scan + NODE_SZ_STR(scan);
2882 DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2886 /* REx optimizer. Converts nodes into quicker variants "in place".
2887 Finds fixed substrings. */
2889 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2890 to the position after last scanned or to NULL. */
2892 #define INIT_AND_WITHP \
2893 assert(!and_withp); \
2894 Newx(and_withp,1,struct regnode_charclass_class); \
2895 SAVEFREEPV(and_withp)
2897 /* this is a chain of data about sub patterns we are processing that
2898 need to be handled separately/specially in study_chunk. Its so
2899 we can simulate recursion without losing state. */
2901 typedef struct scan_frame {
2902 regnode *last; /* last node to process in this frame */
2903 regnode *next; /* next node to process when last is reached */
2904 struct scan_frame *prev; /*previous frame*/
2905 I32 stop; /* what stopparen do we use */
2909 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2911 #define CASE_SYNST_FNC(nAmE) \
2913 if (flags & SCF_DO_STCLASS_AND) { \
2914 for (value = 0; value < 256; value++) \
2915 if (!is_ ## nAmE ## _cp(value)) \
2916 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2919 for (value = 0; value < 256; value++) \
2920 if (is_ ## nAmE ## _cp(value)) \
2921 ANYOF_BITMAP_SET(data->start_class, value); \
2925 if (flags & SCF_DO_STCLASS_AND) { \
2926 for (value = 0; value < 256; value++) \
2927 if (is_ ## nAmE ## _cp(value)) \
2928 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2931 for (value = 0; value < 256; value++) \
2932 if (!is_ ## nAmE ## _cp(value)) \
2933 ANYOF_BITMAP_SET(data->start_class, value); \
2940 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2941 I32 *minlenp, I32 *deltap,
2946 struct regnode_charclass_class *and_withp,
2947 U32 flags, U32 depth)
2948 /* scanp: Start here (read-write). */
2949 /* deltap: Write maxlen-minlen here. */
2950 /* last: Stop before this one. */
2951 /* data: string data about the pattern */
2952 /* stopparen: treat close N as END */
2953 /* recursed: which subroutines have we recursed into */
2954 /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2957 I32 min = 0, pars = 0, code;
2958 regnode *scan = *scanp, *next;
2960 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2961 int is_inf_internal = 0; /* The studied chunk is infinite */
2962 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2963 scan_data_t data_fake;
2964 SV *re_trie_maxbuff = NULL;
2965 regnode *first_non_open = scan;
2966 I32 stopmin = I32_MAX;
2967 scan_frame *frame = NULL;
2968 GET_RE_DEBUG_FLAGS_DECL;
2970 PERL_ARGS_ASSERT_STUDY_CHUNK;
2973 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
2977 while (first_non_open && OP(first_non_open) == OPEN)
2978 first_non_open=regnext(first_non_open);
2983 while ( scan && OP(scan) != END && scan < last ){
2984 UV min_subtract = 0; /* How much to subtract from the minimum node
2985 length to get a real minimum (because the
2986 folded version may be shorter) */
2987 bool has_exactf_sharp_s = FALSE;
2988 /* Peephole optimizer: */
2989 DEBUG_STUDYDATA("Peep:", data,depth);
2990 DEBUG_PEEP("Peep",scan,depth);
2992 /* Its not clear to khw or hv why this is done here, and not in the
2993 * clauses that deal with EXACT nodes. khw's guess is that it's
2994 * because of a previous design */
2995 JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
2997 /* Follow the next-chain of the current node and optimize
2998 away all the NOTHINGs from it. */
2999 if (OP(scan) != CURLYX) {
3000 const int max = (reg_off_by_arg[OP(scan)]
3002 /* I32 may be smaller than U16 on CRAYs! */
3003 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3004 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3008 /* Skip NOTHING and LONGJMP. */
3009 while ((n = regnext(n))
3010 && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3011 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3012 && off + noff < max)
3014 if (reg_off_by_arg[OP(scan)])
3017 NEXT_OFF(scan) = off;
3022 /* The principal pseudo-switch. Cannot be a switch, since we
3023 look into several different things. */
3024 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3025 || OP(scan) == IFTHEN) {
3026 next = regnext(scan);
3028 /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3030 if (OP(next) == code || code == IFTHEN) {
3031 /* NOTE - There is similar code to this block below for handling
3032 TRIE nodes on a re-study. If you change stuff here check there
3034 I32 max1 = 0, min1 = I32_MAX, num = 0;
3035 struct regnode_charclass_class accum;
3036 regnode * const startbranch=scan;
3038 if (flags & SCF_DO_SUBSTR)
3039 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3040 if (flags & SCF_DO_STCLASS)
3041 cl_init_zero(pRExC_state, &accum);
3043 while (OP(scan) == code) {
3044 I32 deltanext, minnext, f = 0, fake;
3045 struct regnode_charclass_class this_class;
3048 data_fake.flags = 0;
3050 data_fake.whilem_c = data->whilem_c;
3051 data_fake.last_closep = data->last_closep;
3054 data_fake.last_closep = &fake;
3056 data_fake.pos_delta = delta;
3057 next = regnext(scan);
3058 scan = NEXTOPER(scan);
3060 scan = NEXTOPER(scan);
3061 if (flags & SCF_DO_STCLASS) {
3062 cl_init(pRExC_state, &this_class);
3063 data_fake.start_class = &this_class;
3064 f = SCF_DO_STCLASS_AND;
3066 if (flags & SCF_WHILEM_VISITED_POS)
3067 f |= SCF_WHILEM_VISITED_POS;
3069 /* we suppose the run is continuous, last=next...*/
3070 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3072 stopparen, recursed, NULL, f,depth+1);
3075 if (max1 < minnext + deltanext)
3076 max1 = minnext + deltanext;
3077 if (deltanext == I32_MAX)
3078 is_inf = is_inf_internal = 1;
3080 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3082 if (data_fake.flags & SCF_SEEN_ACCEPT) {
3083 if ( stopmin > minnext)
3084 stopmin = min + min1;
3085 flags &= ~SCF_DO_SUBSTR;
3087 data->flags |= SCF_SEEN_ACCEPT;
3090 if (data_fake.flags & SF_HAS_EVAL)
3091 data->flags |= SF_HAS_EVAL;
3092 data->whilem_c = data_fake.whilem_c;
3094 if (flags & SCF_DO_STCLASS)
3095 cl_or(pRExC_state, &accum, &this_class);
3097 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3099 if (flags & SCF_DO_SUBSTR) {
3100 data->pos_min += min1;
3101 data->pos_delta += max1 - min1;
3102 if (max1 != min1 || is_inf)
3103 data->longest = &(data->longest_float);
3106 delta += max1 - min1;
3107 if (flags & SCF_DO_STCLASS_OR) {
3108 cl_or(pRExC_state, data->start_class, &accum);
3110 cl_and(data->start_class, and_withp);
3111 flags &= ~SCF_DO_STCLASS;
3114 else if (flags & SCF_DO_STCLASS_AND) {
3116 cl_and(data->start_class, &accum);
3117 flags &= ~SCF_DO_STCLASS;
3120 /* Switch to OR mode: cache the old value of
3121 * data->start_class */
3123 StructCopy(data->start_class, and_withp,
3124 struct regnode_charclass_class);
3125 flags &= ~SCF_DO_STCLASS_AND;
3126 StructCopy(&accum, data->start_class,
3127 struct regnode_charclass_class);
3128 flags |= SCF_DO_STCLASS_OR;
3129 data->start_class->flags |= ANYOF_EOS;
3133 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3136 Assuming this was/is a branch we are dealing with: 'scan' now
3137 points at the item that follows the branch sequence, whatever
3138 it is. We now start at the beginning of the sequence and look
3145 which would be constructed from a pattern like /A|LIST|OF|WORDS/
3147 If we can find such a subsequence we need to turn the first
3148 element into a trie and then add the subsequent branch exact
3149 strings to the trie.
3153 1. patterns where the whole set of branches can be converted.
3155 2. patterns where only a subset can be converted.
3157 In case 1 we can replace the whole set with a single regop
3158 for the trie. In case 2 we need to keep the start and end
3161 'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3162 becomes BRANCH TRIE; BRANCH X;
3164 There is an additional case, that being where there is a
3165 common prefix, which gets split out into an EXACT like node
3166 preceding the TRIE node.
3168 If x(1..n)==tail then we can do a simple trie, if not we make
3169 a "jump" trie, such that when we match the appropriate word
3170 we "jump" to the appropriate tail node. Essentially we turn
3171 a nested if into a case structure of sorts.
3176 if (!re_trie_maxbuff) {
3177 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3178 if (!SvIOK(re_trie_maxbuff))
3179 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3181 if ( SvIV(re_trie_maxbuff)>=0 ) {
3183 regnode *first = (regnode *)NULL;
3184 regnode *last = (regnode *)NULL;
3185 regnode *tail = scan;
3190 SV * const mysv = sv_newmortal(); /* for dumping */
3192 /* var tail is used because there may be a TAIL
3193 regop in the way. Ie, the exacts will point to the
3194 thing following the TAIL, but the last branch will
3195 point at the TAIL. So we advance tail. If we
3196 have nested (?:) we may have to move through several
3200 while ( OP( tail ) == TAIL ) {
3201 /* this is the TAIL generated by (?:) */
3202 tail = regnext( tail );
3207 regprop(RExC_rx, mysv, tail );
3208 PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3209 (int)depth * 2 + 2, "",
3210 "Looking for TRIE'able sequences. Tail node is: ",
3211 SvPV_nolen_const( mysv )
3217 step through the branches, cur represents each
3218 branch, noper is the first thing to be matched
3219 as part of that branch and noper_next is the
3220 regnext() of that node. if noper is an EXACT
3221 and noper_next is the same as scan (our current
3222 position in the regex) then the EXACT branch is
3223 a possible optimization target. Once we have
3224 two or more consecutive such branches we can
3225 create a trie of the EXACT's contents and stich
3226 it in place. If the sequence represents all of
3227 the branches we eliminate the whole thing and
3228 replace it with a single TRIE. If it is a
3229 subsequence then we need to stitch it in. This
3230 means the first branch has to remain, and needs
3231 to be repointed at the item on the branch chain
3232 following the last branch optimized. This could
3233 be either a BRANCH, in which case the
3234 subsequence is internal, or it could be the
3235 item following the branch sequence in which
3236 case the subsequence is at the end.
3240 /* dont use tail as the end marker for this traverse */
3241 for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3242 regnode * const noper = NEXTOPER( cur );
3243 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3244 regnode * const noper_next = regnext( noper );
3248 regprop(RExC_rx, mysv, cur);
3249 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3250 (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3252 regprop(RExC_rx, mysv, noper);
3253 PerlIO_printf( Perl_debug_log, " -> %s",
3254 SvPV_nolen_const(mysv));
3257 regprop(RExC_rx, mysv, noper_next );
3258 PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3259 SvPV_nolen_const(mysv));
3261 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3262 REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3264 if ( (((first && optype!=NOTHING) ? OP( noper ) == optype
3265 : PL_regkind[ OP( noper ) ] == EXACT )
3266 || OP(noper) == NOTHING )
3268 && noper_next == tail
3273 if ( !first || optype == NOTHING ) {
3274 if (!first) first = cur;
3275 optype = OP( noper );
3281 Currently the trie logic handles case insensitive matching properly only
3282 when the pattern is UTF-8 and the node is EXACTFU (thus forcing unicode
3285 If/when this is fixed the following define can be swapped
3286 in below to fully enable trie logic.
3288 #define TRIE_TYPE_IS_SAFE 1
3290 Note that join_exact() assumes that the other types of EXACTFish nodes are not
3291 used in tries, so that would have to be updated if this changed
3294 #define TRIE_TYPE_IS_SAFE ((UTF && optype == EXACTFU) || optype==EXACT)
3296 if ( last && TRIE_TYPE_IS_SAFE ) {
3297 make_trie( pRExC_state,
3298 startbranch, first, cur, tail, count,
3301 if ( PL_regkind[ OP( noper ) ] == EXACT
3303 && noper_next == tail
3308 optype = OP( noper );
3318 regprop(RExC_rx, mysv, cur);
3319 PerlIO_printf( Perl_debug_log,
3320 "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3321 "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3325 if ( last && TRIE_TYPE_IS_SAFE ) {
3326 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, optype, depth+1 );
3327 #ifdef TRIE_STUDY_OPT
3328 if ( ((made == MADE_EXACT_TRIE &&
3329 startbranch == first)
3330 || ( first_non_open == first )) &&
3332 flags |= SCF_TRIE_RESTUDY;
3333 if ( startbranch == first
3336 RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3346 else if ( code == BRANCHJ ) { /* single branch is optimized. */
3347 scan = NEXTOPER(NEXTOPER(scan));
3348 } else /* single branch is optimized. */
3349 scan = NEXTOPER(scan);
3351 } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3352 scan_frame *newframe = NULL;
3357 if (OP(scan) != SUSPEND) {
3358 /* set the pointer */
3359 if (OP(scan) == GOSUB) {
3361 RExC_recurse[ARG2L(scan)] = scan;
3362 start = RExC_open_parens[paren-1];
3363 end = RExC_close_parens[paren-1];
3366 start = RExC_rxi->program + 1;
3370 Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3371 SAVEFREEPV(recursed);
3373 if (!PAREN_TEST(recursed,paren+1)) {
3374 PAREN_SET(recursed,paren+1);
3375 Newx(newframe,1,scan_frame);
3377 if (flags & SCF_DO_SUBSTR) {
3378 SCAN_COMMIT(pRExC_state,data,minlenp);
3379 data->longest = &(data->longest_float);
3381 is_inf = is_inf_internal = 1;
3382 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3383 cl_anything(pRExC_state, data->start_class);
3384 flags &= ~SCF_DO_STCLASS;
3387 Newx(newframe,1,scan_frame);
3390 end = regnext(scan);
3395 SAVEFREEPV(newframe);
3396 newframe->next = regnext(scan);
3397 newframe->last = last;
3398 newframe->stop = stopparen;
3399 newframe->prev = frame;
3409 else if (OP(scan) == EXACT) {
3410 I32 l = STR_LEN(scan);
3413 const U8 * const s = (U8*)STRING(scan);
3414 l = utf8_length(s, s + l);
3415 uc = utf8_to_uvchr(s, NULL);
3417 uc = *((U8*)STRING(scan));
3420 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3421 /* The code below prefers earlier match for fixed
3422 offset, later match for variable offset. */
3423 if (data->last_end == -1) { /* Update the start info. */
3424 data->last_start_min = data->pos_min;
3425 data->last_start_max = is_inf
3426 ? I32_MAX : data->pos_min + data->pos_delta;
3428 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3430 SvUTF8_on(data->last_found);
3432 SV * const sv = data->last_found;
3433 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3434 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3435 if (mg && mg->mg_len >= 0)
3436 mg->mg_len += utf8_length((U8*)STRING(scan),
3437 (U8*)STRING(scan)+STR_LEN(scan));
3439 data->last_end = data->pos_min + l;
3440 data->pos_min += l; /* As in the first entry. */
3441 data->flags &= ~SF_BEFORE_EOL;
3443 if (flags & SCF_DO_STCLASS_AND) {
3444 /* Check whether it is compatible with what we know already! */
3448 /* If compatible, we or it in below. It is compatible if is
3449 * in the bitmp and either 1) its bit or its fold is set, or 2)
3450 * it's for a locale. Even if there isn't unicode semantics
3451 * here, at runtime there may be because of matching against a
3452 * utf8 string, so accept a possible false positive for
3453 * latin1-range folds */
3455 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3456 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3457 && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3458 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3463 ANYOF_CLASS_ZERO(data->start_class);
3464 ANYOF_BITMAP_ZERO(data->start_class);
3466 ANYOF_BITMAP_SET(data->start_class, uc);
3467 else if (uc >= 0x100) {
3470 /* Some Unicode code points fold to the Latin1 range; as
3471 * XXX temporary code, instead of figuring out if this is
3472 * one, just assume it is and set all the start class bits
3473 * that could be some such above 255 code point's fold
3474 * which will generate fals positives. As the code
3475 * elsewhere that does compute the fold settles down, it
3476 * can be extracted out and re-used here */
3477 for (i = 0; i < 256; i++){
3478 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3479 ANYOF_BITMAP_SET(data->start_class, i);
3483 data->start_class->flags &= ~ANYOF_EOS;
3485 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3487 else if (flags & SCF_DO_STCLASS_OR) {
3488 /* false positive possible if the class is case-folded */
3490 ANYOF_BITMAP_SET(data->start_class, uc);
3492 data->start_class->flags |= ANYOF_UNICODE_ALL;
3493 data->start_class->flags &= ~ANYOF_EOS;
3494 cl_and(data->start_class, and_withp);
3496 flags &= ~SCF_DO_STCLASS;
3498 else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3499 I32 l = STR_LEN(scan);
3500 UV uc = *((U8*)STRING(scan));
3502 /* Search for fixed substrings supports EXACT only. */
3503 if (flags & SCF_DO_SUBSTR) {
3505 SCAN_COMMIT(pRExC_state, data, minlenp);
3508 const U8 * const s = (U8 *)STRING(scan);
3509 l = utf8_length(s, s + l);
3510 uc = utf8_to_uvchr(s, NULL);
3512 else if (has_exactf_sharp_s) {
3513 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3515 min += l - min_subtract;
3519 delta += min_subtract;
3520 if (flags & SCF_DO_SUBSTR) {
3521 data->pos_min += l - min_subtract;
3522 if (data->pos_min < 0) {
3525 data->pos_delta += min_subtract;
3527 data->longest = &(data->longest_float);
3530 if (flags & SCF_DO_STCLASS_AND) {
3531 /* Check whether it is compatible with what we know already! */
3534 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3535 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3536 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3540 ANYOF_CLASS_ZERO(data->start_class);
3541 ANYOF_BITMAP_ZERO(data->start_class);
3543 ANYOF_BITMAP_SET(data->start_class, uc);
3544 data->start_class->flags &= ~ANYOF_EOS;
3545 data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3546 if (OP(scan) == EXACTFL) {
3547 /* XXX This set is probably no longer necessary, and
3548 * probably wrong as LOCALE now is on in the initial
3550 data->start_class->flags |= ANYOF_LOCALE;
3554 /* Also set the other member of the fold pair. In case
3555 * that unicode semantics is called for at runtime, use
3556 * the full latin1 fold. (Can't do this for locale,
3557 * because not known until runtime) */
3558 ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3560 /* All other (EXACTFL handled above) folds except under
3561 * /iaa that include s, S, and sharp_s also may include
3563 if (OP(scan) != EXACTFA) {
3564 if (uc == 's' || uc == 'S') {
3565 ANYOF_BITMAP_SET(data->start_class,
3566 LATIN_SMALL_LETTER_SHARP_S);
3568 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3569 ANYOF_BITMAP_SET(data->start_class, 's');
3570 ANYOF_BITMAP_SET(data->start_class, 'S');
3575 else if (uc >= 0x100) {
3577 for (i = 0; i < 256; i++){
3578 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3579 ANYOF_BITMAP_SET(data->start_class, i);
3584 else if (flags & SCF_DO_STCLASS_OR) {
3585 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3586 /* false positive possible if the class is case-folded.
3587 Assume that the locale settings are the same... */
3589 ANYOF_BITMAP_SET(data->start_class, uc);
3590 if (OP(scan) != EXACTFL) {
3592 /* And set the other member of the fold pair, but
3593 * can't do that in locale because not known until
3595 ANYOF_BITMAP_SET(data->start_class,
3596 PL_fold_latin1[uc]);
3598 /* All folds except under /iaa that include s, S,
3599 * and sharp_s also may include the others */
3600 if (OP(scan) != EXACTFA) {
3601 if (uc == 's' || uc == 'S') {
3602 ANYOF_BITMAP_SET(data->start_class,
3603 LATIN_SMALL_LETTER_SHARP_S);
3605 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3606 ANYOF_BITMAP_SET(data->start_class, 's');
3607 ANYOF_BITMAP_SET(data->start_class, 'S');
3612 data->start_class->flags &= ~ANYOF_EOS;
3614 cl_and(data->start_class, and_withp);
3616 flags &= ~SCF_DO_STCLASS;
3618 else if (REGNODE_VARIES(OP(scan))) {
3619 I32 mincount, maxcount, minnext, deltanext, fl = 0;
3620 I32 f = flags, pos_before = 0;
3621 regnode * const oscan = scan;
3622 struct regnode_charclass_class this_class;
3623 struct regnode_charclass_class *oclass = NULL;
3624 I32 next_is_eval = 0;
3626 switch (PL_regkind[OP(scan)]) {
3627 case WHILEM: /* End of (?:...)* . */
3628 scan = NEXTOPER(scan);
3631 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3632 next = NEXTOPER(scan);
3633 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3635 maxcount = REG_INFTY;
3636 next = regnext(scan);
3637 scan = NEXTOPER(scan);
3641 if (flags & SCF_DO_SUBSTR)
3646 if (flags & SCF_DO_STCLASS) {
3648 maxcount = REG_INFTY;
3649 next = regnext(scan);
3650 scan = NEXTOPER(scan);
3653 is_inf = is_inf_internal = 1;
3654 scan = regnext(scan);
3655 if (flags & SCF_DO_SUBSTR) {
3656 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3657 data->longest = &(data->longest_float);
3659 goto optimize_curly_tail;
3661 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3662 && (scan->flags == stopparen))
3667 mincount = ARG1(scan);
3668 maxcount = ARG2(scan);
3670 next = regnext(scan);
3671 if (OP(scan) == CURLYX) {
3672 I32 lp = (data ? *(data->last_closep) : 0);
3673 scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3675 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3676 next_is_eval = (OP(scan) == EVAL);
3678 if (flags & SCF_DO_SUBSTR) {
3679 if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3680 pos_before = data->pos_min;
3684 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3686 data->flags |= SF_IS_INF;
3688 if (flags & SCF_DO_STCLASS) {
3689 cl_init(pRExC_state, &this_class);
3690 oclass = data->start_class;
3691 data->start_class = &this_class;
3692 f |= SCF_DO_STCLASS_AND;
3693 f &= ~SCF_DO_STCLASS_OR;
3695 /* Exclude from super-linear cache processing any {n,m}
3696 regops for which the combination of input pos and regex
3697 pos is not enough information to determine if a match
3700 For example, in the regex /foo(bar\s*){4,8}baz/ with the
3701 regex pos at the \s*, the prospects for a match depend not
3702 only on the input position but also on how many (bar\s*)
3703 repeats into the {4,8} we are. */
3704 if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3705 f &= ~SCF_WHILEM_VISITED_POS;
3707 /* This will finish on WHILEM, setting scan, or on NULL: */
3708 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3709 last, data, stopparen, recursed, NULL,
3711 ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3713 if (flags & SCF_DO_STCLASS)
3714 data->start_class = oclass;
3715 if (mincount == 0 || minnext == 0) {
3716 if (flags & SCF_DO_STCLASS_OR) {
3717 cl_or(pRExC_state, data->start_class, &this_class);
3719 else if (flags & SCF_DO_STCLASS_AND) {
3720 /* Switch to OR mode: cache the old value of
3721 * data->start_class */
3723 StructCopy(data->start_class, and_withp,
3724 struct regnode_charclass_class);
3725 flags &= ~SCF_DO_STCLASS_AND;
3726 StructCopy(&this_class, data->start_class,
3727 struct regnode_charclass_class);
3728 flags |= SCF_DO_STCLASS_OR;
3729 data->start_class->flags |= ANYOF_EOS;
3731 } else { /* Non-zero len */
3732 if (flags & SCF_DO_STCLASS_OR) {
3733 cl_or(pRExC_state, data->start_class, &this_class);
3734 cl_and(data->start_class, and_withp);
3736 else if (flags & SCF_DO_STCLASS_AND)
3737 cl_and(data->start_class, &this_class);
3738 flags &= ~SCF_DO_STCLASS;
3740 if (!scan) /* It was not CURLYX, but CURLY. */
3742 if ( /* ? quantifier ok, except for (?{ ... }) */
3743 (next_is_eval || !(mincount == 0 && maxcount == 1))
3744 && (minnext == 0) && (deltanext == 0)
3745 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3746 && maxcount <= REG_INFTY/3) /* Complement check for big count */
3748 ckWARNreg(RExC_parse,
3749 "Quantifier unexpected on zero-length expression");
3752 min += minnext * mincount;
3753 is_inf_internal |= ((maxcount == REG_INFTY
3754 && (minnext + deltanext) > 0)
3755 || deltanext == I32_MAX);
3756 is_inf |= is_inf_internal;
3757 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3759 /* Try powerful optimization CURLYX => CURLYN. */
3760 if ( OP(oscan) == CURLYX && data
3761 && data->flags & SF_IN_PAR
3762 && !(data->flags & SF_HAS_EVAL)
3763 && !deltanext && minnext == 1 ) {
3764 /* Try to optimize to CURLYN. */
3765 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3766 regnode * const nxt1 = nxt;
3773 if (!REGNODE_SIMPLE(OP(nxt))
3774 && !(PL_regkind[OP(nxt)] == EXACT
3775 && STR_LEN(nxt) == 1))
3781 if (OP(nxt) != CLOSE)
3783 if (RExC_open_parens) {
3784 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3785 RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3787 /* Now we know that nxt2 is the only contents: */
3788 oscan->flags = (U8)ARG(nxt);
3790 OP(nxt1) = NOTHING; /* was OPEN. */
3793 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3794 NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3795 NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3796 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3797 OP(nxt + 1) = OPTIMIZED; /* was count. */
3798 NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3803 /* Try optimization CURLYX => CURLYM. */
3804 if ( OP(oscan) == CURLYX && data
3805 && !(data->flags & SF_HAS_PAR)
3806 && !(data->flags & SF_HAS_EVAL)
3807 && !deltanext /* atom is fixed width */
3808 && minnext != 0 /* CURLYM can't handle zero width */
3810 /* XXXX How to optimize if data == 0? */
3811 /* Optimize to a simpler form. */
3812 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3816 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3817 && (OP(nxt2) != WHILEM))
3819 OP(nxt2) = SUCCEED; /* Whas WHILEM */
3820 /* Need to optimize away parenths. */
3821 if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3822 /* Set the parenth number. */
3823 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3825 oscan->flags = (U8)ARG(nxt);
3826 if (RExC_open_parens) {
3827 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3828 RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3830 OP(nxt1) = OPTIMIZED; /* was OPEN. */
3831 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3834 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3835 OP(nxt + 1) = OPTIMIZED; /* was count. */
3836 NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3837 NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3840 while ( nxt1 && (OP(nxt1) != WHILEM)) {
3841 regnode *nnxt = regnext(nxt1);
3843 if (reg_off_by_arg[OP(nxt1)])
3844 ARG_SET(nxt1, nxt2 - nxt1);
3845 else if (nxt2 - nxt1 < U16_MAX)
3846 NEXT_OFF(nxt1) = nxt2 - nxt1;
3848 OP(nxt) = NOTHING; /* Cannot beautify */
3853 /* Optimize again: */
3854 study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3855 NULL, stopparen, recursed, NULL, 0,depth+1);
3860 else if ((OP(oscan) == CURLYX)
3861 && (flags & SCF_WHILEM_VISITED_POS)
3862 /* See the comment on a similar expression above.
3863 However, this time it's not a subexpression
3864 we care about, but the expression itself. */
3865 && (maxcount == REG_INFTY)
3866 && data && ++data->whilem_c < 16) {
3867 /* This stays as CURLYX, we can put the count/of pair. */
3868 /* Find WHILEM (as in regexec.c) */
3869 regnode *nxt = oscan + NEXT_OFF(oscan);
3871 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3873 PREVOPER(nxt)->flags = (U8)(data->whilem_c
3874 | (RExC_whilem_seen << 4)); /* On WHILEM */
3876 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3878 if (flags & SCF_DO_SUBSTR) {
3879 SV *last_str = NULL;
3880 int counted = mincount != 0;
3882 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3883 #if defined(SPARC64_GCC_WORKAROUND)
3886 const char *s = NULL;
3889 if (pos_before >= data->last_start_min)
3892 b = data->last_start_min;
3895 s = SvPV_const(data->last_found, l);
3896 old = b - data->last_start_min;
3899 I32 b = pos_before >= data->last_start_min
3900 ? pos_before : data->last_start_min;
3902 const char * const s = SvPV_const(data->last_found, l);
3903 I32 old = b - data->last_start_min;
3907 old = utf8_hop((U8*)s, old) - (U8*)s;
3909 /* Get the added string: */
3910 last_str = newSVpvn_utf8(s + old, l, UTF);
3911 if (deltanext == 0 && pos_before == b) {
3912 /* What was added is a constant string */
3914 SvGROW(last_str, (mincount * l) + 1);
3915 repeatcpy(SvPVX(last_str) + l,
3916 SvPVX_const(last_str), l, mincount - 1);
3917 SvCUR_set(last_str, SvCUR(last_str) * mincount);
3918 /* Add additional parts. */
3919 SvCUR_set(data->last_found,
3920 SvCUR(data->last_found) - l);
3921 sv_catsv(data->last_found, last_str);
3923 SV * sv = data->last_found;
3925 SvUTF8(sv) && SvMAGICAL(sv) ?
3926 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3927 if (mg && mg->mg_len >= 0)
3928 mg->mg_len += CHR_SVLEN(last_str) - l;
3930 data->last_end += l * (mincount - 1);
3933 /* start offset must point into the last copy */
3934 data->last_start_min += minnext * (mincount - 1);
3935 data->last_start_max += is_inf ? I32_MAX
3936 : (maxcount - 1) * (minnext + data->pos_delta);
3939 /* It is counted once already... */
3940 data->pos_min += minnext * (mincount - counted);
3941 data->pos_delta += - counted * deltanext +
3942 (minnext + deltanext) * maxcount - minnext * mincount;
3943 if (mincount != maxcount) {
3944 /* Cannot extend fixed substrings found inside
3946 SCAN_COMMIT(pRExC_state,data,minlenp);
3947 if (mincount && last_str) {
3948 SV * const sv = data->last_found;
3949 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3950 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3954 sv_setsv(sv, last_str);
3955 data->last_end = data->pos_min;
3956 data->last_start_min =
3957 data->pos_min - CHR_SVLEN(last_str);
3958 data->last_start_max = is_inf
3960 : data->pos_min + data->pos_delta
3961 - CHR_SVLEN(last_str);
3963 data->longest = &(data->longest_float);
3965 SvREFCNT_dec(last_str);
3967 if (data && (fl & SF_HAS_EVAL))
3968 data->flags |= SF_HAS_EVAL;
3969 optimize_curly_tail:
3970 if (OP(oscan) != CURLYX) {
3971 while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
3973 NEXT_OFF(oscan) += NEXT_OFF(next);
3976 default: /* REF, ANYOFV, and CLUMP only? */
3977 if (flags & SCF_DO_SUBSTR) {
3978 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
3979 data->longest = &(data->longest_float);
3981 is_inf = is_inf_internal = 1;
3982 if (flags & SCF_DO_STCLASS_OR)
3983 cl_anything(pRExC_state, data->start_class);
3984 flags &= ~SCF_DO_STCLASS;
3988 else if (OP(scan) == LNBREAK) {
3989 if (flags & SCF_DO_STCLASS) {
3991 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
3992 if (flags & SCF_DO_STCLASS_AND) {
3993 for (value = 0; value < 256; value++)
3994 if (!is_VERTWS_cp(value))
3995 ANYOF_BITMAP_CLEAR(data->start_class, value);
3998 for (value = 0; value < 256; value++)
3999 if (is_VERTWS_cp(value))
4000 ANYOF_BITMAP_SET(data->start_class, value);
4002 if (flags & SCF_DO_STCLASS_OR)
4003 cl_and(data->start_class, and_withp);
4004 flags &= ~SCF_DO_STCLASS;
4008 if (flags & SCF_DO_SUBSTR) {
4009 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4011 data->pos_delta += 1;
4012 data->longest = &(data->longest_float);
4015 else if (REGNODE_SIMPLE(OP(scan))) {
4018 if (flags & SCF_DO_SUBSTR) {
4019 SCAN_COMMIT(pRExC_state,data,minlenp);
4023 if (flags & SCF_DO_STCLASS) {
4024 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4026 /* Some of the logic below assumes that switching
4027 locale on will only add false positives. */
4028 switch (PL_regkind[OP(scan)]) {
4032 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
4033 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4034 cl_anything(pRExC_state, data->start_class);
4037 if (OP(scan) == SANY)
4039 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4040 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4041 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4042 cl_anything(pRExC_state, data->start_class);
4044 if (flags & SCF_DO_STCLASS_AND || !value)
4045 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4048 if (flags & SCF_DO_STCLASS_AND)
4049 cl_and(data->start_class,
4050 (struct regnode_charclass_class*)scan);
4052 cl_or(pRExC_state, data->start_class,
4053 (struct regnode_charclass_class*)scan);
4056 if (flags & SCF_DO_STCLASS_AND) {
4057 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4058 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
4059 if (OP(scan) == ALNUMU) {
4060 for (value = 0; value < 256; value++) {
4061 if (!isWORDCHAR_L1(value)) {
4062 ANYOF_BITMAP_CLEAR(data->start_class, value);
4066 for (value = 0; value < 256; value++) {
4067 if (!isALNUM(value)) {
4068 ANYOF_BITMAP_CLEAR(data->start_class, value);
4075 if (data->start_class->flags & ANYOF_LOCALE)
4076 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
4078 /* Even if under locale, set the bits for non-locale
4079 * in case it isn't a true locale-node. This will
4080 * create false positives if it truly is locale */
4081 if (OP(scan) == ALNUMU) {
4082 for (value = 0; value < 256; value++) {
4083 if (isWORDCHAR_L1(value)) {
4084 ANYOF_BITMAP_SET(data->start_class, value);
4088 for (value = 0; value < 256; value++) {
4089 if (isALNUM(value)) {
4090 ANYOF_BITMAP_SET(data->start_class, value);
4097 if (flags & SCF_DO_STCLASS_AND) {
4098 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4099 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
4100 if (OP(scan) == NALNUMU) {
4101 for (value = 0; value < 256; value++) {
4102 if (isWORDCHAR_L1(value)) {
4103 ANYOF_BITMAP_CLEAR(data->start_class, value);
4107 for (value = 0; value < 256; value++) {
4108 if (isALNUM(value)) {
4109 ANYOF_BITMAP_CLEAR(data->start_class, value);
4116 if (data->start_class->flags & ANYOF_LOCALE)
4117 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
4119 /* Even if under locale, set the bits for non-locale in
4120 * case it isn't a true locale-node. This will create
4121 * false positives if it truly is locale */
4122 if (OP(scan) == NALNUMU) {
4123 for (value = 0; value < 256; value++) {
4124 if (! isWORDCHAR_L1(value)) {
4125 ANYOF_BITMAP_SET(data->start_class, value);
4129 for (value = 0; value < 256; value++) {
4130 if (! isALNUM(value)) {
4131 ANYOF_BITMAP_SET(data->start_class, value);
4138 if (flags & SCF_DO_STCLASS_AND) {
4139 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4140 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
4141 if (OP(scan) == SPACEU) {
4142 for (value = 0; value < 256; value++) {
4143 if (!isSPACE_L1(value)) {
4144 ANYOF_BITMAP_CLEAR(data->start_class, value);
4148 for (value = 0; value < 256; value++) {
4149 if (!isSPACE(value)) {
4150 ANYOF_BITMAP_CLEAR(data->start_class, value);
4157 if (data->start_class->flags & ANYOF_LOCALE) {
4158 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
4160 if (OP(scan) == SPACEU) {
4161 for (value = 0; value < 256; value++) {
4162 if (isSPACE_L1(value)) {
4163 ANYOF_BITMAP_SET(data->start_class, value);
4167 for (value = 0; value < 256; value++) {
4168 if (isSPACE(value)) {
4169 ANYOF_BITMAP_SET(data->start_class, value);
4176 if (flags & SCF_DO_STCLASS_AND) {
4177 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4178 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
4179 if (OP(scan) == NSPACEU) {
4180 for (value = 0; value < 256; value++) {
4181 if (isSPACE_L1(value)) {
4182 ANYOF_BITMAP_CLEAR(data->start_class, value);
4186 for (value = 0; value < 256; value++) {
4187 if (isSPACE(value)) {
4188 ANYOF_BITMAP_CLEAR(data->start_class, value);
4195 if (data->start_class->flags & ANYOF_LOCALE)
4196 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
4197 if (OP(scan) == NSPACEU) {
4198 for (value = 0; value < 256; value++) {
4199 if (!isSPACE_L1(value)) {
4200 ANYOF_BITMAP_SET(data->start_class, value);
4205 for (value = 0; value < 256; value++) {
4206 if (!isSPACE(value)) {
4207 ANYOF_BITMAP_SET(data->start_class, value);
4214 if (flags & SCF_DO_STCLASS_AND) {
4215 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4216 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
4217 for (value = 0; value < 256; value++)
4218 if (!isDIGIT(value))
4219 ANYOF_BITMAP_CLEAR(data->start_class, value);
4223 if (data->start_class->flags & ANYOF_LOCALE)
4224 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
4225 for (value = 0; value < 256; value++)
4227 ANYOF_BITMAP_SET(data->start_class, value);
4231 if (flags & SCF_DO_STCLASS_AND) {
4232 if (!(data->start_class->flags & ANYOF_LOCALE))
4233 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
4234 for (value = 0; value < 256; value++)
4236 ANYOF_BITMAP_CLEAR(data->start_class, value);
4239 if (data->start_class->flags & ANYOF_LOCALE)
4240 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
4241 for (value = 0; value < 256; value++)
4242 if (!isDIGIT(value))
4243 ANYOF_BITMAP_SET(data->start_class, value);
4246 CASE_SYNST_FNC(VERTWS);
4247 CASE_SYNST_FNC(HORIZWS);
4250 if (flags & SCF_DO_STCLASS_OR)
4251 cl_and(data->start_class, and_withp);
4252 flags &= ~SCF_DO_STCLASS;
4255 else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4256 data->flags |= (OP(scan) == MEOL
4260 else if ( PL_regkind[OP(scan)] == BRANCHJ
4261 /* Lookbehind, or need to calculate parens/evals/stclass: */
4262 && (scan->flags || data || (flags & SCF_DO_STCLASS))
4263 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4264 if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4265 || OP(scan) == UNLESSM )
4267 /* Negative Lookahead/lookbehind
4268 In this case we can't do fixed string optimisation.
4271 I32 deltanext, minnext, fake = 0;
4273 struct regnode_charclass_class intrnl;
4276 data_fake.flags = 0;
4278 data_fake.whilem_c = data->whilem_c;
4279 data_fake.last_closep = data->last_closep;
4282 data_fake.last_closep = &fake;
4283 data_fake.pos_delta = delta;
4284 if ( flags & SCF_DO_STCLASS && !scan->flags
4285 && OP(scan) == IFMATCH ) { /* Lookahead */
4286 cl_init(pRExC_state, &intrnl);
4287 data_fake.start_class = &intrnl;
4288 f |= SCF_DO_STCLASS_AND;
4290 if (flags & SCF_WHILEM_VISITED_POS)
4291 f |= SCF_WHILEM_VISITED_POS;
4292 next = regnext(scan);
4293 nscan = NEXTOPER(NEXTOPER(scan));
4294 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
4295 last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4298 FAIL("Variable length lookbehind not implemented");
4300 else if (minnext > (I32)U8_MAX) {
4301 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4303 scan->flags = (U8)minnext;
4306 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4308 if (data_fake.flags & SF_HAS_EVAL)
4309 data->flags |= SF_HAS_EVAL;
4310 data->whilem_c = data_fake.whilem_c;
4312 if (f & SCF_DO_STCLASS_AND) {
4313 if (flags & SCF_DO_STCLASS_OR) {
4314 /* OR before, AND after: ideally we would recurse with
4315 * data_fake to get the AND applied by study of the
4316 * remainder of the pattern, and then derecurse;
4317 * *** HACK *** for now just treat as "no information".
4318 * See [perl #56690].
4320 cl_init(pRExC_state, data->start_class);
4322 /* AND before and after: combine and continue */
4323 const int was = (data->start_class->flags & ANYOF_EOS);
4325 cl_and(data->start_class, &intrnl);
4327 data->start_class->flags |= ANYOF_EOS;
4331 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4333 /* Positive Lookahead/lookbehind
4334 In this case we can do fixed string optimisation,
4335 but we must be careful about it. Note in the case of
4336 lookbehind the positions will be offset by the minimum
4337 length of the pattern, something we won't know about
4338 until after the recurse.
4340 I32 deltanext, fake = 0;
4342 struct regnode_charclass_class intrnl;
4344 /* We use SAVEFREEPV so that when the full compile
4345 is finished perl will clean up the allocated
4346 minlens when it's all done. This way we don't
4347 have to worry about freeing them when we know
4348 they wont be used, which would be a pain.
4351 Newx( minnextp, 1, I32 );
4352 SAVEFREEPV(minnextp);
4355 StructCopy(data, &data_fake, scan_data_t);
4356 if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4359 SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4360 data_fake.last_found=newSVsv(data->last_found);
4364 data_fake.last_closep = &fake;
4365 data_fake.flags = 0;
4366 data_fake.pos_delta = delta;
4368 data_fake.flags |= SF_IS_INF;
4369 if ( flags & SCF_DO_STCLASS && !scan->flags
4370 && OP(scan) == IFMATCH ) { /* Lookahead */
4371 cl_init(pRExC_state, &intrnl);
4372 data_fake.start_class = &intrnl;
4373 f |= SCF_DO_STCLASS_AND;
4375 if (flags & SCF_WHILEM_VISITED_POS)
4376 f |= SCF_WHILEM_VISITED_POS;
4377 next = regnext(scan);
4378 nscan = NEXTOPER(NEXTOPER(scan));
4380 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext,
4381 last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4384 FAIL("Variable length lookbehind not implemented");
4386 else if (*minnextp > (I32)U8_MAX) {
4387 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4389 scan->flags = (U8)*minnextp;
4394 if (f & SCF_DO_STCLASS_AND) {
4395 const int was = (data->start_class->flags & ANYOF_EOS);
4397 cl_and(data->start_class, &intrnl);
4399 data->start_class->flags |= ANYOF_EOS;
4402 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4404 if (data_fake.flags & SF_HAS_EVAL)
4405 data->flags |= SF_HAS_EVAL;
4406 data->whilem_c = data_fake.whilem_c;
4407 if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4408 if (RExC_rx->minlen<*minnextp)
4409 RExC_rx->minlen=*minnextp;
4410 SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4411 SvREFCNT_dec(data_fake.last_found);
4413 if ( data_fake.minlen_fixed != minlenp )
4415 data->offset_fixed= data_fake.offset_fixed;
4416 data->minlen_fixed= data_fake.minlen_fixed;
4417 data->lookbehind_fixed+= scan->flags;
4419 if ( data_fake.minlen_float != minlenp )
4421 data->minlen_float= data_fake.minlen_float;
4422 data->offset_float_min=data_fake.offset_float_min;
4423 data->offset_float_max=data_fake.offset_float_max;
4424 data->lookbehind_float+= scan->flags;
4433 else if (OP(scan) == OPEN) {
4434 if (stopparen != (I32)ARG(scan))
4437 else if (OP(scan) == CLOSE) {
4438 if (stopparen == (I32)ARG(scan)) {
4441 if ((I32)ARG(scan) == is_par) {
4442 next = regnext(scan);
4444 if ( next && (OP(next) != WHILEM) && next < last)
4445 is_par = 0; /* Disable optimization */
4448 *(data->last_closep) = ARG(scan);
4450 else if (OP(scan) == EVAL) {
4452 data->flags |= SF_HAS_EVAL;
4454 else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4455 if (flags & SCF_DO_SUBSTR) {
4456 SCAN_COMMIT(pRExC_state,data,minlenp);
4457 flags &= ~SCF_DO_SUBSTR;
4459 if (data && OP(scan)==ACCEPT) {
4460 data->flags |= SCF_SEEN_ACCEPT;
4465 else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4467 if (flags & SCF_DO_SUBSTR) {
4468 SCAN_COMMIT(pRExC_state,data,minlenp);
4469 data->longest = &(data->longest_float);
4471 is_inf = is_inf_internal = 1;
4472 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4473 cl_anything(pRExC_state, data->start_class);
4474 flags &= ~SCF_DO_STCLASS;
4476 else if (OP(scan) == GPOS) {
4477 if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4478 !(delta || is_inf || (data && data->pos_delta)))
4480 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4481 RExC_rx->extflags |= RXf_ANCH_GPOS;
4482 if (RExC_rx->gofs < (U32)min)
4483 RExC_rx->gofs = min;
4485 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4489 #ifdef TRIE_STUDY_OPT
4490 #ifdef FULL_TRIE_STUDY
4491 else if (PL_regkind[OP(scan)] == TRIE) {
4492 /* NOTE - There is similar code to this block above for handling
4493 BRANCH nodes on the initial study. If you change stuff here
4495 regnode *trie_node= scan;
4496 regnode *tail= regnext(scan);
4497 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4498 I32 max1 = 0, min1 = I32_MAX;
4499 struct regnode_charclass_class accum;
4501 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4502 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4503 if (flags & SCF_DO_STCLASS)
4504 cl_init_zero(pRExC_state, &accum);
4510 const regnode *nextbranch= NULL;
4513 for ( word=1 ; word <= trie->wordcount ; word++)
4515 I32 deltanext=0, minnext=0, f = 0, fake;
4516 struct regnode_charclass_class this_class;
4518 data_fake.flags = 0;
4520 data_fake.whilem_c = data->whilem_c;
4521 data_fake.last_closep = data->last_closep;
4524 data_fake.last_closep = &fake;
4525 data_fake.pos_delta = delta;
4526 if (flags & SCF_DO_STCLASS) {
4527 cl_init(pRExC_state, &this_class);
4528 data_fake.start_class = &this_class;
4529 f = SCF_DO_STCLASS_AND;
4531 if (flags & SCF_WHILEM_VISITED_POS)
4532 f |= SCF_WHILEM_VISITED_POS;
4534 if (trie->jump[word]) {
4536 nextbranch = trie_node + trie->jump[0];
4537 scan= trie_node + trie->jump[word];
4538 /* We go from the jump point to the branch that follows
4539 it. Note this means we need the vestigal unused branches
4540 even though they arent otherwise used.
4542 minnext = study_chunk(pRExC_state, &scan, minlenp,
4543 &deltanext, (regnode *)nextbranch, &data_fake,
4544 stopparen, recursed, NULL, f,depth+1);
4546 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4547 nextbranch= regnext((regnode*)nextbranch);
4549 if (min1 > (I32)(minnext + trie->minlen))
4550 min1 = minnext + trie->minlen;
4551 if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4552 max1 = minnext + deltanext + trie->maxlen;
4553 if (deltanext == I32_MAX)
4554 is_inf = is_inf_internal = 1;
4556 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4558 if (data_fake.flags & SCF_SEEN_ACCEPT) {
4559 if ( stopmin > min + min1)
4560 stopmin = min + min1;
4561 flags &= ~SCF_DO_SUBSTR;
4563 data->flags |= SCF_SEEN_ACCEPT;
4566 if (data_fake.flags & SF_HAS_EVAL)
4567 data->flags |= SF_HAS_EVAL;
4568 data->whilem_c = data_fake.whilem_c;
4570 if (flags & SCF_DO_STCLASS)
4571 cl_or(pRExC_state, &accum, &this_class);
4574 if (flags & SCF_DO_SUBSTR) {
4575 data->pos_min += min1;
4576 data->pos_delta += max1 - min1;
4577 if (max1 != min1 || is_inf)
4578 data->longest = &(data->longest_float);
4581 delta += max1 - min1;
4582 if (flags & SCF_DO_STCLASS_OR) {
4583 cl_or(pRExC_state, data->start_class, &accum);
4585 cl_and(data->start_class, and_withp);
4586 flags &= ~SCF_DO_STCLASS;
4589 else if (flags & SCF_DO_STCLASS_AND) {
4591 cl_and(data->start_class, &accum);
4592 flags &= ~SCF_DO_STCLASS;
4595 /* Switch to OR mode: cache the old value of
4596 * data->start_class */
4598 StructCopy(data->start_class, and_withp,
4599 struct regnode_charclass_class);
4600 flags &= ~SCF_DO_STCLASS_AND;
4601 StructCopy(&accum, data->start_class,
4602 struct regnode_charclass_class);
4603 flags |= SCF_DO_STCLASS_OR;
4604 data->start_class->flags |= ANYOF_EOS;
4611 else if (PL_regkind[OP(scan)] == TRIE) {
4612 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4615 min += trie->minlen;
4616 delta += (trie->maxlen - trie->minlen);
4617 flags &= ~SCF_DO_STCLASS; /* xxx */
4618 if (flags & SCF_DO_SUBSTR) {
4619 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4620 data->pos_min += trie->minlen;
4621 data->pos_delta += (trie->maxlen - trie->minlen);
4622 if (trie->maxlen != trie->minlen)
4623 data->longest = &(data->longest_float);
4625 if (trie->jump) /* no more substrings -- for now /grr*/
4626 flags &= ~SCF_DO_SUBSTR;
4628 #endif /* old or new */
4629 #endif /* TRIE_STUDY_OPT */
4631 /* Else: zero-length, ignore. */
4632 scan = regnext(scan);
4637 stopparen = frame->stop;
4638 frame = frame->prev;
4639 goto fake_study_recurse;
4644 DEBUG_STUDYDATA("pre-fin:",data,depth);
4647 *deltap = is_inf_internal ? I32_MAX : delta;
4648 if (flags & SCF_DO_SUBSTR && is_inf)
4649 data->pos_delta = I32_MAX - data->pos_min;
4650 if (is_par > (I32)U8_MAX)
4652 if (is_par && pars==1 && data) {
4653 data->flags |= SF_IN_PAR;
4654 data->flags &= ~SF_HAS_PAR;
4656 else if (pars && data) {
4657 data->flags |= SF_HAS_PAR;
4658 data->flags &= ~SF_IN_PAR;
4660 if (flags & SCF_DO_STCLASS_OR)
4661 cl_and(data->start_class, and_withp);
4662 if (flags & SCF_TRIE_RESTUDY)
4663 data->flags |= SCF_TRIE_RESTUDY;
4665 DEBUG_STUDYDATA("post-fin:",data,depth);
4667 return min < stopmin ? min : stopmin;
4671 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4673 U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4675 PERL_ARGS_ASSERT_ADD_DATA;
4677 Renewc(RExC_rxi->data,
4678 sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4679 char, struct reg_data);
4681 Renew(RExC_rxi->data->what, count + n, U8);
4683 Newx(RExC_rxi->data->what, n, U8);
4684 RExC_rxi->data->count = count + n;
4685 Copy(s, RExC_rxi->data->what + count, n, U8);
4689 /*XXX: todo make this not included in a non debugging perl */
4690 #ifndef PERL_IN_XSUB_RE
4692 Perl_reginitcolors(pTHX)
4695 const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4697 char *t = savepv(s);
4701 t = strchr(t, '\t');
4707 PL_colors[i] = t = (char *)"";
4712 PL_colors[i++] = (char *)"";
4719 #ifdef TRIE_STUDY_OPT
4720 #define CHECK_RESTUDY_GOTO \
4722 (data.flags & SCF_TRIE_RESTUDY) \
4726 #define CHECK_RESTUDY_GOTO
4730 - pregcomp - compile a regular expression into internal code
4732 * We can't allocate space until we know how big the compiled form will be,
4733 * but we can't compile it (and thus know how big it is) until we've got a
4734 * place to put the code. So we cheat: we compile it twice, once with code
4735 * generation turned off and size counting turned on, and once "for real".
4736 * This also means that we don't allocate space until we are sure that the
4737 * thing really will compile successfully, and we never have to move the
4738 * code and thus invalidate pointers into it. (Note that it has to be in
4739 * one piece because free() must be able to free it all.) [NB: not true in perl]
4741 * Beware that the optimization-preparation code in here knows about some
4742 * of the structure of the compiled regexp. [I'll say.]
4747 #ifndef PERL_IN_XSUB_RE
4748 #define RE_ENGINE_PTR &PL_core_reg_engine
4750 extern const struct regexp_engine my_reg_engine;
4751 #define RE_ENGINE_PTR &my_reg_engine
4754 #ifndef PERL_IN_XSUB_RE
4756 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4759 HV * const table = GvHV(PL_hintgv);
4761 PERL_ARGS_ASSERT_PREGCOMP;
4763 /* Dispatch a request to compile a regexp to correct
4766 SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4767 GET_RE_DEBUG_FLAGS_DECL;
4768 if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4769 const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4771 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4774 return CALLREGCOMP_ENG(eng, pattern, flags);
4777 return Perl_re_compile(aTHX_ pattern, flags);
4782 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4787 register regexp_internal *ri;
4796 /* these are all flags - maybe they should be turned
4797 * into a single int with different bit masks */
4798 I32 sawlookahead = 0;
4801 bool used_setjump = FALSE;
4802 regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4807 RExC_state_t RExC_state;
4808 RExC_state_t * const pRExC_state = &RExC_state;
4809 #ifdef TRIE_STUDY_OPT
4811 RExC_state_t copyRExC_state;
4813 GET_RE_DEBUG_FLAGS_DECL;
4815 PERL_ARGS_ASSERT_RE_COMPILE;
4817 DEBUG_r(if (!PL_colorset) reginitcolors());
4819 #ifndef PERL_IN_XSUB_RE
4820 /* Initialize these here instead of as-needed, as is quick and avoids
4821 * having to test them each time otherwise */
4822 if (! PL_AboveLatin1) {
4823 PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
4824 PL_ASCII = _new_invlist_C_array(ASCII_invlist);
4825 PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
4827 PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4828 PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4830 PL_L1PosixAlpha = _new_invlist_C_array(L1PosixAlpha_invlist);
4831 PL_PosixAlpha = _new_invlist_C_array(PosixAlpha_invlist);
4833 PL_PosixBlank = _new_invlist_C_array(PosixBlank_invlist);
4834 PL_XPosixBlank = _new_invlist_C_array(XPosixBlank_invlist);
4836 PL_L1Cased = _new_invlist_C_array(L1Cased_invlist);
4838 PL_PosixCntrl = _new_invlist_C_array(PosixCntrl_invlist);
4839 PL_XPosixCntrl = _new_invlist_C_array(XPosixCntrl_invlist);
4841 PL_PosixDigit = _new_invlist_C_array(PosixDigit_invlist);
4843 PL_L1PosixGraph = _new_invlist_C_array(L1PosixGraph_invlist);
4844 PL_PosixGraph = _new_invlist_C_array(PosixGraph_invlist);
4846 PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4847 PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4849 PL_L1PosixLower = _new_invlist_C_array(L1PosixLower_invlist);
4850 PL_PosixLower = _new_invlist_C_array(PosixLower_invlist);
4852 PL_L1PosixPrint = _new_invlist_C_array(L1PosixPrint_invlist);
4853 PL_PosixPrint = _new_invlist_C_array(PosixPrint_invlist);
4855 PL_L1PosixPunct = _new_invlist_C_array(L1PosixPunct_invlist);
4856 PL_PosixPunct = _new_invlist_C_array(PosixPunct_invlist);
4858 PL_PerlSpace = _new_invlist_C_array(PerlSpace_invlist);
4859 PL_XPerlSpace = _new_invlist_C_array(XPerlSpace_invlist);
4861 PL_PosixSpace = _new_invlist_C_array(PosixSpace_invlist);
4862 PL_XPosixSpace = _new_invlist_C_array(XPosixSpace_invlist);
4864 PL_L1PosixUpper = _new_invlist_C_array(L1PosixUpper_invlist);
4865 PL_PosixUpper = _new_invlist_C_array(PosixUpper_invlist);
4867 PL_VertSpace = _new_invlist_C_array(VertSpace_invlist);
4869 PL_PosixWord = _new_invlist_C_array(PosixWord_invlist);
4870 PL_L1PosixWord = _new_invlist_C_array(L1PosixWord_invlist);
4872 PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
4873 PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
4877 exp = SvPV(pattern, plen);
4879 if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */
4880 RExC_utf8 = RExC_orig_utf8 = 0;
4883 RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4885 RExC_uni_semantics = 0;
4886 RExC_contains_locale = 0;
4888 /****************** LONG JUMP TARGET HERE***********************/
4889 /* Longjmp back to here if have to switch in midstream to utf8 */
4890 if (! RExC_orig_utf8) {
4891 JMPENV_PUSH(jump_ret);
4892 used_setjump = TRUE;
4895 if (jump_ret == 0) { /* First time through */
4899 SV *dsv= sv_newmortal();
4900 RE_PV_QUOTED_DECL(s, RExC_utf8,
4901 dsv, exp, plen, 60);
4902 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4903 PL_colors[4],PL_colors[5],s);
4906 else { /* longjumped back */
4909 /* If the cause for the longjmp was other than changing to utf8, pop
4910 * our own setjmp, and longjmp to the correct handler */
4911 if (jump_ret != UTF8_LONGJMP) {
4913 JMPENV_JUMP(jump_ret);
4918 /* It's possible to write a regexp in ascii that represents Unicode
4919 codepoints outside of the byte range, such as via \x{100}. If we
4920 detect such a sequence we have to convert the entire pattern to utf8
4921 and then recompile, as our sizing calculation will have been based
4922 on 1 byte == 1 character, but we will need to use utf8 to encode
4923 at least some part of the pattern, and therefore must convert the whole
4926 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
4927 "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
4928 exp = (char*)Perl_bytes_to_utf8(aTHX_
4929 (U8*)SvPV_nomg(pattern, plen),
4932 RExC_orig_utf8 = RExC_utf8 = 1;
4936 #ifdef TRIE_STUDY_OPT
4940 pm_flags = orig_pm_flags;
4942 if (initial_charset == REGEX_LOCALE_CHARSET) {
4943 RExC_contains_locale = 1;
4945 else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
4947 /* Set to use unicode semantics if the pattern is in utf8 and has the
4948 * 'depends' charset specified, as it means unicode when utf8 */
4949 set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
4953 RExC_flags = pm_flags;
4957 RExC_in_lookbehind = 0;
4958 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
4959 RExC_seen_evals = 0;
4961 RExC_override_recoding = 0;
4963 /* First pass: determine size, legality. */
4971 RExC_emit = &PL_regdummy;
4972 RExC_whilem_seen = 0;
4973 RExC_open_parens = NULL;
4974 RExC_close_parens = NULL;
4976 RExC_paren_names = NULL;
4978 RExC_paren_name_list = NULL;
4980 RExC_recurse = NULL;
4981 RExC_recurse_count = 0;
4983 #if 0 /* REGC() is (currently) a NOP at the first pass.
4984 * Clever compilers notice this and complain. --jhi */
4985 REGC((U8)REG_MAGIC, (char*)RExC_emit);
4988 PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
4990 RExC_lastparse=NULL;
4992 if (reg(pRExC_state, 0, &flags,1) == NULL) {
4993 RExC_precomp = NULL;
4997 /* Here, finished first pass. Get rid of any added setjmp */
5003 PerlIO_printf(Perl_debug_log,
5004 "Required size %"IVdf" nodes\n"
5005 "Starting second pass (creation)\n",
5008 RExC_lastparse=NULL;
5011 /* The first pass could have found things that force Unicode semantics */
5012 if ((RExC_utf8 || RExC_uni_semantics)
5013 && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
5015 set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5018 /* Small enough for pointer-storage convention?
5019 If extralen==0, this means that we will not need long jumps. */
5020 if (RExC_size >= 0x10000L && RExC_extralen)
5021 RExC_size += RExC_extralen;
5024 if (RExC_whilem_seen > 15)
5025 RExC_whilem_seen = 15;
5027 /* Allocate space and zero-initialize. Note, the two step process
5028 of zeroing when in debug mode, thus anything assigned has to
5029 happen after that */
5030 rx = (REGEXP*) newSV_type(SVt_REGEXP);
5031 r = (struct regexp*)SvANY(rx);
5032 Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5033 char, regexp_internal);
5034 if ( r == NULL || ri == NULL )
5035 FAIL("Regexp out of space");
5037 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5038 Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5040 /* bulk initialize base fields with 0. */
5041 Zero(ri, sizeof(regexp_internal), char);
5044 /* non-zero initialization begins here */
5046 r->engine= RE_ENGINE_PTR;
5047 r->extflags = pm_flags;
5049 bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5050 bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5052 /* The caret is output if there are any defaults: if not all the STD
5053 * flags are set, or if no character set specifier is needed */
5055 (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5057 bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5058 U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5059 >> RXf_PMf_STD_PMMOD_SHIFT);
5060 const char *fptr = STD_PAT_MODS; /*"msix"*/
5062 /* Allocate for the worst case, which is all the std flags are turned
5063 * on. If more precision is desired, we could do a population count of
5064 * the flags set. This could be done with a small lookup table, or by
5065 * shifting, masking and adding, or even, when available, assembly
5066 * language for a machine-language population count.
5067 * We never output a minus, as all those are defaults, so are
5068 * covered by the caret */
5069 const STRLEN wraplen = plen + has_p + has_runon
5070 + has_default /* If needs a caret */
5072 /* If needs a character set specifier */
5073 + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5074 + (sizeof(STD_PAT_MODS) - 1)
5075 + (sizeof("(?:)") - 1);
5077 p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
5079 SvFLAGS(rx) |= SvUTF8(pattern);
5082 /* If a default, cover it using the caret */
5084 *p++= DEFAULT_PAT_MOD;
5088 const char* const name = get_regex_charset_name(r->extflags, &len);
5089 Copy(name, p, len, char);
5093 *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5096 while((ch = *fptr++)) {
5104 Copy(RExC_precomp, p, plen, char);
5105 assert ((RX_WRAPPED(rx) - p) < 16);
5106 r->pre_prefix = p - RX_WRAPPED(rx);
5112 SvCUR_set(rx, p - SvPVX_const(rx));
5116 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5118 if (RExC_seen & REG_SEEN_RECURSE) {
5119 Newxz(RExC_open_parens, RExC_npar,regnode *);
5120 SAVEFREEPV(RExC_open_parens);
5121 Newxz(RExC_close_parens,RExC_npar,regnode *);
5122 SAVEFREEPV(RExC_close_parens);
5125 /* Useful during FAIL. */
5126 #ifdef RE_TRACK_PATTERN_OFFSETS
5127 Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5128 DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5129 "%s %"UVuf" bytes for offset annotations.\n",
5130 ri->u.offsets ? "Got" : "Couldn't get",
5131 (UV)((2*RExC_size+1) * sizeof(U32))));
5133 SetProgLen(ri,RExC_size);
5137 REH_CALL_COMP_BEGIN_HOOK(pRExC_state->rx);
5139 /* Second pass: emit code. */
5140 RExC_flags = pm_flags; /* don't let top level (?i) bleed */
5145 RExC_emit_start = ri->program;
5146 RExC_emit = ri->program;
5147 RExC_emit_bound = ri->program + RExC_size + 1;
5149 /* Store the count of eval-groups for security checks: */
5150 RExC_rx->seen_evals = RExC_seen_evals;
5151 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5152 if (reg(pRExC_state, 0, &flags,1) == NULL) {
5156 /* XXXX To minimize changes to RE engine we always allocate
5157 3-units-long substrs field. */
5158 Newx(r->substrs, 1, struct reg_substr_data);
5159 if (RExC_recurse_count) {
5160 Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5161 SAVEFREEPV(RExC_recurse);
5165 r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
5166 Zero(r->substrs, 1, struct reg_substr_data);
5168 #ifdef TRIE_STUDY_OPT
5170 StructCopy(&zero_scan_data, &data, scan_data_t);
5171 copyRExC_state = RExC_state;
5174 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
5176 RExC_state = copyRExC_state;
5177 if (seen & REG_TOP_LEVEL_BRANCHES)
5178 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5180 RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
5181 if (data.last_found) {
5182 SvREFCNT_dec(data.longest_fixed);
5183 SvREFCNT_dec(data.longest_float);
5184 SvREFCNT_dec(data.last_found);
5186 StructCopy(&zero_scan_data, &data, scan_data_t);
5189 StructCopy(&zero_scan_data, &data, scan_data_t);
5192 /* Dig out information for optimizations. */
5193 r->extflags = RExC_flags; /* was pm_op */
5194 /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
5197 SvUTF8_on(rx); /* Unicode in it? */
5198 ri->regstclass = NULL;
5199 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
5200 r->intflags |= PREGf_NAUGHTY;
5201 scan = ri->program + 1; /* First BRANCH. */
5203 /* testing for BRANCH here tells us whether there is "must appear"
5204 data in the pattern. If there is then we can use it for optimisations */
5205 if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */
5207 STRLEN longest_float_length, longest_fixed_length;
5208 struct regnode_charclass_class ch_class; /* pointed to by data */
5210 I32 last_close = 0; /* pointed to by data */
5211 regnode *first= scan;
5212 regnode *first_next= regnext(first);
5214 * Skip introductions and multiplicators >= 1
5215 * so that we can extract the 'meat' of the pattern that must
5216 * match in the large if() sequence following.
5217 * NOTE that EXACT is NOT covered here, as it is normally
5218 * picked up by the optimiser separately.
5220 * This is unfortunate as the optimiser isnt handling lookahead
5221 * properly currently.
5224 while ((OP(first) == OPEN && (sawopen = 1)) ||
5225 /* An OR of *one* alternative - should not happen now. */
5226 (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
5227 /* for now we can't handle lookbehind IFMATCH*/
5228 (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
5229 (OP(first) == PLUS) ||
5230 (OP(first) == MINMOD) ||
5231 /* An {n,m} with n>0 */
5232 (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
5233 (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
5236 * the only op that could be a regnode is PLUS, all the rest
5237 * will be regnode_1 or regnode_2.
5240 if (OP(first) == PLUS)
5243 first += regarglen[OP(first)];
5245 first = NEXTOPER(first);
5246 first_next= regnext(first);
5249 /* Starting-point info. */
5251 DEBUG_PEEP("first:",first,0);
5252 /* Ignore EXACT as we deal with it later. */
5253 if (PL_regkind[OP(first)] == EXACT) {
5254 if (OP(first) == EXACT)
5255 NOOP; /* Empty, get anchored substr later. */
5257 ri->regstclass = first;
5260 else if (PL_regkind[OP(first)] == TRIE &&
5261 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
5264 /* this can happen only on restudy */
5265 if ( OP(first) == TRIE ) {
5266 struct regnode_1 *trieop = (struct regnode_1 *)
5267 PerlMemShared_calloc(1, sizeof(struct regnode_1));
5268 StructCopy(first,trieop,struct regnode_1);
5269 trie_op=(regnode *)trieop;
5271 struct regnode_charclass *trieop = (struct regnode_charclass *)
5272 PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
5273 StructCopy(first,trieop,struct regnode_charclass);
5274 trie_op=(regnode *)trieop;
5277 make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
5278 ri->regstclass = trie_op;
5281 else if (REGNODE_SIMPLE(OP(first)))
5282 ri->regstclass = first;
5283 else if (PL_regkind[OP(first)] == BOUND ||
5284 PL_regkind[OP(first)] == NBOUND)
5285 ri->regstclass = first;
5286 else if (PL_regkind[OP(first)] == BOL) {
5287 r->extflags |= (OP(first) == MBOL
5289 : (OP(first) == SBOL
5292 first = NEXTOPER(first);
5295 else if (OP(first) == GPOS) {
5296 r->extflags |= RXf_ANCH_GPOS;
5297 first = NEXTOPER(first);
5300 else if ((!sawopen || !RExC_sawback) &&
5301 (OP(first) == STAR &&
5302 PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
5303 !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
5305 /* turn .* into ^.* with an implied $*=1 */
5307 (OP(NEXTOPER(first)) == REG_ANY)
5310 r->extflags |= type;
5311 r->intflags |= PREGf_IMPLICIT;
5312 first = NEXTOPER(first);
5315 if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
5316 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
5317 /* x+ must match at the 1st pos of run of x's */
5318 r->intflags |= PREGf_SKIP;
5320 /* Scan is after the zeroth branch, first is atomic matcher. */
5321 #ifdef TRIE_STUDY_OPT
5324 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5325 (IV)(first - scan + 1))
5329 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5330 (IV)(first - scan + 1))
5336 * If there's something expensive in the r.e., find the
5337 * longest literal string that must appear and make it the
5338 * regmust. Resolve ties in favor of later strings, since
5339 * the regstart check works with the beginning of the r.e.
5340 * and avoiding duplication strengthens checking. Not a
5341 * strong reason, but sufficient in the absence of others.
5342 * [Now we resolve ties in favor of the earlier string if
5343 * it happens that c_offset_min has been invalidated, since the
5344 * earlier string may buy us something the later one won't.]
5347 data.longest_fixed = newSVpvs("");
5348 data.longest_float = newSVpvs("");
5349 data.last_found = newSVpvs("");
5350 data.longest = &(data.longest_fixed);
5352 if (!ri->regstclass) {
5353 cl_init(pRExC_state, &ch_class);
5354 data.start_class = &ch_class;
5355 stclass_flag = SCF_DO_STCLASS_AND;
5356 } else /* XXXX Check for BOUND? */
5358 data.last_closep = &last_close;
5360 minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5361 &data, -1, NULL, NULL,
5362 SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5368 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5369 && data.last_start_min == 0 && data.last_end > 0
5370 && !RExC_seen_zerolen
5371 && !(RExC_seen & REG_SEEN_VERBARG)
5372 && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5373 r->extflags |= RXf_CHECK_ALL;
5374 scan_commit(pRExC_state, &data,&minlen,0);
5375 SvREFCNT_dec(data.last_found);
5377 /* Note that code very similar to this but for anchored string
5378 follows immediately below, changes may need to be made to both.
5381 longest_float_length = CHR_SVLEN(data.longest_float);
5382 if (longest_float_length
5383 || (data.flags & SF_FL_BEFORE_EOL
5384 && (!(data.flags & SF_FL_BEFORE_MEOL)
5385 || (RExC_flags & RXf_PMf_MULTILINE))))
5389 /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5390 if ((RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5391 || (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
5392 && data.offset_fixed == data.offset_float_min
5393 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
5394 goto remove_float; /* As in (a)+. */
5396 /* copy the information about the longest float from the reg_scan_data
5397 over to the program. */
5398 if (SvUTF8(data.longest_float)) {
5399 r->float_utf8 = data.longest_float;
5400 r->float_substr = NULL;
5402 r->float_substr = data.longest_float;
5403 r->float_utf8 = NULL;
5405 /* float_end_shift is how many chars that must be matched that
5406 follow this item. We calculate it ahead of time as once the
5407 lookbehind offset is added in we lose the ability to correctly
5409 ml = data.minlen_float ? *(data.minlen_float)
5410 : (I32)longest_float_length;
5411 r->float_end_shift = ml - data.offset_float_min
5412 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5413 + data.lookbehind_float;
5414 r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5415 r->float_max_offset = data.offset_float_max;
5416 if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5417 r->float_max_offset -= data.lookbehind_float;
5419 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5420 && (!(data.flags & SF_FL_BEFORE_MEOL)
5421 || (RExC_flags & RXf_PMf_MULTILINE)));
5422 fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5426 r->float_substr = r->float_utf8 = NULL;
5427 SvREFCNT_dec(data.longest_float);
5428 longest_float_length = 0;
5431 /* Note that code very similar to this but for floating string
5432 is immediately above, changes may need to be made to both.
5435 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5437 /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5438 if (! (RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5439 && (longest_fixed_length
5440 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5441 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5442 || (RExC_flags & RXf_PMf_MULTILINE)))) )
5446 /* copy the information about the longest fixed
5447 from the reg_scan_data over to the program. */
5448 if (SvUTF8(data.longest_fixed)) {
5449 r->anchored_utf8 = data.longest_fixed;
5450 r->anchored_substr = NULL;
5452 r->anchored_substr = data.longest_fixed;
5453 r->anchored_utf8 = NULL;
5455 /* fixed_end_shift is how many chars that must be matched that
5456 follow this item. We calculate it ahead of time as once the
5457 lookbehind offset is added in we lose the ability to correctly
5459 ml = data.minlen_fixed ? *(data.minlen_fixed)
5460 : (I32)longest_fixed_length;
5461 r->anchored_end_shift = ml - data.offset_fixed
5462 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5463 + data.lookbehind_fixed;
5464 r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5466 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5467 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5468 || (RExC_flags & RXf_PMf_MULTILINE)));
5469 fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5472 r->anchored_substr = r->anchored_utf8 = NULL;
5473 SvREFCNT_dec(data.longest_fixed);
5474 longest_fixed_length = 0;
5477 && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5478 ri->regstclass = NULL;
5480 if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5482 && !(data.start_class->flags & ANYOF_EOS)
5483 && !cl_is_anything(data.start_class))
5485 const U32 n = add_data(pRExC_state, 1, "f");
5486 data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5488 Newx(RExC_rxi->data->data[n], 1,
5489 struct regnode_charclass_class);
5490 StructCopy(data.start_class,
5491 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5492 struct regnode_charclass_class);
5493 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5494 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5495 DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5496 regprop(r, sv, (regnode*)data.start_class);
5497 PerlIO_printf(Perl_debug_log,
5498 "synthetic stclass \"%s\".\n",
5499 SvPVX_const(sv));});
5502 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5503 if (longest_fixed_length > longest_float_length) {
5504 r->check_end_shift = r->anchored_end_shift;
5505 r->check_substr = r->anchored_substr;
5506 r->check_utf8 = r->anchored_utf8;
5507 r->check_offset_min = r->check_offset_max = r->anchored_offset;
5508 if (r->extflags & RXf_ANCH_SINGLE)
5509 r->extflags |= RXf_NOSCAN;
5512 r->check_end_shift = r->float_end_shift;
5513 r->check_substr = r->float_substr;
5514 r->check_utf8 = r->float_utf8;
5515 r->check_offset_min = r->float_min_offset;
5516 r->check_offset_max = r->float_max_offset;
5518 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5519 This should be changed ASAP! */
5520 if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5521 r->extflags |= RXf_USE_INTUIT;
5522 if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5523 r->extflags |= RXf_INTUIT_TAIL;
5525 /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5526 if ( (STRLEN)minlen < longest_float_length )
5527 minlen= longest_float_length;
5528 if ( (STRLEN)minlen < longest_fixed_length )
5529 minlen= longest_fixed_length;
5533 /* Several toplevels. Best we can is to set minlen. */
5535 struct regnode_charclass_class ch_class;
5538 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5540 scan = ri->program + 1;
5541 cl_init(pRExC_state, &ch_class);
5542 data.start_class = &ch_class;
5543 data.last_closep = &last_close;
5546 minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5547 &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5551 r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5552 = r->float_substr = r->float_utf8 = NULL;
5554 if (!(data.start_class->flags & ANYOF_EOS)
5555 && !cl_is_anything(data.start_class))
5557 const U32 n = add_data(pRExC_state, 1, "f");
5558 data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5560 Newx(RExC_rxi->data->data[n], 1,
5561 struct regnode_charclass_class);
5562 StructCopy(data.start_class,
5563 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5564 struct regnode_charclass_class);
5565 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5566 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5567 DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5568 regprop(r, sv, (regnode*)data.start_class);
5569 PerlIO_printf(Perl_debug_log,
5570 "synthetic stclass \"%s\".\n",
5571 SvPVX_const(sv));});
5575 /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5576 the "real" pattern. */
5578 PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5579 (IV)minlen, (IV)r->minlen);
5581 r->minlenret = minlen;
5582 if (r->minlen < minlen)
5585 if (RExC_seen & REG_SEEN_GPOS)
5586 r->extflags |= RXf_GPOS_SEEN;
5587 if (RExC_seen & REG_SEEN_LOOKBEHIND)
5588 r->extflags |= RXf_LOOKBEHIND_SEEN;
5589 if (RExC_seen & REG_SEEN_EVAL)
5590 r->extflags |= RXf_EVAL_SEEN;
5591 if (RExC_seen & REG_SEEN_CANY)
5592 r->extflags |= RXf_CANY_SEEN;
5593 if (RExC_seen & REG_SEEN_VERBARG)
5594 r->intflags |= PREGf_VERBARG_SEEN;
5595 if (RExC_seen & REG_SEEN_CUTGROUP)
5596 r->intflags |= PREGf_CUTGROUP_SEEN;
5597 if (RExC_paren_names)
5598 RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5600 RXp_PAREN_NAMES(r) = NULL;
5602 #ifdef STUPID_PATTERN_CHECKS
5603 if (RX_PRELEN(rx) == 0)
5604 r->extflags |= RXf_NULL;
5605 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5606 /* XXX: this should happen BEFORE we compile */
5607 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5608 else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5609 r->extflags |= RXf_WHITE;
5610 else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5611 r->extflags |= RXf_START_ONLY;
5613 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5614 /* XXX: this should happen BEFORE we compile */
5615 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5617 regnode *first = ri->program + 1;
5620 if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5621 r->extflags |= RXf_NULL;
5622 else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5623 r->extflags |= RXf_START_ONLY;
5624 else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5625 && OP(regnext(first)) == END)
5626 r->extflags |= RXf_WHITE;
5630 if (RExC_paren_names) {
5631 ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5632 ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5635 ri->name_list_idx = 0;
5637 if (RExC_recurse_count) {
5638 for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5639 const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5640 ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5643 Newxz(r->offs, RExC_npar, regexp_paren_pair);
5644 /* assume we don't need to swap parens around before we match */
5647 PerlIO_printf(Perl_debug_log,"Final program:\n");
5650 #ifdef RE_TRACK_PATTERN_OFFSETS
5651 DEBUG_OFFSETS_r(if (ri->u.offsets) {
5652 const U32 len = ri->u.offsets[0];
5654 GET_RE_DEBUG_FLAGS_DECL;
5655 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5656 for (i = 1; i <= len; i++) {
5657 if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5658 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5659 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5661 PerlIO_printf(Perl_debug_log, "\n");
5667 #undef RE_ENGINE_PTR
5671 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5674 PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5676 PERL_UNUSED_ARG(value);
5678 if (flags & RXapif_FETCH) {
5679 return reg_named_buff_fetch(rx, key, flags);
5680 } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5681 Perl_croak_no_modify(aTHX);
5683 } else if (flags & RXapif_EXISTS) {
5684 return reg_named_buff_exists(rx, key, flags)
5687 } else if (flags & RXapif_REGNAMES) {
5688 return reg_named_buff_all(rx, flags);
5689 } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5690 return reg_named_buff_scalar(rx, flags);
5692 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5698 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5701 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5702 PERL_UNUSED_ARG(lastkey);
5704 if (flags & RXapif_FIRSTKEY)
5705 return reg_named_buff_firstkey(rx, flags);
5706 else if (flags & RXapif_NEXTKEY)
5707 return reg_named_buff_nextkey(rx, flags);
5709 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5715 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5718 AV *retarray = NULL;
5720 struct regexp *const rx = (struct regexp *)SvANY(r);
5722 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5724 if (flags & RXapif_ALL)
5727 if (rx && RXp_PAREN_NAMES(rx)) {
5728 HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5731 SV* sv_dat=HeVAL(he_str);
5732 I32 *nums=(I32*)SvPVX(sv_dat);
5733 for ( i=0; i<SvIVX(sv_dat); i++ ) {
5734 if ((I32)(rx->nparens) >= nums[i]
5735 && rx->offs[nums[i]].start != -1
5736 && rx->offs[nums[i]].end != -1)
5739 CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5744 ret = newSVsv(&PL_sv_undef);
5747 av_push(retarray, ret);
5750 return newRV_noinc(MUTABLE_SV(retarray));
5757 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5760 struct regexp *const rx = (struct regexp *)SvANY(r);
5762 PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5764 if (rx && RXp_PAREN_NAMES(rx)) {
5765 if (flags & RXapif_ALL) {
5766 return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5768 SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5782 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5784 struct regexp *const rx = (struct regexp *)SvANY(r);
5786 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5788 if ( rx && RXp_PAREN_NAMES(rx) ) {
5789 (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5791 return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5798 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5800 struct regexp *const rx = (struct regexp *)SvANY(r);
5801 GET_RE_DEBUG_FLAGS_DECL;
5803 PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5805 if (rx && RXp_PAREN_NAMES(rx)) {
5806 HV *hv = RXp_PAREN_NAMES(rx);
5808 while ( (temphe = hv_iternext_flags(hv,0)) ) {
5811 SV* sv_dat = HeVAL(temphe);
5812 I32 *nums = (I32*)SvPVX(sv_dat);
5813 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5814 if ((I32)(rx->lastparen) >= nums[i] &&
5815 rx->offs[nums[i]].start != -1 &&
5816 rx->offs[nums[i]].end != -1)
5822 if (parno || flags & RXapif_ALL) {
5823 return newSVhek(HeKEY_hek(temphe));
5831 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5836 struct regexp *const rx = (struct regexp *)SvANY(r);
5838 PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5840 if (rx && RXp_PAREN_NAMES(rx)) {
5841 if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5842 return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5843 } else if (flags & RXapif_ONE) {
5844 ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5845 av = MUTABLE_AV(SvRV(ret));
5846 length = av_len(av);
5848 return newSViv(length + 1);
5850 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5854 return &PL_sv_undef;
5858 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5860 struct regexp *const rx = (struct regexp *)SvANY(r);
5863 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5865 if (rx && RXp_PAREN_NAMES(rx)) {
5866 HV *hv= RXp_PAREN_NAMES(rx);
5868 (void)hv_iterinit(hv);
5869 while ( (temphe = hv_iternext_flags(hv,0)) ) {
5872 SV* sv_dat = HeVAL(temphe);
5873 I32 *nums = (I32*)SvPVX(sv_dat);
5874 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5875 if ((I32)(rx->lastparen) >= nums[i] &&
5876 rx->offs[nums[i]].start != -1 &&
5877 rx->offs[nums[i]].end != -1)
5883 if (parno || flags & RXapif_ALL) {
5884 av_push(av, newSVhek(HeKEY_hek(temphe)));
5889 return newRV_noinc(MUTABLE_SV(av));
5893 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5896 struct regexp *const rx = (struct regexp *)SvANY(r);
5901 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5904 sv_setsv(sv,&PL_sv_undef);
5908 if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5910 i = rx->offs[0].start;
5914 if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5916 s = rx->subbeg + rx->offs[0].end;
5917 i = rx->sublen - rx->offs[0].end;
5920 if ( 0 <= paren && paren <= (I32)rx->nparens &&
5921 (s1 = rx->offs[paren].start) != -1 &&
5922 (t1 = rx->offs[paren].end) != -1)
5926 s = rx->subbeg + s1;
5928 sv_setsv(sv,&PL_sv_undef);
5931 assert(rx->sublen >= (s - rx->subbeg) + i );
5933 const int oldtainted = PL_tainted;
5935 sv_setpvn(sv, s, i);
5936 PL_tainted = oldtainted;
5937 if ( (rx->extflags & RXf_CANY_SEEN)
5938 ? (RXp_MATCH_UTF8(rx)
5939 && (!i || is_utf8_string((U8*)s, i)))
5940 : (RXp_MATCH_UTF8(rx)) )
5947 if (RXp_MATCH_TAINTED(rx)) {
5948 if (SvTYPE(sv) >= SVt_PVMG) {
5949 MAGIC* const mg = SvMAGIC(sv);
5952 SvMAGIC_set(sv, mg->mg_moremagic);
5954 if ((mgt = SvMAGIC(sv))) {
5955 mg->mg_moremagic = mgt;
5956 SvMAGIC_set(sv, mg);
5966 sv_setsv(sv,&PL_sv_undef);
5972 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
5973 SV const * const value)
5975 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
5977 PERL_UNUSED_ARG(rx);
5978 PERL_UNUSED_ARG(paren);
5979 PERL_UNUSED_ARG(value);
5982 Perl_croak_no_modify(aTHX);
5986 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
5989 struct regexp *const rx = (struct regexp *)SvANY(r);
5993 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
5995 /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
5997 /* $` / ${^PREMATCH} */
5998 case RX_BUFF_IDX_PREMATCH:
5999 if (rx->offs[0].start != -1) {
6000 i = rx->offs[0].start;
6008 /* $' / ${^POSTMATCH} */
6009 case RX_BUFF_IDX_POSTMATCH:
6010 if (rx->offs[0].end != -1) {
6011 i = rx->sublen - rx->offs[0].end;
6013 s1 = rx->offs[0].end;
6019 /* $& / ${^MATCH}, $1, $2, ... */
6021 if (paren <= (I32)rx->nparens &&
6022 (s1 = rx->offs[paren].start) != -1 &&
6023 (t1 = rx->offs[paren].end) != -1)
6028 if (ckWARN(WARN_UNINITIALIZED))
6029 report_uninit((const SV *)sv);
6034 if (i > 0 && RXp_MATCH_UTF8(rx)) {
6035 const char * const s = rx->subbeg + s1;
6040 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6047 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6049 PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6050 PERL_UNUSED_ARG(rx);
6054 return newSVpvs("Regexp");
6057 /* Scans the name of a named buffer from the pattern.
6058 * If flags is REG_RSN_RETURN_NULL returns null.
6059 * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6060 * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6061 * to the parsed name as looked up in the RExC_paren_names hash.
6062 * If there is an error throws a vFAIL().. type exception.
6065 #define REG_RSN_RETURN_NULL 0
6066 #define REG_RSN_RETURN_NAME 1
6067 #define REG_RSN_RETURN_DATA 2
6070 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6072 char *name_start = RExC_parse;
6074 PERL_ARGS_ASSERT_REG_SCAN_NAME;
6076 if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6077 /* skip IDFIRST by using do...while */
6080 RExC_parse += UTF8SKIP(RExC_parse);
6081 } while (isALNUM_utf8((U8*)RExC_parse));
6085 } while (isALNUM(*RExC_parse));
6090 = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6091 SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6092 if ( flags == REG_RSN_RETURN_NAME)
6094 else if (flags==REG_RSN_RETURN_DATA) {
6097 if ( ! sv_name ) /* should not happen*/
6098 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6099 if (RExC_paren_names)
6100 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6102 sv_dat = HeVAL(he_str);
6104 vFAIL("Reference to nonexistent named group");
6108 Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6109 (unsigned long) flags);
6116 #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
6117 int rem=(int)(RExC_end - RExC_parse); \
6126 if (RExC_lastparse!=RExC_parse) \
6127 PerlIO_printf(Perl_debug_log," >%.*s%-*s", \
6130 iscut ? "..." : "<" \
6133 PerlIO_printf(Perl_debug_log,"%16s",""); \
6136 num = RExC_size + 1; \
6138 num=REG_NODE_NUM(RExC_emit); \
6139 if (RExC_lastnum!=num) \
6140 PerlIO_printf(Perl_debug_log,"|%4d",num); \
6142 PerlIO_printf(Perl_debug_log,"|%4s",""); \
6143 PerlIO_printf(Perl_debug_log,"|%*s%-4s", \
6144 (int)((depth*2)), "", \
6148 RExC_lastparse=RExC_parse; \
6153 #define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
6154 DEBUG_PARSE_MSG((funcname)); \
6155 PerlIO_printf(Perl_debug_log,"%4s","\n"); \
6157 #define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({ \
6158 DEBUG_PARSE_MSG((funcname)); \
6159 PerlIO_printf(Perl_debug_log,fmt "\n",args); \
6162 /* This section of code defines the inversion list object and its methods. The
6163 * interfaces are highly subject to change, so as much as possible is static to
6164 * this file. An inversion list is here implemented as a malloc'd C UV array
6165 * with some added info that is placed as UVs at the beginning in a header
6166 * portion. An inversion list for Unicode is an array of code points, sorted
6167 * by ordinal number. The zeroth element is the first code point in the list.
6168 * The 1th element is the first element beyond that not in the list. In other
6169 * words, the first range is
6170 * invlist[0]..(invlist[1]-1)
6171 * The other ranges follow. Thus every element whose index is divisible by two
6172 * marks the beginning of a range that is in the list, and every element not
6173 * divisible by two marks the beginning of a range not in the list. A single
6174 * element inversion list that contains the single code point N generally
6175 * consists of two elements
6178 * (The exception is when N is the highest representable value on the
6179 * machine, in which case the list containing just it would be a single
6180 * element, itself. By extension, if the last range in the list extends to
6181 * infinity, then the first element of that range will be in the inversion list
6182 * at a position that is divisible by two, and is the final element in the
6184 * Taking the complement (inverting) an inversion list is quite simple, if the
6185 * first element is 0, remove it; otherwise add a 0 element at the beginning.
6186 * This implementation reserves an element at the beginning of each inversion list
6187 * to contain 0 when the list contains 0, and contains 1 otherwise. The actual
6188 * beginning of the list is either that element if 0, or the next one if 1.
6190 * More about inversion lists can be found in "Unicode Demystified"
6191 * Chapter 13 by Richard Gillam, published by Addison-Wesley.
6192 * More will be coming when functionality is added later.
6194 * The inversion list data structure is currently implemented as an SV pointing
6195 * to an array of UVs that the SV thinks are bytes. This allows us to have an
6196 * array of UV whose memory management is automatically handled by the existing
6197 * facilities for SV's.
6199 * Some of the methods should always be private to the implementation, and some
6200 * should eventually be made public */
6202 #define INVLIST_LEN_OFFSET 0 /* Number of elements in the inversion list */
6203 #define INVLIST_ITER_OFFSET 1 /* Current iteration position */
6205 /* This is a combination of a version and data structure type, so that one
6206 * being passed in can be validated to be an inversion list of the correct
6207 * vintage. When the structure of the header is changed, a new random number
6208 * in the range 2**31-1 should be generated and the new() method changed to
6209 * insert that at this location. Then, if an auxiliary program doesn't change
6210 * correspondingly, it will be discovered immediately */
6211 #define INVLIST_VERSION_ID_OFFSET 2
6212 #define INVLIST_VERSION_ID 1064334010
6214 /* For safety, when adding new elements, remember to #undef them at the end of
6215 * the inversion list code section */
6217 #define INVLIST_ZERO_OFFSET 3 /* 0 or 1; must be last element in header */
6218 /* The UV at position ZERO contains either 0 or 1. If 0, the inversion list
6219 * contains the code point U+00000, and begins here. If 1, the inversion list
6220 * doesn't contain U+0000, and it begins at the next UV in the array.
6221 * Inverting an inversion list consists of adding or removing the 0 at the
6222 * beginning of it. By reserving a space for that 0, inversion can be made
6225 #define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
6227 /* Internally things are UVs */
6228 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
6229 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
6231 #define INVLIST_INITIAL_LEN 10
6233 PERL_STATIC_INLINE UV*
6234 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
6236 /* Returns a pointer to the first element in the inversion list's array.
6237 * This is called upon initialization of an inversion list. Where the
6238 * array begins depends on whether the list has the code point U+0000
6239 * in it or not. The other parameter tells it whether the code that
6240 * follows this call is about to put a 0 in the inversion list or not.
6241 * The first element is either the element with 0, if 0, or the next one,
6244 UV* zero = get_invlist_zero_addr(invlist);
6246 PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
6249 assert(! *get_invlist_len_addr(invlist));
6251 /* 1^1 = 0; 1^0 = 1 */
6252 *zero = 1 ^ will_have_0;
6253 return zero + *zero;
6256 PERL_STATIC_INLINE UV*
6257 S_invlist_array(pTHX_ SV* const invlist)
6259 /* Returns the pointer to the inversion list's array. Every time the
6260 * length changes, this needs to be called in case malloc or realloc moved
6263 PERL_ARGS_ASSERT_INVLIST_ARRAY;
6265 /* Must not be empty. If these fail, you probably didn't check for <len>
6266 * being non-zero before trying to get the array */
6267 assert(*get_invlist_len_addr(invlist));
6268 assert(*get_invlist_zero_addr(invlist) == 0
6269 || *get_invlist_zero_addr(invlist) == 1);
6271 /* The array begins either at the element reserved for zero if the
6272 * list contains 0 (that element will be set to 0), or otherwise the next
6273 * element (in which case the reserved element will be set to 1). */
6274 return (UV *) (get_invlist_zero_addr(invlist)
6275 + *get_invlist_zero_addr(invlist));
6278 PERL_STATIC_INLINE UV*
6279 S_get_invlist_len_addr(pTHX_ SV* invlist)
6281 /* Return the address of the UV that contains the current number
6282 * of used elements in the inversion list */
6284 PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
6286 return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
6289 PERL_STATIC_INLINE UV
6290 S_invlist_len(pTHX_ SV* const invlist)
6292 /* Returns the current number of elements stored in the inversion list's
6295 PERL_ARGS_ASSERT_INVLIST_LEN;
6297 return *get_invlist_len_addr(invlist);
6300 PERL_STATIC_INLINE void
6301 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
6303 /* Sets the current number of elements stored in the inversion list */
6305 PERL_ARGS_ASSERT_INVLIST_SET_LEN;
6307 *get_invlist_len_addr(invlist) = len;
6309 assert(len <= SvLEN(invlist));
6311 SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
6312 /* If the list contains U+0000, that element is part of the header,
6313 * and should not be counted as part of the array. It will contain
6314 * 0 in that case, and 1 otherwise. So we could flop 0=>1, 1=>0 and
6316 * SvCUR_set(invlist,
6317 * TO_INTERNAL_SIZE(len
6318 * - (*get_invlist_zero_addr(inv_list) ^ 1)));
6319 * But, this is only valid if len is not 0. The consequences of not doing
6320 * this is that the memory allocation code may think that 1 more UV is
6321 * being used than actually is, and so might do an unnecessary grow. That
6322 * seems worth not bothering to make this the precise amount.
6324 * Note that when inverting, SvCUR shouldn't change */
6327 PERL_STATIC_INLINE UV
6328 S_invlist_max(pTHX_ SV* const invlist)
6330 /* Returns the maximum number of elements storable in the inversion list's
6331 * array, without having to realloc() */
6333 PERL_ARGS_ASSERT_INVLIST_MAX;
6335 return FROM_INTERNAL_SIZE(SvLEN(invlist));
6338 PERL_STATIC_INLINE UV*
6339 S_get_invlist_zero_addr(pTHX_ SV* invlist)
6341 /* Return the address of the UV that is reserved to hold 0 if the inversion
6342 * list contains 0. This has to be the last element of the heading, as the
6343 * list proper starts with either it if 0, or the next element if not.
6344 * (But we force it to contain either 0 or 1) */
6346 PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
6348 return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
6351 #ifndef PERL_IN_XSUB_RE
6353 Perl__new_invlist(pTHX_ IV initial_size)
6356 /* Return a pointer to a newly constructed inversion list, with enough
6357 * space to store 'initial_size' elements. If that number is negative, a
6358 * system default is used instead */
6362 if (initial_size < 0) {
6363 initial_size = INVLIST_INITIAL_LEN;
6366 /* Allocate the initial space */
6367 new_list = newSV(TO_INTERNAL_SIZE(initial_size));
6368 invlist_set_len(new_list, 0);
6370 /* Force iterinit() to be used to get iteration to work */
6371 *get_invlist_iter_addr(new_list) = UV_MAX;
6373 /* This should force a segfault if a method doesn't initialize this
6375 *get_invlist_zero_addr(new_list) = UV_MAX;
6377 *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
6378 #if HEADER_LENGTH != 4
6379 # error Need to regenerate VERSION_ID by running perl -E 'say int(rand 2**31-1)', and then changing the #if to the new length
6387 S__new_invlist_C_array(pTHX_ UV* list)
6389 /* Return a pointer to a newly constructed inversion list, initialized to
6390 * point to <list>, which has to be in the exact correct inversion list
6391 * form, including internal fields. Thus this is a dangerous routine that
6392 * should not be used in the wrong hands */
6394 SV* invlist = newSV_type(SVt_PV);
6396 PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
6398 SvPV_set(invlist, (char *) list);
6399 SvLEN_set(invlist, 0); /* Means we own the contents, and the system
6400 shouldn't touch it */
6401 SvCUR_set(invlist, TO_INTERNAL_SIZE(invlist_len(invlist)));
6403 if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
6404 Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
6411 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
6413 /* Grow the maximum size of an inversion list */
6415 PERL_ARGS_ASSERT_INVLIST_EXTEND;
6417 SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
6420 PERL_STATIC_INLINE void
6421 S_invlist_trim(pTHX_ SV* const invlist)
6423 PERL_ARGS_ASSERT_INVLIST_TRIM;
6425 /* Change the length of the inversion list to how many entries it currently
6428 SvPV_shrink_to_cur((SV *) invlist);
6431 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
6433 #define ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
6434 #define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(i))
6436 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
6438 #ifndef PERL_IN_XSUB_RE
6440 Perl__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
6442 /* Subject to change or removal. Append the range from 'start' to 'end' at
6443 * the end of the inversion list. The range must be above any existing
6447 UV max = invlist_max(invlist);
6448 UV len = invlist_len(invlist);
6450 PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
6452 if (len == 0) { /* Empty lists must be initialized */
6453 array = _invlist_array_init(invlist, start == 0);
6456 /* Here, the existing list is non-empty. The current max entry in the
6457 * list is generally the first value not in the set, except when the
6458 * set extends to the end of permissible values, in which case it is
6459 * the first entry in that final set, and so this call is an attempt to
6460 * append out-of-order */
6462 UV final_element = len - 1;
6463 array = invlist_array(invlist);
6464 if (array[final_element] > start
6465 || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
6467 Perl_croak(aTHX_ "panic: attempting to append to an inversion list, but wasn't at the end of the list, final=%"UVuf", start=%"UVuf", match=%c",
6468 array[final_element], start,
6469 ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
6472 /* Here, it is a legal append. If the new range begins with the first
6473 * value not in the set, it is extending the set, so the new first
6474 * value not in the set is one greater than the newly extended range.
6476 if (array[final_element] == start) {
6477 if (end != UV_MAX) {
6478 array[final_element] = end + 1;
6481 /* But if the end is the maximum representable on the machine,
6482 * just let the range that this would extend to have no end */
6483 invlist_set_len(invlist, len - 1);
6489 /* Here the new range doesn't extend any existing set. Add it */
6491 len += 2; /* Includes an element each for the start and end of range */
6493 /* If overflows the existing space, extend, which may cause the array to be
6496 invlist_extend(invlist, len);
6497 invlist_set_len(invlist, len); /* Have to set len here to avoid assert
6498 failure in invlist_array() */
6499 array = invlist_array(invlist);
6502 invlist_set_len(invlist, len);
6505 /* The next item on the list starts the range, the one after that is
6506 * one past the new range. */
6507 array[len - 2] = start;
6508 if (end != UV_MAX) {
6509 array[len - 1] = end + 1;
6512 /* But if the end is the maximum representable on the machine, just let
6513 * the range have no end */
6514 invlist_set_len(invlist, len - 1);
6519 S_invlist_search(pTHX_ SV* const invlist, const UV cp)
6521 /* Searches the inversion list for the entry that contains the input code
6522 * point <cp>. If <cp> is not in the list, -1 is returned. Otherwise, the
6523 * return value is the index into the list's array of the range that
6527 IV high = invlist_len(invlist);
6528 const UV * const array = invlist_array(invlist);
6530 PERL_ARGS_ASSERT_INVLIST_SEARCH;
6532 /* If list is empty or the code point is before the first element, return
6534 if (high == 0 || cp < array[0]) {
6538 /* Binary search. What we are looking for is <i> such that
6539 * array[i] <= cp < array[i+1]
6540 * The loop below converges on the i+1. */
6541 while (low < high) {
6542 IV mid = (low + high) / 2;
6543 if (array[mid] <= cp) {
6546 /* We could do this extra test to exit the loop early.
6547 if (cp < array[low]) {
6552 else { /* cp < array[mid] */
6561 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
6563 /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
6564 * but is used when the swash has an inversion list. This makes this much
6565 * faster, as it uses a binary search instead of a linear one. This is
6566 * intimately tied to that function, and perhaps should be in utf8.c,
6567 * except it is intimately tied to inversion lists as well. It assumes
6568 * that <swatch> is all 0's on input */
6571 const IV len = invlist_len(invlist);
6575 PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
6577 if (len == 0) { /* Empty inversion list */
6581 array = invlist_array(invlist);
6583 /* Find which element it is */
6584 i = invlist_search(invlist, start);
6586 /* We populate from <start> to <end> */
6587 while (current < end) {
6590 /* The inversion list gives the results for every possible code point
6591 * after the first one in the list. Only those ranges whose index is
6592 * even are ones that the inversion list matches. For the odd ones,
6593 * and if the initial code point is not in the list, we have to skip
6594 * forward to the next element */
6595 if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
6597 if (i >= len) { /* Finished if beyond the end of the array */
6601 if (current >= end) { /* Finished if beyond the end of what we
6606 assert(current >= start);
6608 /* The current range ends one below the next one, except don't go past
6611 upper = (i < len && array[i] < end) ? array[i] : end;
6613 /* Here we are in a range that matches. Populate a bit in the 3-bit U8
6614 * for each code point in it */
6615 for (; current < upper; current++) {
6616 const STRLEN offset = (STRLEN)(current - start);
6617 swatch[offset >> 3] |= 1 << (offset & 7);
6620 /* Quit if at the end of the list */
6623 /* But first, have to deal with the highest possible code point on
6624 * the platform. The previous code assumes that <end> is one
6625 * beyond where we want to populate, but that is impossible at the
6626 * platform's infinity, so have to handle it specially */
6627 if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
6629 const STRLEN offset = (STRLEN)(end - start);
6630 swatch[offset >> 3] |= 1 << (offset & 7);
6635 /* Advance to the next range, which will be for code points not in the
6645 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
6647 /* Take the union of two inversion lists and point <output> to it. *output
6648 * should be defined upon input, and if it points to one of the two lists,
6649 * the reference count to that list will be decremented. The first list,
6650 * <a>, may be NULL, in which case a copy of the second list is returned.
6651 * If <complement_b> is TRUE, the union is taken of the complement
6652 * (inversion) of <b> instead of b itself.
6654 * The basis for this comes from "Unicode Demystified" Chapter 13 by
6655 * Richard Gillam, published by Addison-Wesley, and explained at some
6656 * length there. The preface says to incorporate its examples into your
6657 * code at your own risk.
6659 * The algorithm is like a merge sort.
6661 * XXX A potential performance improvement is to keep track as we go along
6662 * if only one of the inputs contributes to the result, meaning the other
6663 * is a subset of that one. In that case, we can skip the final copy and
6664 * return the larger of the input lists, but then outside code might need
6665 * to keep track of whether to free the input list or not */
6667 UV* array_a; /* a's array */
6669 UV len_a; /* length of a's array */
6672 SV* u; /* the resulting union */
6676 UV i_a = 0; /* current index into a's array */
6680 /* running count, as explained in the algorithm source book; items are
6681 * stopped accumulating and are output when the count changes to/from 0.
6682 * The count is incremented when we start a range that's in the set, and
6683 * decremented when we start a range that's not in the set. So its range
6684 * is 0 to 2. Only when the count is zero is something not in the set.
6688 PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
6691 /* If either one is empty, the union is the other one */
6692 if (a == NULL || ((len_a = invlist_len(a)) == 0)) {
6699 *output = invlist_clone(b);
6701 _invlist_invert(*output);
6703 } /* else *output already = b; */
6706 else if ((len_b = invlist_len(b)) == 0) {
6711 /* The complement of an empty list is a list that has everything in it,
6712 * so the union with <a> includes everything too */
6717 *output = _new_invlist(1);
6718 _append_range_to_invlist(*output, 0, UV_MAX);
6720 else if (*output != a) {
6721 *output = invlist_clone(a);
6723 /* else *output already = a; */
6727 /* Here both lists exist and are non-empty */
6728 array_a = invlist_array(a);
6729 array_b = invlist_array(b);
6731 /* If are to take the union of 'a' with the complement of b, set it
6732 * up so are looking at b's complement. */
6735 /* To complement, we invert: if the first element is 0, remove it. To
6736 * do this, we just pretend the array starts one later, and clear the
6737 * flag as we don't have to do anything else later */
6738 if (array_b[0] == 0) {
6741 complement_b = FALSE;
6745 /* But if the first element is not zero, we unshift a 0 before the
6746 * array. The data structure reserves a space for that 0 (which
6747 * should be a '1' right now), so physical shifting is unneeded,
6748 * but temporarily change that element to 0. Before exiting the
6749 * routine, we must restore the element to '1' */
6756 /* Size the union for the worst case: that the sets are completely
6758 u = _new_invlist(len_a + len_b);
6760 /* Will contain U+0000 if either component does */
6761 array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
6762 || (len_b > 0 && array_b[0] == 0));
6764 /* Go through each list item by item, stopping when exhausted one of
6766 while (i_a < len_a && i_b < len_b) {
6767 UV cp; /* The element to potentially add to the union's array */
6768 bool cp_in_set; /* is it in the the input list's set or not */
6770 /* We need to take one or the other of the two inputs for the union.
6771 * Since we are merging two sorted lists, we take the smaller of the
6772 * next items. In case of a tie, we take the one that is in its set
6773 * first. If we took one not in the set first, it would decrement the
6774 * count, possibly to 0 which would cause it to be output as ending the
6775 * range, and the next time through we would take the same number, and
6776 * output it again as beginning the next range. By doing it the
6777 * opposite way, there is no possibility that the count will be
6778 * momentarily decremented to 0, and thus the two adjoining ranges will
6779 * be seamlessly merged. (In a tie and both are in the set or both not
6780 * in the set, it doesn't matter which we take first.) */
6781 if (array_a[i_a] < array_b[i_b]
6782 || (array_a[i_a] == array_b[i_b]
6783 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
6785 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
6789 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
6793 /* Here, have chosen which of the two inputs to look at. Only output
6794 * if the running count changes to/from 0, which marks the
6795 * beginning/end of a range in that's in the set */
6798 array_u[i_u++] = cp;
6805 array_u[i_u++] = cp;
6810 /* Here, we are finished going through at least one of the lists, which
6811 * means there is something remaining in at most one. We check if the list
6812 * that hasn't been exhausted is positioned such that we are in the middle
6813 * of a range in its set or not. (i_a and i_b point to the element beyond
6814 * the one we care about.) If in the set, we decrement 'count'; if 0, there
6815 * is potentially more to output.
6816 * There are four cases:
6817 * 1) Both weren't in their sets, count is 0, and remains 0. What's left
6818 * in the union is entirely from the non-exhausted set.
6819 * 2) Both were in their sets, count is 2. Nothing further should
6820 * be output, as everything that remains will be in the exhausted
6821 * list's set, hence in the union; decrementing to 1 but not 0 insures
6823 * 3) the exhausted was in its set, non-exhausted isn't, count is 1.
6824 * Nothing further should be output because the union includes
6825 * everything from the exhausted set. Not decrementing ensures that.
6826 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6827 * decrementing to 0 insures that we look at the remainder of the
6828 * non-exhausted set */
6829 if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
6830 || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
6835 /* The final length is what we've output so far, plus what else is about to
6836 * be output. (If 'count' is non-zero, then the input list we exhausted
6837 * has everything remaining up to the machine's limit in its set, and hence
6838 * in the union, so there will be no further output. */
6841 /* At most one of the subexpressions will be non-zero */
6842 len_u += (len_a - i_a) + (len_b - i_b);
6845 /* Set result to final length, which can change the pointer to array_u, so
6847 if (len_u != invlist_len(u)) {
6848 invlist_set_len(u, len_u);
6850 array_u = invlist_array(u);
6853 /* When 'count' is 0, the list that was exhausted (if one was shorter than
6854 * the other) ended with everything above it not in its set. That means
6855 * that the remaining part of the union is precisely the same as the
6856 * non-exhausted list, so can just copy it unchanged. (If both list were
6857 * exhausted at the same time, then the operations below will be both 0.)
6860 IV copy_count; /* At most one will have a non-zero copy count */
6861 if ((copy_count = len_a - i_a) > 0) {
6862 Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6864 else if ((copy_count = len_b - i_b) > 0) {
6865 Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6869 /* We may be removing a reference to one of the inputs */
6870 if (a == *output || b == *output) {
6871 SvREFCNT_dec(*output);
6874 /* If we've changed b, restore it */
6884 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
6886 /* Take the intersection of two inversion lists and point <i> to it. *i
6887 * should be defined upon input, and if it points to one of the two lists,
6888 * the reference count to that list will be decremented.
6889 * If <complement_b> is TRUE, the result will be the intersection of <a>
6890 * and the complement (or inversion) of <b> instead of <b> directly.
6892 * The basis for this comes from "Unicode Demystified" Chapter 13 by
6893 * Richard Gillam, published by Addison-Wesley, and explained at some
6894 * length there. The preface says to incorporate its examples into your
6895 * code at your own risk. In fact, it had bugs
6897 * The algorithm is like a merge sort, and is essentially the same as the
6901 UV* array_a; /* a's array */
6903 UV len_a; /* length of a's array */
6906 SV* r; /* the resulting intersection */
6910 UV i_a = 0; /* current index into a's array */
6914 /* running count, as explained in the algorithm source book; items are
6915 * stopped accumulating and are output when the count changes to/from 2.
6916 * The count is incremented when we start a range that's in the set, and
6917 * decremented when we start a range that's not in the set. So its range
6918 * is 0 to 2. Only when the count is 2 is something in the intersection.
6922 PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
6925 /* Special case if either one is empty */
6926 len_a = invlist_len(a);
6927 if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
6929 if (len_a != 0 && complement_b) {
6931 /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
6932 * be empty. Here, also we are using 'b's complement, which hence
6933 * must be every possible code point. Thus the intersection is
6936 *i = invlist_clone(a);
6942 /* else *i is already 'a' */
6946 /* Here, 'a' or 'b' is empty and not using the complement of 'b'. The
6947 * intersection must be empty */
6954 *i = _new_invlist(0);
6958 /* Here both lists exist and are non-empty */
6959 array_a = invlist_array(a);
6960 array_b = invlist_array(b);
6962 /* If are to take the intersection of 'a' with the complement of b, set it
6963 * up so are looking at b's complement. */
6966 /* To complement, we invert: if the first element is 0, remove it. To
6967 * do this, we just pretend the array starts one later, and clear the
6968 * flag as we don't have to do anything else later */
6969 if (array_b[0] == 0) {
6972 complement_b = FALSE;
6976 /* But if the first element is not zero, we unshift a 0 before the
6977 * array. The data structure reserves a space for that 0 (which
6978 * should be a '1' right now), so physical shifting is unneeded,
6979 * but temporarily change that element to 0. Before exiting the
6980 * routine, we must restore the element to '1' */
6987 /* Size the intersection for the worst case: that the intersection ends up
6988 * fragmenting everything to be completely disjoint */
6989 r= _new_invlist(len_a + len_b);
6991 /* Will contain U+0000 iff both components do */
6992 array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
6993 && len_b > 0 && array_b[0] == 0);
6995 /* Go through each list item by item, stopping when exhausted one of
6997 while (i_a < len_a && i_b < len_b) {
6998 UV cp; /* The element to potentially add to the intersection's
7000 bool cp_in_set; /* Is it in the input list's set or not */
7002 /* We need to take one or the other of the two inputs for the
7003 * intersection. Since we are merging two sorted lists, we take the
7004 * smaller of the next items. In case of a tie, we take the one that
7005 * is not in its set first (a difference from the union algorithm). If
7006 * we took one in the set first, it would increment the count, possibly
7007 * to 2 which would cause it to be output as starting a range in the
7008 * intersection, and the next time through we would take that same
7009 * number, and output it again as ending the set. By doing it the
7010 * opposite of this, there is no possibility that the count will be
7011 * momentarily incremented to 2. (In a tie and both are in the set or
7012 * both not in the set, it doesn't matter which we take first.) */
7013 if (array_a[i_a] < array_b[i_b]
7014 || (array_a[i_a] == array_b[i_b]
7015 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7017 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7021 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7025 /* Here, have chosen which of the two inputs to look at. Only output
7026 * if the running count changes to/from 2, which marks the
7027 * beginning/end of a range that's in the intersection */
7031 array_r[i_r++] = cp;
7036 array_r[i_r++] = cp;
7042 /* Here, we are finished going through at least one of the lists, which
7043 * means there is something remaining in at most one. We check if the list
7044 * that has been exhausted is positioned such that we are in the middle
7045 * of a range in its set or not. (i_a and i_b point to elements 1 beyond
7046 * the ones we care about.) There are four cases:
7047 * 1) Both weren't in their sets, count is 0, and remains 0. There's
7048 * nothing left in the intersection.
7049 * 2) Both were in their sets, count is 2 and perhaps is incremented to
7050 * above 2. What should be output is exactly that which is in the
7051 * non-exhausted set, as everything it has is also in the intersection
7052 * set, and everything it doesn't have can't be in the intersection
7053 * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7054 * gets incremented to 2. Like the previous case, the intersection is
7055 * everything that remains in the non-exhausted set.
7056 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7057 * remains 1. And the intersection has nothing more. */
7058 if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7059 || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7064 /* The final length is what we've output so far plus what else is in the
7065 * intersection. At most one of the subexpressions below will be non-zero */
7068 len_r += (len_a - i_a) + (len_b - i_b);
7071 /* Set result to final length, which can change the pointer to array_r, so
7073 if (len_r != invlist_len(r)) {
7074 invlist_set_len(r, len_r);
7076 array_r = invlist_array(r);
7079 /* Finish outputting any remaining */
7080 if (count >= 2) { /* At most one will have a non-zero copy count */
7082 if ((copy_count = len_a - i_a) > 0) {
7083 Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7085 else if ((copy_count = len_b - i_b) > 0) {
7086 Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7090 /* We may be removing a reference to one of the inputs */
7091 if (a == *i || b == *i) {
7095 /* If we've changed b, restore it */
7107 S_add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7109 /* Add the range from 'start' to 'end' inclusive to the inversion list's
7110 * set. A pointer to the inversion list is returned. This may actually be
7111 * a new list, in which case the passed in one has been destroyed. The
7112 * passed in inversion list can be NULL, in which case a new one is created
7113 * with just the one range in it */
7118 if (invlist == NULL) {
7119 invlist = _new_invlist(2);
7123 len = invlist_len(invlist);
7126 /* If comes after the final entry, can just append it to the end */
7128 || start >= invlist_array(invlist)
7129 [invlist_len(invlist) - 1])
7131 _append_range_to_invlist(invlist, start, end);
7135 /* Here, can't just append things, create and return a new inversion list
7136 * which is the union of this range and the existing inversion list */
7137 range_invlist = _new_invlist(2);
7138 _append_range_to_invlist(range_invlist, start, end);
7140 _invlist_union(invlist, range_invlist, &invlist);
7142 /* The temporary can be freed */
7143 SvREFCNT_dec(range_invlist);
7148 PERL_STATIC_INLINE SV*
7149 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
7150 return add_range_to_invlist(invlist, cp, cp);
7153 #ifndef PERL_IN_XSUB_RE
7155 Perl__invlist_invert(pTHX_ SV* const invlist)
7157 /* Complement the input inversion list. This adds a 0 if the list didn't
7158 * have a zero; removes it otherwise. As described above, the data
7159 * structure is set up so that this is very efficient */
7161 UV* len_pos = get_invlist_len_addr(invlist);
7163 PERL_ARGS_ASSERT__INVLIST_INVERT;
7165 /* The inverse of matching nothing is matching everything */
7166 if (*len_pos == 0) {
7167 _append_range_to_invlist(invlist, 0, UV_MAX);
7171 /* The exclusive or complents 0 to 1; and 1 to 0. If the result is 1, the
7172 * zero element was a 0, so it is being removed, so the length decrements
7173 * by 1; and vice-versa. SvCUR is unaffected */
7174 if (*get_invlist_zero_addr(invlist) ^= 1) {
7183 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
7185 /* Complement the input inversion list (which must be a Unicode property,
7186 * all of which don't match above the Unicode maximum code point.) And
7187 * Perl has chosen to not have the inversion match above that either. This
7188 * adds a 0x110000 if the list didn't end with it, and removes it if it did
7194 PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
7196 _invlist_invert(invlist);
7198 len = invlist_len(invlist);
7200 if (len != 0) { /* If empty do nothing */
7201 array = invlist_array(invlist);
7202 if (array[len - 1] != PERL_UNICODE_MAX + 1) {
7203 /* Add 0x110000. First, grow if necessary */
7205 if (invlist_max(invlist) < len) {
7206 invlist_extend(invlist, len);
7207 array = invlist_array(invlist);
7209 invlist_set_len(invlist, len);
7210 array[len - 1] = PERL_UNICODE_MAX + 1;
7212 else { /* Remove the 0x110000 */
7213 invlist_set_len(invlist, len - 1);
7221 PERL_STATIC_INLINE SV*
7222 S_invlist_clone(pTHX_ SV* const invlist)
7225 /* Return a new inversion list that is a copy of the input one, which is
7228 /* Need to allocate extra space to accommodate Perl's addition of a
7229 * trailing NUL to SvPV's, since it thinks they are always strings */
7230 SV* new_invlist = _new_invlist(invlist_len(invlist) + 1);
7231 STRLEN length = SvCUR(invlist);
7233 PERL_ARGS_ASSERT_INVLIST_CLONE;
7235 SvCUR_set(new_invlist, length); /* This isn't done automatically */
7236 Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
7241 PERL_STATIC_INLINE UV*
7242 S_get_invlist_iter_addr(pTHX_ SV* invlist)
7244 /* Return the address of the UV that contains the current iteration
7247 PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
7249 return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
7252 PERL_STATIC_INLINE UV*
7253 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
7255 /* Return the address of the UV that contains the version id. */
7257 PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
7259 return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
7262 PERL_STATIC_INLINE void
7263 S_invlist_iterinit(pTHX_ SV* invlist) /* Initialize iterator for invlist */
7265 PERL_ARGS_ASSERT_INVLIST_ITERINIT;
7267 *get_invlist_iter_addr(invlist) = 0;
7271 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
7273 /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
7274 * This call sets in <*start> and <*end>, the next range in <invlist>.
7275 * Returns <TRUE> if successful and the next call will return the next
7276 * range; <FALSE> if was already at the end of the list. If the latter,
7277 * <*start> and <*end> are unchanged, and the next call to this function
7278 * will start over at the beginning of the list */
7280 UV* pos = get_invlist_iter_addr(invlist);
7281 UV len = invlist_len(invlist);
7284 PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
7287 *pos = UV_MAX; /* Force iternit() to be required next time */
7291 array = invlist_array(invlist);
7293 *start = array[(*pos)++];
7299 *end = array[(*pos)++] - 1;
7305 #ifndef PERL_IN_XSUB_RE
7307 Perl__invlist_contents(pTHX_ SV* const invlist)
7309 /* Get the contents of an inversion list into a string SV so that they can
7310 * be printed out. It uses the format traditionally done for debug tracing
7314 SV* output = newSVpvs("\n");
7316 PERL_ARGS_ASSERT__INVLIST_CONTENTS;
7318 invlist_iterinit(invlist);
7319 while (invlist_iternext(invlist, &start, &end)) {
7320 if (end == UV_MAX) {
7321 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
7323 else if (end != start) {
7324 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
7328 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
7338 S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
7340 /* Dumps out the ranges in an inversion list. The string 'header'
7341 * if present is output on a line before the first range */
7345 if (header && strlen(header)) {
7346 PerlIO_printf(Perl_debug_log, "%s\n", header);
7348 invlist_iterinit(invlist);
7349 while (invlist_iternext(invlist, &start, &end)) {
7350 if (end == UV_MAX) {
7351 PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
7354 PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
7360 #undef HEADER_LENGTH
7361 #undef INVLIST_INITIAL_LENGTH
7362 #undef TO_INTERNAL_SIZE
7363 #undef FROM_INTERNAL_SIZE
7364 #undef INVLIST_LEN_OFFSET
7365 #undef INVLIST_ZERO_OFFSET
7366 #undef INVLIST_ITER_OFFSET
7367 #undef INVLIST_VERSION_ID
7369 /* End of inversion list object */
7372 - reg - regular expression, i.e. main body or parenthesized thing
7374 * Caller must absorb opening parenthesis.
7376 * Combining parenthesis handling with the base level of regular expression
7377 * is a trifle forced, but the need to tie the tails of the branches to what
7378 * follows makes it hard to avoid.
7380 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
7382 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
7384 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
7388 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
7389 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
7392 register regnode *ret; /* Will be the head of the group. */
7393 register regnode *br;
7394 register regnode *lastbr;
7395 register regnode *ender = NULL;
7396 register I32 parno = 0;
7398 U32 oregflags = RExC_flags;
7399 bool have_branch = 0;
7401 I32 freeze_paren = 0;
7402 I32 after_freeze = 0;
7404 /* for (?g), (?gc), and (?o) warnings; warning
7405 about (?c) will warn about (?g) -- japhy */
7407 #define WASTED_O 0x01
7408 #define WASTED_G 0x02
7409 #define WASTED_C 0x04
7410 #define WASTED_GC (0x02|0x04)
7411 I32 wastedflags = 0x00;
7413 char * parse_start = RExC_parse; /* MJD */
7414 char * const oregcomp_parse = RExC_parse;
7416 GET_RE_DEBUG_FLAGS_DECL;
7418 PERL_ARGS_ASSERT_REG;
7419 DEBUG_PARSE("reg ");
7421 *flagp = 0; /* Tentatively. */
7424 /* Make an OPEN node, if parenthesized. */
7426 if ( *RExC_parse == '*') { /* (*VERB:ARG) */
7427 char *start_verb = RExC_parse;
7428 STRLEN verb_len = 0;
7429 char *start_arg = NULL;
7430 unsigned char op = 0;
7432 int internal_argval = 0; /* internal_argval is only useful if !argok */
7433 while ( *RExC_parse && *RExC_parse != ')' ) {
7434 if ( *RExC_parse == ':' ) {
7435 start_arg = RExC_parse + 1;
7441 verb_len = RExC_parse - start_verb;
7444 while ( *RExC_parse && *RExC_parse != ')' )
7446 if ( *RExC_parse != ')' )
7447 vFAIL("Unterminated verb pattern argument");
7448 if ( RExC_parse == start_arg )
7451 if ( *RExC_parse != ')' )
7452 vFAIL("Unterminated verb pattern");
7455 switch ( *start_verb ) {
7456 case 'A': /* (*ACCEPT) */
7457 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
7459 internal_argval = RExC_nestroot;
7462 case 'C': /* (*COMMIT) */
7463 if ( memEQs(start_verb,verb_len,"COMMIT") )
7466 case 'F': /* (*FAIL) */
7467 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
7472 case ':': /* (*:NAME) */
7473 case 'M': /* (*MARK:NAME) */
7474 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
7479 case 'P': /* (*PRUNE) */
7480 if ( memEQs(start_verb,verb_len,"PRUNE") )
7483 case 'S': /* (*SKIP) */
7484 if ( memEQs(start_verb,verb_len,"SKIP") )
7487 case 'T': /* (*THEN) */
7488 /* [19:06] <TimToady> :: is then */
7489 if ( memEQs(start_verb,verb_len,"THEN") ) {
7491 RExC_seen |= REG_SEEN_CUTGROUP;
7497 vFAIL3("Unknown verb pattern '%.*s'",
7498 verb_len, start_verb);
7501 if ( start_arg && internal_argval ) {
7502 vFAIL3("Verb pattern '%.*s' may not have an argument",
7503 verb_len, start_verb);
7504 } else if ( argok < 0 && !start_arg ) {
7505 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
7506 verb_len, start_verb);
7508 ret = reganode(pRExC_state, op, internal_argval);
7509 if ( ! internal_argval && ! SIZE_ONLY ) {
7511 SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
7512 ARG(ret) = add_data( pRExC_state, 1, "S" );
7513 RExC_rxi->data->data[ARG(ret)]=(void*)sv;
7520 if (!internal_argval)
7521 RExC_seen |= REG_SEEN_VERBARG;
7522 } else if ( start_arg ) {
7523 vFAIL3("Verb pattern '%.*s' may not have an argument",
7524 verb_len, start_verb);
7526 ret = reg_node(pRExC_state, op);
7528 nextchar(pRExC_state);
7531 if (*RExC_parse == '?') { /* (?...) */
7532 bool is_logical = 0;
7533 const char * const seqstart = RExC_parse;
7534 bool has_use_defaults = FALSE;
7537 paren = *RExC_parse++;
7538 ret = NULL; /* For look-ahead/behind. */
7541 case 'P': /* (?P...) variants for those used to PCRE/Python */
7542 paren = *RExC_parse++;
7543 if ( paren == '<') /* (?P<...>) named capture */
7545 else if (paren == '>') { /* (?P>name) named recursion */
7546 goto named_recursion;
7548 else if (paren == '=') { /* (?P=...) named backref */
7549 /* this pretty much dupes the code for \k<NAME> in regatom(), if
7550 you change this make sure you change that */
7551 char* name_start = RExC_parse;
7553 SV *sv_dat = reg_scan_name(pRExC_state,
7554 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7555 if (RExC_parse == name_start || *RExC_parse != ')')
7556 vFAIL2("Sequence %.3s... not terminated",parse_start);
7559 num = add_data( pRExC_state, 1, "S" );
7560 RExC_rxi->data->data[num]=(void*)sv_dat;
7561 SvREFCNT_inc_simple_void(sv_dat);
7564 ret = reganode(pRExC_state,
7567 : (MORE_ASCII_RESTRICTED)
7569 : (AT_LEAST_UNI_SEMANTICS)
7577 Set_Node_Offset(ret, parse_start+1);
7578 Set_Node_Cur_Length(ret); /* MJD */
7580 nextchar(pRExC_state);
7584 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7586 case '<': /* (?<...) */
7587 if (*RExC_parse == '!')
7589 else if (*RExC_parse != '=')
7595 case '\'': /* (?'...') */
7596 name_start= RExC_parse;
7597 svname = reg_scan_name(pRExC_state,
7598 SIZE_ONLY ? /* reverse test from the others */
7599 REG_RSN_RETURN_NAME :
7600 REG_RSN_RETURN_NULL);
7601 if (RExC_parse == name_start) {
7603 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7606 if (*RExC_parse != paren)
7607 vFAIL2("Sequence (?%c... not terminated",
7608 paren=='>' ? '<' : paren);
7612 if (!svname) /* shouldn't happen */
7614 "panic: reg_scan_name returned NULL");
7615 if (!RExC_paren_names) {
7616 RExC_paren_names= newHV();
7617 sv_2mortal(MUTABLE_SV(RExC_paren_names));
7619 RExC_paren_name_list= newAV();
7620 sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
7623 he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
7625 sv_dat = HeVAL(he_str);
7627 /* croak baby croak */
7629 "panic: paren_name hash element allocation failed");
7630 } else if ( SvPOK(sv_dat) ) {
7631 /* (?|...) can mean we have dupes so scan to check
7632 its already been stored. Maybe a flag indicating
7633 we are inside such a construct would be useful,
7634 but the arrays are likely to be quite small, so
7635 for now we punt -- dmq */
7636 IV count = SvIV(sv_dat);
7637 I32 *pv = (I32*)SvPVX(sv_dat);
7639 for ( i = 0 ; i < count ; i++ ) {
7640 if ( pv[i] == RExC_npar ) {
7646 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
7647 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
7648 pv[count] = RExC_npar;
7649 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
7652 (void)SvUPGRADE(sv_dat,SVt_PVNV);
7653 sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
7655 SvIV_set(sv_dat, 1);
7658 /* Yes this does cause a memory leak in debugging Perls */
7659 if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
7660 SvREFCNT_dec(svname);
7663 /*sv_dump(sv_dat);*/
7665 nextchar(pRExC_state);
7667 goto capturing_parens;
7669 RExC_seen |= REG_SEEN_LOOKBEHIND;
7670 RExC_in_lookbehind++;
7672 case '=': /* (?=...) */
7673 RExC_seen_zerolen++;
7675 case '!': /* (?!...) */
7676 RExC_seen_zerolen++;
7677 if (*RExC_parse == ')') {
7678 ret=reg_node(pRExC_state, OPFAIL);
7679 nextchar(pRExC_state);
7683 case '|': /* (?|...) */
7684 /* branch reset, behave like a (?:...) except that
7685 buffers in alternations share the same numbers */
7687 after_freeze = freeze_paren = RExC_npar;
7689 case ':': /* (?:...) */
7690 case '>': /* (?>...) */
7692 case '$': /* (?$...) */
7693 case '@': /* (?@...) */
7694 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
7696 case '#': /* (?#...) */
7697 while (*RExC_parse && *RExC_parse != ')')
7699 if (*RExC_parse != ')')
7700 FAIL("Sequence (?#... not terminated");
7701 nextchar(pRExC_state);
7704 case '0' : /* (?0) */
7705 case 'R' : /* (?R) */
7706 if (*RExC_parse != ')')
7707 FAIL("Sequence (?R) not terminated");
7708 ret = reg_node(pRExC_state, GOSTART);
7709 *flagp |= POSTPONED;
7710 nextchar(pRExC_state);
7713 { /* named and numeric backreferences */
7715 case '&': /* (?&NAME) */
7716 parse_start = RExC_parse - 1;
7719 SV *sv_dat = reg_scan_name(pRExC_state,
7720 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7721 num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
7723 goto gen_recurse_regop;
7726 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7728 vFAIL("Illegal pattern");
7730 goto parse_recursion;
7732 case '-': /* (?-1) */
7733 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7734 RExC_parse--; /* rewind to let it be handled later */
7738 case '1': case '2': case '3': case '4': /* (?1) */
7739 case '5': case '6': case '7': case '8': case '9':
7742 num = atoi(RExC_parse);
7743 parse_start = RExC_parse - 1; /* MJD */
7744 if (*RExC_parse == '-')
7746 while (isDIGIT(*RExC_parse))
7748 if (*RExC_parse!=')')
7749 vFAIL("Expecting close bracket");
7752 if ( paren == '-' ) {
7754 Diagram of capture buffer numbering.
7755 Top line is the normal capture buffer numbers
7756 Bottom line is the negative indexing as from
7760 /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
7764 num = RExC_npar + num;
7767 vFAIL("Reference to nonexistent group");
7769 } else if ( paren == '+' ) {
7770 num = RExC_npar + num - 1;
7773 ret = reganode(pRExC_state, GOSUB, num);
7775 if (num > (I32)RExC_rx->nparens) {
7777 vFAIL("Reference to nonexistent group");
7779 ARG2L_SET( ret, RExC_recurse_count++);
7781 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7782 "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
7786 RExC_seen |= REG_SEEN_RECURSE;
7787 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
7788 Set_Node_Offset(ret, parse_start); /* MJD */
7790 *flagp |= POSTPONED;
7791 nextchar(pRExC_state);
7793 } /* named and numeric backreferences */
7796 case '?': /* (??...) */
7798 if (*RExC_parse != '{') {
7800 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7803 *flagp |= POSTPONED;
7804 paren = *RExC_parse++;
7806 case '{': /* (?{...}) */
7811 char *s = RExC_parse;
7813 RExC_seen_zerolen++;
7814 RExC_seen |= REG_SEEN_EVAL;
7815 while (count && (c = *RExC_parse)) {
7826 if (*RExC_parse != ')') {
7828 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
7832 OP_4tree *sop, *rop;
7833 SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
7836 Perl_save_re_context(aTHX);
7837 rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
7838 sop->op_private |= OPpREFCOUNTED;
7839 /* re_dup will OpREFCNT_inc */
7840 OpREFCNT_set(sop, 1);
7843 n = add_data(pRExC_state, 3, "nop");
7844 RExC_rxi->data->data[n] = (void*)rop;
7845 RExC_rxi->data->data[n+1] = (void*)sop;
7846 RExC_rxi->data->data[n+2] = (void*)pad;
7849 else { /* First pass */
7850 if (PL_reginterp_cnt < ++RExC_seen_evals
7852 /* No compiled RE interpolated, has runtime
7853 components ===> unsafe. */
7854 FAIL("Eval-group not allowed at runtime, use re 'eval'");
7855 if (PL_tainting && PL_tainted)
7856 FAIL("Eval-group in insecure regular expression");
7857 #if PERL_VERSION > 8
7858 if (IN_PERL_COMPILETIME)
7863 nextchar(pRExC_state);
7865 ret = reg_node(pRExC_state, LOGICAL);
7868 REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
7869 /* deal with the length of this later - MJD */
7872 ret = reganode(pRExC_state, EVAL, n);
7873 Set_Node_Length(ret, RExC_parse - parse_start + 1);
7874 Set_Node_Offset(ret, parse_start);
7877 case '(': /* (?(?{...})...) and (?(?=...)...) */
7880 if (RExC_parse[0] == '?') { /* (?(?...)) */
7881 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
7882 || RExC_parse[1] == '<'
7883 || RExC_parse[1] == '{') { /* Lookahead or eval. */
7886 ret = reg_node(pRExC_state, LOGICAL);
7889 REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
7893 else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
7894 || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
7896 char ch = RExC_parse[0] == '<' ? '>' : '\'';
7897 char *name_start= RExC_parse++;
7899 SV *sv_dat=reg_scan_name(pRExC_state,
7900 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7901 if (RExC_parse == name_start || *RExC_parse != ch)
7902 vFAIL2("Sequence (?(%c... not terminated",
7903 (ch == '>' ? '<' : ch));
7906 num = add_data( pRExC_state, 1, "S" );
7907 RExC_rxi->data->data[num]=(void*)sv_dat;
7908 SvREFCNT_inc_simple_void(sv_dat);
7910 ret = reganode(pRExC_state,NGROUPP,num);
7911 goto insert_if_check_paren;
7913 else if (RExC_parse[0] == 'D' &&
7914 RExC_parse[1] == 'E' &&
7915 RExC_parse[2] == 'F' &&
7916 RExC_parse[3] == 'I' &&
7917 RExC_parse[4] == 'N' &&
7918 RExC_parse[5] == 'E')
7920 ret = reganode(pRExC_state,DEFINEP,0);
7923 goto insert_if_check_paren;
7925 else if (RExC_parse[0] == 'R') {
7928 if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
7929 parno = atoi(RExC_parse++);
7930 while (isDIGIT(*RExC_parse))
7932 } else if (RExC_parse[0] == '&') {
7935 sv_dat = reg_scan_name(pRExC_state,
7936 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7937 parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
7939 ret = reganode(pRExC_state,INSUBP,parno);
7940 goto insert_if_check_paren;
7942 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
7945 parno = atoi(RExC_parse++);
7947 while (isDIGIT(*RExC_parse))
7949 ret = reganode(pRExC_state, GROUPP, parno);
7951 insert_if_check_paren:
7952 if ((c = *nextchar(pRExC_state)) != ')')
7953 vFAIL("Switch condition not recognized");
7955 REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
7956 br = regbranch(pRExC_state, &flags, 1,depth+1);
7958 br = reganode(pRExC_state, LONGJMP, 0);
7960 REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
7961 c = *nextchar(pRExC_state);
7966 vFAIL("(?(DEFINE)....) does not allow branches");
7967 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
7968 regbranch(pRExC_state, &flags, 1,depth+1);
7969 REGTAIL(pRExC_state, ret, lastbr);
7972 c = *nextchar(pRExC_state);
7977 vFAIL("Switch (?(condition)... contains too many branches");
7978 ender = reg_node(pRExC_state, TAIL);
7979 REGTAIL(pRExC_state, br, ender);
7981 REGTAIL(pRExC_state, lastbr, ender);
7982 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
7985 REGTAIL(pRExC_state, ret, ender);
7986 RExC_size++; /* XXX WHY do we need this?!!
7987 For large programs it seems to be required
7988 but I can't figure out why. -- dmq*/
7992 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
7996 RExC_parse--; /* for vFAIL to print correctly */
7997 vFAIL("Sequence (? incomplete");
7999 case DEFAULT_PAT_MOD: /* Use default flags with the exceptions
8001 has_use_defaults = TRUE;
8002 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8003 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8004 ? REGEX_UNICODE_CHARSET
8005 : REGEX_DEPENDS_CHARSET);
8009 parse_flags: /* (?i) */
8011 U32 posflags = 0, negflags = 0;
8012 U32 *flagsp = &posflags;
8013 char has_charset_modifier = '\0';
8014 regex_charset cs = (RExC_utf8 || RExC_uni_semantics)
8015 ? REGEX_UNICODE_CHARSET
8016 : REGEX_DEPENDS_CHARSET;
8018 while (*RExC_parse) {
8019 /* && strchr("iogcmsx", *RExC_parse) */
8020 /* (?g), (?gc) and (?o) are useless here
8021 and must be globally applied -- japhy */
8022 switch (*RExC_parse) {
8023 CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8024 case LOCALE_PAT_MOD:
8025 if (has_charset_modifier) {
8026 goto excess_modifier;
8028 else if (flagsp == &negflags) {
8031 cs = REGEX_LOCALE_CHARSET;
8032 has_charset_modifier = LOCALE_PAT_MOD;
8033 RExC_contains_locale = 1;
8035 case UNICODE_PAT_MOD:
8036 if (has_charset_modifier) {
8037 goto excess_modifier;
8039 else if (flagsp == &negflags) {
8042 cs = REGEX_UNICODE_CHARSET;
8043 has_charset_modifier = UNICODE_PAT_MOD;
8045 case ASCII_RESTRICT_PAT_MOD:
8046 if (flagsp == &negflags) {
8049 if (has_charset_modifier) {
8050 if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8051 goto excess_modifier;
8053 /* Doubled modifier implies more restricted */
8054 cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8057 cs = REGEX_ASCII_RESTRICTED_CHARSET;
8059 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8061 case DEPENDS_PAT_MOD:
8062 if (has_use_defaults) {
8063 goto fail_modifiers;
8065 else if (flagsp == &negflags) {
8068 else if (has_charset_modifier) {
8069 goto excess_modifier;
8072 /* The dual charset means unicode semantics if the
8073 * pattern (or target, not known until runtime) are
8074 * utf8, or something in the pattern indicates unicode
8076 cs = (RExC_utf8 || RExC_uni_semantics)
8077 ? REGEX_UNICODE_CHARSET
8078 : REGEX_DEPENDS_CHARSET;
8079 has_charset_modifier = DEPENDS_PAT_MOD;
8083 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8084 vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8086 else if (has_charset_modifier == *(RExC_parse - 1)) {
8087 vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8090 vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8095 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8097 case ONCE_PAT_MOD: /* 'o' */
8098 case GLOBAL_PAT_MOD: /* 'g' */
8099 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8100 const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8101 if (! (wastedflags & wflagbit) ) {
8102 wastedflags |= wflagbit;
8105 "Useless (%s%c) - %suse /%c modifier",
8106 flagsp == &negflags ? "?-" : "?",
8108 flagsp == &negflags ? "don't " : "",
8115 case CONTINUE_PAT_MOD: /* 'c' */
8116 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8117 if (! (wastedflags & WASTED_C) ) {
8118 wastedflags |= WASTED_GC;
8121 "Useless (%sc) - %suse /gc modifier",
8122 flagsp == &negflags ? "?-" : "?",
8123 flagsp == &negflags ? "don't " : ""
8128 case KEEPCOPY_PAT_MOD: /* 'p' */
8129 if (flagsp == &negflags) {
8131 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8133 *flagsp |= RXf_PMf_KEEPCOPY;
8137 /* A flag is a default iff it is following a minus, so
8138 * if there is a minus, it means will be trying to
8139 * re-specify a default which is an error */
8140 if (has_use_defaults || flagsp == &negflags) {
8143 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8147 wastedflags = 0; /* reset so (?g-c) warns twice */
8153 RExC_flags |= posflags;
8154 RExC_flags &= ~negflags;
8155 set_regex_charset(&RExC_flags, cs);
8157 oregflags |= posflags;
8158 oregflags &= ~negflags;
8159 set_regex_charset(&oregflags, cs);
8161 nextchar(pRExC_state);
8172 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8177 }} /* one for the default block, one for the switch */
8184 ret = reganode(pRExC_state, OPEN, parno);
8187 RExC_nestroot = parno;
8188 if (RExC_seen & REG_SEEN_RECURSE
8189 && !RExC_open_parens[parno-1])
8191 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8192 "Setting open paren #%"IVdf" to %d\n",
8193 (IV)parno, REG_NODE_NUM(ret)));
8194 RExC_open_parens[parno-1]= ret;
8197 Set_Node_Length(ret, 1); /* MJD */
8198 Set_Node_Offset(ret, RExC_parse); /* MJD */
8206 /* Pick up the branches, linking them together. */
8207 parse_start = RExC_parse; /* MJD */
8208 br = regbranch(pRExC_state, &flags, 1,depth+1);
8210 /* branch_len = (paren != 0); */
8214 if (*RExC_parse == '|') {
8215 if (!SIZE_ONLY && RExC_extralen) {
8216 reginsert(pRExC_state, BRANCHJ, br, depth+1);
8219 reginsert(pRExC_state, BRANCH, br, depth+1);
8220 Set_Node_Length(br, paren != 0);
8221 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
8225 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
8227 else if (paren == ':') {
8228 *flagp |= flags&SIMPLE;
8230 if (is_open) { /* Starts with OPEN. */
8231 REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
8233 else if (paren != '?') /* Not Conditional */
8235 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8237 while (*RExC_parse == '|') {
8238 if (!SIZE_ONLY && RExC_extralen) {
8239 ender = reganode(pRExC_state, LONGJMP,0);
8240 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
8243 RExC_extralen += 2; /* Account for LONGJMP. */
8244 nextchar(pRExC_state);
8246 if (RExC_npar > after_freeze)
8247 after_freeze = RExC_npar;
8248 RExC_npar = freeze_paren;
8250 br = regbranch(pRExC_state, &flags, 0, depth+1);
8254 REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
8256 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8259 if (have_branch || paren != ':') {
8260 /* Make a closing node, and hook it on the end. */
8263 ender = reg_node(pRExC_state, TAIL);
8266 ender = reganode(pRExC_state, CLOSE, parno);
8267 if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
8268 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8269 "Setting close paren #%"IVdf" to %d\n",
8270 (IV)parno, REG_NODE_NUM(ender)));
8271 RExC_close_parens[parno-1]= ender;
8272 if (RExC_nestroot == parno)
8275 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
8276 Set_Node_Length(ender,1); /* MJD */
8282 *flagp &= ~HASWIDTH;
8285 ender = reg_node(pRExC_state, SUCCEED);
8288 ender = reg_node(pRExC_state, END);
8290 assert(!RExC_opend); /* there can only be one! */
8295 REGTAIL(pRExC_state, lastbr, ender);
8297 if (have_branch && !SIZE_ONLY) {
8299 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
8301 /* Hook the tails of the branches to the closing node. */
8302 for (br = ret; br; br = regnext(br)) {
8303 const U8 op = PL_regkind[OP(br)];
8305 REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
8307 else if (op == BRANCHJ) {
8308 REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
8316 static const char parens[] = "=!<,>";
8318 if (paren && (p = strchr(parens, paren))) {
8319 U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
8320 int flag = (p - parens) > 1;
8323 node = SUSPEND, flag = 0;
8324 reginsert(pRExC_state, node,ret, depth+1);
8325 Set_Node_Cur_Length(ret);
8326 Set_Node_Offset(ret, parse_start + 1);
8328 REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
8332 /* Check for proper termination. */
8334 RExC_flags = oregflags;
8335 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
8336 RExC_parse = oregcomp_parse;
8337 vFAIL("Unmatched (");
8340 else if (!paren && RExC_parse < RExC_end) {
8341 if (*RExC_parse == ')') {
8343 vFAIL("Unmatched )");
8346 FAIL("Junk on end of regexp"); /* "Can't happen". */
8350 if (RExC_in_lookbehind) {
8351 RExC_in_lookbehind--;
8353 if (after_freeze > RExC_npar)
8354 RExC_npar = after_freeze;
8359 - regbranch - one alternative of an | operator
8361 * Implements the concatenation operator.
8364 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
8367 register regnode *ret;
8368 register regnode *chain = NULL;
8369 register regnode *latest;
8370 I32 flags = 0, c = 0;
8371 GET_RE_DEBUG_FLAGS_DECL;
8373 PERL_ARGS_ASSERT_REGBRANCH;
8375 DEBUG_PARSE("brnc");
8380 if (!SIZE_ONLY && RExC_extralen)
8381 ret = reganode(pRExC_state, BRANCHJ,0);
8383 ret = reg_node(pRExC_state, BRANCH);
8384 Set_Node_Length(ret, 1);
8388 if (!first && SIZE_ONLY)
8389 RExC_extralen += 1; /* BRANCHJ */
8391 *flagp = WORST; /* Tentatively. */
8394 nextchar(pRExC_state);
8395 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
8397 latest = regpiece(pRExC_state, &flags,depth+1);
8398 if (latest == NULL) {
8399 if (flags & TRYAGAIN)
8403 else if (ret == NULL)
8405 *flagp |= flags&(HASWIDTH|POSTPONED);
8406 if (chain == NULL) /* First piece. */
8407 *flagp |= flags&SPSTART;
8410 REGTAIL(pRExC_state, chain, latest);
8415 if (chain == NULL) { /* Loop ran zero times. */
8416 chain = reg_node(pRExC_state, NOTHING);
8421 *flagp |= flags&SIMPLE;
8428 - regpiece - something followed by possible [*+?]
8430 * Note that the branching code sequences used for ? and the general cases
8431 * of * and + are somewhat optimized: they use the same NOTHING node as
8432 * both the endmarker for their branch list and the body of the last branch.
8433 * It might seem that this node could be dispensed with entirely, but the
8434 * endmarker role is not redundant.
8437 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8440 register regnode *ret;
8442 register char *next;
8444 const char * const origparse = RExC_parse;
8446 I32 max = REG_INFTY;
8447 #ifdef RE_TRACK_PATTERN_OFFSETS
8450 const char *maxpos = NULL;
8451 GET_RE_DEBUG_FLAGS_DECL;
8453 PERL_ARGS_ASSERT_REGPIECE;
8455 DEBUG_PARSE("piec");
8457 ret = regatom(pRExC_state, &flags,depth+1);
8459 if (flags & TRYAGAIN)
8466 if (op == '{' && regcurly(RExC_parse)) {
8468 #ifdef RE_TRACK_PATTERN_OFFSETS
8469 parse_start = RExC_parse; /* MJD */
8471 next = RExC_parse + 1;
8472 while (isDIGIT(*next) || *next == ',') {
8481 if (*next == '}') { /* got one */
8485 min = atoi(RExC_parse);
8489 maxpos = RExC_parse;
8491 if (!max && *maxpos != '0')
8492 max = REG_INFTY; /* meaning "infinity" */
8493 else if (max >= REG_INFTY)
8494 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
8496 nextchar(pRExC_state);
8499 if ((flags&SIMPLE)) {
8500 RExC_naughty += 2 + RExC_naughty / 2;
8501 reginsert(pRExC_state, CURLY, ret, depth+1);
8502 Set_Node_Offset(ret, parse_start+1); /* MJD */
8503 Set_Node_Cur_Length(ret);
8506 regnode * const w = reg_node(pRExC_state, WHILEM);
8509 REGTAIL(pRExC_state, ret, w);
8510 if (!SIZE_ONLY && RExC_extralen) {
8511 reginsert(pRExC_state, LONGJMP,ret, depth+1);
8512 reginsert(pRExC_state, NOTHING,ret, depth+1);
8513 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
8515 reginsert(pRExC_state, CURLYX,ret, depth+1);
8517 Set_Node_Offset(ret, parse_start+1);
8518 Set_Node_Length(ret,
8519 op == '{' ? (RExC_parse - parse_start) : 1);
8521 if (!SIZE_ONLY && RExC_extralen)
8522 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
8523 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
8525 RExC_whilem_seen++, RExC_extralen += 3;
8526 RExC_naughty += 4 + RExC_naughty; /* compound interest */
8535 vFAIL("Can't do {n,m} with n > m");
8537 ARG1_SET(ret, (U16)min);
8538 ARG2_SET(ret, (U16)max);
8550 #if 0 /* Now runtime fix should be reliable. */
8552 /* if this is reinstated, don't forget to put this back into perldiag:
8554 =item Regexp *+ operand could be empty at {#} in regex m/%s/
8556 (F) The part of the regexp subject to either the * or + quantifier
8557 could match an empty string. The {#} shows in the regular
8558 expression about where the problem was discovered.
8562 if (!(flags&HASWIDTH) && op != '?')
8563 vFAIL("Regexp *+ operand could be empty");
8566 #ifdef RE_TRACK_PATTERN_OFFSETS
8567 parse_start = RExC_parse;
8569 nextchar(pRExC_state);
8571 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
8573 if (op == '*' && (flags&SIMPLE)) {
8574 reginsert(pRExC_state, STAR, ret, depth+1);
8578 else if (op == '*') {
8582 else if (op == '+' && (flags&SIMPLE)) {
8583 reginsert(pRExC_state, PLUS, ret, depth+1);
8587 else if (op == '+') {
8591 else if (op == '?') {
8596 if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
8597 ckWARN3reg(RExC_parse,
8598 "%.*s matches null string many times",
8599 (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
8603 if (RExC_parse < RExC_end && *RExC_parse == '?') {
8604 nextchar(pRExC_state);
8605 reginsert(pRExC_state, MINMOD, ret, depth+1);
8606 REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
8608 #ifndef REG_ALLOW_MINMOD_SUSPEND
8611 if (RExC_parse < RExC_end && *RExC_parse == '+') {
8613 nextchar(pRExC_state);
8614 ender = reg_node(pRExC_state, SUCCEED);
8615 REGTAIL(pRExC_state, ret, ender);
8616 reginsert(pRExC_state, SUSPEND, ret, depth+1);
8618 ender = reg_node(pRExC_state, TAIL);
8619 REGTAIL(pRExC_state, ret, ender);
8623 if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
8625 vFAIL("Nested quantifiers");
8632 /* reg_namedseq(pRExC_state,UVp, UV depth)
8634 This is expected to be called by a parser routine that has
8635 recognized '\N' and needs to handle the rest. RExC_parse is
8636 expected to point at the first char following the N at the time
8639 The \N may be inside (indicated by valuep not being NULL) or outside a
8642 \N may begin either a named sequence, or if outside a character class, mean
8643 to match a non-newline. For non single-quoted regexes, the tokenizer has
8644 attempted to decide which, and in the case of a named sequence converted it
8645 into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
8646 where c1... are the characters in the sequence. For single-quoted regexes,
8647 the tokenizer passes the \N sequence through unchanged; this code will not
8648 attempt to determine this nor expand those. The net effect is that if the
8649 beginning of the passed-in pattern isn't '{U+' or there is no '}', it
8650 signals that this \N occurrence means to match a non-newline.
8652 Only the \N{U+...} form should occur in a character class, for the same
8653 reason that '.' inside a character class means to just match a period: it
8654 just doesn't make sense.
8656 If valuep is non-null then it is assumed that we are parsing inside
8657 of a charclass definition and the first codepoint in the resolved
8658 string is returned via *valuep and the routine will return NULL.
8659 In this mode if a multichar string is returned from the charnames
8660 handler, a warning will be issued, and only the first char in the
8661 sequence will be examined. If the string returned is zero length
8662 then the value of *valuep is undefined and NON-NULL will
8663 be returned to indicate failure. (This will NOT be a valid pointer
8666 If valuep is null then it is assumed that we are parsing normal text and a
8667 new EXACT node is inserted into the program containing the resolved string,
8668 and a pointer to the new node is returned. But if the string is zero length
8669 a NOTHING node is emitted instead.
8671 On success RExC_parse is set to the char following the endbrace.
8672 Parsing failures will generate a fatal error via vFAIL(...)
8675 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
8677 char * endbrace; /* '}' following the name */
8678 regnode *ret = NULL;
8681 GET_RE_DEBUG_FLAGS_DECL;
8683 PERL_ARGS_ASSERT_REG_NAMEDSEQ;
8687 /* The [^\n] meaning of \N ignores spaces and comments under the /x
8688 * modifier. The other meaning does not */
8689 p = (RExC_flags & RXf_PMf_EXTENDED)
8690 ? regwhite( pRExC_state, RExC_parse )
8693 /* Disambiguate between \N meaning a named character versus \N meaning
8694 * [^\n]. The former is assumed when it can't be the latter. */
8695 if (*p != '{' || regcurly(p)) {
8698 /* no bare \N in a charclass */
8699 vFAIL("\\N in a character class must be a named character: \\N{...}");
8701 nextchar(pRExC_state);
8702 ret = reg_node(pRExC_state, REG_ANY);
8703 *flagp |= HASWIDTH|SIMPLE;
8706 Set_Node_Length(ret, 1); /* MJD */
8710 /* Here, we have decided it should be a named sequence */
8712 /* The test above made sure that the next real character is a '{', but
8713 * under the /x modifier, it could be separated by space (or a comment and
8714 * \n) and this is not allowed (for consistency with \x{...} and the
8715 * tokenizer handling of \N{NAME}). */
8716 if (*RExC_parse != '{') {
8717 vFAIL("Missing braces on \\N{}");
8720 RExC_parse++; /* Skip past the '{' */
8722 if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
8723 || ! (endbrace == RExC_parse /* nothing between the {} */
8724 || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below */
8725 && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
8727 if (endbrace) RExC_parse = endbrace; /* position msg's '<--HERE' */
8728 vFAIL("\\N{NAME} must be resolved by the lexer");
8731 if (endbrace == RExC_parse) { /* empty: \N{} */
8733 RExC_parse = endbrace + 1;
8734 return reg_node(pRExC_state,NOTHING);
8738 ckWARNreg(RExC_parse,
8739 "Ignoring zero length \\N{} in character class"
8741 RExC_parse = endbrace + 1;
8744 return (regnode *) &RExC_parse; /* Invalid regnode pointer */
8747 REQUIRE_UTF8; /* named sequences imply Unicode semantics */
8748 RExC_parse += 2; /* Skip past the 'U+' */
8750 if (valuep) { /* In a bracketed char class */
8751 /* We only pay attention to the first char of
8752 multichar strings being returned. I kinda wonder
8753 if this makes sense as it does change the behaviour
8754 from earlier versions, OTOH that behaviour was broken
8755 as well. XXX Solution is to recharacterize as
8756 [rest-of-class]|multi1|multi2... */
8758 STRLEN length_of_hex;
8759 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8760 | PERL_SCAN_DISALLOW_PREFIX
8761 | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
8763 char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
8764 if (endchar < endbrace) {
8765 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
8768 length_of_hex = (STRLEN)(endchar - RExC_parse);
8769 *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
8771 /* The tokenizer should have guaranteed validity, but it's possible to
8772 * bypass it by using single quoting, so check */
8773 if (length_of_hex == 0
8774 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
8776 RExC_parse += length_of_hex; /* Includes all the valid */
8777 RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
8778 ? UTF8SKIP(RExC_parse)
8780 /* Guard against malformed utf8 */
8781 if (RExC_parse >= endchar) RExC_parse = endchar;
8782 vFAIL("Invalid hexadecimal number in \\N{U+...}");
8785 RExC_parse = endbrace + 1;
8786 if (endchar == endbrace) return NULL;
8788 ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */
8790 else { /* Not a char class */
8792 /* What is done here is to convert this to a sub-pattern of the form
8793 * (?:\x{char1}\x{char2}...)
8794 * and then call reg recursively. That way, it retains its atomicness,
8795 * while not having to worry about special handling that some code
8796 * points may have. toke.c has converted the original Unicode values
8797 * to native, so that we can just pass on the hex values unchanged. We
8798 * do have to set a flag to keep recoding from happening in the
8801 SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
8803 char *endchar; /* Points to '.' or '}' ending cur char in the input
8805 char *orig_end = RExC_end;
8807 while (RExC_parse < endbrace) {
8809 /* Code points are separated by dots. If none, there is only one
8810 * code point, and is terminated by the brace */
8811 endchar = RExC_parse + strcspn(RExC_parse, ".}");
8813 /* Convert to notation the rest of the code understands */
8814 sv_catpv(substitute_parse, "\\x{");
8815 sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
8816 sv_catpv(substitute_parse, "}");
8818 /* Point to the beginning of the next character in the sequence. */
8819 RExC_parse = endchar + 1;
8821 sv_catpv(substitute_parse, ")");
8823 RExC_parse = SvPV(substitute_parse, len);
8825 /* Don't allow empty number */
8827 vFAIL("Invalid hexadecimal number in \\N{U+...}");
8829 RExC_end = RExC_parse + len;
8831 /* The values are Unicode, and therefore not subject to recoding */
8832 RExC_override_recoding = 1;
8834 ret = reg(pRExC_state, 1, flagp, depth+1);
8836 RExC_parse = endbrace;
8837 RExC_end = orig_end;
8838 RExC_override_recoding = 0;
8840 nextchar(pRExC_state);
8850 * It returns the code point in utf8 for the value in *encp.
8851 * value: a code value in the source encoding
8852 * encp: a pointer to an Encode object
8854 * If the result from Encode is not a single character,
8855 * it returns U+FFFD (Replacement character) and sets *encp to NULL.
8858 S_reg_recode(pTHX_ const char value, SV **encp)
8861 SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
8862 const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
8863 const STRLEN newlen = SvCUR(sv);
8864 UV uv = UNICODE_REPLACEMENT;
8866 PERL_ARGS_ASSERT_REG_RECODE;
8870 ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
8873 if (!newlen || numlen != newlen) {
8874 uv = UNICODE_REPLACEMENT;
8882 - regatom - the lowest level
8884 Try to identify anything special at the start of the pattern. If there
8885 is, then handle it as required. This may involve generating a single regop,
8886 such as for an assertion; or it may involve recursing, such as to
8887 handle a () structure.
8889 If the string doesn't start with something special then we gobble up
8890 as much literal text as we can.
8892 Once we have been able to handle whatever type of thing started the
8893 sequence, we return.
8895 Note: we have to be careful with escapes, as they can be both literal
8896 and special, and in the case of \10 and friends can either, depending
8897 on context. Specifically there are two separate switches for handling
8898 escape sequences, with the one for handling literal escapes requiring
8899 a dummy entry for all of the special escapes that are actually handled
8904 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8907 register regnode *ret = NULL;
8909 char *parse_start = RExC_parse;
8911 GET_RE_DEBUG_FLAGS_DECL;
8912 DEBUG_PARSE("atom");
8913 *flagp = WORST; /* Tentatively. */
8915 PERL_ARGS_ASSERT_REGATOM;
8918 switch ((U8)*RExC_parse) {
8920 RExC_seen_zerolen++;
8921 nextchar(pRExC_state);
8922 if (RExC_flags & RXf_PMf_MULTILINE)
8923 ret = reg_node(pRExC_state, MBOL);
8924 else if (RExC_flags & RXf_PMf_SINGLELINE)
8925 ret = reg_node(pRExC_state, SBOL);
8927 ret = reg_node(pRExC_state, BOL);
8928 Set_Node_Length(ret, 1); /* MJD */
8931 nextchar(pRExC_state);
8933 RExC_seen_zerolen++;
8934 if (RExC_flags & RXf_PMf_MULTILINE)
8935 ret = reg_node(pRExC_state, MEOL);
8936 else if (RExC_flags & RXf_PMf_SINGLELINE)
8937 ret = reg_node(pRExC_state, SEOL);
8939 ret = reg_node(pRExC_state, EOL);
8940 Set_Node_Length(ret, 1); /* MJD */
8943 nextchar(pRExC_state);
8944 if (RExC_flags & RXf_PMf_SINGLELINE)
8945 ret = reg_node(pRExC_state, SANY);
8947 ret = reg_node(pRExC_state, REG_ANY);
8948 *flagp |= HASWIDTH|SIMPLE;
8950 Set_Node_Length(ret, 1); /* MJD */
8954 char * const oregcomp_parse = ++RExC_parse;
8955 ret = regclass(pRExC_state,depth+1);
8956 if (*RExC_parse != ']') {
8957 RExC_parse = oregcomp_parse;
8958 vFAIL("Unmatched [");
8960 nextchar(pRExC_state);
8961 *flagp |= HASWIDTH|SIMPLE;
8962 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
8966 nextchar(pRExC_state);
8967 ret = reg(pRExC_state, 1, &flags,depth+1);
8969 if (flags & TRYAGAIN) {
8970 if (RExC_parse == RExC_end) {
8971 /* Make parent create an empty node if needed. */
8979 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
8983 if (flags & TRYAGAIN) {
8987 vFAIL("Internal urp");
8988 /* Supposed to be caught earlier. */
8991 if (!regcurly(RExC_parse)) {
9000 vFAIL("Quantifier follows nothing");
9005 This switch handles escape sequences that resolve to some kind
9006 of special regop and not to literal text. Escape sequnces that
9007 resolve to literal text are handled below in the switch marked
9010 Every entry in this switch *must* have a corresponding entry
9011 in the literal escape switch. However, the opposite is not
9012 required, as the default for this switch is to jump to the
9013 literal text handling code.
9015 switch ((U8)*++RExC_parse) {
9016 /* Special Escapes */
9018 RExC_seen_zerolen++;
9019 ret = reg_node(pRExC_state, SBOL);
9021 goto finish_meta_pat;
9023 ret = reg_node(pRExC_state, GPOS);
9024 RExC_seen |= REG_SEEN_GPOS;
9026 goto finish_meta_pat;
9028 RExC_seen_zerolen++;
9029 ret = reg_node(pRExC_state, KEEPS);
9031 /* XXX:dmq : disabling in-place substitution seems to
9032 * be necessary here to avoid cases of memory corruption, as
9033 * with: C<$_="x" x 80; s/x\K/y/> -- rgs
9035 RExC_seen |= REG_SEEN_LOOKBEHIND;
9036 goto finish_meta_pat;
9038 ret = reg_node(pRExC_state, SEOL);
9040 RExC_seen_zerolen++; /* Do not optimize RE away */
9041 goto finish_meta_pat;
9043 ret = reg_node(pRExC_state, EOS);
9045 RExC_seen_zerolen++; /* Do not optimize RE away */
9046 goto finish_meta_pat;
9048 ret = reg_node(pRExC_state, CANY);
9049 RExC_seen |= REG_SEEN_CANY;
9050 *flagp |= HASWIDTH|SIMPLE;
9051 goto finish_meta_pat;
9053 ret = reg_node(pRExC_state, CLUMP);
9055 goto finish_meta_pat;
9057 switch (get_regex_charset(RExC_flags)) {
9058 case REGEX_LOCALE_CHARSET:
9061 case REGEX_UNICODE_CHARSET:
9064 case REGEX_ASCII_RESTRICTED_CHARSET:
9065 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9068 case REGEX_DEPENDS_CHARSET:
9074 ret = reg_node(pRExC_state, op);
9075 *flagp |= HASWIDTH|SIMPLE;
9076 goto finish_meta_pat;
9078 switch (get_regex_charset(RExC_flags)) {
9079 case REGEX_LOCALE_CHARSET:
9082 case REGEX_UNICODE_CHARSET:
9085 case REGEX_ASCII_RESTRICTED_CHARSET:
9086 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9089 case REGEX_DEPENDS_CHARSET:
9095 ret = reg_node(pRExC_state, op);
9096 *flagp |= HASWIDTH|SIMPLE;
9097 goto finish_meta_pat;
9099 RExC_seen_zerolen++;
9100 RExC_seen |= REG_SEEN_LOOKBEHIND;
9101 switch (get_regex_charset(RExC_flags)) {
9102 case REGEX_LOCALE_CHARSET:
9105 case REGEX_UNICODE_CHARSET:
9108 case REGEX_ASCII_RESTRICTED_CHARSET:
9109 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9112 case REGEX_DEPENDS_CHARSET:
9118 ret = reg_node(pRExC_state, op);
9119 FLAGS(ret) = get_regex_charset(RExC_flags);
9121 if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9122 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
9124 goto finish_meta_pat;
9126 RExC_seen_zerolen++;
9127 RExC_seen |= REG_SEEN_LOOKBEHIND;
9128 switch (get_regex_charset(RExC_flags)) {
9129 case REGEX_LOCALE_CHARSET:
9132 case REGEX_UNICODE_CHARSET:
9135 case REGEX_ASCII_RESTRICTED_CHARSET:
9136 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9139 case REGEX_DEPENDS_CHARSET:
9145 ret = reg_node(pRExC_state, op);
9146 FLAGS(ret) = get_regex_charset(RExC_flags);
9148 if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9149 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
9151 goto finish_meta_pat;
9153 switch (get_regex_charset(RExC_flags)) {
9154 case REGEX_LOCALE_CHARSET:
9157 case REGEX_UNICODE_CHARSET:
9160 case REGEX_ASCII_RESTRICTED_CHARSET:
9161 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9164 case REGEX_DEPENDS_CHARSET:
9170 ret = reg_node(pRExC_state, op);
9171 *flagp |= HASWIDTH|SIMPLE;
9172 goto finish_meta_pat;
9174 switch (get_regex_charset(RExC_flags)) {
9175 case REGEX_LOCALE_CHARSET:
9178 case REGEX_UNICODE_CHARSET:
9181 case REGEX_ASCII_RESTRICTED_CHARSET:
9182 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9185 case REGEX_DEPENDS_CHARSET:
9191 ret = reg_node(pRExC_state, op);
9192 *flagp |= HASWIDTH|SIMPLE;
9193 goto finish_meta_pat;
9195 switch (get_regex_charset(RExC_flags)) {
9196 case REGEX_LOCALE_CHARSET:
9199 case REGEX_ASCII_RESTRICTED_CHARSET:
9200 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9203 case REGEX_DEPENDS_CHARSET: /* No difference between these */
9204 case REGEX_UNICODE_CHARSET:
9210 ret = reg_node(pRExC_state, op);
9211 *flagp |= HASWIDTH|SIMPLE;
9212 goto finish_meta_pat;
9214 switch (get_regex_charset(RExC_flags)) {
9215 case REGEX_LOCALE_CHARSET:
9218 case REGEX_ASCII_RESTRICTED_CHARSET:
9219 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9222 case REGEX_DEPENDS_CHARSET: /* No difference between these */
9223 case REGEX_UNICODE_CHARSET:
9229 ret = reg_node(pRExC_state, op);
9230 *flagp |= HASWIDTH|SIMPLE;
9231 goto finish_meta_pat;
9233 ret = reg_node(pRExC_state, LNBREAK);
9234 *flagp |= HASWIDTH|SIMPLE;
9235 goto finish_meta_pat;
9237 ret = reg_node(pRExC_state, HORIZWS);
9238 *flagp |= HASWIDTH|SIMPLE;
9239 goto finish_meta_pat;
9241 ret = reg_node(pRExC_state, NHORIZWS);
9242 *flagp |= HASWIDTH|SIMPLE;
9243 goto finish_meta_pat;
9245 ret = reg_node(pRExC_state, VERTWS);
9246 *flagp |= HASWIDTH|SIMPLE;
9247 goto finish_meta_pat;
9249 ret = reg_node(pRExC_state, NVERTWS);
9250 *flagp |= HASWIDTH|SIMPLE;
9252 nextchar(pRExC_state);
9253 Set_Node_Length(ret, 2); /* MJD */
9258 char* const oldregxend = RExC_end;
9260 char* parse_start = RExC_parse - 2;
9263 if (RExC_parse[1] == '{') {
9264 /* a lovely hack--pretend we saw [\pX] instead */
9265 RExC_end = strchr(RExC_parse, '}');
9267 const U8 c = (U8)*RExC_parse;
9269 RExC_end = oldregxend;
9270 vFAIL2("Missing right brace on \\%c{}", c);
9275 RExC_end = RExC_parse + 2;
9276 if (RExC_end > oldregxend)
9277 RExC_end = oldregxend;
9281 ret = regclass(pRExC_state,depth+1);
9283 RExC_end = oldregxend;
9286 Set_Node_Offset(ret, parse_start + 2);
9287 Set_Node_Cur_Length(ret);
9288 nextchar(pRExC_state);
9289 *flagp |= HASWIDTH|SIMPLE;
9293 /* Handle \N and \N{NAME} here and not below because it can be
9294 multicharacter. join_exact() will join them up later on.
9295 Also this makes sure that things like /\N{BLAH}+/ and
9296 \N{BLAH} being multi char Just Happen. dmq*/
9298 ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
9300 case 'k': /* Handle \k<NAME> and \k'NAME' */
9303 char ch= RExC_parse[1];
9304 if (ch != '<' && ch != '\'' && ch != '{') {
9306 vFAIL2("Sequence %.2s... not terminated",parse_start);
9308 /* this pretty much dupes the code for (?P=...) in reg(), if
9309 you change this make sure you change that */
9310 char* name_start = (RExC_parse += 2);
9312 SV *sv_dat = reg_scan_name(pRExC_state,
9313 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9314 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
9315 if (RExC_parse == name_start || *RExC_parse != ch)
9316 vFAIL2("Sequence %.3s... not terminated",parse_start);
9319 num = add_data( pRExC_state, 1, "S" );
9320 RExC_rxi->data->data[num]=(void*)sv_dat;
9321 SvREFCNT_inc_simple_void(sv_dat);
9325 ret = reganode(pRExC_state,
9328 : (MORE_ASCII_RESTRICTED)
9330 : (AT_LEAST_UNI_SEMANTICS)
9338 /* override incorrect value set in reganode MJD */
9339 Set_Node_Offset(ret, parse_start+1);
9340 Set_Node_Cur_Length(ret); /* MJD */
9341 nextchar(pRExC_state);
9347 case '1': case '2': case '3': case '4':
9348 case '5': case '6': case '7': case '8': case '9':
9351 bool isg = *RExC_parse == 'g';
9356 if (*RExC_parse == '{') {
9360 if (*RExC_parse == '-') {
9364 if (hasbrace && !isDIGIT(*RExC_parse)) {
9365 if (isrel) RExC_parse--;
9367 goto parse_named_seq;
9369 num = atoi(RExC_parse);
9370 if (isg && num == 0)
9371 vFAIL("Reference to invalid group 0");
9373 num = RExC_npar - num;
9375 vFAIL("Reference to nonexistent or unclosed group");
9377 if (!isg && num > 9 && num >= RExC_npar)
9380 char * const parse_start = RExC_parse - 1; /* MJD */
9381 while (isDIGIT(*RExC_parse))
9383 if (parse_start == RExC_parse - 1)
9384 vFAIL("Unterminated \\g... pattern");
9386 if (*RExC_parse != '}')
9387 vFAIL("Unterminated \\g{...} pattern");
9391 if (num > (I32)RExC_rx->nparens)
9392 vFAIL("Reference to nonexistent group");
9395 ret = reganode(pRExC_state,
9398 : (MORE_ASCII_RESTRICTED)
9400 : (AT_LEAST_UNI_SEMANTICS)
9408 /* override incorrect value set in reganode MJD */
9409 Set_Node_Offset(ret, parse_start+1);
9410 Set_Node_Cur_Length(ret); /* MJD */
9412 nextchar(pRExC_state);
9417 if (RExC_parse >= RExC_end)
9418 FAIL("Trailing \\");
9421 /* Do not generate "unrecognized" warnings here, we fall
9422 back into the quick-grab loop below */
9429 if (RExC_flags & RXf_PMf_EXTENDED) {
9430 if ( reg_skipcomment( pRExC_state ) )
9437 parse_start = RExC_parse - 1;
9442 register STRLEN len;
9447 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
9450 /* Is this a LATIN LOWER CASE SHARP S in an EXACTFU node? If so,
9451 * it is folded to 'ss' even if not utf8 */
9452 bool is_exactfu_sharp_s;
9455 node_type = ((! FOLD) ? EXACT
9458 : (MORE_ASCII_RESTRICTED)
9460 : (AT_LEAST_UNI_SEMANTICS)
9463 ret = reg_node(pRExC_state, node_type);
9466 /* XXX The node can hold up to 255 bytes, yet this only goes to
9467 * 127. I (khw) do not know why. Keeping it somewhat less than
9468 * 255 allows us to not have to worry about overflow due to
9469 * converting to utf8 and fold expansion, but that value is
9470 * 255-UTF8_MAXBYTES_CASE. join_exact() may join adjacent nodes
9471 * split up by this limit into a single one using the real max of
9472 * 255. Even at 127, this breaks under rare circumstances. If
9473 * folding, we do not want to split a node at a character that is a
9474 * non-final in a multi-char fold, as an input string could just
9475 * happen to want to match across the node boundary. The join
9476 * would solve that problem if the join actually happens. But a
9477 * series of more than two nodes in a row each of 127 would cause
9478 * the first join to succeed to get to 254, but then there wouldn't
9479 * be room for the next one, which could at be one of those split
9480 * multi-char folds. I don't know of any fool-proof solution. One
9481 * could back off to end with only a code point that isn't such a
9482 * non-final, but it is possible for there not to be any in the
9484 for (len = 0, p = RExC_parse - 1;
9485 len < 127 && p < RExC_end;
9488 char * const oldp = p;
9490 if (RExC_flags & RXf_PMf_EXTENDED)
9491 p = regwhite( pRExC_state, p );
9502 /* Literal Escapes Switch
9504 This switch is meant to handle escape sequences that
9505 resolve to a literal character.
9507 Every escape sequence that represents something
9508 else, like an assertion or a char class, is handled
9509 in the switch marked 'Special Escapes' above in this
9510 routine, but also has an entry here as anything that
9511 isn't explicitly mentioned here will be treated as
9512 an unescaped equivalent literal.
9516 /* These are all the special escapes. */
9517 case 'A': /* Start assertion */
9518 case 'b': case 'B': /* Word-boundary assertion*/
9519 case 'C': /* Single char !DANGEROUS! */
9520 case 'd': case 'D': /* digit class */
9521 case 'g': case 'G': /* generic-backref, pos assertion */
9522 case 'h': case 'H': /* HORIZWS */
9523 case 'k': case 'K': /* named backref, keep marker */
9524 case 'N': /* named char sequence */
9525 case 'p': case 'P': /* Unicode property */
9526 case 'R': /* LNBREAK */
9527 case 's': case 'S': /* space class */
9528 case 'v': case 'V': /* VERTWS */
9529 case 'w': case 'W': /* word class */
9530 case 'X': /* eXtended Unicode "combining character sequence" */
9531 case 'z': case 'Z': /* End of line/string assertion */
9535 /* Anything after here is an escape that resolves to a
9536 literal. (Except digits, which may or may not)
9555 ender = ASCII_TO_NATIVE('\033');
9559 ender = ASCII_TO_NATIVE('\007');
9564 STRLEN brace_len = len;
9566 const char* error_msg;
9568 bool valid = grok_bslash_o(p,
9575 RExC_parse = p; /* going to die anyway; point
9576 to exact spot of failure */
9583 if (PL_encoding && ender < 0x100) {
9584 goto recode_encoding;
9593 char* const e = strchr(p, '}');
9597 vFAIL("Missing right brace on \\x{}");
9600 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9601 | PERL_SCAN_DISALLOW_PREFIX;
9602 STRLEN numlen = e - p - 1;
9603 ender = grok_hex(p + 1, &numlen, &flags, NULL);
9610 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9612 ender = grok_hex(p, &numlen, &flags, NULL);
9615 if (PL_encoding && ender < 0x100)
9616 goto recode_encoding;
9620 ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
9622 case '0': case '1': case '2': case '3':case '4':
9623 case '5': case '6': case '7': case '8':case '9':
9625 (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
9627 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9629 ender = grok_oct(p, &numlen, &flags, NULL);
9639 if (PL_encoding && ender < 0x100)
9640 goto recode_encoding;
9643 if (! RExC_override_recoding) {
9644 SV* enc = PL_encoding;
9645 ender = reg_recode((const char)(U8)ender, &enc);
9646 if (!enc && SIZE_ONLY)
9647 ckWARNreg(p, "Invalid escape in the specified encoding");
9653 FAIL("Trailing \\");
9656 if (!SIZE_ONLY&& isALPHA(*p)) {
9657 /* Include any { following the alpha to emphasize
9658 * that it could be part of an escape at some point
9660 int len = (*(p + 1) == '{') ? 2 : 1;
9661 ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
9663 goto normal_default;
9668 if (UTF8_IS_START(*p) && UTF) {
9670 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
9671 &numlen, UTF8_ALLOW_DEFAULT);
9677 } /* End of switch on the literal */
9679 is_exactfu_sharp_s = (node_type == EXACTFU
9680 && ender == LATIN_SMALL_LETTER_SHARP_S);
9681 if ( RExC_flags & RXf_PMf_EXTENDED)
9682 p = regwhite( pRExC_state, p );
9683 if ((UTF && FOLD) || is_exactfu_sharp_s) {
9684 /* Prime the casefolded buffer. Locale rules, which apply
9685 * only to code points < 256, aren't known until execution,
9686 * so for them, just output the original character using
9687 * utf8. If we start to fold non-UTF patterns, be sure to
9688 * update join_exact() */
9689 if (LOC && ender < 256) {
9690 if (UNI_IS_INVARIANT(ender)) {
9691 *tmpbuf = (U8) ender;
9694 *tmpbuf = UTF8_TWO_BYTE_HI(ender);
9695 *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
9699 else if (isASCII(ender)) { /* Note: Here can't also be LOC
9701 ender = toLOWER(ender);
9702 *tmpbuf = (U8) ender;
9705 else if (! MORE_ASCII_RESTRICTED && ! LOC) {
9707 /* Locale and /aa require more selectivity about the
9708 * fold, so are handled below. Otherwise, here, just
9710 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
9713 /* Under locale rules or /aa we are not to mix,
9714 * respectively, ords < 256 or ASCII with non-. So
9715 * reject folds that mix them, using only the
9716 * non-folded code point. So do the fold to a
9717 * temporary, and inspect each character in it. */
9718 U8 trialbuf[UTF8_MAXBYTES_CASE+1];
9720 UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
9721 U8* e = s + foldlen;
9722 bool fold_ok = TRUE;
9726 || (LOC && (UTF8_IS_INVARIANT(*s)
9727 || UTF8_IS_DOWNGRADEABLE_START(*s))))
9735 Copy(trialbuf, tmpbuf, foldlen, U8);
9739 uvuni_to_utf8(tmpbuf, ender);
9740 foldlen = UNISKIP(ender);
9744 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
9747 else if (UTF || is_exactfu_sharp_s) {
9749 /* Emit all the Unicode characters. */
9751 for (foldbuf = tmpbuf;
9753 foldlen -= numlen) {
9754 ender = utf8_to_uvchr(foldbuf, &numlen);
9756 const STRLEN unilen = reguni(pRExC_state, ender, s);
9759 /* In EBCDIC the numlen
9760 * and unilen can differ. */
9762 if (numlen >= foldlen)
9766 break; /* "Can't happen." */
9770 const STRLEN unilen = reguni(pRExC_state, ender, s);
9779 REGC((char)ender, s++);
9783 if (UTF || is_exactfu_sharp_s) {
9785 /* Emit all the Unicode characters. */
9787 for (foldbuf = tmpbuf;
9789 foldlen -= numlen) {
9790 ender = utf8_to_uvchr(foldbuf, &numlen);
9792 const STRLEN unilen = reguni(pRExC_state, ender, s);
9795 /* In EBCDIC the numlen
9796 * and unilen can differ. */
9798 if (numlen >= foldlen)
9806 const STRLEN unilen = reguni(pRExC_state, ender, s);
9815 REGC((char)ender, s++);
9818 loopdone: /* Jumped to when encounters something that shouldn't be in
9821 Set_Node_Cur_Length(ret); /* MJD */
9822 nextchar(pRExC_state);
9824 /* len is STRLEN which is unsigned, need to copy to signed */
9827 vFAIL("Internal disaster");
9831 if (len == 1 && UNI_IS_INVARIANT(ender))
9835 RExC_size += STR_SZ(len);
9838 RExC_emit += STR_SZ(len);
9846 /* Jumped to when an unrecognized character set is encountered */
9848 Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9853 S_regwhite( RExC_state_t *pRExC_state, char *p )
9855 const char *e = RExC_end;
9857 PERL_ARGS_ASSERT_REGWHITE;
9862 else if (*p == '#') {
9871 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9879 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9880 Character classes ([:foo:]) can also be negated ([:^foo:]).
9881 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9882 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9883 but trigger failures because they are currently unimplemented. */
9885 #define POSIXCC_DONE(c) ((c) == ':')
9886 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9887 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9890 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9893 I32 namedclass = OOB_NAMEDCLASS;
9895 PERL_ARGS_ASSERT_REGPPOSIXCC;
9897 if (value == '[' && RExC_parse + 1 < RExC_end &&
9898 /* I smell either [: or [= or [. -- POSIX has been here, right? */
9899 POSIXCC(UCHARAT(RExC_parse))) {
9900 const char c = UCHARAT(RExC_parse);
9901 char* const s = RExC_parse++;
9903 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9905 if (RExC_parse == RExC_end)
9906 /* Grandfather lone [:, [=, [. */
9909 const char* const t = RExC_parse++; /* skip over the c */
9912 if (UCHARAT(RExC_parse) == ']') {
9913 const char *posixcc = s + 1;
9914 RExC_parse++; /* skip over the ending ] */
9917 const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
9918 const I32 skip = t - posixcc;
9920 /* Initially switch on the length of the name. */
9923 if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
9924 namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
9927 /* Names all of length 5. */
9928 /* alnum alpha ascii blank cntrl digit graph lower
9929 print punct space upper */
9930 /* Offset 4 gives the best switch position. */
9931 switch (posixcc[4]) {
9933 if (memEQ(posixcc, "alph", 4)) /* alpha */
9934 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
9937 if (memEQ(posixcc, "spac", 4)) /* space */
9938 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
9941 if (memEQ(posixcc, "grap", 4)) /* graph */
9942 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
9945 if (memEQ(posixcc, "asci", 4)) /* ascii */
9946 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
9949 if (memEQ(posixcc, "blan", 4)) /* blank */
9950 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
9953 if (memEQ(posixcc, "cntr", 4)) /* cntrl */
9954 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
9957 if (memEQ(posixcc, "alnu", 4)) /* alnum */
9958 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
9961 if (memEQ(posixcc, "lowe", 4)) /* lower */
9962 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
9963 else if (memEQ(posixcc, "uppe", 4)) /* upper */
9964 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
9967 if (memEQ(posixcc, "digi", 4)) /* digit */
9968 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
9969 else if (memEQ(posixcc, "prin", 4)) /* print */
9970 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
9971 else if (memEQ(posixcc, "punc", 4)) /* punct */
9972 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
9977 if (memEQ(posixcc, "xdigit", 6))
9978 namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
9982 if (namedclass == OOB_NAMEDCLASS)
9983 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
9985 assert (posixcc[skip] == ':');
9986 assert (posixcc[skip+1] == ']');
9987 } else if (!SIZE_ONLY) {
9988 /* [[=foo=]] and [[.foo.]] are still future. */
9990 /* adjust RExC_parse so the warning shows after
9992 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
9994 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
9997 /* Maternal grandfather:
9998 * "[:" ending in ":" but not in ":]" */
10008 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
10012 PERL_ARGS_ASSERT_CHECKPOSIXCC;
10014 if (POSIXCC(UCHARAT(RExC_parse))) {
10015 const char *s = RExC_parse;
10016 const char c = *s++;
10018 while (isALNUM(*s))
10020 if (*s && c == *s && s[1] == ']') {
10022 "POSIX syntax [%c %c] belongs inside character classes",
10025 /* [[=foo=]] and [[.foo.]] are still future. */
10026 if (POSIXCC_NOTYET(c)) {
10027 /* adjust RExC_parse so the error shows after
10028 the class closes */
10029 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
10031 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10037 /* Generate the code to add a full posix character <class> to the bracketed
10038 * character class given by <node>. (<node> is needed only under locale rules)
10039 * destlist is the inversion list for non-locale rules that this class is
10041 * sourcelist is the ASCII-range inversion list to add under /a rules
10042 * Xsourcelist is the full Unicode range list to use otherwise. */
10043 #define DO_POSIX(node, class, destlist, sourcelist, Xsourcelist) \
10045 SV* scratch_list = NULL; \
10047 /* Set this class in the node for runtime matching */ \
10048 ANYOF_CLASS_SET(node, class); \
10050 /* For above Latin1 code points, we use the full Unicode range */ \
10051 _invlist_intersection(PL_AboveLatin1, \
10054 /* And set the output to it, adding instead if there already is an \
10055 * output. Checking if <destlist> is NULL first saves an extra \
10056 * clone. Its reference count will be decremented at the next \
10057 * union, etc, or if this is the only instance, at the end of the \
10059 if (! destlist) { \
10060 destlist = scratch_list; \
10063 _invlist_union(destlist, scratch_list, &destlist); \
10064 SvREFCNT_dec(scratch_list); \
10068 /* For non-locale, just add it to any existing list */ \
10069 _invlist_union(destlist, \
10070 (AT_LEAST_ASCII_RESTRICTED) \
10076 /* Like DO_POSIX, but matches the complement of <sourcelist> and <Xsourcelist>.
10078 #define DO_N_POSIX(node, class, destlist, sourcelist, Xsourcelist) \
10080 SV* scratch_list = NULL; \
10081 ANYOF_CLASS_SET(node, class); \
10082 _invlist_subtract(PL_AboveLatin1, Xsourcelist, &scratch_list); \
10083 if (! destlist) { \
10084 destlist = scratch_list; \
10087 _invlist_union(destlist, scratch_list, &destlist); \
10088 SvREFCNT_dec(scratch_list); \
10092 _invlist_union_complement_2nd(destlist, \
10093 (AT_LEAST_ASCII_RESTRICTED) \
10097 /* Under /d, everything in the upper half of the Latin1 range \
10098 * matches this complement */ \
10099 if (DEPENDS_SEMANTICS) { \
10100 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL; \
10104 /* Generate the code to add a posix character <class> to the bracketed
10105 * character class given by <node>. (<node> is needed only under locale rules)
10106 * destlist is the inversion list for non-locale rules that this class is
10108 * sourcelist is the ASCII-range inversion list to add under /a rules
10109 * l1_sourcelist is the Latin1 range list to use otherwise.
10110 * Xpropertyname is the name to add to <run_time_list> of the property to
10111 * specify the code points above Latin1 that will have to be
10112 * determined at run-time
10113 * run_time_list is a SV* that contains text names of properties that are to
10114 * be computed at run time. This concatenates <Xpropertyname>
10115 * to it, apppropriately
10116 * This is essentially DO_POSIX, but we know only the Latin1 values at compile
10118 #define DO_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist, \
10119 l1_sourcelist, Xpropertyname, run_time_list) \
10120 /* If not /a matching, there are going to be code points we will have \
10121 * to defer to runtime to look-up */ \
10122 if (! AT_LEAST_ASCII_RESTRICTED) { \
10123 Perl_sv_catpvf(aTHX_ run_time_list, "+utf8::%s\n", Xpropertyname); \
10126 ANYOF_CLASS_SET(node, class); \
10129 _invlist_union(destlist, \
10130 (AT_LEAST_ASCII_RESTRICTED) \
10136 /* Like DO_POSIX_LATIN1_ONLY_KNOWN, but for the complement. A combination of
10137 * this and DO_N_POSIX */
10138 #define DO_N_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist, \
10139 l1_sourcelist, Xpropertyname, run_time_list) \
10140 if (AT_LEAST_ASCII_RESTRICTED) { \
10141 _invlist_union_complement_2nd(destlist, sourcelist, &destlist); \
10144 Perl_sv_catpvf(aTHX_ run_time_list, "!utf8::%s\n", Xpropertyname); \
10146 ANYOF_CLASS_SET(node, namedclass); \
10149 SV* scratch_list = NULL; \
10150 _invlist_subtract(PL_Latin1, l1_sourcelist, &scratch_list); \
10151 if (! destlist) { \
10152 destlist = scratch_list; \
10155 _invlist_union(destlist, scratch_list, &destlist); \
10156 SvREFCNT_dec(scratch_list); \
10158 if (DEPENDS_SEMANTICS) { \
10159 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL; \
10165 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10168 /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
10169 * Locale folding is done at run-time, so this function should not be
10170 * called for nodes that are for locales.
10172 * This function sets the bit corresponding to the fold of the input
10173 * 'value', if not already set. The fold of 'f' is 'F', and the fold of
10176 * It also knows about the characters that are in the bitmap that have
10177 * folds that are matchable only outside it, and sets the appropriate lists
10180 * It returns the number of bits that actually changed from 0 to 1 */
10185 PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
10187 fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
10190 /* It assumes the bit for 'value' has already been set */
10191 if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
10192 ANYOF_BITMAP_SET(node, fold);
10195 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
10196 /* Certain Latin1 characters have matches outside the bitmap. To get
10197 * here, 'value' is one of those characters. None of these matches is
10198 * valid for ASCII characters under /aa, which have been excluded by
10199 * the 'if' above. The matches fall into three categories:
10200 * 1) They are singly folded-to or -from an above 255 character, as
10201 * LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
10203 * 2) They are part of a multi-char fold with another character in the
10204 * bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
10205 * 3) They are part of a multi-char fold with a character not in the
10206 * bitmap, such as various ligatures.
10207 * We aren't dealing fully with multi-char folds, except we do deal
10208 * with the pattern containing a character that has a multi-char fold
10209 * (not so much the inverse).
10210 * For types 1) and 3), the matches only happen when the target string
10211 * is utf8; that's not true for 2), and we set a flag for it.
10213 * The code below adds to the passed in inversion list the single fold
10214 * closures for 'value'. The values are hard-coded here so that an
10215 * innocent-looking character class, like /[ks]/i won't have to go out
10216 * to disk to find the possible matches. XXX It would be better to
10217 * generate these via regen, in case a new version of the Unicode
10218 * standard adds new mappings, though that is not really likely. */
10223 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
10227 /* LATIN SMALL LETTER LONG S */
10228 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
10231 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10232 GREEK_SMALL_LETTER_MU);
10233 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10234 GREEK_CAPITAL_LETTER_MU);
10236 case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
10237 case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
10238 /* ANGSTROM SIGN */
10239 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
10240 if (DEPENDS_SEMANTICS) { /* See DEPENDS comment below */
10241 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10242 PL_fold_latin1[value]);
10245 case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
10246 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10247 LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
10249 case LATIN_SMALL_LETTER_SHARP_S:
10250 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10251 LATIN_CAPITAL_LETTER_SHARP_S);
10253 /* Under /a, /d, and /u, this can match the two chars "ss" */
10254 if (! MORE_ASCII_RESTRICTED) {
10255 add_alternate(alternate_ptr, (U8 *) "ss", 2);
10257 /* And under /u or /a, it can match even if the target is
10259 if (AT_LEAST_UNI_SEMANTICS) {
10260 ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
10264 case 'F': case 'f':
10265 case 'I': case 'i':
10266 case 'L': case 'l':
10267 case 'T': case 't':
10268 case 'A': case 'a':
10269 case 'H': case 'h':
10270 case 'J': case 'j':
10271 case 'N': case 'n':
10272 case 'W': case 'w':
10273 case 'Y': case 'y':
10274 /* These all are targets of multi-character folds from code
10275 * points that require UTF8 to express, so they can't match
10276 * unless the target string is in UTF-8, so no action here is
10277 * necessary, as regexec.c properly handles the general case
10278 * for UTF-8 matching */
10281 /* Use deprecated warning to increase the chances of this
10283 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
10287 else if (DEPENDS_SEMANTICS
10288 && ! isASCII(value)
10289 && PL_fold_latin1[value] != value)
10291 /* Under DEPENDS rules, non-ASCII Latin1 characters match their
10292 * folds only when the target string is in UTF-8. We add the fold
10293 * here to the list of things to match outside the bitmap, which
10294 * won't be looked at unless it is UTF8 (or else if something else
10295 * says to look even if not utf8, but those things better not happen
10296 * under DEPENDS semantics. */
10297 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
10304 PERL_STATIC_INLINE U8
10305 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10307 /* This inline function sets a bit in the bitmap if not already set, and if
10308 * appropriate, its fold, returning the number of bits that actually
10309 * changed from 0 to 1 */
10313 PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
10315 if (ANYOF_BITMAP_TEST(node, value)) { /* Already set */
10319 ANYOF_BITMAP_SET(node, value);
10322 if (FOLD && ! LOC) { /* Locale folds aren't known until runtime */
10323 stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
10330 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
10332 /* Adds input 'string' with length 'len' to the ANYOF node's unicode
10333 * alternate list, pointed to by 'alternate_ptr'. This is an array of
10334 * the multi-character folds of characters in the node */
10337 PERL_ARGS_ASSERT_ADD_ALTERNATE;
10339 if (! *alternate_ptr) {
10340 *alternate_ptr = newAV();
10342 sv = newSVpvn_utf8((char*)string, len, TRUE);
10343 av_push(*alternate_ptr, sv);
10348 parse a class specification and produce either an ANYOF node that
10349 matches the pattern or perhaps will be optimized into an EXACTish node
10350 instead. The node contains a bit map for the first 256 characters, with the
10351 corresponding bit set if that character is in the list. For characters
10352 above 255, a range list is used */
10355 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
10358 register UV nextvalue;
10359 register IV prevvalue = OOB_UNICODE;
10360 register IV range = 0;
10361 UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
10362 register regnode *ret;
10365 char *rangebegin = NULL;
10366 bool need_class = 0;
10367 bool allow_full_fold = TRUE; /* Assume wants multi-char folding */
10369 STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
10370 than just initialized. */
10371 SV* properties = NULL; /* Code points that match \p{} \P{} */
10372 UV element_count = 0; /* Number of distinct elements in the class.
10373 Optimizations may be possible if this is tiny */
10376 /* Unicode properties are stored in a swash; this holds the current one
10377 * being parsed. If this swash is the only above-latin1 component of the
10378 * character class, an optimization is to pass it directly on to the
10379 * execution engine. Otherwise, it is set to NULL to indicate that there
10380 * are other things in the class that have to be dealt with at execution
10382 SV* swash = NULL; /* Code points that match \p{} \P{} */
10384 /* Set if a component of this character class is user-defined; just passed
10385 * on to the engine */
10386 UV has_user_defined_property = 0;
10388 /* code points this node matches that can't be stored in the bitmap */
10389 SV* nonbitmap = NULL;
10391 /* The items that are to match that aren't stored in the bitmap, but are a
10392 * result of things that are stored there. This is the fold closure of
10393 * such a character, either because it has DEPENDS semantics and shouldn't
10394 * be matched unless the target string is utf8, or is a code point that is
10395 * too large for the bit map, as for example, the fold of the MICRO SIGN is
10396 * above 255. This all is solely for performance reasons. By having this
10397 * code know the outside-the-bitmap folds that the bitmapped characters are
10398 * involved with, we don't have to go out to disk to find the list of
10399 * matches, unless the character class includes code points that aren't
10400 * storable in the bit map. That means that a character class with an 's'
10401 * in it, for example, doesn't need to go out to disk to find everything
10402 * that matches. A 2nd list is used so that the 'nonbitmap' list is kept
10403 * empty unless there is something whose fold we don't know about, and will
10404 * have to go out to the disk to find. */
10405 SV* l1_fold_invlist = NULL;
10407 /* List of multi-character folds that are matched by this node */
10408 AV* unicode_alternate = NULL;
10410 UV literal_endpoint = 0;
10412 UV stored = 0; /* how many chars stored in the bitmap */
10414 regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
10415 case we need to change the emitted regop to an EXACT. */
10416 const char * orig_parse = RExC_parse;
10417 GET_RE_DEBUG_FLAGS_DECL;
10419 PERL_ARGS_ASSERT_REGCLASS;
10421 PERL_UNUSED_ARG(depth);
10424 DEBUG_PARSE("clas");
10426 /* Assume we are going to generate an ANYOF node. */
10427 ret = reganode(pRExC_state, ANYOF, 0);
10431 ANYOF_FLAGS(ret) = 0;
10434 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
10438 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
10440 /* We have decided to not allow multi-char folds in inverted character
10441 * classes, due to the confusion that can happen, especially with
10442 * classes that are designed for a non-Unicode world: You have the
10443 * peculiar case that:
10444 "s s" =~ /^[^\xDF]+$/i => Y
10445 "ss" =~ /^[^\xDF]+$/i => N
10447 * See [perl #89750] */
10448 allow_full_fold = FALSE;
10452 RExC_size += ANYOF_SKIP;
10453 listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
10456 RExC_emit += ANYOF_SKIP;
10458 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
10460 ANYOF_BITMAP_ZERO(ret);
10461 listsv = newSVpvs("# comment\n");
10462 initial_listsv_len = SvCUR(listsv);
10465 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10467 if (!SIZE_ONLY && POSIXCC(nextvalue))
10468 checkposixcc(pRExC_state);
10470 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
10471 if (UCHARAT(RExC_parse) == ']')
10472 goto charclassloop;
10475 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
10479 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
10482 rangebegin = RExC_parse;
10486 value = utf8n_to_uvchr((U8*)RExC_parse,
10487 RExC_end - RExC_parse,
10488 &numlen, UTF8_ALLOW_DEFAULT);
10489 RExC_parse += numlen;
10492 value = UCHARAT(RExC_parse++);
10494 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10495 if (value == '[' && POSIXCC(nextvalue))
10496 namedclass = regpposixcc(pRExC_state, value);
10497 else if (value == '\\') {
10499 value = utf8n_to_uvchr((U8*)RExC_parse,
10500 RExC_end - RExC_parse,
10501 &numlen, UTF8_ALLOW_DEFAULT);
10502 RExC_parse += numlen;
10505 value = UCHARAT(RExC_parse++);
10506 /* Some compilers cannot handle switching on 64-bit integer
10507 * values, therefore value cannot be an UV. Yes, this will
10508 * be a problem later if we want switch on Unicode.
10509 * A similar issue a little bit later when switching on
10510 * namedclass. --jhi */
10511 switch ((I32)value) {
10512 case 'w': namedclass = ANYOF_ALNUM; break;
10513 case 'W': namedclass = ANYOF_NALNUM; break;
10514 case 's': namedclass = ANYOF_SPACE; break;
10515 case 'S': namedclass = ANYOF_NSPACE; break;
10516 case 'd': namedclass = ANYOF_DIGIT; break;
10517 case 'D': namedclass = ANYOF_NDIGIT; break;
10518 case 'v': namedclass = ANYOF_VERTWS; break;
10519 case 'V': namedclass = ANYOF_NVERTWS; break;
10520 case 'h': namedclass = ANYOF_HORIZWS; break;
10521 case 'H': namedclass = ANYOF_NHORIZWS; break;
10522 case 'N': /* Handle \N{NAME} in class */
10524 /* We only pay attention to the first char of
10525 multichar strings being returned. I kinda wonder
10526 if this makes sense as it does change the behaviour
10527 from earlier versions, OTOH that behaviour was broken
10529 UV v; /* value is register so we cant & it /grrr */
10530 if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
10540 if (RExC_parse >= RExC_end)
10541 vFAIL2("Empty \\%c{}", (U8)value);
10542 if (*RExC_parse == '{') {
10543 const U8 c = (U8)value;
10544 e = strchr(RExC_parse++, '}');
10546 vFAIL2("Missing right brace on \\%c{}", c);
10547 while (isSPACE(UCHARAT(RExC_parse)))
10549 if (e == RExC_parse)
10550 vFAIL2("Empty \\%c{}", c);
10551 n = e - RExC_parse;
10552 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
10563 if (UCHARAT(RExC_parse) == '^') {
10566 value = value == 'p' ? 'P' : 'p'; /* toggle */
10567 while (isSPACE(UCHARAT(RExC_parse))) {
10572 /* Try to get the definition of the property into
10573 * <invlist>. If /i is in effect, the effective property
10574 * will have its name be <__NAME_i>. The design is
10575 * discussed in commit
10576 * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
10577 Newx(name, n + sizeof("_i__\n"), char);
10579 sprintf(name, "%s%.*s%s\n",
10580 (FOLD) ? "__" : "",
10586 /* Look up the property name, and get its swash and
10587 * inversion list, if the property is found */
10589 SvREFCNT_dec(swash);
10591 swash = _core_swash_init("utf8", name, &PL_sv_undef,
10594 TRUE, /* this routine will handle
10595 undefined properties */
10596 NULL, FALSE /* No inversion list */
10600 || ! SvTYPE(SvRV(swash)) == SVt_PVHV
10602 hv_fetchs(MUTABLE_HV(SvRV(swash)),
10604 || ! (invlist = *invlistsvp))
10607 SvREFCNT_dec(swash);
10611 /* Here didn't find it. It could be a user-defined
10612 * property that will be available at run-time. Add it
10613 * to the list to look up then */
10614 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
10615 (value == 'p' ? '+' : '!'),
10617 has_user_defined_property = 1;
10619 /* We don't know yet, so have to assume that the
10620 * property could match something in the Latin1 range,
10621 * hence something that isn't utf8 */
10622 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
10626 /* Here, did get the swash and its inversion list. If
10627 * the swash is from a user-defined property, then this
10628 * whole character class should be regarded as such */
10629 SV** user_defined_svp =
10630 hv_fetchs(MUTABLE_HV(SvRV(swash)),
10631 "USER_DEFINED", FALSE);
10632 if (user_defined_svp) {
10633 has_user_defined_property
10634 |= SvUV(*user_defined_svp);
10637 /* Invert if asking for the complement */
10638 if (value == 'P') {
10639 _invlist_union_complement_2nd(properties, invlist, &properties);
10641 /* The swash can't be used as-is, because we've
10642 * inverted things; delay removing it to here after
10643 * have copied its invlist above */
10644 SvREFCNT_dec(swash);
10648 _invlist_union(properties, invlist, &properties);
10653 RExC_parse = e + 1;
10654 namedclass = ANYOF_MAX; /* no official name, but it's named */
10656 /* \p means they want Unicode semantics */
10657 RExC_uni_semantics = 1;
10660 case 'n': value = '\n'; break;
10661 case 'r': value = '\r'; break;
10662 case 't': value = '\t'; break;
10663 case 'f': value = '\f'; break;
10664 case 'b': value = '\b'; break;
10665 case 'e': value = ASCII_TO_NATIVE('\033');break;
10666 case 'a': value = ASCII_TO_NATIVE('\007');break;
10668 RExC_parse--; /* function expects to be pointed at the 'o' */
10670 const char* error_msg;
10671 bool valid = grok_bslash_o(RExC_parse,
10676 RExC_parse += numlen;
10681 if (PL_encoding && value < 0x100) {
10682 goto recode_encoding;
10686 if (*RExC_parse == '{') {
10687 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
10688 | PERL_SCAN_DISALLOW_PREFIX;
10689 char * const e = strchr(RExC_parse++, '}');
10691 vFAIL("Missing right brace on \\x{}");
10693 numlen = e - RExC_parse;
10694 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10695 RExC_parse = e + 1;
10698 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
10700 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10701 RExC_parse += numlen;
10703 if (PL_encoding && value < 0x100)
10704 goto recode_encoding;
10707 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
10709 case '0': case '1': case '2': case '3': case '4':
10710 case '5': case '6': case '7':
10712 /* Take 1-3 octal digits */
10713 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10715 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
10716 RExC_parse += numlen;
10717 if (PL_encoding && value < 0x100)
10718 goto recode_encoding;
10722 if (! RExC_override_recoding) {
10723 SV* enc = PL_encoding;
10724 value = reg_recode((const char)(U8)value, &enc);
10725 if (!enc && SIZE_ONLY)
10726 ckWARNreg(RExC_parse,
10727 "Invalid escape in the specified encoding");
10731 /* Allow \_ to not give an error */
10732 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
10733 ckWARN2reg(RExC_parse,
10734 "Unrecognized escape \\%c in character class passed through",
10739 } /* end of \blah */
10742 literal_endpoint++;
10745 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
10747 /* What matches in a locale is not known until runtime, so need to
10748 * (one time per class) allocate extra space to pass to regexec.
10749 * The space will contain a bit for each named class that is to be
10750 * matched against. This isn't needed for \p{} and pseudo-classes,
10751 * as they are not affected by locale, and hence are dealt with
10753 if (LOC && namedclass < ANYOF_MAX && ! need_class) {
10756 RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10759 RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10760 ANYOF_CLASS_ZERO(ret);
10762 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
10765 /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a
10766 * literal, as is the character that began the false range, i.e.
10767 * the 'a' in the examples */
10771 RExC_parse >= rangebegin ?
10772 RExC_parse - rangebegin : 0;
10773 ckWARN4reg(RExC_parse,
10774 "False [] range \"%*.*s\"",
10778 set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
10779 if (prevvalue < 256) {
10781 set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
10784 nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
10788 range = 0; /* this was not a true range */
10793 /* Possible truncation here but in some 64-bit environments
10794 * the compiler gets heartburn about switch on 64-bit values.
10795 * A similar issue a little earlier when switching on value.
10797 switch ((I32)namedclass) {
10799 case ANYOF_ALNUMC: /* C's alnum, in contrast to \w */
10800 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10801 PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10803 case ANYOF_NALNUMC:
10804 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10805 PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10808 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10809 PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10812 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10813 PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10817 ANYOF_CLASS_SET(ret, namedclass);
10820 _invlist_union(properties, PL_ASCII, &properties);
10825 ANYOF_CLASS_SET(ret, namedclass);
10828 _invlist_union_complement_2nd(properties,
10829 PL_ASCII, &properties);
10830 if (DEPENDS_SEMANTICS) {
10831 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
10836 DO_POSIX(ret, namedclass, properties,
10837 PL_PosixBlank, PL_XPosixBlank);
10840 DO_N_POSIX(ret, namedclass, properties,
10841 PL_PosixBlank, PL_XPosixBlank);
10844 DO_POSIX(ret, namedclass, properties,
10845 PL_PosixCntrl, PL_XPosixCntrl);
10848 DO_N_POSIX(ret, namedclass, properties,
10849 PL_PosixCntrl, PL_XPosixCntrl);
10852 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10853 PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10856 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10857 PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10860 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10861 PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10864 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10865 PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10867 case ANYOF_HORIZWS:
10868 /* For these, we use the nonbitmap, as /d doesn't make a
10869 * difference in what these match. There would be problems
10870 * if these characters had folds other than themselves, as
10871 * nonbitmap is subject to folding. It turns out that \h
10872 * is just a synonym for XPosixBlank */
10873 _invlist_union(nonbitmap, PL_XPosixBlank, &nonbitmap);
10875 case ANYOF_NHORIZWS:
10876 _invlist_union_complement_2nd(nonbitmap,
10877 PL_XPosixBlank, &nonbitmap);
10881 { /* These require special handling, as they differ under
10882 folding, matching Cased there (which in the ASCII range
10883 is the same as Alpha */
10889 if (FOLD && ! LOC) {
10890 ascii_source = PL_PosixAlpha;
10891 l1_source = PL_L1Cased;
10895 ascii_source = PL_PosixLower;
10896 l1_source = PL_L1PosixLower;
10897 Xname = "XPosixLower";
10899 if (namedclass == ANYOF_LOWER) {
10900 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10901 ascii_source, l1_source, Xname, listsv);
10904 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
10905 properties, ascii_source, l1_source, Xname, listsv);
10910 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10911 PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
10914 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10915 PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
10918 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10919 PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
10922 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10923 PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
10926 DO_POSIX(ret, namedclass, properties,
10927 PL_PosixSpace, PL_XPosixSpace);
10929 case ANYOF_NPSXSPC:
10930 DO_N_POSIX(ret, namedclass, properties,
10931 PL_PosixSpace, PL_XPosixSpace);
10934 DO_POSIX(ret, namedclass, properties,
10935 PL_PerlSpace, PL_XPerlSpace);
10938 DO_N_POSIX(ret, namedclass, properties,
10939 PL_PerlSpace, PL_XPerlSpace);
10941 case ANYOF_UPPER: /* Same as LOWER, above */
10948 if (FOLD && ! LOC) {
10949 ascii_source = PL_PosixAlpha;
10950 l1_source = PL_L1Cased;
10954 ascii_source = PL_PosixUpper;
10955 l1_source = PL_L1PosixUpper;
10956 Xname = "XPosixUpper";
10958 if (namedclass == ANYOF_UPPER) {
10959 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10960 ascii_source, l1_source, Xname, listsv);
10963 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
10964 properties, ascii_source, l1_source, Xname, listsv);
10968 case ANYOF_ALNUM: /* Really is 'Word' */
10969 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10970 PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
10973 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10974 PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
10977 /* For these, we use the nonbitmap, as /d doesn't make a
10978 * difference in what these match. There would be problems
10979 * if these characters had folds other than themselves, as
10980 * nonbitmap is subject to folding */
10981 _invlist_union(nonbitmap, PL_VertSpace, &nonbitmap);
10983 case ANYOF_NVERTWS:
10984 _invlist_union_complement_2nd(nonbitmap,
10985 PL_VertSpace, &nonbitmap);
10988 DO_POSIX(ret, namedclass, properties,
10989 PL_PosixXDigit, PL_XPosixXDigit);
10991 case ANYOF_NXDIGIT:
10992 DO_N_POSIX(ret, namedclass, properties,
10993 PL_PosixXDigit, PL_XPosixXDigit);
10996 /* this is to handle \p and \P */
10999 vFAIL("Invalid [::] class");
11005 } /* end of namedclass \blah */
11008 if (prevvalue > (IV)value) /* b-a */ {
11009 const int w = RExC_parse - rangebegin;
11010 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
11011 range = 0; /* not a valid range */
11015 prevvalue = value; /* save the beginning of the range */
11016 if (RExC_parse+1 < RExC_end
11017 && *RExC_parse == '-'
11018 && RExC_parse[1] != ']')
11022 /* a bad range like \w-, [:word:]- ? */
11023 if (namedclass > OOB_NAMEDCLASS) {
11024 if (ckWARN(WARN_REGEXP)) {
11026 RExC_parse >= rangebegin ?
11027 RExC_parse - rangebegin : 0;
11029 "False [] range \"%*.*s\"",
11034 set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
11036 range = 1; /* yeah, it's a range! */
11037 continue; /* but do it the next time */
11041 /* non-Latin1 code point implies unicode semantics. Must be set in
11042 * pass1 so is there for the whole of pass 2 */
11044 RExC_uni_semantics = 1;
11047 /* now is the next time */
11049 if (prevvalue < 256) {
11050 const IV ceilvalue = value < 256 ? value : 255;
11053 /* In EBCDIC [\x89-\x91] should include
11054 * the \x8e but [i-j] should not. */
11055 if (literal_endpoint == 2 &&
11056 ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
11057 (isUPPER(prevvalue) && isUPPER(ceilvalue))))
11059 if (isLOWER(prevvalue)) {
11060 for (i = prevvalue; i <= ceilvalue; i++)
11061 if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11063 set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11066 for (i = prevvalue; i <= ceilvalue; i++)
11067 if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11069 set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11075 for (i = prevvalue; i <= ceilvalue; i++) {
11076 stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11080 const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
11081 const UV natvalue = NATIVE_TO_UNI(value);
11082 nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
11085 literal_endpoint = 0;
11089 range = 0; /* this range (if it was one) is done now */
11096 /****** !SIZE_ONLY AFTER HERE *********/
11098 /* If folding and there are code points above 255, we calculate all
11099 * characters that could fold to or from the ones already on the list */
11100 if (FOLD && nonbitmap) {
11101 UV start, end; /* End points of code point ranges */
11103 SV* fold_intersection = NULL;
11105 /* This is a list of all the characters that participate in folds
11106 * (except marks, etc in multi-char folds */
11107 if (! PL_utf8_foldable) {
11108 SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
11109 PL_utf8_foldable = _swash_to_invlist(swash);
11110 SvREFCNT_dec(swash);
11113 /* This is a hash that for a particular fold gives all characters
11114 * that are involved in it */
11115 if (! PL_utf8_foldclosures) {
11117 /* If we were unable to find any folds, then we likely won't be
11118 * able to find the closures. So just create an empty list.
11119 * Folding will effectively be restricted to the non-Unicode rules
11120 * hard-coded into Perl. (This case happens legitimately during
11121 * compilation of Perl itself before the Unicode tables are
11123 if (invlist_len(PL_utf8_foldable) == 0) {
11124 PL_utf8_foldclosures = newHV();
11126 /* If the folds haven't been read in, call a fold function
11128 if (! PL_utf8_tofold) {
11129 U8 dummy[UTF8_MAXBYTES+1];
11132 /* This particular string is above \xff in both UTF-8 and
11134 to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
11135 assert(PL_utf8_tofold); /* Verify that worked */
11137 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
11141 /* Only the characters in this class that participate in folds need be
11142 * checked. Get the intersection of this class and all the possible
11143 * characters that are foldable. This can quickly narrow down a large
11145 _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection);
11147 /* Now look at the foldable characters in this class individually */
11148 invlist_iterinit(fold_intersection);
11149 while (invlist_iternext(fold_intersection, &start, &end)) {
11152 /* Look at every character in the range */
11153 for (j = start; j <= end; j++) {
11156 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
11159 _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
11161 if (foldlen > (STRLEN)UNISKIP(f)) {
11163 /* Any multicharacter foldings (disallowed in lookbehind
11164 * patterns) require the following transform: [ABCDEF] ->
11165 * (?:[ABCabcDEFd]|pq|rst) where E folds into "pq" and F
11166 * folds into "rst", all other characters fold to single
11167 * characters. We save away these multicharacter foldings,
11168 * to be later saved as part of the additional "s" data. */
11169 if (! RExC_in_lookbehind) {
11171 U8* e = foldbuf + foldlen;
11173 /* If any of the folded characters of this are in the
11174 * Latin1 range, tell the regex engine that this can
11175 * match a non-utf8 target string. The only multi-byte
11176 * fold whose source is in the Latin1 range (U+00DF)
11177 * applies only when the target string is utf8, or
11178 * under unicode rules */
11179 if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
11182 /* Can't mix ascii with non- under /aa */
11183 if (MORE_ASCII_RESTRICTED
11184 && (isASCII(*loc) != isASCII(j)))
11186 goto end_multi_fold;
11188 if (UTF8_IS_INVARIANT(*loc)
11189 || UTF8_IS_DOWNGRADEABLE_START(*loc))
11191 /* Can't mix above and below 256 under LOC
11194 goto end_multi_fold;
11197 |= ANYOF_NONBITMAP_NON_UTF8;
11200 loc += UTF8SKIP(loc);
11204 add_alternate(&unicode_alternate, foldbuf, foldlen);
11208 /* This is special-cased, as it is the only letter which
11209 * has both a multi-fold and single-fold in Latin1. All
11210 * the other chars that have single and multi-folds are
11211 * always in utf8, and the utf8 folding algorithm catches
11213 if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
11214 stored += set_regclass_bit(pRExC_state,
11216 LATIN_SMALL_LETTER_SHARP_S,
11217 &l1_fold_invlist, &unicode_alternate);
11221 /* Single character fold. Add everything in its fold
11222 * closure to the list that this node should match */
11225 /* The fold closures data structure is a hash with the keys
11226 * being every character that is folded to, like 'k', and
11227 * the values each an array of everything that folds to its
11228 * key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
11229 if ((listp = hv_fetch(PL_utf8_foldclosures,
11230 (char *) foldbuf, foldlen, FALSE)))
11232 AV* list = (AV*) *listp;
11234 for (k = 0; k <= av_len(list); k++) {
11235 SV** c_p = av_fetch(list, k, FALSE);
11238 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
11242 /* /aa doesn't allow folds between ASCII and non-;
11243 * /l doesn't allow them between above and below
11245 if ((MORE_ASCII_RESTRICTED
11246 && (isASCII(c) != isASCII(j)))
11247 || (LOC && ((c < 256) != (j < 256))))
11252 if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
11253 stored += set_regclass_bit(pRExC_state,
11256 &l1_fold_invlist, &unicode_alternate);
11258 /* It may be that the code point is already in
11259 * this range or already in the bitmap, in
11260 * which case we need do nothing */
11261 else if ((c < start || c > end)
11263 || ! ANYOF_BITMAP_TEST(ret, c)))
11265 nonbitmap = add_cp_to_invlist(nonbitmap, c);
11272 SvREFCNT_dec(fold_intersection);
11275 /* Combine the two lists into one. */
11276 if (l1_fold_invlist) {
11278 _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap);
11279 SvREFCNT_dec(l1_fold_invlist);
11282 nonbitmap = l1_fold_invlist;
11286 /* And combine the result (if any) with any inversion list from properties.
11287 * The lists are kept separate up to now because we don't want to fold the
11291 _invlist_union(nonbitmap, properties, &nonbitmap);
11292 SvREFCNT_dec(properties);
11295 nonbitmap = properties;
11299 /* Here, <nonbitmap> contains all the code points we can determine at
11300 * compile time that we haven't put into the bitmap. Go through it, and
11301 * for things that belong in the bitmap, put them there, and delete from
11305 /* Above-ASCII code points in /d have to stay in <nonbitmap>, as they
11306 * possibly only should match when the target string is UTF-8 */
11307 UV max_cp_to_set = (DEPENDS_SEMANTICS) ? 127 : 255;
11309 /* This gets set if we actually need to modify things */
11310 bool change_invlist = FALSE;
11314 /* Start looking through <nonbitmap> */
11315 invlist_iterinit(nonbitmap);
11316 while (invlist_iternext(nonbitmap, &start, &end)) {
11320 /* Quit if are above what we should change */
11321 if (start > max_cp_to_set) {
11325 change_invlist = TRUE;
11327 /* Set all the bits in the range, up to the max that we are doing */
11328 high = (end < max_cp_to_set) ? end : max_cp_to_set;
11329 for (i = start; i <= (int) high; i++) {
11330 if (! ANYOF_BITMAP_TEST(ret, i)) {
11331 ANYOF_BITMAP_SET(ret, i);
11339 /* Done with loop; remove any code points that are in the bitmap from
11341 if (change_invlist) {
11342 _invlist_subtract(nonbitmap,
11343 (DEPENDS_SEMANTICS)
11349 /* If have completely emptied it, remove it completely */
11350 if (invlist_len(nonbitmap) == 0) {
11351 SvREFCNT_dec(nonbitmap);
11356 /* Here, we have calculated what code points should be in the character
11357 * class. <nonbitmap> does not overlap the bitmap except possibly in the
11358 * case of DEPENDS rules.
11360 * Now we can see about various optimizations. Fold calculation (which we
11361 * did above) needs to take place before inversion. Otherwise /[^k]/i
11362 * would invert to include K, which under /i would match k, which it
11365 /* Optimize inverted simple patterns (e.g. [^a-z]). Note that we haven't
11366 * set the FOLD flag yet, so this does optimize those. It doesn't
11367 * optimize locale. Doing so perhaps could be done as long as there is
11368 * nothing like \w in it; some thought also would have to be given to the
11369 * interaction with above 0x100 chars */
11370 if ((ANYOF_FLAGS(ret) & ANYOF_INVERT)
11372 && ! unicode_alternate
11373 /* In case of /d, there are some things that should match only when in
11374 * not in the bitmap, i.e., they require UTF8 to match. These are
11375 * listed in nonbitmap, but if ANYOF_NONBITMAP_NON_UTF8 is set in this
11376 * case, they don't require UTF8, so can invert here */
11378 || ! DEPENDS_SEMANTICS
11379 || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11380 && SvCUR(listsv) == initial_listsv_len)
11384 for (i = 0; i < 256; ++i) {
11385 if (ANYOF_BITMAP_TEST(ret, i)) {
11386 ANYOF_BITMAP_CLEAR(ret, i);
11389 ANYOF_BITMAP_SET(ret, i);
11394 /* The inversion means that everything above 255 is matched */
11395 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
11398 /* Here, also has things outside the bitmap that may overlap with
11399 * the bitmap. We have to sync them up, so that they get inverted
11400 * in both places. Earlier, we removed all overlaps except in the
11401 * case of /d rules, so no syncing is needed except for this case
11403 SV *remove_list = NULL;
11405 if (DEPENDS_SEMANTICS) {
11408 /* Set the bits that correspond to the ones that aren't in the
11409 * bitmap. Otherwise, when we invert, we'll miss these.
11410 * Earlier, we removed from the nonbitmap all code points
11411 * < 128, so there is no extra work here */
11412 invlist_iterinit(nonbitmap);
11413 while (invlist_iternext(nonbitmap, &start, &end)) {
11414 if (start > 255) { /* The bit map goes to 255 */
11420 for (i = start; i <= (int) end; ++i) {
11421 ANYOF_BITMAP_SET(ret, i);
11428 /* Now invert both the bitmap and the nonbitmap. Anything in the
11429 * bitmap has to also be removed from the non-bitmap, but again,
11430 * there should not be overlap unless is /d rules. */
11431 _invlist_invert(nonbitmap);
11433 /* Any swash can't be used as-is, because we've inverted things */
11435 SvREFCNT_dec(swash);
11439 for (i = 0; i < 256; ++i) {
11440 if (ANYOF_BITMAP_TEST(ret, i)) {
11441 ANYOF_BITMAP_CLEAR(ret, i);
11442 if (DEPENDS_SEMANTICS) {
11443 if (! remove_list) {
11444 remove_list = _new_invlist(2);
11446 remove_list = add_cp_to_invlist(remove_list, i);
11450 ANYOF_BITMAP_SET(ret, i);
11456 /* And do the removal */
11457 if (DEPENDS_SEMANTICS) {
11459 _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
11460 SvREFCNT_dec(remove_list);
11464 /* There is no overlap for non-/d, so just delete anything
11466 _invlist_intersection(nonbitmap, PL_AboveLatin1, &nonbitmap);
11470 stored = 256 - stored;
11472 /* Clear the invert flag since have just done it here */
11473 ANYOF_FLAGS(ret) &= ~ANYOF_INVERT;
11476 /* Folding in the bitmap is taken care of above, but not for locale (for
11477 * which we have to wait to see what folding is in effect at runtime), and
11478 * for some things not in the bitmap (only the upper latin folds in this
11479 * case, as all other single-char folding has been set above). Set
11480 * run-time fold flag for these */
11482 || (DEPENDS_SEMANTICS
11484 && ! (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11485 || unicode_alternate))
11487 ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
11490 /* A single character class can be "optimized" into an EXACTish node.
11491 * Note that since we don't currently count how many characters there are
11492 * outside the bitmap, we are XXX missing optimization possibilities for
11493 * them. This optimization can't happen unless this is a truly single
11494 * character class, which means that it can't be an inversion into a
11495 * many-character class, and there must be no possibility of there being
11496 * things outside the bitmap. 'stored' (only) for locales doesn't include
11497 * \w, etc, so have to make a special test that they aren't present
11499 * Similarly A 2-character class of the very special form like [bB] can be
11500 * optimized into an EXACTFish node, but only for non-locales, and for
11501 * characters which only have the two folds; so things like 'fF' and 'Ii'
11502 * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
11505 && ! unicode_alternate
11506 && SvCUR(listsv) == initial_listsv_len
11507 && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
11508 && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11509 || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
11510 || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11511 && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
11512 /* If the latest code point has a fold whose
11513 * bit is set, it must be the only other one */
11514 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
11515 && ANYOF_BITMAP_TEST(ret, prevvalue)))))
11517 /* Note that the information needed to decide to do this optimization
11518 * is not currently available until the 2nd pass, and that the actually
11519 * used EXACTish node takes less space than the calculated ANYOF node,
11520 * and hence the amount of space calculated in the first pass is larger
11521 * than actually used, so this optimization doesn't gain us any space.
11522 * But an EXACT node is faster than an ANYOF node, and can be combined
11523 * with any adjacent EXACT nodes later by the optimizer for further
11524 * gains. The speed of executing an EXACTF is similar to an ANYOF
11525 * node, so the optimization advantage comes from the ability to join
11526 * it to adjacent EXACT nodes */
11528 const char * cur_parse= RExC_parse;
11530 RExC_emit = (regnode *)orig_emit;
11531 RExC_parse = (char *)orig_parse;
11535 /* A locale node with one point can be folded; all the other cases
11536 * with folding will have two points, since we calculate them above
11538 if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
11545 else { /* else 2 chars in the bit map: the folds of each other */
11547 /* Use the folded value, which for the cases where we get here,
11548 * is just the lower case of the current one (which may resolve to
11549 * itself, or to the other one */
11550 value = toLOWER_LATIN1(value);
11552 /* To join adjacent nodes, they must be the exact EXACTish type.
11553 * Try to use the most likely type, by using EXACTFA if possible,
11554 * then EXACTFU if the regex calls for it, or is required because
11555 * the character is non-ASCII. (If <value> is ASCII, its fold is
11556 * also ASCII for the cases where we get here.) */
11557 if (MORE_ASCII_RESTRICTED && isASCII(value)) {
11560 else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
11563 else { /* Otherwise, more likely to be EXACTF type */
11568 ret = reg_node(pRExC_state, op);
11569 RExC_parse = (char *)cur_parse;
11570 if (UTF && ! NATIVE_IS_INVARIANT(value)) {
11571 *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
11572 *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
11574 RExC_emit += STR_SZ(2);
11577 *STRING(ret)= (char)value;
11579 RExC_emit += STR_SZ(1);
11581 SvREFCNT_dec(listsv);
11585 /* If there is a swash and more than one element, we can't use the swash in
11586 * the optimization below. */
11587 if (swash && element_count > 1) {
11588 SvREFCNT_dec(swash);
11592 && SvCUR(listsv) == initial_listsv_len
11593 && ! unicode_alternate)
11595 ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
11596 SvREFCNT_dec(listsv);
11597 SvREFCNT_dec(unicode_alternate);
11600 /* av[0] stores the character class description in its textual form:
11601 * used later (regexec.c:Perl_regclass_swash()) to initialize the
11602 * appropriate swash, and is also useful for dumping the regnode.
11603 * av[1] if NULL, is a placeholder to later contain the swash computed
11604 * from av[0]. But if no further computation need be done, the
11605 * swash is stored there now.
11606 * av[2] stores the multicharacter foldings, used later in
11607 * regexec.c:S_reginclass().
11608 * av[3] stores the nonbitmap inversion list for use in addition or
11609 * instead of av[0]; not used if av[1] isn't NULL
11610 * av[4] is set if any component of the class is from a user-defined
11611 * property; not used if av[1] isn't NULL */
11612 AV * const av = newAV();
11615 av_store(av, 0, (SvCUR(listsv) == initial_listsv_len)
11619 av_store(av, 1, swash);
11620 SvREFCNT_dec(nonbitmap);
11623 av_store(av, 1, NULL);
11625 av_store(av, 3, nonbitmap);
11626 av_store(av, 4, newSVuv(has_user_defined_property));
11630 /* Store any computed multi-char folds only if we are allowing
11632 if (allow_full_fold) {
11633 av_store(av, 2, MUTABLE_SV(unicode_alternate));
11634 if (unicode_alternate) { /* This node is variable length */
11639 av_store(av, 2, NULL);
11641 rv = newRV_noinc(MUTABLE_SV(av));
11642 n = add_data(pRExC_state, 1, "s");
11643 RExC_rxi->data->data[n] = (void*)rv;
11650 /* reg_skipcomment()
11652 Absorbs an /x style # comments from the input stream.
11653 Returns true if there is more text remaining in the stream.
11654 Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
11655 terminates the pattern without including a newline.
11657 Note its the callers responsibility to ensure that we are
11658 actually in /x mode
11663 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
11667 PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
11669 while (RExC_parse < RExC_end)
11670 if (*RExC_parse++ == '\n') {
11675 /* we ran off the end of the pattern without ending
11676 the comment, so we have to add an \n when wrapping */
11677 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11685 Advances the parse position, and optionally absorbs
11686 "whitespace" from the inputstream.
11688 Without /x "whitespace" means (?#...) style comments only,
11689 with /x this means (?#...) and # comments and whitespace proper.
11691 Returns the RExC_parse point from BEFORE the scan occurs.
11693 This is the /x friendly way of saying RExC_parse++.
11697 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
11699 char* const retval = RExC_parse++;
11701 PERL_ARGS_ASSERT_NEXTCHAR;
11704 if (RExC_end - RExC_parse >= 3
11705 && *RExC_parse == '('
11706 && RExC_parse[1] == '?'
11707 && RExC_parse[2] == '#')
11709 while (*RExC_parse != ')') {
11710 if (RExC_parse == RExC_end)
11711 FAIL("Sequence (?#... not terminated");
11717 if (RExC_flags & RXf_PMf_EXTENDED) {
11718 if (isSPACE(*RExC_parse)) {
11722 else if (*RExC_parse == '#') {
11723 if ( reg_skipcomment( pRExC_state ) )
11732 - reg_node - emit a node
11734 STATIC regnode * /* Location. */
11735 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
11738 register regnode *ptr;
11739 regnode * const ret = RExC_emit;
11740 GET_RE_DEBUG_FLAGS_DECL;
11742 PERL_ARGS_ASSERT_REG_NODE;
11745 SIZE_ALIGN(RExC_size);
11749 if (RExC_emit >= RExC_emit_bound)
11750 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11751 op, RExC_emit, RExC_emit_bound);
11753 NODE_ALIGN_FILL(ret);
11755 FILL_ADVANCE_NODE(ptr, op);
11756 REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (ptr) - 1);
11757 #ifdef RE_TRACK_PATTERN_OFFSETS
11758 if (RExC_offsets) { /* MJD */
11759 MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
11760 "reg_node", __LINE__,
11762 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
11763 ? "Overwriting end of array!\n" : "OK",
11764 (UV)(RExC_emit - RExC_emit_start),
11765 (UV)(RExC_parse - RExC_start),
11766 (UV)RExC_offsets[0]));
11767 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
11775 - reganode - emit a node with an argument
11777 STATIC regnode * /* Location. */
11778 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
11781 register regnode *ptr;
11782 regnode * const ret = RExC_emit;
11783 GET_RE_DEBUG_FLAGS_DECL;
11785 PERL_ARGS_ASSERT_REGANODE;
11788 SIZE_ALIGN(RExC_size);
11793 assert(2==regarglen[op]+1);
11795 Anything larger than this has to allocate the extra amount.
11796 If we changed this to be:
11798 RExC_size += (1 + regarglen[op]);
11800 then it wouldn't matter. Its not clear what side effect
11801 might come from that so its not done so far.
11806 if (RExC_emit >= RExC_emit_bound)
11807 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11808 op, RExC_emit, RExC_emit_bound);
11810 NODE_ALIGN_FILL(ret);
11812 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
11813 REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (ptr) - 2);
11814 #ifdef RE_TRACK_PATTERN_OFFSETS
11815 if (RExC_offsets) { /* MJD */
11816 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
11820 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
11821 "Overwriting end of array!\n" : "OK",
11822 (UV)(RExC_emit - RExC_emit_start),
11823 (UV)(RExC_parse - RExC_start),
11824 (UV)RExC_offsets[0]));
11825 Set_Cur_Node_Offset;
11833 - reguni - emit (if appropriate) a Unicode character
11836 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
11840 PERL_ARGS_ASSERT_REGUNI;
11842 return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
11846 - reginsert - insert an operator in front of already-emitted operand
11848 * Means relocating the operand.
11851 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
11854 register regnode *src;
11855 register regnode *dst;
11856 register regnode *place;
11857 const int offset = regarglen[(U8)op];
11858 const int size = NODE_STEP_REGNODE + offset;
11859 GET_RE_DEBUG_FLAGS_DECL;
11861 PERL_ARGS_ASSERT_REGINSERT;
11862 PERL_UNUSED_ARG(depth);
11863 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
11864 DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
11873 if (RExC_open_parens) {
11875 /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
11876 for ( paren=0 ; paren < RExC_npar ; paren++ ) {
11877 if ( RExC_open_parens[paren] >= opnd ) {
11878 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
11879 RExC_open_parens[paren] += size;
11881 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
11883 if ( RExC_close_parens[paren] >= opnd ) {
11884 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
11885 RExC_close_parens[paren] += size;
11887 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
11892 while (src > opnd) {
11893 StructCopy(--src, --dst, regnode);
11894 #ifdef RE_TRACK_PATTERN_OFFSETS
11895 if (RExC_offsets) { /* MJD 20010112 */
11896 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
11900 (UV)(dst - RExC_emit_start) > RExC_offsets[0]
11901 ? "Overwriting end of array!\n" : "OK",
11902 (UV)(src - RExC_emit_start),
11903 (UV)(dst - RExC_emit_start),
11904 (UV)RExC_offsets[0]));
11905 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
11906 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
11912 place = opnd; /* Op node, where operand used to be. */
11913 #ifdef RE_TRACK_PATTERN_OFFSETS
11914 if (RExC_offsets) { /* MJD */
11915 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
11919 (UV)(place - RExC_emit_start) > RExC_offsets[0]
11920 ? "Overwriting end of array!\n" : "OK",
11921 (UV)(place - RExC_emit_start),
11922 (UV)(RExC_parse - RExC_start),
11923 (UV)RExC_offsets[0]));
11924 Set_Node_Offset(place, RExC_parse);
11925 Set_Node_Length(place, 1);
11928 src = NEXTOPER(place);
11929 FILL_ADVANCE_NODE(place, op);
11930 REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (place) - 1);
11931 Zero(src, offset, regnode);
11935 - regtail - set the next-pointer at the end of a node chain of p to val.
11936 - SEE ALSO: regtail_study
11938 /* TODO: All three parms should be const */
11940 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
11943 register regnode *scan;
11944 GET_RE_DEBUG_FLAGS_DECL;
11946 PERL_ARGS_ASSERT_REGTAIL;
11948 PERL_UNUSED_ARG(depth);
11954 /* Find last node. */
11957 regnode * const temp = regnext(scan);
11959 SV * const mysv=sv_newmortal();
11960 DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
11961 regprop(RExC_rx, mysv, scan);
11962 PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
11963 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
11964 (temp == NULL ? "->" : ""),
11965 (temp == NULL ? PL_reg_name[OP(val)] : "")
11973 if (reg_off_by_arg[OP(scan)]) {
11974 ARG_SET(scan, val - scan);
11977 NEXT_OFF(scan) = val - scan;
11983 - regtail_study - set the next-pointer at the end of a node chain of p to val.
11984 - Look for optimizable sequences at the same time.
11985 - currently only looks for EXACT chains.
11987 This is experimental code. The idea is to use this routine to perform
11988 in place optimizations on branches and groups as they are constructed,
11989 with the long term intention of removing optimization from study_chunk so
11990 that it is purely analytical.
11992 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
11993 to control which is which.
11996 /* TODO: All four parms should be const */
11999 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12002 register regnode *scan;
12004 #ifdef EXPERIMENTAL_INPLACESCAN
12007 GET_RE_DEBUG_FLAGS_DECL;
12009 PERL_ARGS_ASSERT_REGTAIL_STUDY;
12015 /* Find last node. */
12019 regnode * const temp = regnext(scan);
12020 #ifdef EXPERIMENTAL_INPLACESCAN
12021 if (PL_regkind[OP(scan)] == EXACT) {
12022 bool has_exactf_sharp_s; /* Unexamined in this routine */
12023 if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
12028 switch (OP(scan)) {
12034 case EXACTFU_NO_TRIE:
12036 if( exact == PSEUDO )
12038 else if ( exact != OP(scan) )
12047 SV * const mysv=sv_newmortal();
12048 DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
12049 regprop(RExC_rx, mysv, scan);
12050 PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
12051 SvPV_nolen_const(mysv),
12052 REG_NODE_NUM(scan),
12053 PL_reg_name[exact]);
12060 SV * const mysv_val=sv_newmortal();
12061 DEBUG_PARSE_MSG("");
12062 regprop(RExC_rx, mysv_val, val);
12063 PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
12064 SvPV_nolen_const(mysv_val),
12065 (IV)REG_NODE_NUM(val),
12069 if (reg_off_by_arg[OP(scan)]) {
12070 ARG_SET(scan, val - scan);
12073 NEXT_OFF(scan) = val - scan;
12081 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
12085 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
12091 for (bit=0; bit<32; bit++) {
12092 if (flags & (1<<bit)) {
12093 if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */
12096 if (!set++ && lead)
12097 PerlIO_printf(Perl_debug_log, "%s",lead);
12098 PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
12101 if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
12102 if (!set++ && lead) {
12103 PerlIO_printf(Perl_debug_log, "%s",lead);
12106 case REGEX_UNICODE_CHARSET:
12107 PerlIO_printf(Perl_debug_log, "UNICODE");
12109 case REGEX_LOCALE_CHARSET:
12110 PerlIO_printf(Perl_debug_log, "LOCALE");
12112 case REGEX_ASCII_RESTRICTED_CHARSET:
12113 PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
12115 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
12116 PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
12119 PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
12125 PerlIO_printf(Perl_debug_log, "\n");
12127 PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
12133 Perl_regdump(pTHX_ const regexp *r)
12137 SV * const sv = sv_newmortal();
12138 SV *dsv= sv_newmortal();
12139 RXi_GET_DECL(r,ri);
12140 GET_RE_DEBUG_FLAGS_DECL;
12142 PERL_ARGS_ASSERT_REGDUMP;
12144 (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
12146 /* Header fields of interest. */
12147 if (r->anchored_substr) {
12148 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
12149 RE_SV_DUMPLEN(r->anchored_substr), 30);
12150 PerlIO_printf(Perl_debug_log,
12151 "anchored %s%s at %"IVdf" ",
12152 s, RE_SV_TAIL(r->anchored_substr),
12153 (IV)r->anchored_offset);
12154 } else if (r->anchored_utf8) {
12155 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
12156 RE_SV_DUMPLEN(r->anchored_utf8), 30);
12157 PerlIO_printf(Perl_debug_log,
12158 "anchored utf8 %s%s at %"IVdf" ",
12159 s, RE_SV_TAIL(r->anchored_utf8),
12160 (IV)r->anchored_offset);
12162 if (r->float_substr) {
12163 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
12164 RE_SV_DUMPLEN(r->float_substr), 30);
12165 PerlIO_printf(Perl_debug_log,
12166 "floating %s%s at %"IVdf"..%"UVuf" ",
12167 s, RE_SV_TAIL(r->float_substr),
12168 (IV)r->float_min_offset, (UV)r->float_max_offset);
12169 } else if (r->float_utf8) {
12170 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
12171 RE_SV_DUMPLEN(r->float_utf8), 30);
12172 PerlIO_printf(Perl_debug_log,
12173 "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
12174 s, RE_SV_TAIL(r->float_utf8),
12175 (IV)r->float_min_offset, (UV)r->float_max_offset);
12177 if (r->check_substr || r->check_utf8)
12178 PerlIO_printf(Perl_debug_log,
12180 (r->check_substr == r->float_substr
12181 && r->check_utf8 == r->float_utf8
12182 ? "(checking floating" : "(checking anchored"));
12183 if (r->extflags & RXf_NOSCAN)
12184 PerlIO_printf(Perl_debug_log, " noscan");
12185 if (r->extflags & RXf_CHECK_ALL)
12186 PerlIO_printf(Perl_debug_log, " isall");
12187 if (r->check_substr || r->check_utf8)
12188 PerlIO_printf(Perl_debug_log, ") ");
12190 if (ri->regstclass) {
12191 regprop(r, sv, ri->regstclass);
12192 PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
12194 if (r->extflags & RXf_ANCH) {
12195 PerlIO_printf(Perl_debug_log, "anchored");
12196 if (r->extflags & RXf_ANCH_BOL)
12197 PerlIO_printf(Perl_debug_log, "(BOL)");
12198 if (r->extflags & RXf_ANCH_MBOL)
12199 PerlIO_printf(Perl_debug_log, "(MBOL)");
12200 if (r->extflags & RXf_ANCH_SBOL)
12201 PerlIO_printf(Perl_debug_log, "(SBOL)");
12202 if (r->extflags & RXf_ANCH_GPOS)
12203 PerlIO_printf(Perl_debug_log, "(GPOS)");
12204 PerlIO_putc(Perl_debug_log, ' ');
12206 if (r->extflags & RXf_GPOS_SEEN)
12207 PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
12208 if (r->intflags & PREGf_SKIP)
12209 PerlIO_printf(Perl_debug_log, "plus ");
12210 if (r->intflags & PREGf_IMPLICIT)
12211 PerlIO_printf(Perl_debug_log, "implicit ");
12212 PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
12213 if (r->extflags & RXf_EVAL_SEEN)
12214 PerlIO_printf(Perl_debug_log, "with eval ");
12215 PerlIO_printf(Perl_debug_log, "\n");
12216 DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));
12218 PERL_ARGS_ASSERT_REGDUMP;
12219 PERL_UNUSED_CONTEXT;
12220 PERL_UNUSED_ARG(r);
12221 #endif /* DEBUGGING */
12225 - regprop - printable representation of opcode
12227 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
12230 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
12231 if (flags & ANYOF_INVERT) \
12232 /*make sure the invert info is in each */ \
12233 sv_catpvs(sv, "^"); \
12239 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
12244 RXi_GET_DECL(prog,progi);
12245 GET_RE_DEBUG_FLAGS_DECL;
12247 PERL_ARGS_ASSERT_REGPROP;
12251 if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */
12252 /* It would be nice to FAIL() here, but this may be called from
12253 regexec.c, and it would be hard to supply pRExC_state. */
12254 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
12255 sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
12257 k = PL_regkind[OP(o)];
12260 sv_catpvs(sv, " ");
12261 /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
12262 * is a crude hack but it may be the best for now since
12263 * we have no flag "this EXACTish node was UTF-8"
12265 pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
12266 PERL_PV_ESCAPE_UNI_DETECT |
12267 PERL_PV_ESCAPE_NONASCII |
12268 PERL_PV_PRETTY_ELLIPSES |
12269 PERL_PV_PRETTY_LTGT |
12270 PERL_PV_PRETTY_NOCLEAR
12272 } else if (k == TRIE) {
12273 /* print the details of the trie in dumpuntil instead, as
12274 * progi->data isn't available here */
12275 const char op = OP(o);
12276 const U32 n = ARG(o);
12277 const reg_ac_data * const ac = IS_TRIE_AC(op) ?
12278 (reg_ac_data *)progi->data->data[n] :
12280 const reg_trie_data * const trie
12281 = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
12283 Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
12284 DEBUG_TRIE_COMPILE_r(
12285 Perl_sv_catpvf(aTHX_ sv,
12286 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
12287 (UV)trie->startstate,
12288 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
12289 (UV)trie->wordcount,
12292 (UV)TRIE_CHARCOUNT(trie),
12293 (UV)trie->uniquecharcount
12296 if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
12298 int rangestart = -1;
12299 U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
12300 sv_catpvs(sv, "[");
12301 for (i = 0; i <= 256; i++) {
12302 if (i < 256 && BITMAP_TEST(bitmap,i)) {
12303 if (rangestart == -1)
12305 } else if (rangestart != -1) {
12306 if (i <= rangestart + 3)
12307 for (; rangestart < i; rangestart++)
12308 put_byte(sv, rangestart);
12310 put_byte(sv, rangestart);
12311 sv_catpvs(sv, "-");
12312 put_byte(sv, i - 1);
12317 sv_catpvs(sv, "]");
12320 } else if (k == CURLY) {
12321 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
12322 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
12323 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
12325 else if (k == WHILEM && o->flags) /* Ordinal/of */
12326 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
12327 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
12328 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
12329 if ( RXp_PAREN_NAMES(prog) ) {
12330 if ( k != REF || (OP(o) < NREF)) {
12331 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
12332 SV **name= av_fetch(list, ARG(o), 0 );
12334 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12337 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
12338 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
12339 I32 *nums=(I32*)SvPVX(sv_dat);
12340 SV **name= av_fetch(list, nums[0], 0 );
12343 for ( n=0; n<SvIVX(sv_dat); n++ ) {
12344 Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
12345 (n ? "," : ""), (IV)nums[n]);
12347 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12351 } else if (k == GOSUB)
12352 Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
12353 else if (k == VERB) {
12355 Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
12356 SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
12357 } else if (k == LOGICAL)
12358 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
12359 else if (k == ANYOF) {
12360 int i, rangestart = -1;
12361 const U8 flags = ANYOF_FLAGS(o);
12364 /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
12365 static const char * const anyofs[] = {
12398 if (flags & ANYOF_LOCALE)
12399 sv_catpvs(sv, "{loc}");
12400 if (flags & ANYOF_LOC_NONBITMAP_FOLD)
12401 sv_catpvs(sv, "{i}");
12402 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
12403 if (flags & ANYOF_INVERT)
12404 sv_catpvs(sv, "^");
12406 /* output what the standard cp 0-255 bitmap matches */
12407 for (i = 0; i <= 256; i++) {
12408 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
12409 if (rangestart == -1)
12411 } else if (rangestart != -1) {
12412 if (i <= rangestart + 3)
12413 for (; rangestart < i; rangestart++)
12414 put_byte(sv, rangestart);
12416 put_byte(sv, rangestart);
12417 sv_catpvs(sv, "-");
12418 put_byte(sv, i - 1);
12425 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12426 /* output any special charclass tests (used entirely under use locale) */
12427 if (ANYOF_CLASS_TEST_ANY_SET(o))
12428 for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
12429 if (ANYOF_CLASS_TEST(o,i)) {
12430 sv_catpv(sv, anyofs[i]);
12434 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12436 if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
12437 sv_catpvs(sv, "{non-utf8-latin1-all}");
12440 /* output information about the unicode matching */
12441 if (flags & ANYOF_UNICODE_ALL)
12442 sv_catpvs(sv, "{unicode_all}");
12443 else if (ANYOF_NONBITMAP(o))
12444 sv_catpvs(sv, "{unicode}");
12445 if (flags & ANYOF_NONBITMAP_NON_UTF8)
12446 sv_catpvs(sv, "{outside bitmap}");
12448 if (ANYOF_NONBITMAP(o)) {
12449 SV *lv; /* Set if there is something outside the bit map */
12450 SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
12451 bool byte_output = FALSE; /* If something in the bitmap has been
12454 if (lv && lv != &PL_sv_undef) {
12456 U8 s[UTF8_MAXBYTES_CASE+1];
12458 for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
12459 uvchr_to_utf8(s, i);
12462 && ! ANYOF_BITMAP_TEST(o, i) /* Don't duplicate
12466 && swash_fetch(sw, s, TRUE))
12468 if (rangestart == -1)
12470 } else if (rangestart != -1) {
12471 byte_output = TRUE;
12472 if (i <= rangestart + 3)
12473 for (; rangestart < i; rangestart++) {
12474 put_byte(sv, rangestart);
12477 put_byte(sv, rangestart);
12478 sv_catpvs(sv, "-");
12487 char *s = savesvpv(lv);
12488 char * const origs = s;
12490 while (*s && *s != '\n')
12494 const char * const t = ++s;
12497 sv_catpvs(sv, " ");
12503 /* Truncate very long output */
12504 if (s - origs > 256) {
12505 Perl_sv_catpvf(aTHX_ sv,
12507 (int) (s - origs - 1),
12513 else if (*s == '\t') {
12532 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
12534 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
12535 Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
12537 PERL_UNUSED_CONTEXT;
12538 PERL_UNUSED_ARG(sv);
12539 PERL_UNUSED_ARG(o);
12540 PERL_UNUSED_ARG(prog);
12541 #endif /* DEBUGGING */
12545 Perl_re_intuit_string(pTHX_ REGEXP * const r)
12546 { /* Assume that RE_INTUIT is set */
12548 struct regexp *const prog = (struct regexp *)SvANY(r);
12549 GET_RE_DEBUG_FLAGS_DECL;
12551 PERL_ARGS_ASSERT_RE_INTUIT_STRING;
12552 PERL_UNUSED_CONTEXT;
12556 const char * const s = SvPV_nolen_const(prog->check_substr
12557 ? prog->check_substr : prog->check_utf8);
12559 if (!PL_colorset) reginitcolors();
12560 PerlIO_printf(Perl_debug_log,
12561 "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
12563 prog->check_substr ? "" : "utf8 ",
12564 PL_colors[5],PL_colors[0],
12567 (strlen(s) > 60 ? "..." : ""));
12570 return prog->check_substr ? prog->check_substr : prog->check_utf8;
12576 handles refcounting and freeing the perl core regexp structure. When
12577 it is necessary to actually free the structure the first thing it
12578 does is call the 'free' method of the regexp_engine associated to
12579 the regexp, allowing the handling of the void *pprivate; member
12580 first. (This routine is not overridable by extensions, which is why
12581 the extensions free is called first.)
12583 See regdupe and regdupe_internal if you change anything here.
12585 #ifndef PERL_IN_XSUB_RE
12587 Perl_pregfree(pTHX_ REGEXP *r)
12593 Perl_pregfree2(pTHX_ REGEXP *rx)
12596 struct regexp *const r = (struct regexp *)SvANY(rx);
12597 GET_RE_DEBUG_FLAGS_DECL;
12599 PERL_ARGS_ASSERT_PREGFREE2;
12601 if (r->mother_re) {
12602 ReREFCNT_dec(r->mother_re);
12604 CALLREGFREE_PVT(rx); /* free the private data */
12605 SvREFCNT_dec(RXp_PAREN_NAMES(r));
12608 SvREFCNT_dec(r->anchored_substr);
12609 SvREFCNT_dec(r->anchored_utf8);
12610 SvREFCNT_dec(r->float_substr);
12611 SvREFCNT_dec(r->float_utf8);
12612 Safefree(r->substrs);
12614 RX_MATCH_COPY_FREE(rx);
12615 #ifdef PERL_OLD_COPY_ON_WRITE
12616 SvREFCNT_dec(r->saved_copy);
12623 This is a hacky workaround to the structural issue of match results
12624 being stored in the regexp structure which is in turn stored in
12625 PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
12626 could be PL_curpm in multiple contexts, and could require multiple
12627 result sets being associated with the pattern simultaneously, such
12628 as when doing a recursive match with (??{$qr})
12630 The solution is to make a lightweight copy of the regexp structure
12631 when a qr// is returned from the code executed by (??{$qr}) this
12632 lightweight copy doesn't actually own any of its data except for
12633 the starp/end and the actual regexp structure itself.
12639 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
12641 struct regexp *ret;
12642 struct regexp *const r = (struct regexp *)SvANY(rx);
12643 register const I32 npar = r->nparens+1;
12645 PERL_ARGS_ASSERT_REG_TEMP_COPY;
12648 ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
12649 ret = (struct regexp *)SvANY(ret_x);
12651 (void)ReREFCNT_inc(rx);
12652 /* We can take advantage of the existing "copied buffer" mechanism in SVs
12653 by pointing directly at the buffer, but flagging that the allocated
12654 space in the copy is zero. As we've just done a struct copy, it's now
12655 a case of zero-ing that, rather than copying the current length. */
12656 SvPV_set(ret_x, RX_WRAPPED(rx));
12657 SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
12658 memcpy(&(ret->xpv_cur), &(r->xpv_cur),
12659 sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
12660 SvLEN_set(ret_x, 0);
12661 SvSTASH_set(ret_x, NULL);
12662 SvMAGIC_set(ret_x, NULL);
12663 Newx(ret->offs, npar, regexp_paren_pair);
12664 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12666 Newx(ret->substrs, 1, struct reg_substr_data);
12667 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12669 SvREFCNT_inc_void(ret->anchored_substr);
12670 SvREFCNT_inc_void(ret->anchored_utf8);
12671 SvREFCNT_inc_void(ret->float_substr);
12672 SvREFCNT_inc_void(ret->float_utf8);
12674 /* check_substr and check_utf8, if non-NULL, point to either their
12675 anchored or float namesakes, and don't hold a second reference. */
12677 RX_MATCH_COPIED_off(ret_x);
12678 #ifdef PERL_OLD_COPY_ON_WRITE
12679 ret->saved_copy = NULL;
12681 ret->mother_re = rx;
12687 /* regfree_internal()
12689 Free the private data in a regexp. This is overloadable by
12690 extensions. Perl takes care of the regexp structure in pregfree(),
12691 this covers the *pprivate pointer which technically perl doesn't
12692 know about, however of course we have to handle the
12693 regexp_internal structure when no extension is in use.
12695 Note this is called before freeing anything in the regexp
12700 Perl_regfree_internal(pTHX_ REGEXP * const rx)
12703 struct regexp *const r = (struct regexp *)SvANY(rx);
12704 RXi_GET_DECL(r,ri);
12705 GET_RE_DEBUG_FLAGS_DECL;
12707 PERL_ARGS_ASSERT_REGFREE_INTERNAL;
12713 SV *dsv= sv_newmortal();
12714 RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
12715 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
12716 PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
12717 PL_colors[4],PL_colors[5],s);
12720 #ifdef RE_TRACK_PATTERN_OFFSETS
12722 Safefree(ri->u.offsets); /* 20010421 MJD */
12725 int n = ri->data->count;
12726 PAD* new_comppad = NULL;
12731 /* If you add a ->what type here, update the comment in regcomp.h */
12732 switch (ri->data->what[n]) {
12737 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
12740 Safefree(ri->data->data[n]);
12743 new_comppad = MUTABLE_AV(ri->data->data[n]);
12746 if (new_comppad == NULL)
12747 Perl_croak(aTHX_ "panic: pregfree comppad");
12748 PAD_SAVE_LOCAL(old_comppad,
12749 /* Watch out for global destruction's random ordering. */
12750 (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
12753 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
12756 op_free((OP_4tree*)ri->data->data[n]);
12758 PAD_RESTORE_LOCAL(old_comppad);
12759 SvREFCNT_dec(MUTABLE_SV(new_comppad));
12760 new_comppad = NULL;
12765 { /* Aho Corasick add-on structure for a trie node.
12766 Used in stclass optimization only */
12768 reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
12770 refcount = --aho->refcount;
12773 PerlMemShared_free(aho->states);
12774 PerlMemShared_free(aho->fail);
12775 /* do this last!!!! */
12776 PerlMemShared_free(ri->data->data[n]);
12777 PerlMemShared_free(ri->regstclass);
12783 /* trie structure. */
12785 reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
12787 refcount = --trie->refcount;
12790 PerlMemShared_free(trie->charmap);
12791 PerlMemShared_free(trie->states);
12792 PerlMemShared_free(trie->trans);
12794 PerlMemShared_free(trie->bitmap);
12796 PerlMemShared_free(trie->jump);
12797 PerlMemShared_free(trie->wordinfo);
12798 /* do this last!!!! */
12799 PerlMemShared_free(ri->data->data[n]);
12804 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
12807 Safefree(ri->data->what);
12808 Safefree(ri->data);
12814 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
12815 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
12816 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
12819 re_dup - duplicate a regexp.
12821 This routine is expected to clone a given regexp structure. It is only
12822 compiled under USE_ITHREADS.
12824 After all of the core data stored in struct regexp is duplicated
12825 the regexp_engine.dupe method is used to copy any private data
12826 stored in the *pprivate pointer. This allows extensions to handle
12827 any duplication it needs to do.
12829 See pregfree() and regfree_internal() if you change anything here.
12831 #if defined(USE_ITHREADS)
12832 #ifndef PERL_IN_XSUB_RE
12834 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
12838 const struct regexp *r = (const struct regexp *)SvANY(sstr);
12839 struct regexp *ret = (struct regexp *)SvANY(dstr);
12841 PERL_ARGS_ASSERT_RE_DUP_GUTS;
12843 npar = r->nparens+1;
12844 Newx(ret->offs, npar, regexp_paren_pair);
12845 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12847 /* no need to copy these */
12848 Newx(ret->swap, npar, regexp_paren_pair);
12851 if (ret->substrs) {
12852 /* Do it this way to avoid reading from *r after the StructCopy().
12853 That way, if any of the sv_dup_inc()s dislodge *r from the L1
12854 cache, it doesn't matter. */
12855 const bool anchored = r->check_substr
12856 ? r->check_substr == r->anchored_substr
12857 : r->check_utf8 == r->anchored_utf8;
12858 Newx(ret->substrs, 1, struct reg_substr_data);
12859 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12861 ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
12862 ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
12863 ret->float_substr = sv_dup_inc(ret->float_substr, param);
12864 ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
12866 /* check_substr and check_utf8, if non-NULL, point to either their
12867 anchored or float namesakes, and don't hold a second reference. */
12869 if (ret->check_substr) {
12871 assert(r->check_utf8 == r->anchored_utf8);
12872 ret->check_substr = ret->anchored_substr;
12873 ret->check_utf8 = ret->anchored_utf8;
12875 assert(r->check_substr == r->float_substr);
12876 assert(r->check_utf8 == r->float_utf8);
12877 ret->check_substr = ret->float_substr;
12878 ret->check_utf8 = ret->float_utf8;
12880 } else if (ret->check_utf8) {
12882 ret->check_utf8 = ret->anchored_utf8;
12884 ret->check_utf8 = ret->float_utf8;
12889 RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
12892 RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
12894 if (RX_MATCH_COPIED(dstr))
12895 ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
12897 ret->subbeg = NULL;
12898 #ifdef PERL_OLD_COPY_ON_WRITE
12899 ret->saved_copy = NULL;
12902 if (ret->mother_re) {
12903 if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
12904 /* Our storage points directly to our mother regexp, but that's
12905 1: a buffer in a different thread
12906 2: something we no longer hold a reference on
12907 so we need to copy it locally. */
12908 /* Note we need to use SvCUR(), rather than
12909 SvLEN(), on our mother_re, because it, in
12910 turn, may well be pointing to its own mother_re. */
12911 SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
12912 SvCUR(ret->mother_re)+1));
12913 SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
12915 ret->mother_re = NULL;
12919 #endif /* PERL_IN_XSUB_RE */
12924 This is the internal complement to regdupe() which is used to copy
12925 the structure pointed to by the *pprivate pointer in the regexp.
12926 This is the core version of the extension overridable cloning hook.
12927 The regexp structure being duplicated will be copied by perl prior
12928 to this and will be provided as the regexp *r argument, however
12929 with the /old/ structures pprivate pointer value. Thus this routine
12930 may override any copying normally done by perl.
12932 It returns a pointer to the new regexp_internal structure.
12936 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
12939 struct regexp *const r = (struct regexp *)SvANY(rx);
12940 regexp_internal *reti;
12942 RXi_GET_DECL(r,ri);
12944 PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
12948 Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
12949 Copy(ri->program, reti->program, len+1, regnode);
12952 reti->regstclass = NULL;
12955 struct reg_data *d;
12956 const int count = ri->data->count;
12959 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
12960 char, struct reg_data);
12961 Newx(d->what, count, U8);
12964 for (i = 0; i < count; i++) {
12965 d->what[i] = ri->data->what[i];
12966 switch (d->what[i]) {
12967 /* legal options are one of: sSfpontTua
12968 see also regcomp.h and pregfree() */
12969 case 'a': /* actually an AV, but the dup function is identical. */
12972 case 'p': /* actually an AV, but the dup function is identical. */
12973 case 'u': /* actually an HV, but the dup function is identical. */
12974 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
12977 /* This is cheating. */
12978 Newx(d->data[i], 1, struct regnode_charclass_class);
12979 StructCopy(ri->data->data[i], d->data[i],
12980 struct regnode_charclass_class);
12981 reti->regstclass = (regnode*)d->data[i];
12984 /* Compiled op trees are readonly and in shared memory,
12985 and can thus be shared without duplication. */
12987 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
12991 /* Trie stclasses are readonly and can thus be shared
12992 * without duplication. We free the stclass in pregfree
12993 * when the corresponding reg_ac_data struct is freed.
12995 reti->regstclass= ri->regstclass;
12999 ((reg_trie_data*)ri->data->data[i])->refcount++;
13003 d->data[i] = ri->data->data[i];
13006 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
13015 reti->name_list_idx = ri->name_list_idx;
13017 #ifdef RE_TRACK_PATTERN_OFFSETS
13018 if (ri->u.offsets) {
13019 Newx(reti->u.offsets, 2*len+1, U32);
13020 Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
13023 SetProgLen(reti,len);
13026 return (void*)reti;
13029 #endif /* USE_ITHREADS */
13031 #ifndef PERL_IN_XSUB_RE
13034 - regnext - dig the "next" pointer out of a node
13037 Perl_regnext(pTHX_ register regnode *p)
13040 register I32 offset;
13045 if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */
13046 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
13049 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
13058 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
13061 STRLEN l1 = strlen(pat1);
13062 STRLEN l2 = strlen(pat2);
13065 const char *message;
13067 PERL_ARGS_ASSERT_RE_CROAK2;
13073 Copy(pat1, buf, l1 , char);
13074 Copy(pat2, buf + l1, l2 , char);
13075 buf[l1 + l2] = '\n';
13076 buf[l1 + l2 + 1] = '\0';
13078 /* ANSI variant takes additional second argument */
13079 va_start(args, pat2);
13083 msv = vmess(buf, &args);
13085 message = SvPV_const(msv,l1);
13088 Copy(message, buf, l1 , char);
13089 buf[l1-1] = '\0'; /* Overwrite \n */
13090 Perl_croak(aTHX_ "%s", buf);
13093 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
13095 #ifndef PERL_IN_XSUB_RE
13097 Perl_save_re_context(pTHX)
13101 struct re_save_state *state;
13103 SAVEVPTR(PL_curcop);
13104 SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
13106 state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
13107 PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
13108 SSPUSHUV(SAVEt_RE_STATE);
13110 Copy(&PL_reg_state, state, 1, struct re_save_state);
13112 PL_reg_start_tmp = 0;
13113 PL_reg_start_tmpl = 0;
13114 PL_reg_oldsaved = NULL;
13115 PL_reg_oldsavedlen = 0;
13116 PL_reg_maxiter = 0;
13117 PL_reg_leftiter = 0;
13118 PL_reg_poscache = NULL;
13119 PL_reg_poscache_size = 0;
13120 #ifdef PERL_OLD_COPY_ON_WRITE
13124 /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
13126 const REGEXP * const rx = PM_GETRE(PL_curpm);
13129 for (i = 1; i <= RX_NPARENS(rx); i++) {
13130 char digits[TYPE_CHARS(long)];
13131 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
13132 GV *const *const gvp
13133 = (GV**)hv_fetch(PL_defstash, digits, len, 0);
13136 GV * const gv = *gvp;
13137 if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
13147 clear_re(pTHX_ void *r)
13150 ReREFCNT_dec((REGEXP *)r);
13156 S_put_byte(pTHX_ SV *sv, int c)
13158 PERL_ARGS_ASSERT_PUT_BYTE;
13160 /* Our definition of isPRINT() ignores locales, so only bytes that are
13161 not part of UTF-8 are considered printable. I assume that the same
13162 holds for UTF-EBCDIC.
13163 Also, code point 255 is not printable in either (it's E0 in EBCDIC,
13164 which Wikipedia says:
13166 EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
13167 ones (binary 1111 1111, hexadecimal FF). It is similar, but not
13168 identical, to the ASCII delete (DEL) or rubout control character.
13169 ) So the old condition can be simplified to !isPRINT(c) */
13172 Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
13175 Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
13179 const char string = c;
13180 if (c == '-' || c == ']' || c == '\\' || c == '^')
13181 sv_catpvs(sv, "\\");
13182 sv_catpvn(sv, &string, 1);
13187 #define CLEAR_OPTSTART \
13188 if (optstart) STMT_START { \
13189 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
13193 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
13195 STATIC const regnode *
13196 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
13197 const regnode *last, const regnode *plast,
13198 SV* sv, I32 indent, U32 depth)
13201 register U8 op = PSEUDO; /* Arbitrary non-END op. */
13202 register const regnode *next;
13203 const regnode *optstart= NULL;
13205 RXi_GET_DECL(r,ri);
13206 GET_RE_DEBUG_FLAGS_DECL;
13208 PERL_ARGS_ASSERT_DUMPUNTIL;
13210 #ifdef DEBUG_DUMPUNTIL
13211 PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
13212 last ? last-start : 0,plast ? plast-start : 0);
13215 if (plast && plast < last)
13218 while (PL_regkind[op] != END && (!last || node < last)) {
13219 /* While that wasn't END last time... */
13222 if (op == CLOSE || op == WHILEM)
13224 next = regnext((regnode *)node);
13227 if (OP(node) == OPTIMIZED) {
13228 if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
13235 regprop(r, sv, node);
13236 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
13237 (int)(2*indent + 1), "", SvPVX_const(sv));
13239 if (OP(node) != OPTIMIZED) {
13240 if (next == NULL) /* Next ptr. */
13241 PerlIO_printf(Perl_debug_log, " (0)");
13242 else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
13243 PerlIO_printf(Perl_debug_log, " (FAIL)");
13245 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
13246 (void)PerlIO_putc(Perl_debug_log, '\n');
13250 if (PL_regkind[(U8)op] == BRANCHJ) {
13253 register const regnode *nnode = (OP(next) == LONGJMP
13254 ? regnext((regnode *)next)
13256 if (last && nnode > last)
13258 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
13261 else if (PL_regkind[(U8)op] == BRANCH) {
13263 DUMPUNTIL(NEXTOPER(node), next);
13265 else if ( PL_regkind[(U8)op] == TRIE ) {
13266 const regnode *this_trie = node;
13267 const char op = OP(node);
13268 const U32 n = ARG(node);
13269 const reg_ac_data * const ac = op>=AHOCORASICK ?
13270 (reg_ac_data *)ri->data->data[n] :
13272 const reg_trie_data * const trie =
13273 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
13275 AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
13277 const regnode *nextbranch= NULL;
13280 for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
13281 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
13283 PerlIO_printf(Perl_debug_log, "%*s%s ",
13284 (int)(2*(indent+3)), "",
13285 elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
13286 PL_colors[0], PL_colors[1],
13287 (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
13288 PERL_PV_PRETTY_ELLIPSES |
13289 PERL_PV_PRETTY_LTGT
13294 U16 dist= trie->jump[word_idx+1];
13295 PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
13296 (UV)((dist ? this_trie + dist : next) - start));
13299 nextbranch= this_trie + trie->jump[0];
13300 DUMPUNTIL(this_trie + dist, nextbranch);
13302 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
13303 nextbranch= regnext((regnode *)nextbranch);
13305 PerlIO_printf(Perl_debug_log, "\n");
13308 if (last && next > last)
13313 else if ( op == CURLY ) { /* "next" might be very big: optimizer */
13314 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
13315 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
13317 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
13319 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
13321 else if ( op == PLUS || op == STAR) {
13322 DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
13324 else if (PL_regkind[(U8)op] == ANYOF) {
13325 /* arglen 1 + class block */
13326 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
13327 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
13328 node = NEXTOPER(node);
13330 else if (PL_regkind[(U8)op] == EXACT) {
13331 /* Literal string, where present. */
13332 node += NODE_SZ_STR(node) - 1;
13333 node = NEXTOPER(node);
13336 node = NEXTOPER(node);
13337 node += regarglen[(U8)op];
13339 if (op == CURLYX || op == OPEN)
13343 #ifdef DEBUG_DUMPUNTIL
13344 PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
13349 #endif /* DEBUGGING */
13353 * c-indentation-style: bsd
13354 * c-basic-offset: 4
13355 * indent-tabs-mode: t
13358 * ex: set ts=8 sts=4 sw=4 noet: