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"
93 #define HAS_NONLATIN1_FOLD_CLOSURE(i) _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)
100 # if defined(BUGGY_MSC6)
101 /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
102 # pragma optimize("a",off)
103 /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
104 # pragma optimize("w",on )
105 # endif /* BUGGY_MSC6 */
109 #define STATIC static
113 typedef struct RExC_state_t {
114 U32 flags; /* RXf_* are we folding, multilining? */
115 U32 pm_flags; /* PMf_* stuff from the calling PMOP */
116 char *precomp; /* uncompiled string. */
117 REGEXP *rx_sv; /* The SV that is the regexp. */
118 regexp *rx; /* perl core regexp structure */
119 regexp_internal *rxi; /* internal data for regexp object pprivate field */
120 char *start; /* Start of input for compile */
121 char *end; /* End of input for compile */
122 char *parse; /* Input-scan pointer. */
123 I32 whilem_seen; /* number of WHILEM in this expr */
124 regnode *emit_start; /* Start of emitted-code area */
125 regnode *emit_bound; /* First regnode outside of the allocated space */
126 regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */
127 I32 naughty; /* How bad is this pattern? */
128 I32 sawback; /* Did we see \1, ...? */
130 I32 size; /* Code size. */
131 I32 npar; /* Capture buffer count, (OPEN). */
132 I32 cpar; /* Capture buffer count, (CLOSE). */
133 I32 nestroot; /* root parens we are in - used by accept */
136 regnode **open_parens; /* pointers to open parens */
137 regnode **close_parens; /* pointers to close parens */
138 regnode *opend; /* END node in program */
139 I32 utf8; /* whether the pattern is utf8 or not */
140 I32 orig_utf8; /* whether the pattern was originally in utf8 */
141 /* XXX use this for future optimisation of case
142 * where pattern must be upgraded to utf8. */
143 I32 uni_semantics; /* If a d charset modifier should use unicode
144 rules, even if the pattern is not in
146 HV *paren_names; /* Paren names */
148 regnode **recurse; /* Recurse regops */
149 I32 recurse_count; /* Number of recurse regops */
152 I32 override_recoding;
153 struct reg_code_block *code_blocks; /* positions of literal (?{})
155 int num_code_blocks; /* size of code_blocks[] */
156 int code_index; /* next code_blocks[] slot */
158 char *starttry; /* -Dr: where regtry was called. */
159 #define RExC_starttry (pRExC_state->starttry)
161 SV *runtime_code_qr; /* qr with the runtime code blocks */
163 const char *lastparse;
165 AV *paren_name_list; /* idx -> name */
166 #define RExC_lastparse (pRExC_state->lastparse)
167 #define RExC_lastnum (pRExC_state->lastnum)
168 #define RExC_paren_name_list (pRExC_state->paren_name_list)
172 #define RExC_flags (pRExC_state->flags)
173 #define RExC_pm_flags (pRExC_state->pm_flags)
174 #define RExC_precomp (pRExC_state->precomp)
175 #define RExC_rx_sv (pRExC_state->rx_sv)
176 #define RExC_rx (pRExC_state->rx)
177 #define RExC_rxi (pRExC_state->rxi)
178 #define RExC_start (pRExC_state->start)
179 #define RExC_end (pRExC_state->end)
180 #define RExC_parse (pRExC_state->parse)
181 #define RExC_whilem_seen (pRExC_state->whilem_seen)
182 #ifdef RE_TRACK_PATTERN_OFFSETS
183 #define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the others */
185 #define RExC_emit (pRExC_state->emit)
186 #define RExC_emit_start (pRExC_state->emit_start)
187 #define RExC_emit_bound (pRExC_state->emit_bound)
188 #define RExC_naughty (pRExC_state->naughty)
189 #define RExC_sawback (pRExC_state->sawback)
190 #define RExC_seen (pRExC_state->seen)
191 #define RExC_size (pRExC_state->size)
192 #define RExC_npar (pRExC_state->npar)
193 #define RExC_nestroot (pRExC_state->nestroot)
194 #define RExC_extralen (pRExC_state->extralen)
195 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
196 #define RExC_utf8 (pRExC_state->utf8)
197 #define RExC_uni_semantics (pRExC_state->uni_semantics)
198 #define RExC_orig_utf8 (pRExC_state->orig_utf8)
199 #define RExC_open_parens (pRExC_state->open_parens)
200 #define RExC_close_parens (pRExC_state->close_parens)
201 #define RExC_opend (pRExC_state->opend)
202 #define RExC_paren_names (pRExC_state->paren_names)
203 #define RExC_recurse (pRExC_state->recurse)
204 #define RExC_recurse_count (pRExC_state->recurse_count)
205 #define RExC_in_lookbehind (pRExC_state->in_lookbehind)
206 #define RExC_contains_locale (pRExC_state->contains_locale)
207 #define RExC_override_recoding (pRExC_state->override_recoding)
210 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
211 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
212 ((*s) == '{' && regcurly(s)))
215 #undef SPSTART /* dratted cpp namespace... */
218 * Flags to be passed up and down.
220 #define WORST 0 /* Worst case. */
221 #define HASWIDTH 0x01 /* Known to match non-null strings. */
223 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
224 * character, and if utf8, must be invariant. Note that this is not the same
225 * thing as REGNODE_SIMPLE */
227 #define SPSTART 0x04 /* Starts with * or +. */
228 #define TRYAGAIN 0x08 /* Weeded out a declaration. */
229 #define POSTPONED 0x10 /* (?1),(?&name), (??{...}) or similar */
231 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
233 /* whether trie related optimizations are enabled */
234 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
235 #define TRIE_STUDY_OPT
236 #define FULL_TRIE_STUDY
242 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
243 #define PBITVAL(paren) (1 << ((paren) & 7))
244 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
245 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
246 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
248 /* If not already in utf8, do a longjmp back to the beginning */
249 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
250 #define REQUIRE_UTF8 STMT_START { \
251 if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
254 /* About scan_data_t.
256 During optimisation we recurse through the regexp program performing
257 various inplace (keyhole style) optimisations. In addition study_chunk
258 and scan_commit populate this data structure with information about
259 what strings MUST appear in the pattern. We look for the longest
260 string that must appear at a fixed location, and we look for the
261 longest string that may appear at a floating location. So for instance
266 Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
267 strings (because they follow a .* construct). study_chunk will identify
268 both FOO and BAR as being the longest fixed and floating strings respectively.
270 The strings can be composites, for instance
274 will result in a composite fixed substring 'foo'.
276 For each string some basic information is maintained:
278 - offset or min_offset
279 This is the position the string must appear at, or not before.
280 It also implicitly (when combined with minlenp) tells us how many
281 characters must match before the string we are searching for.
282 Likewise when combined with minlenp and the length of the string it
283 tells us how many characters must appear after the string we have
287 Only used for floating strings. This is the rightmost point that
288 the string can appear at. If set to I32 max it indicates that the
289 string can occur infinitely far to the right.
292 A pointer to the minimum length of the pattern that the string
293 was found inside. This is important as in the case of positive
294 lookahead or positive lookbehind we can have multiple patterns
299 The minimum length of the pattern overall is 3, the minimum length
300 of the lookahead part is 3, but the minimum length of the part that
301 will actually match is 1. So 'FOO's minimum length is 3, but the
302 minimum length for the F is 1. This is important as the minimum length
303 is used to determine offsets in front of and behind the string being
304 looked for. Since strings can be composites this is the length of the
305 pattern at the time it was committed with a scan_commit. Note that
306 the length is calculated by study_chunk, so that the minimum lengths
307 are not known until the full pattern has been compiled, thus the
308 pointer to the value.
312 In the case of lookbehind the string being searched for can be
313 offset past the start point of the final matching string.
314 If this value was just blithely removed from the min_offset it would
315 invalidate some of the calculations for how many chars must match
316 before or after (as they are derived from min_offset and minlen and
317 the length of the string being searched for).
318 When the final pattern is compiled and the data is moved from the
319 scan_data_t structure into the regexp structure the information
320 about lookbehind is factored in, with the information that would
321 have been lost precalculated in the end_shift field for the
324 The fields pos_min and pos_delta are used to store the minimum offset
325 and the delta to the maximum offset at the current point in the pattern.
329 typedef struct scan_data_t {
330 /*I32 len_min; unused */
331 /*I32 len_delta; unused */
335 I32 last_end; /* min value, <0 unless valid. */
338 SV **longest; /* Either &l_fixed, or &l_float. */
339 SV *longest_fixed; /* longest fixed string found in pattern */
340 I32 offset_fixed; /* offset where it starts */
341 I32 *minlen_fixed; /* pointer to the minlen relevant to the string */
342 I32 lookbehind_fixed; /* is the position of the string modfied by LB */
343 SV *longest_float; /* longest floating string found in pattern */
344 I32 offset_float_min; /* earliest point in string it can appear */
345 I32 offset_float_max; /* latest point in string it can appear */
346 I32 *minlen_float; /* pointer to the minlen relevant to the string */
347 I32 lookbehind_float; /* is the position of the string modified by LB */
351 struct regnode_charclass_class *start_class;
355 * Forward declarations for pregcomp()'s friends.
358 static const scan_data_t zero_scan_data =
359 { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
361 #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
362 #define SF_BEFORE_SEOL 0x0001
363 #define SF_BEFORE_MEOL 0x0002
364 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
365 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
368 # define SF_FIX_SHIFT_EOL (0+2)
369 # define SF_FL_SHIFT_EOL (0+4)
371 # define SF_FIX_SHIFT_EOL (+2)
372 # define SF_FL_SHIFT_EOL (+4)
375 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
376 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
378 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
379 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
380 #define SF_IS_INF 0x0040
381 #define SF_HAS_PAR 0x0080
382 #define SF_IN_PAR 0x0100
383 #define SF_HAS_EVAL 0x0200
384 #define SCF_DO_SUBSTR 0x0400
385 #define SCF_DO_STCLASS_AND 0x0800
386 #define SCF_DO_STCLASS_OR 0x1000
387 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
388 #define SCF_WHILEM_VISITED_POS 0x2000
390 #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */
391 #define SCF_SEEN_ACCEPT 0x8000
393 #define UTF cBOOL(RExC_utf8)
395 /* The enums for all these are ordered so things work out correctly */
396 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
397 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
398 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
399 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
400 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
401 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
402 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
404 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
406 #define OOB_UNICODE 12345678
407 #define OOB_NAMEDCLASS -1
409 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
410 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
413 /* length of regex to show in messages that don't mark a position within */
414 #define RegexLengthToShowInErrorMessages 127
417 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
418 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
419 * op/pragma/warn/regcomp.
421 #define MARKER1 "<-- HERE" /* marker as it appears in the description */
422 #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
424 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
427 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
428 * arg. Show regex, up to a maximum length. If it's too long, chop and add
431 #define _FAIL(code) STMT_START { \
432 const char *ellipses = ""; \
433 IV len = RExC_end - RExC_precomp; \
436 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
437 if (len > RegexLengthToShowInErrorMessages) { \
438 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
439 len = RegexLengthToShowInErrorMessages - 10; \
445 #define FAIL(msg) _FAIL( \
446 Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
447 msg, (int)len, RExC_precomp, ellipses))
449 #define FAIL2(msg,arg) _FAIL( \
450 Perl_croak(aTHX_ msg " in regex m/%.*s%s/", \
451 arg, (int)len, RExC_precomp, ellipses))
454 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
456 #define Simple_vFAIL(m) STMT_START { \
457 const IV offset = RExC_parse - RExC_precomp; \
458 Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
459 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
463 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
465 #define vFAIL(m) STMT_START { \
467 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
472 * Like Simple_vFAIL(), but accepts two arguments.
474 #define Simple_vFAIL2(m,a1) STMT_START { \
475 const IV offset = RExC_parse - RExC_precomp; \
476 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \
477 (int)offset, RExC_precomp, RExC_precomp + offset); \
481 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
483 #define vFAIL2(m,a1) STMT_START { \
485 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
486 Simple_vFAIL2(m, a1); \
491 * Like Simple_vFAIL(), but accepts three arguments.
493 #define Simple_vFAIL3(m, a1, a2) STMT_START { \
494 const IV offset = RExC_parse - RExC_precomp; \
495 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \
496 (int)offset, RExC_precomp, RExC_precomp + offset); \
500 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
502 #define vFAIL3(m,a1,a2) STMT_START { \
504 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
505 Simple_vFAIL3(m, a1, a2); \
509 * Like Simple_vFAIL(), but accepts four arguments.
511 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \
512 const IV offset = RExC_parse - RExC_precomp; \
513 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, \
514 (int)offset, RExC_precomp, RExC_precomp + offset); \
517 #define ckWARNreg(loc,m) STMT_START { \
518 const IV offset = loc - RExC_precomp; \
519 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
520 (int)offset, RExC_precomp, RExC_precomp + offset); \
523 #define ckWARNregdep(loc,m) STMT_START { \
524 const IV offset = loc - RExC_precomp; \
525 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
527 (int)offset, RExC_precomp, RExC_precomp + offset); \
530 #define ckWARN2regdep(loc,m, a1) STMT_START { \
531 const IV offset = loc - RExC_precomp; \
532 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
534 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
537 #define ckWARN2reg(loc, m, a1) STMT_START { \
538 const IV offset = loc - RExC_precomp; \
539 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
540 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
543 #define vWARN3(loc, m, a1, a2) STMT_START { \
544 const IV offset = loc - RExC_precomp; \
545 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
546 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
549 #define ckWARN3reg(loc, m, a1, a2) STMT_START { \
550 const IV offset = loc - RExC_precomp; \
551 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
552 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
555 #define vWARN4(loc, m, a1, a2, a3) STMT_START { \
556 const IV offset = loc - RExC_precomp; \
557 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
558 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
561 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START { \
562 const IV offset = loc - RExC_precomp; \
563 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
564 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
567 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \
568 const IV offset = loc - RExC_precomp; \
569 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
570 a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
574 /* Allow for side effects in s */
575 #define REGC(c,s) STMT_START { \
576 if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
579 /* Macros for recording node offsets. 20001227 mjd@plover.com
580 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
581 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
582 * Element 0 holds the number n.
583 * Position is 1 indexed.
585 #ifndef RE_TRACK_PATTERN_OFFSETS
586 #define Set_Node_Offset_To_R(node,byte)
587 #define Set_Node_Offset(node,byte)
588 #define Set_Cur_Node_Offset
589 #define Set_Node_Length_To_R(node,len)
590 #define Set_Node_Length(node,len)
591 #define Set_Node_Cur_Length(node)
592 #define Node_Offset(n)
593 #define Node_Length(n)
594 #define Set_Node_Offset_Length(node,offset,len)
595 #define ProgLen(ri) ri->u.proglen
596 #define SetProgLen(ri,x) ri->u.proglen = x
598 #define ProgLen(ri) ri->u.offsets[0]
599 #define SetProgLen(ri,x) ri->u.offsets[0] = x
600 #define Set_Node_Offset_To_R(node,byte) STMT_START { \
602 MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \
603 __LINE__, (int)(node), (int)(byte))); \
605 Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
607 RExC_offsets[2*(node)-1] = (byte); \
612 #define Set_Node_Offset(node,byte) \
613 Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
614 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
616 #define Set_Node_Length_To_R(node,len) STMT_START { \
618 MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \
619 __LINE__, (int)(node), (int)(len))); \
621 Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
623 RExC_offsets[2*(node)] = (len); \
628 #define Set_Node_Length(node,len) \
629 Set_Node_Length_To_R((node)-RExC_emit_start, len)
630 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
631 #define Set_Node_Cur_Length(node) \
632 Set_Node_Length(node, RExC_parse - parse_start)
634 /* Get offsets and lengths */
635 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
636 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
638 #define Set_Node_Offset_Length(node,offset,len) STMT_START { \
639 Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \
640 Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \
644 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
645 #define EXPERIMENTAL_INPLACESCAN
646 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
648 #define DEBUG_STUDYDATA(str,data,depth) \
649 DEBUG_OPTIMISE_MORE_r(if(data){ \
650 PerlIO_printf(Perl_debug_log, \
651 "%*s" str "Pos:%"IVdf"/%"IVdf \
652 " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s", \
653 (int)(depth)*2, "", \
654 (IV)((data)->pos_min), \
655 (IV)((data)->pos_delta), \
656 (UV)((data)->flags), \
657 (IV)((data)->whilem_c), \
658 (IV)((data)->last_closep ? *((data)->last_closep) : -1), \
659 is_inf ? "INF " : "" \
661 if ((data)->last_found) \
662 PerlIO_printf(Perl_debug_log, \
663 "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
664 " %sFloat: '%s' @ %"IVdf"/%"IVdf"", \
665 SvPVX_const((data)->last_found), \
666 (IV)((data)->last_end), \
667 (IV)((data)->last_start_min), \
668 (IV)((data)->last_start_max), \
669 ((data)->longest && \
670 (data)->longest==&((data)->longest_fixed)) ? "*" : "", \
671 SvPVX_const((data)->longest_fixed), \
672 (IV)((data)->offset_fixed), \
673 ((data)->longest && \
674 (data)->longest==&((data)->longest_float)) ? "*" : "", \
675 SvPVX_const((data)->longest_float), \
676 (IV)((data)->offset_float_min), \
677 (IV)((data)->offset_float_max) \
679 PerlIO_printf(Perl_debug_log,"\n"); \
682 static void clear_re(pTHX_ void *r);
684 /* Mark that we cannot extend a found fixed substring at this point.
685 Update the longest found anchored substring and the longest found
686 floating substrings if needed. */
689 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
691 const STRLEN l = CHR_SVLEN(data->last_found);
692 const STRLEN old_l = CHR_SVLEN(*data->longest);
693 GET_RE_DEBUG_FLAGS_DECL;
695 PERL_ARGS_ASSERT_SCAN_COMMIT;
697 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
698 SvSetMagicSV(*data->longest, data->last_found);
699 if (*data->longest == data->longest_fixed) {
700 data->offset_fixed = l ? data->last_start_min : data->pos_min;
701 if (data->flags & SF_BEFORE_EOL)
703 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
705 data->flags &= ~SF_FIX_BEFORE_EOL;
706 data->minlen_fixed=minlenp;
707 data->lookbehind_fixed=0;
709 else { /* *data->longest == data->longest_float */
710 data->offset_float_min = l ? data->last_start_min : data->pos_min;
711 data->offset_float_max = (l
712 ? data->last_start_max
713 : data->pos_min + data->pos_delta);
714 if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
715 data->offset_float_max = I32_MAX;
716 if (data->flags & SF_BEFORE_EOL)
718 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
720 data->flags &= ~SF_FL_BEFORE_EOL;
721 data->minlen_float=minlenp;
722 data->lookbehind_float=0;
725 SvCUR_set(data->last_found, 0);
727 SV * const sv = data->last_found;
728 if (SvUTF8(sv) && SvMAGICAL(sv)) {
729 MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
735 data->flags &= ~SF_BEFORE_EOL;
736 DEBUG_STUDYDATA("commit: ",data,0);
739 /* Can match anything (initialization) */
741 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
743 PERL_ARGS_ASSERT_CL_ANYTHING;
745 ANYOF_BITMAP_SETALL(cl);
746 cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
747 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
749 /* If any portion of the regex is to operate under locale rules,
750 * initialization includes it. The reason this isn't done for all regexes
751 * is that the optimizer was written under the assumption that locale was
752 * all-or-nothing. Given the complexity and lack of documentation in the
753 * optimizer, and that there are inadequate test cases for locale, so many
754 * parts of it may not work properly, it is safest to avoid locale unless
756 if (RExC_contains_locale) {
757 ANYOF_CLASS_SETALL(cl); /* /l uses class */
758 cl->flags |= ANYOF_LOCALE;
761 ANYOF_CLASS_ZERO(cl); /* Only /l uses class now */
765 /* Can match anything (initialization) */
767 S_cl_is_anything(const struct regnode_charclass_class *cl)
771 PERL_ARGS_ASSERT_CL_IS_ANYTHING;
773 for (value = 0; value <= ANYOF_MAX; value += 2)
774 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
776 if (!(cl->flags & ANYOF_UNICODE_ALL))
778 if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
783 /* Can match anything (initialization) */
785 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
787 PERL_ARGS_ASSERT_CL_INIT;
789 Zero(cl, 1, struct regnode_charclass_class);
791 cl_anything(pRExC_state, cl);
792 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
795 /* These two functions currently do the exact same thing */
796 #define cl_init_zero S_cl_init
798 /* 'AND' a given class with another one. Can create false positives. 'cl'
799 * should not be inverted. 'and_with->flags & ANYOF_CLASS' should be 0 if
800 * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
802 S_cl_and(struct regnode_charclass_class *cl,
803 const struct regnode_charclass_class *and_with)
805 PERL_ARGS_ASSERT_CL_AND;
807 assert(and_with->type == ANYOF);
809 /* I (khw) am not sure all these restrictions are necessary XXX */
810 if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
811 && !(ANYOF_CLASS_TEST_ANY_SET(cl))
812 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
813 && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
814 && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
817 if (and_with->flags & ANYOF_INVERT)
818 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
819 cl->bitmap[i] &= ~and_with->bitmap[i];
821 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
822 cl->bitmap[i] &= and_with->bitmap[i];
823 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
825 if (and_with->flags & ANYOF_INVERT) {
827 /* Here, the and'ed node is inverted. Get the AND of the flags that
828 * aren't affected by the inversion. Those that are affected are
829 * handled individually below */
830 U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
831 cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
832 cl->flags |= affected_flags;
834 /* We currently don't know how to deal with things that aren't in the
835 * bitmap, but we know that the intersection is no greater than what
836 * is already in cl, so let there be false positives that get sorted
837 * out after the synthetic start class succeeds, and the node is
838 * matched for real. */
840 /* The inversion of these two flags indicate that the resulting
841 * intersection doesn't have them */
842 if (and_with->flags & ANYOF_UNICODE_ALL) {
843 cl->flags &= ~ANYOF_UNICODE_ALL;
845 if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
846 cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
849 else { /* and'd node is not inverted */
850 U8 outside_bitmap_but_not_utf8; /* Temp variable */
852 if (! ANYOF_NONBITMAP(and_with)) {
854 /* Here 'and_with' doesn't match anything outside the bitmap
855 * (except possibly ANYOF_UNICODE_ALL), which means the
856 * intersection can't either, except for ANYOF_UNICODE_ALL, in
857 * which case we don't know what the intersection is, but it's no
858 * greater than what cl already has, so can just leave it alone,
859 * with possible false positives */
860 if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
861 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
862 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
865 else if (! ANYOF_NONBITMAP(cl)) {
867 /* Here, 'and_with' does match something outside the bitmap, and cl
868 * doesn't have a list of things to match outside the bitmap. If
869 * cl can match all code points above 255, the intersection will
870 * be those above-255 code points that 'and_with' matches. If cl
871 * can't match all Unicode code points, it means that it can't
872 * match anything outside the bitmap (since the 'if' that got us
873 * into this block tested for that), so we leave the bitmap empty.
875 if (cl->flags & ANYOF_UNICODE_ALL) {
876 ARG_SET(cl, ARG(and_with));
878 /* and_with's ARG may match things that don't require UTF8.
879 * And now cl's will too, in spite of this being an 'and'. See
880 * the comments below about the kludge */
881 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
885 /* Here, both 'and_with' and cl match something outside the
886 * bitmap. Currently we do not do the intersection, so just match
887 * whatever cl had at the beginning. */
891 /* Take the intersection of the two sets of flags. However, the
892 * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'. This is a
893 * kludge around the fact that this flag is not treated like the others
894 * which are initialized in cl_anything(). The way the optimizer works
895 * is that the synthetic start class (SSC) is initialized to match
896 * anything, and then the first time a real node is encountered, its
897 * values are AND'd with the SSC's with the result being the values of
898 * the real node. However, there are paths through the optimizer where
899 * the AND never gets called, so those initialized bits are set
900 * inappropriately, which is not usually a big deal, as they just cause
901 * false positives in the SSC, which will just mean a probably
902 * imperceptible slow down in execution. However this bit has a
903 * higher false positive consequence in that it can cause utf8.pm,
904 * utf8_heavy.pl ... to be loaded when not necessary, which is a much
905 * bigger slowdown and also causes significant extra memory to be used.
906 * In order to prevent this, the code now takes a different tack. The
907 * bit isn't set unless some part of the regular expression needs it,
908 * but once set it won't get cleared. This means that these extra
909 * modules won't get loaded unless there was some path through the
910 * pattern that would have required them anyway, and so any false
911 * positives that occur by not ANDing them out when they could be
912 * aren't as severe as they would be if we treated this bit like all
914 outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
915 & ANYOF_NONBITMAP_NON_UTF8;
916 cl->flags &= and_with->flags;
917 cl->flags |= outside_bitmap_but_not_utf8;
921 /* 'OR' a given class with another one. Can create false positives. 'cl'
922 * should not be inverted. 'or_with->flags & ANYOF_CLASS' should be 0 if
923 * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
925 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
927 PERL_ARGS_ASSERT_CL_OR;
929 if (or_with->flags & ANYOF_INVERT) {
931 /* Here, the or'd node is to be inverted. This means we take the
932 * complement of everything not in the bitmap, but currently we don't
933 * know what that is, so give up and match anything */
934 if (ANYOF_NONBITMAP(or_with)) {
935 cl_anything(pRExC_state, cl);
938 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
939 * <= (B1 | !B2) | (CL1 | !CL2)
940 * which is wasteful if CL2 is small, but we ignore CL2:
941 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
942 * XXXX Can we handle case-fold? Unclear:
943 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
944 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
946 else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
947 && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
948 && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
951 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
952 cl->bitmap[i] |= ~or_with->bitmap[i];
953 } /* XXXX: logic is complicated otherwise */
955 cl_anything(pRExC_state, cl);
958 /* And, we can just take the union of the flags that aren't affected
959 * by the inversion */
960 cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
962 /* For the remaining flags:
963 ANYOF_UNICODE_ALL and inverted means to not match anything above
964 255, which means that the union with cl should just be
965 what cl has in it, so can ignore this flag
966 ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
967 is 127-255 to match them, but then invert that, so the
968 union with cl should just be what cl has in it, so can
971 } else { /* 'or_with' is not inverted */
972 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
973 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
974 && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
975 || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
978 /* OR char bitmap and class bitmap separately */
979 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
980 cl->bitmap[i] |= or_with->bitmap[i];
981 if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
982 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
983 cl->classflags[i] |= or_with->classflags[i];
984 cl->flags |= ANYOF_CLASS;
987 else { /* XXXX: logic is complicated, leave it along for a moment. */
988 cl_anything(pRExC_state, cl);
991 if (ANYOF_NONBITMAP(or_with)) {
993 /* Use the added node's outside-the-bit-map match if there isn't a
994 * conflict. If there is a conflict (both nodes match something
995 * outside the bitmap, but what they match outside is not the same
996 * pointer, and hence not easily compared until XXX we extend
997 * inversion lists this far), give up and allow the start class to
998 * match everything outside the bitmap. If that stuff is all above
999 * 255, can just set UNICODE_ALL, otherwise caould be anything. */
1000 if (! ANYOF_NONBITMAP(cl)) {
1001 ARG_SET(cl, ARG(or_with));
1003 else if (ARG(cl) != ARG(or_with)) {
1005 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
1006 cl_anything(pRExC_state, cl);
1009 cl->flags |= ANYOF_UNICODE_ALL;
1014 /* Take the union */
1015 cl->flags |= or_with->flags;
1019 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1020 #define TRIE_LIST_CUR(state) ( TRIE_LIST_ITEM( state, 0 ).forid )
1021 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1022 #define TRIE_LIST_USED(idx) ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1027 dump_trie(trie,widecharmap,revcharmap)
1028 dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1029 dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1031 These routines dump out a trie in a somewhat readable format.
1032 The _interim_ variants are used for debugging the interim
1033 tables that are used to generate the final compressed
1034 representation which is what dump_trie expects.
1036 Part of the reason for their existence is to provide a form
1037 of documentation as to how the different representations function.
1042 Dumps the final compressed table form of the trie to Perl_debug_log.
1043 Used for debugging make_trie().
1047 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1048 AV *revcharmap, U32 depth)
1051 SV *sv=sv_newmortal();
1052 int colwidth= widecharmap ? 6 : 4;
1054 GET_RE_DEBUG_FLAGS_DECL;
1056 PERL_ARGS_ASSERT_DUMP_TRIE;
1058 PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1059 (int)depth * 2 + 2,"",
1060 "Match","Base","Ofs" );
1062 for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1063 SV ** const tmp = av_fetch( revcharmap, state, 0);
1065 PerlIO_printf( Perl_debug_log, "%*s",
1067 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1068 PL_colors[0], PL_colors[1],
1069 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1070 PERL_PV_ESCAPE_FIRSTCHAR
1075 PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1076 (int)depth * 2 + 2,"");
1078 for( state = 0 ; state < trie->uniquecharcount ; state++ )
1079 PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1080 PerlIO_printf( Perl_debug_log, "\n");
1082 for( state = 1 ; state < trie->statecount ; state++ ) {
1083 const U32 base = trie->states[ state ].trans.base;
1085 PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1087 if ( trie->states[ state ].wordnum ) {
1088 PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1090 PerlIO_printf( Perl_debug_log, "%6s", "" );
1093 PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1098 while( ( base + ofs < trie->uniquecharcount ) ||
1099 ( base + ofs - trie->uniquecharcount < trie->lasttrans
1100 && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1103 PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1105 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1106 if ( ( base + ofs >= trie->uniquecharcount ) &&
1107 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1108 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1110 PerlIO_printf( Perl_debug_log, "%*"UVXf,
1112 (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1114 PerlIO_printf( Perl_debug_log, "%*s",colwidth," ." );
1118 PerlIO_printf( Perl_debug_log, "]");
1121 PerlIO_printf( Perl_debug_log, "\n" );
1123 PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1124 for (word=1; word <= trie->wordcount; word++) {
1125 PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1126 (int)word, (int)(trie->wordinfo[word].prev),
1127 (int)(trie->wordinfo[word].len));
1129 PerlIO_printf(Perl_debug_log, "\n" );
1132 Dumps a fully constructed but uncompressed trie in list form.
1133 List tries normally only are used for construction when the number of
1134 possible chars (trie->uniquecharcount) is very high.
1135 Used for debugging make_trie().
1138 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1139 HV *widecharmap, AV *revcharmap, U32 next_alloc,
1143 SV *sv=sv_newmortal();
1144 int colwidth= widecharmap ? 6 : 4;
1145 GET_RE_DEBUG_FLAGS_DECL;
1147 PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1149 /* print out the table precompression. */
1150 PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1151 (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1152 "------:-----+-----------------\n" );
1154 for( state=1 ; state < next_alloc ; state ++ ) {
1157 PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1158 (int)depth * 2 + 2,"", (UV)state );
1159 if ( ! trie->states[ state ].wordnum ) {
1160 PerlIO_printf( Perl_debug_log, "%5s| ","");
1162 PerlIO_printf( Perl_debug_log, "W%4x| ",
1163 trie->states[ state ].wordnum
1166 for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1167 SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1169 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1171 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1172 PL_colors[0], PL_colors[1],
1173 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1174 PERL_PV_ESCAPE_FIRSTCHAR
1176 TRIE_LIST_ITEM(state,charid).forid,
1177 (UV)TRIE_LIST_ITEM(state,charid).newstate
1180 PerlIO_printf(Perl_debug_log, "\n%*s| ",
1181 (int)((depth * 2) + 14), "");
1184 PerlIO_printf( Perl_debug_log, "\n");
1189 Dumps a fully constructed but uncompressed trie in table form.
1190 This is the normal DFA style state transition table, with a few
1191 twists to facilitate compression later.
1192 Used for debugging make_trie().
1195 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1196 HV *widecharmap, AV *revcharmap, U32 next_alloc,
1201 SV *sv=sv_newmortal();
1202 int colwidth= widecharmap ? 6 : 4;
1203 GET_RE_DEBUG_FLAGS_DECL;
1205 PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1208 print out the table precompression so that we can do a visual check
1209 that they are identical.
1212 PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1214 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1215 SV ** const tmp = av_fetch( revcharmap, charid, 0);
1217 PerlIO_printf( Perl_debug_log, "%*s",
1219 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1220 PL_colors[0], PL_colors[1],
1221 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1222 PERL_PV_ESCAPE_FIRSTCHAR
1228 PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1230 for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1231 PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1234 PerlIO_printf( Perl_debug_log, "\n" );
1236 for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1238 PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
1239 (int)depth * 2 + 2,"",
1240 (UV)TRIE_NODENUM( state ) );
1242 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1243 UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1245 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1247 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1249 if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1250 PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1252 PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1253 trie->states[ TRIE_NODENUM( state ) ].wordnum );
1261 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1262 startbranch: the first branch in the whole branch sequence
1263 first : start branch of sequence of branch-exact nodes.
1264 May be the same as startbranch
1265 last : Thing following the last branch.
1266 May be the same as tail.
1267 tail : item following the branch sequence
1268 count : words in the sequence
1269 flags : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1270 depth : indent depth
1272 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1274 A trie is an N'ary tree where the branches are determined by digital
1275 decomposition of the key. IE, at the root node you look up the 1st character and
1276 follow that branch repeat until you find the end of the branches. Nodes can be
1277 marked as "accepting" meaning they represent a complete word. Eg:
1281 would convert into the following structure. Numbers represent states, letters
1282 following numbers represent valid transitions on the letter from that state, if
1283 the number is in square brackets it represents an accepting state, otherwise it
1284 will be in parenthesis.
1286 +-h->+-e->[3]-+-r->(8)-+-s->[9]
1290 (1) +-i->(6)-+-s->[7]
1292 +-s->(3)-+-h->(4)-+-e->[5]
1294 Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1296 This shows that when matching against the string 'hers' we will begin at state 1
1297 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1298 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1299 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1300 single traverse. We store a mapping from accepting to state to which word was
1301 matched, and then when we have multiple possibilities we try to complete the
1302 rest of the regex in the order in which they occured in the alternation.
1304 The only prior NFA like behaviour that would be changed by the TRIE support is
1305 the silent ignoring of duplicate alternations which are of the form:
1307 / (DUPE|DUPE) X? (?{ ... }) Y /x
1309 Thus EVAL blocks following a trie may be called a different number of times with
1310 and without the optimisation. With the optimisations dupes will be silently
1311 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1312 the following demonstrates:
1314 'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1316 which prints out 'word' three times, but
1318 'words'=~/(word|word|word)(?{ print $1 })S/
1320 which doesnt print it out at all. This is due to other optimisations kicking in.
1322 Example of what happens on a structural level:
1324 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1326 1: CURLYM[1] {1,32767}(18)
1337 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1338 and should turn into:
1340 1: CURLYM[1] {1,32767}(18)
1342 [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1350 Cases where tail != last would be like /(?foo|bar)baz/:
1360 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1361 and would end up looking like:
1364 [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1371 d = uvuni_to_utf8_flags(d, uv, 0);
1373 is the recommended Unicode-aware way of saying
1378 #define TRIE_STORE_REVCHAR(val) \
1381 SV *zlopp = newSV(7); /* XXX: optimize me */ \
1382 unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \
1383 unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1384 SvCUR_set(zlopp, kapow - flrbbbbb); \
1387 av_push(revcharmap, zlopp); \
1389 char ooooff = (char)val; \
1390 av_push(revcharmap, newSVpvn(&ooooff, 1)); \
1394 #define TRIE_READ_CHAR STMT_START { \
1397 /* if it is UTF then it is either already folded, or does not need folding */ \
1398 uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags); \
1400 else if (folder == PL_fold_latin1) { \
1401 /* if we use this folder we have to obey unicode rules on latin-1 data */ \
1402 if ( foldlen > 0 ) { \
1403 uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags ); \
1409 uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1); \
1410 skiplen = UNISKIP(uvc); \
1411 foldlen -= skiplen; \
1412 scan = foldbuf + skiplen; \
1415 /* raw data, will be folded later if needed */ \
1423 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \
1424 if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \
1425 U32 ging = TRIE_LIST_LEN( state ) *= 2; \
1426 Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1428 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \
1429 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns; \
1430 TRIE_LIST_CUR( state )++; \
1433 #define TRIE_LIST_NEW(state) STMT_START { \
1434 Newxz( trie->states[ state ].trans.list, \
1435 4, reg_trie_trans_le ); \
1436 TRIE_LIST_CUR( state ) = 1; \
1437 TRIE_LIST_LEN( state ) = 4; \
1440 #define TRIE_HANDLE_WORD(state) STMT_START { \
1441 U16 dupe= trie->states[ state ].wordnum; \
1442 regnode * const noper_next = regnext( noper ); \
1445 /* store the word for dumping */ \
1447 if (OP(noper) != NOTHING) \
1448 tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF); \
1450 tmp = newSVpvn_utf8( "", 0, UTF ); \
1451 av_push( trie_words, tmp ); \
1455 trie->wordinfo[curword].prev = 0; \
1456 trie->wordinfo[curword].len = wordlen; \
1457 trie->wordinfo[curword].accept = state; \
1459 if ( noper_next < tail ) { \
1461 trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1462 trie->jump[curword] = (U16)(noper_next - convert); \
1464 jumper = noper_next; \
1466 nextbranch= regnext(cur); \
1470 /* It's a dupe. Pre-insert into the wordinfo[].prev */\
1471 /* chain, so that when the bits of chain are later */\
1472 /* linked together, the dups appear in the chain */\
1473 trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1474 trie->wordinfo[dupe].prev = curword; \
1476 /* we haven't inserted this word yet. */ \
1477 trie->states[ state ].wordnum = curword; \
1482 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special) \
1483 ( ( base + charid >= ucharcount \
1484 && base + charid < ubound \
1485 && state == trie->trans[ base - ucharcount + charid ].check \
1486 && trie->trans[ base - ucharcount + charid ].next ) \
1487 ? trie->trans[ base - ucharcount + charid ].next \
1488 : ( state==1 ? special : 0 ) \
1492 #define MADE_JUMP_TRIE 2
1493 #define MADE_EXACT_TRIE 4
1496 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1499 /* first pass, loop through and scan words */
1500 reg_trie_data *trie;
1501 HV *widecharmap = NULL;
1502 AV *revcharmap = newAV();
1504 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1509 regnode *jumper = NULL;
1510 regnode *nextbranch = NULL;
1511 regnode *convert = NULL;
1512 U32 *prev_states; /* temp array mapping each state to previous one */
1513 /* we just use folder as a flag in utf8 */
1514 const U8 * folder = NULL;
1517 const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1518 AV *trie_words = NULL;
1519 /* along with revcharmap, this only used during construction but both are
1520 * useful during debugging so we store them in the struct when debugging.
1523 const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1524 STRLEN trie_charcount=0;
1526 SV *re_trie_maxbuff;
1527 GET_RE_DEBUG_FLAGS_DECL;
1529 PERL_ARGS_ASSERT_MAKE_TRIE;
1531 PERL_UNUSED_ARG(depth);
1538 case EXACTFU_TRICKYFOLD:
1539 case EXACTFU: folder = PL_fold_latin1; break;
1540 case EXACTF: folder = PL_fold; break;
1541 case EXACTFL: folder = PL_fold_locale; break;
1542 default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1545 trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1547 trie->startstate = 1;
1548 trie->wordcount = word_count;
1549 RExC_rxi->data->data[ data_slot ] = (void*)trie;
1550 trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1552 trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1553 trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1554 trie->wordcount+1, sizeof(reg_trie_wordinfo));
1557 trie_words = newAV();
1560 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1561 if (!SvIOK(re_trie_maxbuff)) {
1562 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1564 DEBUG_TRIE_COMPILE_r({
1565 PerlIO_printf( Perl_debug_log,
1566 "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1567 (int)depth * 2 + 2, "",
1568 REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
1569 REG_NODE_NUM(last), REG_NODE_NUM(tail),
1573 /* Find the node we are going to overwrite */
1574 if ( first == startbranch && OP( last ) != BRANCH ) {
1575 /* whole branch chain */
1578 /* branch sub-chain */
1579 convert = NEXTOPER( first );
1582 /* -- First loop and Setup --
1584 We first traverse the branches and scan each word to determine if it
1585 contains widechars, and how many unique chars there are, this is
1586 important as we have to build a table with at least as many columns as we
1589 We use an array of integers to represent the character codes 0..255
1590 (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1591 native representation of the character value as the key and IV's for the
1594 *TODO* If we keep track of how many times each character is used we can
1595 remap the columns so that the table compression later on is more
1596 efficient in terms of memory by ensuring the most common value is in the
1597 middle and the least common are on the outside. IMO this would be better
1598 than a most to least common mapping as theres a decent chance the most
1599 common letter will share a node with the least common, meaning the node
1600 will not be compressible. With a middle is most common approach the worst
1601 case is when we have the least common nodes twice.
1605 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1606 regnode *noper = NEXTOPER( cur );
1607 const U8 *uc = (U8*)STRING( noper );
1608 const U8 *e = uc + STR_LEN( noper );
1610 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1612 const U8 *scan = (U8*)NULL;
1613 U32 wordlen = 0; /* required init */
1615 bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1617 if (OP(noper) == NOTHING) {
1618 regnode *noper_next= regnext(noper);
1619 if (noper_next != tail && OP(noper_next) == flags) {
1621 uc= (U8*)STRING(noper);
1622 e= uc + STR_LEN(noper);
1623 trie->minlen= STR_LEN(noper);
1630 if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1631 TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1632 regardless of encoding */
1633 if (OP( noper ) == EXACTFU_SS) {
1634 /* false positives are ok, so just set this */
1635 TRIE_BITMAP_SET(trie,0xDF);
1638 for ( ; uc < e ; uc += len ) {
1639 TRIE_CHARCOUNT(trie)++;
1644 U8 folded= folder[ (U8) uvc ];
1645 if ( !trie->charmap[ folded ] ) {
1646 trie->charmap[ folded ]=( ++trie->uniquecharcount );
1647 TRIE_STORE_REVCHAR( folded );
1650 if ( !trie->charmap[ uvc ] ) {
1651 trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1652 TRIE_STORE_REVCHAR( uvc );
1655 /* store the codepoint in the bitmap, and its folded
1657 TRIE_BITMAP_SET(trie, uvc);
1659 /* store the folded codepoint */
1660 if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1663 /* store first byte of utf8 representation of
1664 variant codepoints */
1665 if (! UNI_IS_INVARIANT(uvc)) {
1666 TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1669 set_bit = 0; /* We've done our bit :-) */
1674 widecharmap = newHV();
1676 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1679 Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1681 if ( !SvTRUE( *svpp ) ) {
1682 sv_setiv( *svpp, ++trie->uniquecharcount );
1683 TRIE_STORE_REVCHAR(uvc);
1687 if( cur == first ) {
1688 trie->minlen = chars;
1689 trie->maxlen = chars;
1690 } else if (chars < trie->minlen) {
1691 trie->minlen = chars;
1692 } else if (chars > trie->maxlen) {
1693 trie->maxlen = chars;
1695 if (OP( noper ) == EXACTFU_SS) {
1696 /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1697 if (trie->minlen > 1)
1700 if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1701 /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}"
1702 * - We assume that any such sequence might match a 2 byte string */
1703 if (trie->minlen > 2 )
1707 } /* end first pass */
1708 DEBUG_TRIE_COMPILE_r(
1709 PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1710 (int)depth * 2 + 2,"",
1711 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1712 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1713 (int)trie->minlen, (int)trie->maxlen )
1717 We now know what we are dealing with in terms of unique chars and
1718 string sizes so we can calculate how much memory a naive
1719 representation using a flat table will take. If it's over a reasonable
1720 limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1721 conservative but potentially much slower representation using an array
1724 At the end we convert both representations into the same compressed
1725 form that will be used in regexec.c for matching with. The latter
1726 is a form that cannot be used to construct with but has memory
1727 properties similar to the list form and access properties similar
1728 to the table form making it both suitable for fast searches and
1729 small enough that its feasable to store for the duration of a program.
1731 See the comment in the code where the compressed table is produced
1732 inplace from the flat tabe representation for an explanation of how
1733 the compression works.
1738 Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1741 if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1743 Second Pass -- Array Of Lists Representation
1745 Each state will be represented by a list of charid:state records
1746 (reg_trie_trans_le) the first such element holds the CUR and LEN
1747 points of the allocated array. (See defines above).
1749 We build the initial structure using the lists, and then convert
1750 it into the compressed table form which allows faster lookups
1751 (but cant be modified once converted).
1754 STRLEN transcount = 1;
1756 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1757 "%*sCompiling trie using list compiler\n",
1758 (int)depth * 2 + 2, ""));
1760 trie->states = (reg_trie_state *)
1761 PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1762 sizeof(reg_trie_state) );
1766 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1768 regnode *noper = NEXTOPER( cur );
1769 U8 *uc = (U8*)STRING( noper );
1770 const U8 *e = uc + STR_LEN( noper );
1771 U32 state = 1; /* required init */
1772 U16 charid = 0; /* sanity init */
1773 U8 *scan = (U8*)NULL; /* sanity init */
1774 STRLEN foldlen = 0; /* required init */
1775 U32 wordlen = 0; /* required init */
1776 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1779 if (OP(noper) == NOTHING) {
1780 regnode *noper_next= regnext(noper);
1781 if (noper_next != tail && OP(noper_next) == flags) {
1783 uc= (U8*)STRING(noper);
1784 e= uc + STR_LEN(noper);
1788 if (OP(noper) != NOTHING) {
1789 for ( ; uc < e ; uc += len ) {
1794 charid = trie->charmap[ uvc ];
1796 SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1800 charid=(U16)SvIV( *svpp );
1803 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1810 if ( !trie->states[ state ].trans.list ) {
1811 TRIE_LIST_NEW( state );
1813 for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1814 if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1815 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1820 newstate = next_alloc++;
1821 prev_states[newstate] = state;
1822 TRIE_LIST_PUSH( state, charid, newstate );
1827 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1831 TRIE_HANDLE_WORD(state);
1833 } /* end second pass */
1835 /* next alloc is the NEXT state to be allocated */
1836 trie->statecount = next_alloc;
1837 trie->states = (reg_trie_state *)
1838 PerlMemShared_realloc( trie->states,
1840 * sizeof(reg_trie_state) );
1842 /* and now dump it out before we compress it */
1843 DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1844 revcharmap, next_alloc,
1848 trie->trans = (reg_trie_trans *)
1849 PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1856 for( state=1 ; state < next_alloc ; state ++ ) {
1860 DEBUG_TRIE_COMPILE_MORE_r(
1861 PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1865 if (trie->states[state].trans.list) {
1866 U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1870 for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1871 const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1872 if ( forid < minid ) {
1874 } else if ( forid > maxid ) {
1878 if ( transcount < tp + maxid - minid + 1) {
1880 trie->trans = (reg_trie_trans *)
1881 PerlMemShared_realloc( trie->trans,
1883 * sizeof(reg_trie_trans) );
1884 Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1886 base = trie->uniquecharcount + tp - minid;
1887 if ( maxid == minid ) {
1889 for ( ; zp < tp ; zp++ ) {
1890 if ( ! trie->trans[ zp ].next ) {
1891 base = trie->uniquecharcount + zp - minid;
1892 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1893 trie->trans[ zp ].check = state;
1899 trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1900 trie->trans[ tp ].check = state;
1905 for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1906 const U32 tid = base - trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1907 trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1908 trie->trans[ tid ].check = state;
1910 tp += ( maxid - minid + 1 );
1912 Safefree(trie->states[ state ].trans.list);
1915 DEBUG_TRIE_COMPILE_MORE_r(
1916 PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1919 trie->states[ state ].trans.base=base;
1921 trie->lasttrans = tp + 1;
1925 Second Pass -- Flat Table Representation.
1927 we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1928 We know that we will need Charcount+1 trans at most to store the data
1929 (one row per char at worst case) So we preallocate both structures
1930 assuming worst case.
1932 We then construct the trie using only the .next slots of the entry
1935 We use the .check field of the first entry of the node temporarily to
1936 make compression both faster and easier by keeping track of how many non
1937 zero fields are in the node.
1939 Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1942 There are two terms at use here: state as a TRIE_NODEIDX() which is a
1943 number representing the first entry of the node, and state as a
1944 TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1945 TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1946 are 2 entrys per node. eg:
1954 The table is internally in the right hand, idx form. However as we also
1955 have to deal with the states array which is indexed by nodenum we have to
1956 use TRIE_NODENUM() to convert.
1959 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1960 "%*sCompiling trie using table compiler\n",
1961 (int)depth * 2 + 2, ""));
1963 trie->trans = (reg_trie_trans *)
1964 PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1965 * trie->uniquecharcount + 1,
1966 sizeof(reg_trie_trans) );
1967 trie->states = (reg_trie_state *)
1968 PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1969 sizeof(reg_trie_state) );
1970 next_alloc = trie->uniquecharcount + 1;
1973 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1975 regnode *noper = NEXTOPER( cur );
1976 const U8 *uc = (U8*)STRING( noper );
1977 const U8 *e = uc + STR_LEN( noper );
1979 U32 state = 1; /* required init */
1981 U16 charid = 0; /* sanity init */
1982 U32 accept_state = 0; /* sanity init */
1983 U8 *scan = (U8*)NULL; /* sanity init */
1985 STRLEN foldlen = 0; /* required init */
1986 U32 wordlen = 0; /* required init */
1988 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1990 if (OP(noper) == NOTHING) {
1991 regnode *noper_next= regnext(noper);
1992 if (noper_next != tail && OP(noper_next) == flags) {
1994 uc= (U8*)STRING(noper);
1995 e= uc + STR_LEN(noper);
1999 if ( OP(noper) != NOTHING ) {
2000 for ( ; uc < e ; uc += len ) {
2005 charid = trie->charmap[ uvc ];
2007 SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
2008 charid = svpp ? (U16)SvIV(*svpp) : 0;
2012 if ( !trie->trans[ state + charid ].next ) {
2013 trie->trans[ state + charid ].next = next_alloc;
2014 trie->trans[ state ].check++;
2015 prev_states[TRIE_NODENUM(next_alloc)]
2016 = TRIE_NODENUM(state);
2017 next_alloc += trie->uniquecharcount;
2019 state = trie->trans[ state + charid ].next;
2021 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
2023 /* charid is now 0 if we dont know the char read, or nonzero if we do */
2026 accept_state = TRIE_NODENUM( state );
2027 TRIE_HANDLE_WORD(accept_state);
2029 } /* end second pass */
2031 /* and now dump it out before we compress it */
2032 DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
2034 next_alloc, depth+1));
2038 * Inplace compress the table.*
2040 For sparse data sets the table constructed by the trie algorithm will
2041 be mostly 0/FAIL transitions or to put it another way mostly empty.
2042 (Note that leaf nodes will not contain any transitions.)
2044 This algorithm compresses the tables by eliminating most such
2045 transitions, at the cost of a modest bit of extra work during lookup:
2047 - Each states[] entry contains a .base field which indicates the
2048 index in the state[] array wheres its transition data is stored.
2050 - If .base is 0 there are no valid transitions from that node.
2052 - If .base is nonzero then charid is added to it to find an entry in
2055 -If trans[states[state].base+charid].check!=state then the
2056 transition is taken to be a 0/Fail transition. Thus if there are fail
2057 transitions at the front of the node then the .base offset will point
2058 somewhere inside the previous nodes data (or maybe even into a node
2059 even earlier), but the .check field determines if the transition is
2063 The following process inplace converts the table to the compressed
2064 table: We first do not compress the root node 1,and mark all its
2065 .check pointers as 1 and set its .base pointer as 1 as well. This
2066 allows us to do a DFA construction from the compressed table later,
2067 and ensures that any .base pointers we calculate later are greater
2070 - We set 'pos' to indicate the first entry of the second node.
2072 - We then iterate over the columns of the node, finding the first and
2073 last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2074 and set the .check pointers accordingly, and advance pos
2075 appropriately and repreat for the next node. Note that when we copy
2076 the next pointers we have to convert them from the original
2077 NODEIDX form to NODENUM form as the former is not valid post
2080 - If a node has no transitions used we mark its base as 0 and do not
2081 advance the pos pointer.
2083 - If a node only has one transition we use a second pointer into the
2084 structure to fill in allocated fail transitions from other states.
2085 This pointer is independent of the main pointer and scans forward
2086 looking for null transitions that are allocated to a state. When it
2087 finds one it writes the single transition into the "hole". If the
2088 pointer doesnt find one the single transition is appended as normal.
2090 - Once compressed we can Renew/realloc the structures to release the
2093 See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2094 specifically Fig 3.47 and the associated pseudocode.
2098 const U32 laststate = TRIE_NODENUM( next_alloc );
2101 trie->statecount = laststate;
2103 for ( state = 1 ; state < laststate ; state++ ) {
2105 const U32 stateidx = TRIE_NODEIDX( state );
2106 const U32 o_used = trie->trans[ stateidx ].check;
2107 U32 used = trie->trans[ stateidx ].check;
2108 trie->trans[ stateidx ].check = 0;
2110 for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2111 if ( flag || trie->trans[ stateidx + charid ].next ) {
2112 if ( trie->trans[ stateidx + charid ].next ) {
2114 for ( ; zp < pos ; zp++ ) {
2115 if ( ! trie->trans[ zp ].next ) {
2119 trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2120 trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2121 trie->trans[ zp ].check = state;
2122 if ( ++zp > pos ) pos = zp;
2129 trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2131 trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2132 trie->trans[ pos ].check = state;
2137 trie->lasttrans = pos + 1;
2138 trie->states = (reg_trie_state *)
2139 PerlMemShared_realloc( trie->states, laststate
2140 * sizeof(reg_trie_state) );
2141 DEBUG_TRIE_COMPILE_MORE_r(
2142 PerlIO_printf( Perl_debug_log,
2143 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2144 (int)depth * 2 + 2,"",
2145 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2148 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2151 } /* end table compress */
2153 DEBUG_TRIE_COMPILE_MORE_r(
2154 PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2155 (int)depth * 2 + 2, "",
2156 (UV)trie->statecount,
2157 (UV)trie->lasttrans)
2159 /* resize the trans array to remove unused space */
2160 trie->trans = (reg_trie_trans *)
2161 PerlMemShared_realloc( trie->trans, trie->lasttrans
2162 * sizeof(reg_trie_trans) );
2164 { /* Modify the program and insert the new TRIE node */
2165 U8 nodetype =(U8)(flags & 0xFF);
2169 regnode *optimize = NULL;
2170 #ifdef RE_TRACK_PATTERN_OFFSETS
2173 U32 mjd_nodelen = 0;
2174 #endif /* RE_TRACK_PATTERN_OFFSETS */
2175 #endif /* DEBUGGING */
2177 This means we convert either the first branch or the first Exact,
2178 depending on whether the thing following (in 'last') is a branch
2179 or not and whther first is the startbranch (ie is it a sub part of
2180 the alternation or is it the whole thing.)
2181 Assuming its a sub part we convert the EXACT otherwise we convert
2182 the whole branch sequence, including the first.
2184 /* Find the node we are going to overwrite */
2185 if ( first != startbranch || OP( last ) == BRANCH ) {
2186 /* branch sub-chain */
2187 NEXT_OFF( first ) = (U16)(last - first);
2188 #ifdef RE_TRACK_PATTERN_OFFSETS
2190 mjd_offset= Node_Offset((convert));
2191 mjd_nodelen= Node_Length((convert));
2194 /* whole branch chain */
2196 #ifdef RE_TRACK_PATTERN_OFFSETS
2199 const regnode *nop = NEXTOPER( convert );
2200 mjd_offset= Node_Offset((nop));
2201 mjd_nodelen= Node_Length((nop));
2205 PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2206 (int)depth * 2 + 2, "",
2207 (UV)mjd_offset, (UV)mjd_nodelen)
2210 /* But first we check to see if there is a common prefix we can
2211 split out as an EXACT and put in front of the TRIE node. */
2212 trie->startstate= 1;
2213 if ( trie->bitmap && !widecharmap && !trie->jump ) {
2215 for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2219 const U32 base = trie->states[ state ].trans.base;
2221 if ( trie->states[state].wordnum )
2224 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2225 if ( ( base + ofs >= trie->uniquecharcount ) &&
2226 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2227 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2229 if ( ++count > 1 ) {
2230 SV **tmp = av_fetch( revcharmap, ofs, 0);
2231 const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2232 if ( state == 1 ) break;
2234 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2236 PerlIO_printf(Perl_debug_log,
2237 "%*sNew Start State=%"UVuf" Class: [",
2238 (int)depth * 2 + 2, "",
2241 SV ** const tmp = av_fetch( revcharmap, idx, 0);
2242 const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2244 TRIE_BITMAP_SET(trie,*ch);
2246 TRIE_BITMAP_SET(trie, folder[ *ch ]);
2248 PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2252 TRIE_BITMAP_SET(trie,*ch);
2254 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2255 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2261 SV **tmp = av_fetch( revcharmap, idx, 0);
2263 char *ch = SvPV( *tmp, len );
2265 SV *sv=sv_newmortal();
2266 PerlIO_printf( Perl_debug_log,
2267 "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2268 (int)depth * 2 + 2, "",
2270 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
2271 PL_colors[0], PL_colors[1],
2272 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2273 PERL_PV_ESCAPE_FIRSTCHAR
2278 OP( convert ) = nodetype;
2279 str=STRING(convert);
2282 STR_LEN(convert) += len;
2288 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2293 trie->prefixlen = (state-1);
2295 regnode *n = convert+NODE_SZ_STR(convert);
2296 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2297 trie->startstate = state;
2298 trie->minlen -= (state - 1);
2299 trie->maxlen -= (state - 1);
2301 /* At least the UNICOS C compiler choked on this
2302 * being argument to DEBUG_r(), so let's just have
2305 #ifdef PERL_EXT_RE_BUILD
2311 regnode *fix = convert;
2312 U32 word = trie->wordcount;
2314 Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2315 while( ++fix < n ) {
2316 Set_Node_Offset_Length(fix, 0, 0);
2319 SV ** const tmp = av_fetch( trie_words, word, 0 );
2321 if ( STR_LEN(convert) <= SvCUR(*tmp) )
2322 sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2324 sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2332 NEXT_OFF(convert) = (U16)(tail - convert);
2333 DEBUG_r(optimize= n);
2339 if ( trie->maxlen ) {
2340 NEXT_OFF( convert ) = (U16)(tail - convert);
2341 ARG_SET( convert, data_slot );
2342 /* Store the offset to the first unabsorbed branch in
2343 jump[0], which is otherwise unused by the jump logic.
2344 We use this when dumping a trie and during optimisation. */
2346 trie->jump[0] = (U16)(nextbranch - convert);
2348 /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2349 * and there is a bitmap
2350 * and the first "jump target" node we found leaves enough room
2351 * then convert the TRIE node into a TRIEC node, with the bitmap
2352 * embedded inline in the opcode - this is hypothetically faster.
2354 if ( !trie->states[trie->startstate].wordnum
2356 && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2358 OP( convert ) = TRIEC;
2359 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2360 PerlMemShared_free(trie->bitmap);
2363 OP( convert ) = TRIE;
2365 /* store the type in the flags */
2366 convert->flags = nodetype;
2370 + regarglen[ OP( convert ) ];
2372 /* XXX We really should free up the resource in trie now,
2373 as we won't use them - (which resources?) dmq */
2375 /* needed for dumping*/
2376 DEBUG_r(if (optimize) {
2377 regnode *opt = convert;
2379 while ( ++opt < optimize) {
2380 Set_Node_Offset_Length(opt,0,0);
2383 Try to clean up some of the debris left after the
2386 while( optimize < jumper ) {
2387 mjd_nodelen += Node_Length((optimize));
2388 OP( optimize ) = OPTIMIZED;
2389 Set_Node_Offset_Length(optimize,0,0);
2392 Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2394 } /* end node insert */
2396 /* Finish populating the prev field of the wordinfo array. Walk back
2397 * from each accept state until we find another accept state, and if
2398 * so, point the first word's .prev field at the second word. If the
2399 * second already has a .prev field set, stop now. This will be the
2400 * case either if we've already processed that word's accept state,
2401 * or that state had multiple words, and the overspill words were
2402 * already linked up earlier.
2409 for (word=1; word <= trie->wordcount; word++) {
2411 if (trie->wordinfo[word].prev)
2413 state = trie->wordinfo[word].accept;
2415 state = prev_states[state];
2418 prev = trie->states[state].wordnum;
2422 trie->wordinfo[word].prev = prev;
2424 Safefree(prev_states);
2428 /* and now dump out the compressed format */
2429 DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2431 RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2433 RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2434 RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2436 SvREFCNT_dec(revcharmap);
2440 : trie->startstate>1
2446 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
2448 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2450 This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2451 "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2454 We find the fail state for each state in the trie, this state is the longest proper
2455 suffix of the current state's 'word' that is also a proper prefix of another word in our
2456 trie. State 1 represents the word '' and is thus the default fail state. This allows
2457 the DFA not to have to restart after its tried and failed a word at a given point, it
2458 simply continues as though it had been matching the other word in the first place.
2460 'abcdgu'=~/abcdefg|cdgu/
2461 When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2462 fail, which would bring us to the state representing 'd' in the second word where we would
2463 try 'g' and succeed, proceeding to match 'cdgu'.
2465 /* add a fail transition */
2466 const U32 trie_offset = ARG(source);
2467 reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2469 const U32 ucharcount = trie->uniquecharcount;
2470 const U32 numstates = trie->statecount;
2471 const U32 ubound = trie->lasttrans + ucharcount;
2475 U32 base = trie->states[ 1 ].trans.base;
2478 const U32 data_slot = add_data( pRExC_state, 1, "T" );
2479 GET_RE_DEBUG_FLAGS_DECL;
2481 PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2483 PERL_UNUSED_ARG(depth);
2487 ARG_SET( stclass, data_slot );
2488 aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2489 RExC_rxi->data->data[ data_slot ] = (void*)aho;
2490 aho->trie=trie_offset;
2491 aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2492 Copy( trie->states, aho->states, numstates, reg_trie_state );
2493 Newxz( q, numstates, U32);
2494 aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2497 /* initialize fail[0..1] to be 1 so that we always have
2498 a valid final fail state */
2499 fail[ 0 ] = fail[ 1 ] = 1;
2501 for ( charid = 0; charid < ucharcount ; charid++ ) {
2502 const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2504 q[ q_write ] = newstate;
2505 /* set to point at the root */
2506 fail[ q[ q_write++ ] ]=1;
2509 while ( q_read < q_write) {
2510 const U32 cur = q[ q_read++ % numstates ];
2511 base = trie->states[ cur ].trans.base;
2513 for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2514 const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2516 U32 fail_state = cur;
2519 fail_state = fail[ fail_state ];
2520 fail_base = aho->states[ fail_state ].trans.base;
2521 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2523 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2524 fail[ ch_state ] = fail_state;
2525 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2527 aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
2529 q[ q_write++ % numstates] = ch_state;
2533 /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2534 when we fail in state 1, this allows us to use the
2535 charclass scan to find a valid start char. This is based on the principle
2536 that theres a good chance the string being searched contains lots of stuff
2537 that cant be a start char.
2539 fail[ 0 ] = fail[ 1 ] = 0;
2540 DEBUG_TRIE_COMPILE_r({
2541 PerlIO_printf(Perl_debug_log,
2542 "%*sStclass Failtable (%"UVuf" states): 0",
2543 (int)(depth * 2), "", (UV)numstates
2545 for( q_read=1; q_read<numstates; q_read++ ) {
2546 PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2548 PerlIO_printf(Perl_debug_log, "\n");
2551 /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2556 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2557 * These need to be revisited when a newer toolchain becomes available.
2559 #if defined(__sparc64__) && defined(__GNUC__)
2560 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2561 # undef SPARC64_GCC_WORKAROUND
2562 # define SPARC64_GCC_WORKAROUND 1
2566 #define DEBUG_PEEP(str,scan,depth) \
2567 DEBUG_OPTIMISE_r({if (scan){ \
2568 SV * const mysv=sv_newmortal(); \
2569 regnode *Next = regnext(scan); \
2570 regprop(RExC_rx, mysv, scan); \
2571 PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2572 (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2573 Next ? (REG_NODE_NUM(Next)) : 0 ); \
2577 /* The below joins as many adjacent EXACTish nodes as possible into a single
2578 * one, and looks for problematic sequences of characters whose folds vs.
2579 * non-folds have sufficiently different lengths, that the optimizer would be
2580 * fooled into rejecting legitimate matches of them, and the trie construction
2581 * code can't cope with them. The joining is only done if:
2582 * 1) there is room in the current conglomerated node to entirely contain the
2584 * 2) they are the exact same node type
2586 * The adjacent nodes actually may be separated by NOTHING kind nodes, and
2587 * these get optimized out
2589 * If there are problematic code sequences, *min_subtract is set to the delta
2590 * that the minimum size of the node can be less than its actual size. And,
2591 * the node type of the result is changed to reflect that it contains these
2594 * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2595 * and contains LATIN SMALL LETTER SHARP S
2597 * This is as good a place as any to discuss the design of handling these
2598 * problematic sequences. It's been wrong in Perl for a very long time. There
2599 * are three code points in Unicode whose folded lengths differ so much from
2600 * the un-folded lengths that it causes problems for the optimizer and trie
2601 * construction. Why only these are problematic, and not others where lengths
2602 * also differ is something I (khw) do not understand. New versions of Unicode
2603 * might add more such code points. Hopefully the logic in fold_grind.t that
2604 * figures out what to test (in part by verifying that each size-combination
2605 * gets tested) will catch any that do come along, so they can be added to the
2606 * special handling below. The chances of new ones are actually rather small,
2607 * as most, if not all, of the world's scripts that have casefolding have
2608 * already been encoded by Unicode. Also, a number of Unicode's decisions were
2609 * made to allow compatibility with pre-existing standards, and almost all of
2610 * those have already been dealt with. These would otherwise be the most
2611 * likely candidates for generating further tricky sequences. In other words,
2612 * Unicode by itself is unlikely to add new ones unless it is for compatibility
2613 * with pre-existing standards, and there aren't many of those left.
2615 * The previous designs for dealing with these involved assigning a special
2616 * node for them. This approach doesn't work, as evidenced by this example:
2617 * "\xDFs" =~ /s\xDF/ui # Used to fail before these patches
2618 * Both these fold to "sss", but if the pattern is parsed to create a node of
2619 * that would match just the \xDF, it won't be able to handle the case where a
2620 * successful match would have to cross the node's boundary. The new approach
2621 * that hopefully generally solves the problem generates an EXACTFU_SS node
2624 * There are a number of components to the approach (a lot of work for just
2625 * three code points!):
2626 * 1) This routine examines each EXACTFish node that could contain the
2627 * problematic sequences. It returns in *min_subtract how much to
2628 * subtract from the the actual length of the string to get a real minimum
2629 * for one that could match it. This number is usually 0 except for the
2630 * problematic sequences. This delta is used by the caller to adjust the
2631 * min length of the match, and the delta between min and max, so that the
2632 * optimizer doesn't reject these possibilities based on size constraints.
2633 * 2) These sequences are not currently correctly handled by the trie code
2634 * either, so it changes the joined node type to ops that are not handled
2635 * by trie's, those new ops being EXACTFU_SS and EXACTFU_TRICKYFOLD.
2636 * 3) This is sufficient for the two Greek sequences (described below), but
2637 * the one involving the Sharp s (\xDF) needs more. The node type
2638 * EXACTFU_SS is used for an EXACTFU node that contains at least one "ss"
2639 * sequence in it. For non-UTF-8 patterns and strings, this is the only
2640 * case where there is a possible fold length change. That means that a
2641 * regular EXACTFU node without UTF-8 involvement doesn't have to concern
2642 * itself with length changes, and so can be processed faster. regexec.c
2643 * takes advantage of this. Generally, an EXACTFish node that is in UTF-8
2644 * is pre-folded by regcomp.c. This saves effort in regex matching.
2645 * However, probably mostly for historical reasons, the pre-folding isn't
2646 * done for non-UTF8 patterns (and it can't be for EXACTF and EXACTFL
2647 * nodes, as what they fold to isn't known until runtime.) The fold
2648 * possibilities for the non-UTF8 patterns are quite simple, except for
2649 * the sharp s. All the ones that don't involve a UTF-8 target string
2650 * are members of a fold-pair, and arrays are set up for all of them
2651 * that quickly find the other member of the pair. It might actually
2652 * be faster to pre-fold these, but it isn't currently done, except for
2653 * the sharp s. Code elsewhere in this file makes sure that it gets
2654 * folded to 'ss', even if the pattern isn't UTF-8. This avoids the
2655 * issues described in the next item.
2656 * 4) A problem remains for the sharp s in EXACTF nodes. Whether it matches
2657 * 'ss' or not is not knowable at compile time. It will match iff the
2658 * target string is in UTF-8, unlike the EXACTFU nodes, where it always
2659 * matches; and the EXACTFL and EXACTFA nodes where it never does. Thus
2660 * it can't be folded to "ss" at compile time, unlike EXACTFU does as
2661 * described in item 3). An assumption that the optimizer part of
2662 * regexec.c (probably unwittingly) makes is that a character in the
2663 * pattern corresponds to at most a single character in the target string.
2664 * (And I do mean character, and not byte here, unlike other parts of the
2665 * documentation that have never been updated to account for multibyte
2666 * Unicode.) This assumption is wrong only in this case, as all other
2667 * cases are either 1-1 folds when no UTF-8 is involved; or is true by
2668 * virtue of having this file pre-fold UTF-8 patterns. I'm
2669 * reluctant to try to change this assumption, so instead the code punts.
2670 * This routine examines EXACTF nodes for the sharp s, and returns a
2671 * boolean indicating whether or not the node is an EXACTF node that
2672 * contains a sharp s. When it is true, the caller sets a flag that later
2673 * causes the optimizer in this file to not set values for the floating
2674 * and fixed string lengths, and thus avoids the optimizer code in
2675 * regexec.c that makes the invalid assumption. Thus, there is no
2676 * optimization based on string lengths for EXACTF nodes that contain the
2677 * sharp s. This only happens for /id rules (which means the pattern
2681 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2682 if (PL_regkind[OP(scan)] == EXACT) \
2683 join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2686 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) {
2687 /* Merge several consecutive EXACTish nodes into one. */
2688 regnode *n = regnext(scan);
2690 regnode *next = scan + NODE_SZ_STR(scan);
2694 regnode *stop = scan;
2695 GET_RE_DEBUG_FLAGS_DECL;
2697 PERL_UNUSED_ARG(depth);
2700 PERL_ARGS_ASSERT_JOIN_EXACT;
2701 #ifndef EXPERIMENTAL_INPLACESCAN
2702 PERL_UNUSED_ARG(flags);
2703 PERL_UNUSED_ARG(val);
2705 DEBUG_PEEP("join",scan,depth);
2707 /* Look through the subsequent nodes in the chain. Skip NOTHING, merge
2708 * EXACT ones that are mergeable to the current one. */
2710 && (PL_regkind[OP(n)] == NOTHING
2711 || (stringok && OP(n) == OP(scan)))
2713 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2716 if (OP(n) == TAIL || n > next)
2718 if (PL_regkind[OP(n)] == NOTHING) {
2719 DEBUG_PEEP("skip:",n,depth);
2720 NEXT_OFF(scan) += NEXT_OFF(n);
2721 next = n + NODE_STEP_REGNODE;
2728 else if (stringok) {
2729 const unsigned int oldl = STR_LEN(scan);
2730 regnode * const nnext = regnext(n);
2732 if (oldl + STR_LEN(n) > U8_MAX)
2735 DEBUG_PEEP("merg",n,depth);
2738 NEXT_OFF(scan) += NEXT_OFF(n);
2739 STR_LEN(scan) += STR_LEN(n);
2740 next = n + NODE_SZ_STR(n);
2741 /* Now we can overwrite *n : */
2742 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2750 #ifdef EXPERIMENTAL_INPLACESCAN
2751 if (flags && !NEXT_OFF(n)) {
2752 DEBUG_PEEP("atch", val, depth);
2753 if (reg_off_by_arg[OP(n)]) {
2754 ARG_SET(n, val - n);
2757 NEXT_OFF(n) = val - n;
2765 *has_exactf_sharp_s = FALSE;
2767 /* Here, all the adjacent mergeable EXACTish nodes have been merged. We
2768 * can now analyze for sequences of problematic code points. (Prior to
2769 * this final joining, sequences could have been split over boundaries, and
2770 * hence missed). The sequences only happen in folding, hence for any
2771 * non-EXACT EXACTish node */
2772 if (OP(scan) != EXACT) {
2774 U8 * s0 = (U8*) STRING(scan);
2775 U8 * const s_end = s0 + STR_LEN(scan);
2777 /* The below is perhaps overboard, but this allows us to save a test
2778 * each time through the loop at the expense of a mask. This is
2779 * because on both EBCDIC and ASCII machines, 'S' and 's' differ by a
2780 * single bit. On ASCII they are 32 apart; on EBCDIC, they are 64.
2781 * This uses an exclusive 'or' to find that bit and then inverts it to
2782 * form a mask, with just a single 0, in the bit position where 'S' and
2784 const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2785 const U8 s_masked = 's' & S_or_s_mask;
2787 /* One pass is made over the node's string looking for all the
2788 * possibilities. to avoid some tests in the loop, there are two main
2789 * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2793 /* There are two problematic Greek code points in Unicode
2796 * U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2797 * U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2803 * U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
2804 * U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
2806 * This means that in case-insensitive matching (or "loose
2807 * matching", as Unicode calls it), an EXACTF of length six (the
2808 * UTF-8 encoded byte length of the above casefolded versions) can
2809 * match a target string of length two (the byte length of UTF-8
2810 * encoded U+0390 or U+03B0). This would rather mess up the
2811 * minimum length computation. (there are other code points that
2812 * also fold to these two sequences, but the delta is smaller)
2814 * If these sequences are found, the minimum length is decreased by
2815 * four (six minus two).
2817 * Similarly, 'ss' may match the single char and byte LATIN SMALL
2818 * LETTER SHARP S. We decrease the min length by 1 for each
2819 * occurrence of 'ss' found */
2821 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2822 # define U390_first_byte 0xb4
2823 const U8 U390_tail[] = "\x68\xaf\x49\xaf\x42";
2824 # define U3B0_first_byte 0xb5
2825 const U8 U3B0_tail[] = "\x46\xaf\x49\xaf\x42";
2827 # define U390_first_byte 0xce
2828 const U8 U390_tail[] = "\xb9\xcc\x88\xcc\x81";
2829 # define U3B0_first_byte 0xcf
2830 const U8 U3B0_tail[] = "\x85\xcc\x88\xcc\x81";
2832 const U8 len = sizeof(U390_tail); /* (-1 for NUL; +1 for 1st byte;
2833 yields a net of 0 */
2834 /* Examine the string for one of the problematic sequences */
2836 s < s_end - 1; /* Can stop 1 before the end, as minimum length
2837 * sequence we are looking for is 2 */
2841 /* Look for the first byte in each problematic sequence */
2843 /* We don't have to worry about other things that fold to
2844 * 's' (such as the long s, U+017F), as all above-latin1
2845 * code points have been pre-folded */
2849 /* Current character is an 's' or 'S'. If next one is
2850 * as well, we have the dreaded sequence */
2851 if (((*(s+1) & S_or_s_mask) == s_masked)
2852 /* These two node types don't have special handling
2854 && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2857 OP(scan) = EXACTFU_SS;
2858 s++; /* No need to look at this character again */
2862 case U390_first_byte:
2863 if (s_end - s >= len
2865 /* The 1's are because are skipping comparing the
2867 && memEQ(s + 1, U390_tail, len - 1))
2869 goto greek_sequence;
2873 case U3B0_first_byte:
2874 if (! (s_end - s >= len
2875 && memEQ(s + 1, U3B0_tail, len - 1)))
2882 /* This can't currently be handled by trie's, so change
2883 * the node type to indicate this. If EXACTFA and
2884 * EXACTFL were ever to be handled by trie's, this
2885 * would have to be changed. If this node has already
2886 * been changed to EXACTFU_SS in this loop, leave it as
2887 * is. (I (khw) think it doesn't matter in regexec.c
2888 * for UTF patterns, but no need to change it */
2889 if (OP(scan) == EXACTFU) {
2890 OP(scan) = EXACTFU_TRICKYFOLD;
2892 s += 6; /* We already know what this sequence is. Skip
2898 else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2900 /* Here, the pattern is not UTF-8. We need to look only for the
2901 * 'ss' sequence, and in the EXACTF case, the sharp s, which can be
2902 * in the final position. Otherwise we can stop looking 1 byte
2903 * earlier because have to find both the first and second 's' */
2904 const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2906 for (s = s0; s < upper; s++) {
2911 && ((*(s+1) & S_or_s_mask) == s_masked))
2915 /* EXACTF nodes need to know that the minimum
2916 * length changed so that a sharp s in the string
2917 * can match this ss in the pattern, but they
2918 * remain EXACTF nodes, as they are not trie'able,
2919 * so don't have to invent a new node type to
2920 * exclude them from the trie code */
2921 if (OP(scan) != EXACTF) {
2922 OP(scan) = EXACTFU_SS;
2927 case LATIN_SMALL_LETTER_SHARP_S:
2928 if (OP(scan) == EXACTF) {
2929 *has_exactf_sharp_s = TRUE;
2938 /* Allow dumping but overwriting the collection of skipped
2939 * ops and/or strings with fake optimized ops */
2940 n = scan + NODE_SZ_STR(scan);
2948 DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2952 /* REx optimizer. Converts nodes into quicker variants "in place".
2953 Finds fixed substrings. */
2955 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2956 to the position after last scanned or to NULL. */
2958 #define INIT_AND_WITHP \
2959 assert(!and_withp); \
2960 Newx(and_withp,1,struct regnode_charclass_class); \
2961 SAVEFREEPV(and_withp)
2963 /* this is a chain of data about sub patterns we are processing that
2964 need to be handled separately/specially in study_chunk. Its so
2965 we can simulate recursion without losing state. */
2967 typedef struct scan_frame {
2968 regnode *last; /* last node to process in this frame */
2969 regnode *next; /* next node to process when last is reached */
2970 struct scan_frame *prev; /*previous frame*/
2971 I32 stop; /* what stopparen do we use */
2975 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2977 #define CASE_SYNST_FNC(nAmE) \
2979 if (flags & SCF_DO_STCLASS_AND) { \
2980 for (value = 0; value < 256; value++) \
2981 if (!is_ ## nAmE ## _cp(value)) \
2982 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2985 for (value = 0; value < 256; value++) \
2986 if (is_ ## nAmE ## _cp(value)) \
2987 ANYOF_BITMAP_SET(data->start_class, value); \
2991 if (flags & SCF_DO_STCLASS_AND) { \
2992 for (value = 0; value < 256; value++) \
2993 if (is_ ## nAmE ## _cp(value)) \
2994 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2997 for (value = 0; value < 256; value++) \
2998 if (!is_ ## nAmE ## _cp(value)) \
2999 ANYOF_BITMAP_SET(data->start_class, value); \
3006 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
3007 I32 *minlenp, I32 *deltap,
3012 struct regnode_charclass_class *and_withp,
3013 U32 flags, U32 depth)
3014 /* scanp: Start here (read-write). */
3015 /* deltap: Write maxlen-minlen here. */
3016 /* last: Stop before this one. */
3017 /* data: string data about the pattern */
3018 /* stopparen: treat close N as END */
3019 /* recursed: which subroutines have we recursed into */
3020 /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
3023 I32 min = 0, pars = 0, code;
3024 regnode *scan = *scanp, *next;
3026 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
3027 int is_inf_internal = 0; /* The studied chunk is infinite */
3028 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
3029 scan_data_t data_fake;
3030 SV *re_trie_maxbuff = NULL;
3031 regnode *first_non_open = scan;
3032 I32 stopmin = I32_MAX;
3033 scan_frame *frame = NULL;
3034 GET_RE_DEBUG_FLAGS_DECL;
3036 PERL_ARGS_ASSERT_STUDY_CHUNK;
3039 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3043 while (first_non_open && OP(first_non_open) == OPEN)
3044 first_non_open=regnext(first_non_open);
3049 while ( scan && OP(scan) != END && scan < last ){
3050 UV min_subtract = 0; /* How much to subtract from the minimum node
3051 length to get a real minimum (because the
3052 folded version may be shorter) */
3053 bool has_exactf_sharp_s = FALSE;
3054 /* Peephole optimizer: */
3055 DEBUG_STUDYDATA("Peep:", data,depth);
3056 DEBUG_PEEP("Peep",scan,depth);
3058 /* Its not clear to khw or hv why this is done here, and not in the
3059 * clauses that deal with EXACT nodes. khw's guess is that it's
3060 * because of a previous design */
3061 JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3063 /* Follow the next-chain of the current node and optimize
3064 away all the NOTHINGs from it. */
3065 if (OP(scan) != CURLYX) {
3066 const int max = (reg_off_by_arg[OP(scan)]
3068 /* I32 may be smaller than U16 on CRAYs! */
3069 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3070 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3074 /* Skip NOTHING and LONGJMP. */
3075 while ((n = regnext(n))
3076 && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3077 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3078 && off + noff < max)
3080 if (reg_off_by_arg[OP(scan)])
3083 NEXT_OFF(scan) = off;
3088 /* The principal pseudo-switch. Cannot be a switch, since we
3089 look into several different things. */
3090 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3091 || OP(scan) == IFTHEN) {
3092 next = regnext(scan);
3094 /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3096 if (OP(next) == code || code == IFTHEN) {
3097 /* NOTE - There is similar code to this block below for handling
3098 TRIE nodes on a re-study. If you change stuff here check there
3100 I32 max1 = 0, min1 = I32_MAX, num = 0;
3101 struct regnode_charclass_class accum;
3102 regnode * const startbranch=scan;
3104 if (flags & SCF_DO_SUBSTR)
3105 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3106 if (flags & SCF_DO_STCLASS)
3107 cl_init_zero(pRExC_state, &accum);
3109 while (OP(scan) == code) {
3110 I32 deltanext, minnext, f = 0, fake;
3111 struct regnode_charclass_class this_class;
3114 data_fake.flags = 0;
3116 data_fake.whilem_c = data->whilem_c;
3117 data_fake.last_closep = data->last_closep;
3120 data_fake.last_closep = &fake;
3122 data_fake.pos_delta = delta;
3123 next = regnext(scan);
3124 scan = NEXTOPER(scan);
3126 scan = NEXTOPER(scan);
3127 if (flags & SCF_DO_STCLASS) {
3128 cl_init(pRExC_state, &this_class);
3129 data_fake.start_class = &this_class;
3130 f = SCF_DO_STCLASS_AND;
3132 if (flags & SCF_WHILEM_VISITED_POS)
3133 f |= SCF_WHILEM_VISITED_POS;
3135 /* we suppose the run is continuous, last=next...*/
3136 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3138 stopparen, recursed, NULL, f,depth+1);
3141 if (max1 < minnext + deltanext)
3142 max1 = minnext + deltanext;
3143 if (deltanext == I32_MAX)
3144 is_inf = is_inf_internal = 1;
3146 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3148 if (data_fake.flags & SCF_SEEN_ACCEPT) {
3149 if ( stopmin > minnext)
3150 stopmin = min + min1;
3151 flags &= ~SCF_DO_SUBSTR;
3153 data->flags |= SCF_SEEN_ACCEPT;
3156 if (data_fake.flags & SF_HAS_EVAL)
3157 data->flags |= SF_HAS_EVAL;
3158 data->whilem_c = data_fake.whilem_c;
3160 if (flags & SCF_DO_STCLASS)
3161 cl_or(pRExC_state, &accum, &this_class);
3163 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3165 if (flags & SCF_DO_SUBSTR) {
3166 data->pos_min += min1;
3167 data->pos_delta += max1 - min1;
3168 if (max1 != min1 || is_inf)
3169 data->longest = &(data->longest_float);
3172 delta += max1 - min1;
3173 if (flags & SCF_DO_STCLASS_OR) {
3174 cl_or(pRExC_state, data->start_class, &accum);
3176 cl_and(data->start_class, and_withp);
3177 flags &= ~SCF_DO_STCLASS;
3180 else if (flags & SCF_DO_STCLASS_AND) {
3182 cl_and(data->start_class, &accum);
3183 flags &= ~SCF_DO_STCLASS;
3186 /* Switch to OR mode: cache the old value of
3187 * data->start_class */
3189 StructCopy(data->start_class, and_withp,
3190 struct regnode_charclass_class);
3191 flags &= ~SCF_DO_STCLASS_AND;
3192 StructCopy(&accum, data->start_class,
3193 struct regnode_charclass_class);
3194 flags |= SCF_DO_STCLASS_OR;
3195 data->start_class->flags |= ANYOF_EOS;
3199 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3202 Assuming this was/is a branch we are dealing with: 'scan' now
3203 points at the item that follows the branch sequence, whatever
3204 it is. We now start at the beginning of the sequence and look
3211 which would be constructed from a pattern like /A|LIST|OF|WORDS/
3213 If we can find such a subsequence we need to turn the first
3214 element into a trie and then add the subsequent branch exact
3215 strings to the trie.
3219 1. patterns where the whole set of branches can be converted.
3221 2. patterns where only a subset can be converted.
3223 In case 1 we can replace the whole set with a single regop
3224 for the trie. In case 2 we need to keep the start and end
3227 'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3228 becomes BRANCH TRIE; BRANCH X;
3230 There is an additional case, that being where there is a
3231 common prefix, which gets split out into an EXACT like node
3232 preceding the TRIE node.
3234 If x(1..n)==tail then we can do a simple trie, if not we make
3235 a "jump" trie, such that when we match the appropriate word
3236 we "jump" to the appropriate tail node. Essentially we turn
3237 a nested if into a case structure of sorts.
3242 if (!re_trie_maxbuff) {
3243 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3244 if (!SvIOK(re_trie_maxbuff))
3245 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3247 if ( SvIV(re_trie_maxbuff)>=0 ) {
3249 regnode *first = (regnode *)NULL;
3250 regnode *last = (regnode *)NULL;
3251 regnode *tail = scan;
3256 SV * const mysv = sv_newmortal(); /* for dumping */
3258 /* var tail is used because there may be a TAIL
3259 regop in the way. Ie, the exacts will point to the
3260 thing following the TAIL, but the last branch will
3261 point at the TAIL. So we advance tail. If we
3262 have nested (?:) we may have to move through several
3266 while ( OP( tail ) == TAIL ) {
3267 /* this is the TAIL generated by (?:) */
3268 tail = regnext( tail );
3272 DEBUG_TRIE_COMPILE_r({
3273 regprop(RExC_rx, mysv, tail );
3274 PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3275 (int)depth * 2 + 2, "",
3276 "Looking for TRIE'able sequences. Tail node is: ",
3277 SvPV_nolen_const( mysv )
3283 Step through the branches
3284 cur represents each branch,
3285 noper is the first thing to be matched as part of that branch
3286 noper_next is the regnext() of that node.
3288 We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3289 via a "jump trie" but we also support building with NOJUMPTRIE,
3290 which restricts the trie logic to structures like /FOO|BAR/.
3292 If noper is a trieable nodetype then the branch is a possible optimization
3293 target. If we are building under NOJUMPTRIE then we require that noper_next
3294 is the same as scan (our current position in the regex program).
3296 Once we have two or more consecutive such branches we can create a
3297 trie of the EXACT's contents and stitch it in place into the program.
3299 If the sequence represents all of the branches in the alternation we
3300 replace the entire thing with a single TRIE node.
3302 Otherwise when it is a subsequence we need to stitch it in place and
3303 replace only the relevant branches. This means the first branch has
3304 to remain as it is used by the alternation logic, and its next pointer,
3305 and needs to be repointed at the item on the branch chain following
3306 the last branch we have optimized away.
3308 This could be either a BRANCH, in which case the subsequence is internal,
3309 or it could be the item following the branch sequence in which case the
3310 subsequence is at the end (which does not necessarily mean the first node
3311 is the start of the alternation).
3313 TRIE_TYPE(X) is a define which maps the optype to a trietype.
3316 ----------------+-----------
3320 EXACTFU_SS | EXACTFU
3321 EXACTFU_TRICKYFOLD | EXACTFU
3326 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING : \
3327 ( EXACT == (X) ) ? EXACT : \
3328 ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU : \
3331 /* dont use tail as the end marker for this traverse */
3332 for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3333 regnode * const noper = NEXTOPER( cur );
3334 U8 noper_type = OP( noper );
3335 U8 noper_trietype = TRIE_TYPE( noper_type );
3336 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3337 regnode * const noper_next = regnext( noper );
3338 U8 noper_next_type = (noper_next && noper_next != tail) ? OP(noper_next) : 0;
3339 U8 noper_next_trietype = (noper_next && noper_next != tail) ? TRIE_TYPE( noper_next_type ) :0;
3342 DEBUG_TRIE_COMPILE_r({
3343 regprop(RExC_rx, mysv, cur);
3344 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3345 (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3347 regprop(RExC_rx, mysv, noper);
3348 PerlIO_printf( Perl_debug_log, " -> %s",
3349 SvPV_nolen_const(mysv));
3352 regprop(RExC_rx, mysv, noper_next );
3353 PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3354 SvPV_nolen_const(mysv));
3356 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d,tt==%s,nt==%s,nnt==%s)\n",
3357 REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur),
3358 PL_reg_name[trietype], PL_reg_name[noper_trietype], PL_reg_name[noper_next_trietype]
3362 /* Is noper a trieable nodetype that can be merged with the
3363 * current trie (if there is one)? */
3367 ( noper_trietype == NOTHING)
3368 || ( trietype == NOTHING )
3369 || ( trietype == noper_trietype )
3372 && noper_next == tail
3376 /* Handle mergable triable node
3377 * Either we are the first node in a new trieable sequence,
3378 * in which case we do some bookkeeping, otherwise we update
3379 * the end pointer. */
3382 trietype = noper_trietype;
3383 if ( noper_trietype == NOTHING ) {
3384 #if !defined(DEBUGGING) && !defined(NOJUMPTRIE)
3385 regnode * const noper_next = regnext( noper );
3386 U8 noper_next_type = (noper_next && noper_next!=tail) ? OP(noper_next) : 0;
3387 U8 noper_next_trietype = noper_next_type ? TRIE_TYPE( noper_next_type ) :0;
3390 if ( noper_next_trietype )
3391 trietype = noper_next_trietype;
3394 if ( trietype == NOTHING )
3395 trietype = noper_trietype;
3400 } /* end handle mergable triable node */
3402 /* handle unmergable node -
3403 * noper may either be a triable node which can not be tried
3404 * together with the current trie, or a non triable node */
3406 /* If last is set and trietype is not NOTHING then we have found
3407 * at least two triable branch sequences in a row of a similar
3408 * trietype so we can turn them into a trie. If/when we
3409 * allow NOTHING to start a trie sequence this condition will be
3410 * required, and it isn't expensive so we leave it in for now. */
3411 if ( trietype != NOTHING )
3412 make_trie( pRExC_state,
3413 startbranch, first, cur, tail, count,
3414 trietype, depth+1 );
3415 last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3419 && noper_next == tail
3422 /* noper is triable, so we can start a new trie sequence */
3425 trietype = noper_trietype;
3427 /* if we already saw a first but the current node is not triable then we have
3428 * to reset the first information. */
3433 } /* end handle unmergable node */
3434 } /* loop over branches */
3435 DEBUG_TRIE_COMPILE_r({
3436 regprop(RExC_rx, mysv, cur);
3437 PerlIO_printf( Perl_debug_log,
3438 "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3439 "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3443 if ( trietype != NOTHING ) {
3444 /* the last branch of the sequence was part of a trie,
3445 * so we have to construct it here outside of the loop
3447 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3448 #ifdef TRIE_STUDY_OPT
3449 if ( ((made == MADE_EXACT_TRIE &&
3450 startbranch == first)
3451 || ( first_non_open == first )) &&
3453 flags |= SCF_TRIE_RESTUDY;
3454 if ( startbranch == first
3457 RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3462 /* at this point we know whatever we have is a NOTHING sequence/branch
3463 * AND if 'startbranch' is 'first' then we can turn the whole thing into a NOTHING
3465 if ( startbranch == first ) {
3467 /* the entire thing is a NOTHING sequence, something like this:
3468 * (?:|) So we can turn it into a plain NOTHING op. */
3469 DEBUG_TRIE_COMPILE_r({
3470 regprop(RExC_rx, mysv, cur);
3471 PerlIO_printf( Perl_debug_log,
3472 "%*s- %s (%d) <NOTHING BRANCH SEQUENCE>\n", (int)depth * 2 + 2,
3473 "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3476 OP(startbranch)= NOTHING;
3477 NEXT_OFF(startbranch)= tail - startbranch;
3478 for ( opt= startbranch + 1; opt < tail ; opt++ )
3482 } /* end if ( last) */
3483 } /* TRIE_MAXBUF is non zero */
3488 else if ( code == BRANCHJ ) { /* single branch is optimized. */
3489 scan = NEXTOPER(NEXTOPER(scan));
3490 } else /* single branch is optimized. */
3491 scan = NEXTOPER(scan);
3493 } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3494 scan_frame *newframe = NULL;
3499 if (OP(scan) != SUSPEND) {
3500 /* set the pointer */
3501 if (OP(scan) == GOSUB) {
3503 RExC_recurse[ARG2L(scan)] = scan;
3504 start = RExC_open_parens[paren-1];
3505 end = RExC_close_parens[paren-1];
3508 start = RExC_rxi->program + 1;
3512 Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3513 SAVEFREEPV(recursed);
3515 if (!PAREN_TEST(recursed,paren+1)) {
3516 PAREN_SET(recursed,paren+1);
3517 Newx(newframe,1,scan_frame);
3519 if (flags & SCF_DO_SUBSTR) {
3520 SCAN_COMMIT(pRExC_state,data,minlenp);
3521 data->longest = &(data->longest_float);
3523 is_inf = is_inf_internal = 1;
3524 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3525 cl_anything(pRExC_state, data->start_class);
3526 flags &= ~SCF_DO_STCLASS;
3529 Newx(newframe,1,scan_frame);
3532 end = regnext(scan);
3537 SAVEFREEPV(newframe);
3538 newframe->next = regnext(scan);
3539 newframe->last = last;
3540 newframe->stop = stopparen;
3541 newframe->prev = frame;
3551 else if (OP(scan) == EXACT) {
3552 I32 l = STR_LEN(scan);
3555 const U8 * const s = (U8*)STRING(scan);
3556 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3557 l = utf8_length(s, s + l);
3559 uc = *((U8*)STRING(scan));
3562 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3563 /* The code below prefers earlier match for fixed
3564 offset, later match for variable offset. */
3565 if (data->last_end == -1) { /* Update the start info. */
3566 data->last_start_min = data->pos_min;
3567 data->last_start_max = is_inf
3568 ? I32_MAX : data->pos_min + data->pos_delta;
3570 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3572 SvUTF8_on(data->last_found);
3574 SV * const sv = data->last_found;
3575 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3576 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3577 if (mg && mg->mg_len >= 0)
3578 mg->mg_len += utf8_length((U8*)STRING(scan),
3579 (U8*)STRING(scan)+STR_LEN(scan));
3581 data->last_end = data->pos_min + l;
3582 data->pos_min += l; /* As in the first entry. */
3583 data->flags &= ~SF_BEFORE_EOL;
3585 if (flags & SCF_DO_STCLASS_AND) {
3586 /* Check whether it is compatible with what we know already! */
3590 /* If compatible, we or it in below. It is compatible if is
3591 * in the bitmp and either 1) its bit or its fold is set, or 2)
3592 * it's for a locale. Even if there isn't unicode semantics
3593 * here, at runtime there may be because of matching against a
3594 * utf8 string, so accept a possible false positive for
3595 * latin1-range folds */
3597 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3598 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3599 && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3600 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3605 ANYOF_CLASS_ZERO(data->start_class);
3606 ANYOF_BITMAP_ZERO(data->start_class);
3608 ANYOF_BITMAP_SET(data->start_class, uc);
3609 else if (uc >= 0x100) {
3612 /* Some Unicode code points fold to the Latin1 range; as
3613 * XXX temporary code, instead of figuring out if this is
3614 * one, just assume it is and set all the start class bits
3615 * that could be some such above 255 code point's fold
3616 * which will generate fals positives. As the code
3617 * elsewhere that does compute the fold settles down, it
3618 * can be extracted out and re-used here */
3619 for (i = 0; i < 256; i++){
3620 if (HAS_NONLATIN1_FOLD_CLOSURE(i)) {
3621 ANYOF_BITMAP_SET(data->start_class, i);
3625 data->start_class->flags &= ~ANYOF_EOS;
3627 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3629 else if (flags & SCF_DO_STCLASS_OR) {
3630 /* false positive possible if the class is case-folded */
3632 ANYOF_BITMAP_SET(data->start_class, uc);
3634 data->start_class->flags |= ANYOF_UNICODE_ALL;
3635 data->start_class->flags &= ~ANYOF_EOS;
3636 cl_and(data->start_class, and_withp);
3638 flags &= ~SCF_DO_STCLASS;
3640 else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3641 I32 l = STR_LEN(scan);
3642 UV uc = *((U8*)STRING(scan));
3644 /* Search for fixed substrings supports EXACT only. */
3645 if (flags & SCF_DO_SUBSTR) {
3647 SCAN_COMMIT(pRExC_state, data, minlenp);
3650 const U8 * const s = (U8 *)STRING(scan);
3651 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3652 l = utf8_length(s, s + l);
3654 else if (has_exactf_sharp_s) {
3655 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3657 min += l - min_subtract;
3661 delta += min_subtract;
3662 if (flags & SCF_DO_SUBSTR) {
3663 data->pos_min += l - min_subtract;
3664 if (data->pos_min < 0) {
3667 data->pos_delta += min_subtract;
3669 data->longest = &(data->longest_float);
3672 if (flags & SCF_DO_STCLASS_AND) {
3673 /* Check whether it is compatible with what we know already! */
3676 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3677 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3678 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3682 ANYOF_CLASS_ZERO(data->start_class);
3683 ANYOF_BITMAP_ZERO(data->start_class);
3685 ANYOF_BITMAP_SET(data->start_class, uc);
3686 data->start_class->flags &= ~ANYOF_EOS;
3687 data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3688 if (OP(scan) == EXACTFL) {
3689 /* XXX This set is probably no longer necessary, and
3690 * probably wrong as LOCALE now is on in the initial
3692 data->start_class->flags |= ANYOF_LOCALE;
3696 /* Also set the other member of the fold pair. In case
3697 * that unicode semantics is called for at runtime, use
3698 * the full latin1 fold. (Can't do this for locale,
3699 * because not known until runtime) */
3700 ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3702 /* All other (EXACTFL handled above) folds except under
3703 * /iaa that include s, S, and sharp_s also may include
3705 if (OP(scan) != EXACTFA) {
3706 if (uc == 's' || uc == 'S') {
3707 ANYOF_BITMAP_SET(data->start_class,
3708 LATIN_SMALL_LETTER_SHARP_S);
3710 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3711 ANYOF_BITMAP_SET(data->start_class, 's');
3712 ANYOF_BITMAP_SET(data->start_class, 'S');
3717 else if (uc >= 0x100) {
3719 for (i = 0; i < 256; i++){
3720 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3721 ANYOF_BITMAP_SET(data->start_class, i);
3726 else if (flags & SCF_DO_STCLASS_OR) {
3727 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3728 /* false positive possible if the class is case-folded.
3729 Assume that the locale settings are the same... */
3731 ANYOF_BITMAP_SET(data->start_class, uc);
3732 if (OP(scan) != EXACTFL) {
3734 /* And set the other member of the fold pair, but
3735 * can't do that in locale because not known until
3737 ANYOF_BITMAP_SET(data->start_class,
3738 PL_fold_latin1[uc]);
3740 /* All folds except under /iaa that include s, S,
3741 * and sharp_s also may include the others */
3742 if (OP(scan) != EXACTFA) {
3743 if (uc == 's' || uc == 'S') {
3744 ANYOF_BITMAP_SET(data->start_class,
3745 LATIN_SMALL_LETTER_SHARP_S);
3747 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3748 ANYOF_BITMAP_SET(data->start_class, 's');
3749 ANYOF_BITMAP_SET(data->start_class, 'S');
3754 data->start_class->flags &= ~ANYOF_EOS;
3756 cl_and(data->start_class, and_withp);
3758 flags &= ~SCF_DO_STCLASS;
3760 else if (REGNODE_VARIES(OP(scan))) {
3761 I32 mincount, maxcount, minnext, deltanext, fl = 0;
3762 I32 f = flags, pos_before = 0;
3763 regnode * const oscan = scan;
3764 struct regnode_charclass_class this_class;
3765 struct regnode_charclass_class *oclass = NULL;
3766 I32 next_is_eval = 0;
3768 switch (PL_regkind[OP(scan)]) {
3769 case WHILEM: /* End of (?:...)* . */
3770 scan = NEXTOPER(scan);
3773 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3774 next = NEXTOPER(scan);
3775 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3777 maxcount = REG_INFTY;
3778 next = regnext(scan);
3779 scan = NEXTOPER(scan);
3783 if (flags & SCF_DO_SUBSTR)
3788 if (flags & SCF_DO_STCLASS) {
3790 maxcount = REG_INFTY;
3791 next = regnext(scan);
3792 scan = NEXTOPER(scan);
3795 is_inf = is_inf_internal = 1;
3796 scan = regnext(scan);
3797 if (flags & SCF_DO_SUBSTR) {
3798 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3799 data->longest = &(data->longest_float);
3801 goto optimize_curly_tail;
3803 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3804 && (scan->flags == stopparen))
3809 mincount = ARG1(scan);
3810 maxcount = ARG2(scan);
3812 next = regnext(scan);
3813 if (OP(scan) == CURLYX) {
3814 I32 lp = (data ? *(data->last_closep) : 0);
3815 scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3817 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3818 next_is_eval = (OP(scan) == EVAL);
3820 if (flags & SCF_DO_SUBSTR) {
3821 if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3822 pos_before = data->pos_min;
3826 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3828 data->flags |= SF_IS_INF;
3830 if (flags & SCF_DO_STCLASS) {
3831 cl_init(pRExC_state, &this_class);
3832 oclass = data->start_class;
3833 data->start_class = &this_class;
3834 f |= SCF_DO_STCLASS_AND;
3835 f &= ~SCF_DO_STCLASS_OR;
3837 /* Exclude from super-linear cache processing any {n,m}
3838 regops for which the combination of input pos and regex
3839 pos is not enough information to determine if a match
3842 For example, in the regex /foo(bar\s*){4,8}baz/ with the
3843 regex pos at the \s*, the prospects for a match depend not
3844 only on the input position but also on how many (bar\s*)
3845 repeats into the {4,8} we are. */
3846 if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3847 f &= ~SCF_WHILEM_VISITED_POS;
3849 /* This will finish on WHILEM, setting scan, or on NULL: */
3850 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3851 last, data, stopparen, recursed, NULL,
3853 ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3855 if (flags & SCF_DO_STCLASS)
3856 data->start_class = oclass;
3857 if (mincount == 0 || minnext == 0) {
3858 if (flags & SCF_DO_STCLASS_OR) {
3859 cl_or(pRExC_state, data->start_class, &this_class);
3861 else if (flags & SCF_DO_STCLASS_AND) {
3862 /* Switch to OR mode: cache the old value of
3863 * data->start_class */
3865 StructCopy(data->start_class, and_withp,
3866 struct regnode_charclass_class);
3867 flags &= ~SCF_DO_STCLASS_AND;
3868 StructCopy(&this_class, data->start_class,
3869 struct regnode_charclass_class);
3870 flags |= SCF_DO_STCLASS_OR;
3871 data->start_class->flags |= ANYOF_EOS;
3873 } else { /* Non-zero len */
3874 if (flags & SCF_DO_STCLASS_OR) {
3875 cl_or(pRExC_state, data->start_class, &this_class);
3876 cl_and(data->start_class, and_withp);
3878 else if (flags & SCF_DO_STCLASS_AND)
3879 cl_and(data->start_class, &this_class);
3880 flags &= ~SCF_DO_STCLASS;
3882 if (!scan) /* It was not CURLYX, but CURLY. */
3884 if ( /* ? quantifier ok, except for (?{ ... }) */
3885 (next_is_eval || !(mincount == 0 && maxcount == 1))
3886 && (minnext == 0) && (deltanext == 0)
3887 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3888 && maxcount <= REG_INFTY/3) /* Complement check for big count */
3890 ckWARNreg(RExC_parse,
3891 "Quantifier unexpected on zero-length expression");
3894 min += minnext * mincount;
3895 is_inf_internal |= ((maxcount == REG_INFTY
3896 && (minnext + deltanext) > 0)
3897 || deltanext == I32_MAX);
3898 is_inf |= is_inf_internal;
3899 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3901 /* Try powerful optimization CURLYX => CURLYN. */
3902 if ( OP(oscan) == CURLYX && data
3903 && data->flags & SF_IN_PAR
3904 && !(data->flags & SF_HAS_EVAL)
3905 && !deltanext && minnext == 1 ) {
3906 /* Try to optimize to CURLYN. */
3907 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3908 regnode * const nxt1 = nxt;
3915 if (!REGNODE_SIMPLE(OP(nxt))
3916 && !(PL_regkind[OP(nxt)] == EXACT
3917 && STR_LEN(nxt) == 1))
3923 if (OP(nxt) != CLOSE)
3925 if (RExC_open_parens) {
3926 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3927 RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3929 /* Now we know that nxt2 is the only contents: */
3930 oscan->flags = (U8)ARG(nxt);
3932 OP(nxt1) = NOTHING; /* was OPEN. */
3935 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3936 NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3937 NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3938 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3939 OP(nxt + 1) = OPTIMIZED; /* was count. */
3940 NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3945 /* Try optimization CURLYX => CURLYM. */
3946 if ( OP(oscan) == CURLYX && data
3947 && !(data->flags & SF_HAS_PAR)
3948 && !(data->flags & SF_HAS_EVAL)
3949 && !deltanext /* atom is fixed width */
3950 && minnext != 0 /* CURLYM can't handle zero width */
3952 /* XXXX How to optimize if data == 0? */
3953 /* Optimize to a simpler form. */
3954 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3958 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3959 && (OP(nxt2) != WHILEM))
3961 OP(nxt2) = SUCCEED; /* Whas WHILEM */
3962 /* Need to optimize away parenths. */
3963 if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3964 /* Set the parenth number. */
3965 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3967 oscan->flags = (U8)ARG(nxt);
3968 if (RExC_open_parens) {
3969 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3970 RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3972 OP(nxt1) = OPTIMIZED; /* was OPEN. */
3973 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3976 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3977 OP(nxt + 1) = OPTIMIZED; /* was count. */
3978 NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3979 NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3982 while ( nxt1 && (OP(nxt1) != WHILEM)) {
3983 regnode *nnxt = regnext(nxt1);
3985 if (reg_off_by_arg[OP(nxt1)])
3986 ARG_SET(nxt1, nxt2 - nxt1);
3987 else if (nxt2 - nxt1 < U16_MAX)
3988 NEXT_OFF(nxt1) = nxt2 - nxt1;
3990 OP(nxt) = NOTHING; /* Cannot beautify */
3995 /* Optimize again: */
3996 study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3997 NULL, stopparen, recursed, NULL, 0,depth+1);
4002 else if ((OP(oscan) == CURLYX)
4003 && (flags & SCF_WHILEM_VISITED_POS)
4004 /* See the comment on a similar expression above.
4005 However, this time it's not a subexpression
4006 we care about, but the expression itself. */
4007 && (maxcount == REG_INFTY)
4008 && data && ++data->whilem_c < 16) {
4009 /* This stays as CURLYX, we can put the count/of pair. */
4010 /* Find WHILEM (as in regexec.c) */
4011 regnode *nxt = oscan + NEXT_OFF(oscan);
4013 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
4015 PREVOPER(nxt)->flags = (U8)(data->whilem_c
4016 | (RExC_whilem_seen << 4)); /* On WHILEM */
4018 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
4020 if (flags & SCF_DO_SUBSTR) {
4021 SV *last_str = NULL;
4022 int counted = mincount != 0;
4024 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
4025 #if defined(SPARC64_GCC_WORKAROUND)
4028 const char *s = NULL;
4031 if (pos_before >= data->last_start_min)
4034 b = data->last_start_min;
4037 s = SvPV_const(data->last_found, l);
4038 old = b - data->last_start_min;
4041 I32 b = pos_before >= data->last_start_min
4042 ? pos_before : data->last_start_min;
4044 const char * const s = SvPV_const(data->last_found, l);
4045 I32 old = b - data->last_start_min;
4049 old = utf8_hop((U8*)s, old) - (U8*)s;
4051 /* Get the added string: */
4052 last_str = newSVpvn_utf8(s + old, l, UTF);
4053 if (deltanext == 0 && pos_before == b) {
4054 /* What was added is a constant string */
4056 SvGROW(last_str, (mincount * l) + 1);
4057 repeatcpy(SvPVX(last_str) + l,
4058 SvPVX_const(last_str), l, mincount - 1);
4059 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4060 /* Add additional parts. */
4061 SvCUR_set(data->last_found,
4062 SvCUR(data->last_found) - l);
4063 sv_catsv(data->last_found, last_str);
4065 SV * sv = data->last_found;
4067 SvUTF8(sv) && SvMAGICAL(sv) ?
4068 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4069 if (mg && mg->mg_len >= 0)
4070 mg->mg_len += CHR_SVLEN(last_str) - l;
4072 data->last_end += l * (mincount - 1);
4075 /* start offset must point into the last copy */
4076 data->last_start_min += minnext * (mincount - 1);
4077 data->last_start_max += is_inf ? I32_MAX
4078 : (maxcount - 1) * (minnext + data->pos_delta);
4081 /* It is counted once already... */
4082 data->pos_min += minnext * (mincount - counted);
4083 data->pos_delta += - counted * deltanext +
4084 (minnext + deltanext) * maxcount - minnext * mincount;
4085 if (mincount != maxcount) {
4086 /* Cannot extend fixed substrings found inside
4088 SCAN_COMMIT(pRExC_state,data,minlenp);
4089 if (mincount && last_str) {
4090 SV * const sv = data->last_found;
4091 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4092 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4096 sv_setsv(sv, last_str);
4097 data->last_end = data->pos_min;
4098 data->last_start_min =
4099 data->pos_min - CHR_SVLEN(last_str);
4100 data->last_start_max = is_inf
4102 : data->pos_min + data->pos_delta
4103 - CHR_SVLEN(last_str);
4105 data->longest = &(data->longest_float);
4107 SvREFCNT_dec(last_str);
4109 if (data && (fl & SF_HAS_EVAL))
4110 data->flags |= SF_HAS_EVAL;
4111 optimize_curly_tail:
4112 if (OP(oscan) != CURLYX) {
4113 while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4115 NEXT_OFF(oscan) += NEXT_OFF(next);
4118 default: /* REF, ANYOFV, and CLUMP only? */
4119 if (flags & SCF_DO_SUBSTR) {
4120 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4121 data->longest = &(data->longest_float);
4123 is_inf = is_inf_internal = 1;
4124 if (flags & SCF_DO_STCLASS_OR)
4125 cl_anything(pRExC_state, data->start_class);
4126 flags &= ~SCF_DO_STCLASS;
4130 else if (OP(scan) == LNBREAK) {
4131 if (flags & SCF_DO_STCLASS) {
4133 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4134 if (flags & SCF_DO_STCLASS_AND) {
4135 for (value = 0; value < 256; value++)
4136 if (!is_VERTWS_cp(value))
4137 ANYOF_BITMAP_CLEAR(data->start_class, value);
4140 for (value = 0; value < 256; value++)
4141 if (is_VERTWS_cp(value))
4142 ANYOF_BITMAP_SET(data->start_class, value);
4144 if (flags & SCF_DO_STCLASS_OR)
4145 cl_and(data->start_class, and_withp);
4146 flags &= ~SCF_DO_STCLASS;
4150 if (flags & SCF_DO_SUBSTR) {
4151 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4153 data->pos_delta += 1;
4154 data->longest = &(data->longest_float);
4157 else if (REGNODE_SIMPLE(OP(scan))) {
4160 if (flags & SCF_DO_SUBSTR) {
4161 SCAN_COMMIT(pRExC_state,data,minlenp);
4165 if (flags & SCF_DO_STCLASS) {
4166 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4168 /* Some of the logic below assumes that switching
4169 locale on will only add false positives. */
4170 switch (PL_regkind[OP(scan)]) {
4174 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
4175 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4176 cl_anything(pRExC_state, data->start_class);
4179 if (OP(scan) == SANY)
4181 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4182 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4183 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4184 cl_anything(pRExC_state, data->start_class);
4186 if (flags & SCF_DO_STCLASS_AND || !value)
4187 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4190 if (flags & SCF_DO_STCLASS_AND)
4191 cl_and(data->start_class,
4192 (struct regnode_charclass_class*)scan);
4194 cl_or(pRExC_state, data->start_class,
4195 (struct regnode_charclass_class*)scan);
4198 if (flags & SCF_DO_STCLASS_AND) {
4199 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4200 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
4201 if (OP(scan) == ALNUMU) {
4202 for (value = 0; value < 256; value++) {
4203 if (!isWORDCHAR_L1(value)) {
4204 ANYOF_BITMAP_CLEAR(data->start_class, value);
4208 for (value = 0; value < 256; value++) {
4209 if (!isALNUM(value)) {
4210 ANYOF_BITMAP_CLEAR(data->start_class, value);
4217 if (data->start_class->flags & ANYOF_LOCALE)
4218 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
4220 /* Even if under locale, set the bits for non-locale
4221 * in case it isn't a true locale-node. This will
4222 * create false positives if it truly is locale */
4223 if (OP(scan) == ALNUMU) {
4224 for (value = 0; value < 256; value++) {
4225 if (isWORDCHAR_L1(value)) {
4226 ANYOF_BITMAP_SET(data->start_class, value);
4230 for (value = 0; value < 256; value++) {
4231 if (isALNUM(value)) {
4232 ANYOF_BITMAP_SET(data->start_class, value);
4239 if (flags & SCF_DO_STCLASS_AND) {
4240 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4241 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
4242 if (OP(scan) == NALNUMU) {
4243 for (value = 0; value < 256; value++) {
4244 if (isWORDCHAR_L1(value)) {
4245 ANYOF_BITMAP_CLEAR(data->start_class, value);
4249 for (value = 0; value < 256; value++) {
4250 if (isALNUM(value)) {
4251 ANYOF_BITMAP_CLEAR(data->start_class, value);
4258 if (data->start_class->flags & ANYOF_LOCALE)
4259 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
4261 /* Even if under locale, set the bits for non-locale in
4262 * case it isn't a true locale-node. This will create
4263 * false positives if it truly is locale */
4264 if (OP(scan) == NALNUMU) {
4265 for (value = 0; value < 256; value++) {
4266 if (! isWORDCHAR_L1(value)) {
4267 ANYOF_BITMAP_SET(data->start_class, value);
4271 for (value = 0; value < 256; value++) {
4272 if (! isALNUM(value)) {
4273 ANYOF_BITMAP_SET(data->start_class, value);
4280 if (flags & SCF_DO_STCLASS_AND) {
4281 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4282 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
4283 if (OP(scan) == SPACEU) {
4284 for (value = 0; value < 256; value++) {
4285 if (!isSPACE_L1(value)) {
4286 ANYOF_BITMAP_CLEAR(data->start_class, value);
4290 for (value = 0; value < 256; value++) {
4291 if (!isSPACE(value)) {
4292 ANYOF_BITMAP_CLEAR(data->start_class, value);
4299 if (data->start_class->flags & ANYOF_LOCALE) {
4300 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
4302 if (OP(scan) == SPACEU) {
4303 for (value = 0; value < 256; value++) {
4304 if (isSPACE_L1(value)) {
4305 ANYOF_BITMAP_SET(data->start_class, value);
4309 for (value = 0; value < 256; value++) {
4310 if (isSPACE(value)) {
4311 ANYOF_BITMAP_SET(data->start_class, value);
4318 if (flags & SCF_DO_STCLASS_AND) {
4319 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4320 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
4321 if (OP(scan) == NSPACEU) {
4322 for (value = 0; value < 256; value++) {
4323 if (isSPACE_L1(value)) {
4324 ANYOF_BITMAP_CLEAR(data->start_class, value);
4328 for (value = 0; value < 256; value++) {
4329 if (isSPACE(value)) {
4330 ANYOF_BITMAP_CLEAR(data->start_class, value);
4337 if (data->start_class->flags & ANYOF_LOCALE)
4338 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
4339 if (OP(scan) == NSPACEU) {
4340 for (value = 0; value < 256; value++) {
4341 if (!isSPACE_L1(value)) {
4342 ANYOF_BITMAP_SET(data->start_class, value);
4347 for (value = 0; value < 256; value++) {
4348 if (!isSPACE(value)) {
4349 ANYOF_BITMAP_SET(data->start_class, value);
4356 if (flags & SCF_DO_STCLASS_AND) {
4357 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4358 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
4359 for (value = 0; value < 256; value++)
4360 if (!isDIGIT(value))
4361 ANYOF_BITMAP_CLEAR(data->start_class, value);
4365 if (data->start_class->flags & ANYOF_LOCALE)
4366 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
4367 for (value = 0; value < 256; value++)
4369 ANYOF_BITMAP_SET(data->start_class, value);
4373 if (flags & SCF_DO_STCLASS_AND) {
4374 if (!(data->start_class->flags & ANYOF_LOCALE))
4375 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
4376 for (value = 0; value < 256; value++)
4378 ANYOF_BITMAP_CLEAR(data->start_class, value);
4381 if (data->start_class->flags & ANYOF_LOCALE)
4382 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
4383 for (value = 0; value < 256; value++)
4384 if (!isDIGIT(value))
4385 ANYOF_BITMAP_SET(data->start_class, value);
4388 CASE_SYNST_FNC(VERTWS);
4389 CASE_SYNST_FNC(HORIZWS);
4392 if (flags & SCF_DO_STCLASS_OR)
4393 cl_and(data->start_class, and_withp);
4394 flags &= ~SCF_DO_STCLASS;
4397 else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4398 data->flags |= (OP(scan) == MEOL
4402 else if ( PL_regkind[OP(scan)] == BRANCHJ
4403 /* Lookbehind, or need to calculate parens/evals/stclass: */
4404 && (scan->flags || data || (flags & SCF_DO_STCLASS))
4405 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4406 if ( OP(scan) == UNLESSM &&
4408 OP(NEXTOPER(NEXTOPER(scan))) == NOTHING &&
4409 OP(regnext(NEXTOPER(NEXTOPER(scan)))) == SUCCEED
4412 regnode *upto= regnext(scan);
4414 SV * const mysv_val=sv_newmortal();
4415 DEBUG_STUDYDATA("OPFAIL",data,depth);
4417 /*DEBUG_PARSE_MSG("opfail");*/
4418 regprop(RExC_rx, mysv_val, upto);
4419 PerlIO_printf(Perl_debug_log, "~ replace with OPFAIL pointed at %s (%"IVdf") offset %"IVdf"\n",
4420 SvPV_nolen_const(mysv_val),
4421 (IV)REG_NODE_NUM(upto),
4426 NEXT_OFF(scan) = upto - scan;
4427 for (opt= scan + 1; opt < upto ; opt++)
4428 OP(opt) = OPTIMIZED;
4432 if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4433 || OP(scan) == UNLESSM )
4435 /* Negative Lookahead/lookbehind
4436 In this case we can't do fixed string optimisation.
4439 I32 deltanext, minnext, fake = 0;
4441 struct regnode_charclass_class intrnl;
4444 data_fake.flags = 0;
4446 data_fake.whilem_c = data->whilem_c;
4447 data_fake.last_closep = data->last_closep;
4450 data_fake.last_closep = &fake;
4451 data_fake.pos_delta = delta;
4452 if ( flags & SCF_DO_STCLASS && !scan->flags
4453 && OP(scan) == IFMATCH ) { /* Lookahead */
4454 cl_init(pRExC_state, &intrnl);
4455 data_fake.start_class = &intrnl;
4456 f |= SCF_DO_STCLASS_AND;
4458 if (flags & SCF_WHILEM_VISITED_POS)
4459 f |= SCF_WHILEM_VISITED_POS;
4460 next = regnext(scan);
4461 nscan = NEXTOPER(NEXTOPER(scan));
4462 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
4463 last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4466 FAIL("Variable length lookbehind not implemented");
4468 else if (minnext > (I32)U8_MAX) {
4469 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4471 scan->flags = (U8)minnext;
4474 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4476 if (data_fake.flags & SF_HAS_EVAL)
4477 data->flags |= SF_HAS_EVAL;
4478 data->whilem_c = data_fake.whilem_c;
4480 if (f & SCF_DO_STCLASS_AND) {
4481 if (flags & SCF_DO_STCLASS_OR) {
4482 /* OR before, AND after: ideally we would recurse with
4483 * data_fake to get the AND applied by study of the
4484 * remainder of the pattern, and then derecurse;
4485 * *** HACK *** for now just treat as "no information".
4486 * See [perl #56690].
4488 cl_init(pRExC_state, data->start_class);
4490 /* AND before and after: combine and continue */
4491 const int was = (data->start_class->flags & ANYOF_EOS);
4493 cl_and(data->start_class, &intrnl);
4495 data->start_class->flags |= ANYOF_EOS;
4499 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4501 /* Positive Lookahead/lookbehind
4502 In this case we can do fixed string optimisation,
4503 but we must be careful about it. Note in the case of
4504 lookbehind the positions will be offset by the minimum
4505 length of the pattern, something we won't know about
4506 until after the recurse.
4508 I32 deltanext, fake = 0;
4510 struct regnode_charclass_class intrnl;
4512 /* We use SAVEFREEPV so that when the full compile
4513 is finished perl will clean up the allocated
4514 minlens when it's all done. This way we don't
4515 have to worry about freeing them when we know
4516 they wont be used, which would be a pain.
4519 Newx( minnextp, 1, I32 );
4520 SAVEFREEPV(minnextp);
4523 StructCopy(data, &data_fake, scan_data_t);
4524 if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4527 SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4528 data_fake.last_found=newSVsv(data->last_found);
4532 data_fake.last_closep = &fake;
4533 data_fake.flags = 0;
4534 data_fake.pos_delta = delta;
4536 data_fake.flags |= SF_IS_INF;
4537 if ( flags & SCF_DO_STCLASS && !scan->flags
4538 && OP(scan) == IFMATCH ) { /* Lookahead */
4539 cl_init(pRExC_state, &intrnl);
4540 data_fake.start_class = &intrnl;
4541 f |= SCF_DO_STCLASS_AND;
4543 if (flags & SCF_WHILEM_VISITED_POS)
4544 f |= SCF_WHILEM_VISITED_POS;
4545 next = regnext(scan);
4546 nscan = NEXTOPER(NEXTOPER(scan));
4548 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext,
4549 last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4552 FAIL("Variable length lookbehind not implemented");
4554 else if (*minnextp > (I32)U8_MAX) {
4555 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4557 scan->flags = (U8)*minnextp;
4562 if (f & SCF_DO_STCLASS_AND) {
4563 const int was = (data->start_class->flags & ANYOF_EOS);
4565 cl_and(data->start_class, &intrnl);
4567 data->start_class->flags |= ANYOF_EOS;
4570 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4572 if (data_fake.flags & SF_HAS_EVAL)
4573 data->flags |= SF_HAS_EVAL;
4574 data->whilem_c = data_fake.whilem_c;
4575 if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4576 if (RExC_rx->minlen<*minnextp)
4577 RExC_rx->minlen=*minnextp;
4578 SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4579 SvREFCNT_dec(data_fake.last_found);
4581 if ( data_fake.minlen_fixed != minlenp )
4583 data->offset_fixed= data_fake.offset_fixed;
4584 data->minlen_fixed= data_fake.minlen_fixed;
4585 data->lookbehind_fixed+= scan->flags;
4587 if ( data_fake.minlen_float != minlenp )
4589 data->minlen_float= data_fake.minlen_float;
4590 data->offset_float_min=data_fake.offset_float_min;
4591 data->offset_float_max=data_fake.offset_float_max;
4592 data->lookbehind_float+= scan->flags;
4599 else if (OP(scan) == OPEN) {
4600 if (stopparen != (I32)ARG(scan))
4603 else if (OP(scan) == CLOSE) {
4604 if (stopparen == (I32)ARG(scan)) {
4607 if ((I32)ARG(scan) == is_par) {
4608 next = regnext(scan);
4610 if ( next && (OP(next) != WHILEM) && next < last)
4611 is_par = 0; /* Disable optimization */
4614 *(data->last_closep) = ARG(scan);
4616 else if (OP(scan) == EVAL) {
4618 data->flags |= SF_HAS_EVAL;
4620 else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4621 if (flags & SCF_DO_SUBSTR) {
4622 SCAN_COMMIT(pRExC_state,data,minlenp);
4623 flags &= ~SCF_DO_SUBSTR;
4625 if (data && OP(scan)==ACCEPT) {
4626 data->flags |= SCF_SEEN_ACCEPT;
4631 else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4633 if (flags & SCF_DO_SUBSTR) {
4634 SCAN_COMMIT(pRExC_state,data,minlenp);
4635 data->longest = &(data->longest_float);
4637 is_inf = is_inf_internal = 1;
4638 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4639 cl_anything(pRExC_state, data->start_class);
4640 flags &= ~SCF_DO_STCLASS;
4642 else if (OP(scan) == GPOS) {
4643 if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4644 !(delta || is_inf || (data && data->pos_delta)))
4646 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4647 RExC_rx->extflags |= RXf_ANCH_GPOS;
4648 if (RExC_rx->gofs < (U32)min)
4649 RExC_rx->gofs = min;
4651 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4655 #ifdef TRIE_STUDY_OPT
4656 #ifdef FULL_TRIE_STUDY
4657 else if (PL_regkind[OP(scan)] == TRIE) {
4658 /* NOTE - There is similar code to this block above for handling
4659 BRANCH nodes on the initial study. If you change stuff here
4661 regnode *trie_node= scan;
4662 regnode *tail= regnext(scan);
4663 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4664 I32 max1 = 0, min1 = I32_MAX;
4665 struct regnode_charclass_class accum;
4667 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4668 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4669 if (flags & SCF_DO_STCLASS)
4670 cl_init_zero(pRExC_state, &accum);
4676 const regnode *nextbranch= NULL;
4679 for ( word=1 ; word <= trie->wordcount ; word++)
4681 I32 deltanext=0, minnext=0, f = 0, fake;
4682 struct regnode_charclass_class this_class;
4684 data_fake.flags = 0;
4686 data_fake.whilem_c = data->whilem_c;
4687 data_fake.last_closep = data->last_closep;
4690 data_fake.last_closep = &fake;
4691 data_fake.pos_delta = delta;
4692 if (flags & SCF_DO_STCLASS) {
4693 cl_init(pRExC_state, &this_class);
4694 data_fake.start_class = &this_class;
4695 f = SCF_DO_STCLASS_AND;
4697 if (flags & SCF_WHILEM_VISITED_POS)
4698 f |= SCF_WHILEM_VISITED_POS;
4700 if (trie->jump[word]) {
4702 nextbranch = trie_node + trie->jump[0];
4703 scan= trie_node + trie->jump[word];
4704 /* We go from the jump point to the branch that follows
4705 it. Note this means we need the vestigal unused branches
4706 even though they arent otherwise used.
4708 minnext = study_chunk(pRExC_state, &scan, minlenp,
4709 &deltanext, (regnode *)nextbranch, &data_fake,
4710 stopparen, recursed, NULL, f,depth+1);
4712 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4713 nextbranch= regnext((regnode*)nextbranch);
4715 if (min1 > (I32)(minnext + trie->minlen))
4716 min1 = minnext + trie->minlen;
4717 if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4718 max1 = minnext + deltanext + trie->maxlen;
4719 if (deltanext == I32_MAX)
4720 is_inf = is_inf_internal = 1;
4722 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4724 if (data_fake.flags & SCF_SEEN_ACCEPT) {
4725 if ( stopmin > min + min1)
4726 stopmin = min + min1;
4727 flags &= ~SCF_DO_SUBSTR;
4729 data->flags |= SCF_SEEN_ACCEPT;
4732 if (data_fake.flags & SF_HAS_EVAL)
4733 data->flags |= SF_HAS_EVAL;
4734 data->whilem_c = data_fake.whilem_c;
4736 if (flags & SCF_DO_STCLASS)
4737 cl_or(pRExC_state, &accum, &this_class);
4740 if (flags & SCF_DO_SUBSTR) {
4741 data->pos_min += min1;
4742 data->pos_delta += max1 - min1;
4743 if (max1 != min1 || is_inf)
4744 data->longest = &(data->longest_float);
4747 delta += max1 - min1;
4748 if (flags & SCF_DO_STCLASS_OR) {
4749 cl_or(pRExC_state, data->start_class, &accum);
4751 cl_and(data->start_class, and_withp);
4752 flags &= ~SCF_DO_STCLASS;
4755 else if (flags & SCF_DO_STCLASS_AND) {
4757 cl_and(data->start_class, &accum);
4758 flags &= ~SCF_DO_STCLASS;
4761 /* Switch to OR mode: cache the old value of
4762 * data->start_class */
4764 StructCopy(data->start_class, and_withp,
4765 struct regnode_charclass_class);
4766 flags &= ~SCF_DO_STCLASS_AND;
4767 StructCopy(&accum, data->start_class,
4768 struct regnode_charclass_class);
4769 flags |= SCF_DO_STCLASS_OR;
4770 data->start_class->flags |= ANYOF_EOS;
4777 else if (PL_regkind[OP(scan)] == TRIE) {
4778 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4781 min += trie->minlen;
4782 delta += (trie->maxlen - trie->minlen);
4783 flags &= ~SCF_DO_STCLASS; /* xxx */
4784 if (flags & SCF_DO_SUBSTR) {
4785 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4786 data->pos_min += trie->minlen;
4787 data->pos_delta += (trie->maxlen - trie->minlen);
4788 if (trie->maxlen != trie->minlen)
4789 data->longest = &(data->longest_float);
4791 if (trie->jump) /* no more substrings -- for now /grr*/
4792 flags &= ~SCF_DO_SUBSTR;
4794 #endif /* old or new */
4795 #endif /* TRIE_STUDY_OPT */
4797 /* Else: zero-length, ignore. */
4798 scan = regnext(scan);
4803 stopparen = frame->stop;
4804 frame = frame->prev;
4805 goto fake_study_recurse;
4810 DEBUG_STUDYDATA("pre-fin:",data,depth);
4813 *deltap = is_inf_internal ? I32_MAX : delta;
4814 if (flags & SCF_DO_SUBSTR && is_inf)
4815 data->pos_delta = I32_MAX - data->pos_min;
4816 if (is_par > (I32)U8_MAX)
4818 if (is_par && pars==1 && data) {
4819 data->flags |= SF_IN_PAR;
4820 data->flags &= ~SF_HAS_PAR;
4822 else if (pars && data) {
4823 data->flags |= SF_HAS_PAR;
4824 data->flags &= ~SF_IN_PAR;
4826 if (flags & SCF_DO_STCLASS_OR)
4827 cl_and(data->start_class, and_withp);
4828 if (flags & SCF_TRIE_RESTUDY)
4829 data->flags |= SCF_TRIE_RESTUDY;
4831 DEBUG_STUDYDATA("post-fin:",data,depth);
4833 return min < stopmin ? min : stopmin;
4837 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4839 U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4841 PERL_ARGS_ASSERT_ADD_DATA;
4843 Renewc(RExC_rxi->data,
4844 sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4845 char, struct reg_data);
4847 Renew(RExC_rxi->data->what, count + n, U8);
4849 Newx(RExC_rxi->data->what, n, U8);
4850 RExC_rxi->data->count = count + n;
4851 Copy(s, RExC_rxi->data->what + count, n, U8);
4855 /*XXX: todo make this not included in a non debugging perl */
4856 #ifndef PERL_IN_XSUB_RE
4858 Perl_reginitcolors(pTHX)
4861 const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4863 char *t = savepv(s);
4867 t = strchr(t, '\t');
4873 PL_colors[i] = t = (char *)"";
4878 PL_colors[i++] = (char *)"";
4885 #ifdef TRIE_STUDY_OPT
4886 #define CHECK_RESTUDY_GOTO \
4888 (data.flags & SCF_TRIE_RESTUDY) \
4892 #define CHECK_RESTUDY_GOTO
4896 * pregcomp - compile a regular expression into internal code
4898 * Decides which engine's compiler to call based on the hint currently in
4902 #ifndef PERL_IN_XSUB_RE
4904 /* return the currently in-scope regex engine (or the default if none) */
4906 regexp_engine const *
4907 Perl_current_re_engine(pTHX)
4911 if (IN_PERL_COMPILETIME) {
4912 HV * const table = GvHV(PL_hintgv);
4916 return &PL_core_reg_engine;
4917 ptr = hv_fetchs(table, "regcomp", FALSE);
4918 if ( !(ptr && SvIOK(*ptr) && SvIV(*ptr)))
4919 return &PL_core_reg_engine;
4920 return INT2PTR(regexp_engine*,SvIV(*ptr));
4924 if (!PL_curcop->cop_hints_hash)
4925 return &PL_core_reg_engine;
4926 ptr = cop_hints_fetch_pvs(PL_curcop, "regcomp", 0);
4927 if ( !(ptr && SvIOK(ptr) && SvIV(ptr)))
4928 return &PL_core_reg_engine;
4929 return INT2PTR(regexp_engine*,SvIV(ptr));
4935 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4938 regexp_engine const *eng = current_re_engine();
4939 GET_RE_DEBUG_FLAGS_DECL;
4941 PERL_ARGS_ASSERT_PREGCOMP;
4943 /* Dispatch a request to compile a regexp to correct regexp engine. */
4945 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4948 return CALLREGCOMP_ENG(eng, pattern, flags);
4952 /* public(ish) wrapper for Perl_re_op_compile that only takes an SV
4953 * pattern rather than a list of OPs */
4956 Perl_re_compile(pTHX_ SV * const pattern, U32 rx_flags)
4958 SV *pat = pattern; /* defeat constness! */
4959 PERL_ARGS_ASSERT_RE_COMPILE;
4960 return Perl_re_op_compile(aTHX_ &pat, 1, NULL, current_re_engine(),
4961 NULL, NULL, rx_flags, 0);
4964 /* see if there are any run-time code blocks in the pattern.
4965 * False positives are allowed */
4968 S_has_runtime_code(pTHX_ RExC_state_t * const pRExC_state, OP *expr,
4969 U32 pm_flags, char *pat, STRLEN plen)
4974 /* avoid infinitely recursing when we recompile the pattern parcelled up
4975 * as qr'...'. A single constant qr// string can't have have any
4976 * run-time component in it, and thus, no runtime code. (A non-qr
4977 * string, however, can, e.g. $x =~ '(?{})') */
4978 if ((pm_flags & PMf_IS_QR) && expr && expr->op_type == OP_CONST)
4981 for (s = 0; s < plen; s++) {
4982 if (n < pRExC_state->num_code_blocks
4983 && s == pRExC_state->code_blocks[n].start)
4985 s = pRExC_state->code_blocks[n].end;
4989 /* TODO ideally should handle [..], (#..), /#.../x to reduce false
4991 if (pat[s] == '(' && pat[s+1] == '?' &&
4992 (pat[s+2] == '{' || (pat[s+2] == '?' && pat[s+3] == '{'))
4999 /* Handle run-time code blocks. We will already have compiled any direct
5000 * or indirect literal code blocks. Now, take the pattern 'pat' and make a
5001 * copy of it, but with any literal code blocks blanked out and
5002 * appropriate chars escaped; then feed it into
5004 * eval "qr'modified_pattern'"
5008 * a\bc(?{"this was literal"})def'ghi\\jkl(?{"this is runtime"})mno
5012 * qr'a\\bc def\'ghi\\\\jkl(?{"this is runtime"})mno'
5014 * After eval_sv()-ing that, grab any new code blocks from the returned qr
5015 * and merge them with any code blocks of the original regexp.
5017 * If the pat is non-UTF8, while the evalled qr is UTF8, don't merge;
5018 * instead, just save the qr and return FALSE; this tells our caller that
5019 * the original pattern needs upgrading to utf8.
5023 S_compile_runtime_code(pTHX_ RExC_state_t * const pRExC_state,
5024 char *pat, STRLEN plen)
5028 GET_RE_DEBUG_FLAGS_DECL;
5030 if (pRExC_state->runtime_code_qr) {
5031 /* this is the second time we've been called; this should
5032 * only happen if the main pattern got upgraded to utf8
5033 * during compilation; re-use the qr we compiled first time
5034 * round (which should be utf8 too)
5036 qr = pRExC_state->runtime_code_qr;
5037 pRExC_state->runtime_code_qr = NULL;
5038 assert(RExC_utf8 && SvUTF8(qr));
5044 int newlen = plen + 6; /* allow for "qr''x\0" extra chars */
5048 /* determine how many extra chars we need for ' and \ escaping */
5049 for (s = 0; s < plen; s++) {
5050 if (pat[s] == '\'' || pat[s] == '\\')
5054 Newx(newpat, newlen, char);
5056 *p++ = 'q'; *p++ = 'r'; *p++ = '\'';
5058 for (s = 0; s < plen; s++) {
5059 if (n < pRExC_state->num_code_blocks
5060 && s == pRExC_state->code_blocks[n].start)
5062 /* blank out literal code block */
5063 assert(pat[s] == '(');
5064 while (s <= pRExC_state->code_blocks[n].end) {
5072 if (pat[s] == '\'' || pat[s] == '\\')
5077 if (pRExC_state->pm_flags & RXf_PMf_EXTENDED)
5081 PerlIO_printf(Perl_debug_log,
5082 "%sre-parsing pattern for runtime code:%s %s\n",
5083 PL_colors[4],PL_colors[5],newpat);
5086 sv = newSVpvn_flags(newpat, p-newpat-1, RExC_utf8 ? SVf_UTF8 : 0);
5092 PUSHSTACKi(PERLSI_REQUIRE);
5093 /* this causes the toker to collapse \\ into \ when parsing
5094 * qr''; normally only q'' does this. It also alters hints
5096 PL_reg_state.re_reparsing = TRUE;
5097 eval_sv(sv, G_SCALAR);
5103 Perl_croak(aTHX_ "%s", SvPVx_nolen_const(ERRSV));
5104 assert(SvROK(qr_ref));
5106 assert(SvTYPE(qr) == SVt_REGEXP && RX_ENGINE((REGEXP*)qr)->op_comp);
5107 /* the leaving below frees the tmp qr_ref.
5108 * Give qr a life of its own */
5116 if (!RExC_utf8 && SvUTF8(qr)) {
5117 /* first time through; the pattern got upgraded; save the
5118 * qr for the next time through */
5119 assert(!pRExC_state->runtime_code_qr);
5120 pRExC_state->runtime_code_qr = qr;
5125 /* extract any code blocks within the returned qr// */
5128 /* merge the main (r1) and run-time (r2) code blocks into one */
5130 RXi_GET_DECL(((struct regexp*)SvANY(qr)), r2);
5131 struct reg_code_block *new_block, *dst;
5132 RExC_state_t * const r1 = pRExC_state; /* convenient alias */
5135 if (!r2->num_code_blocks) /* we guessed wrong */
5139 r1->num_code_blocks + r2->num_code_blocks,
5140 struct reg_code_block);
5143 while ( i1 < r1->num_code_blocks
5144 || i2 < r2->num_code_blocks)
5146 struct reg_code_block *src;
5149 if (i1 == r1->num_code_blocks) {
5150 src = &r2->code_blocks[i2++];
5153 else if (i2 == r2->num_code_blocks)
5154 src = &r1->code_blocks[i1++];
5155 else if ( r1->code_blocks[i1].start
5156 < r2->code_blocks[i2].start)
5158 src = &r1->code_blocks[i1++];
5159 assert(src->end < r2->code_blocks[i2].start);
5162 assert( r1->code_blocks[i1].start
5163 > r2->code_blocks[i2].start);
5164 src = &r2->code_blocks[i2++];
5166 assert(src->end < r1->code_blocks[i1].start);
5169 assert(pat[src->start] == '(');
5170 assert(pat[src->end] == ')');
5171 dst->start = src->start;
5172 dst->end = src->end;
5173 dst->block = src->block;
5174 dst->src_regex = is_qr ? (REGEXP*) SvREFCNT_inc( (SV*) qr)
5178 r1->num_code_blocks += r2->num_code_blocks;
5179 Safefree(r1->code_blocks);
5180 r1->code_blocks = new_block;
5189 * Perl_re_op_compile - the perl internal RE engine's function to compile a
5190 * regular expression into internal code.
5191 * The pattern may be passed either as:
5192 * a list of SVs (patternp plus pat_count)
5193 * a list of OPs (expr)
5194 * If both are passed, the SV list is used, but the OP list indicates
5195 * which SVs are actually pre-compiled code blocks
5197 * The SVs in the list have magic and qr overloading applied to them (and
5198 * the list may be modified in-place with replacement SVs in the latter
5201 * If the pattern hasn't changed from old_re, then old_re will be
5204 * eng is the current engine. If that engine has an op_comp method, then
5205 * handle directly (i.e. we assume that op_comp was us); otherwise, just
5206 * do the initial concatenation of arguments and pass on to the external
5209 * If is_bare_re is not null, set it to a boolean indicating whether the
5210 * arg list reduced (after overloading) to a single bare regex which has
5211 * been returned (i.e. /$qr/).
5213 * orig_rx_flags contains RXf_* flags. See perlreapi.pod for more details.
5215 * pm_flags contains the PMf_* flags, typically based on those from the
5216 * pm_flags field of the related PMOP. Currently we're only interested in
5217 * PMf_HAS_CV, PMf_IS_QR, PMf_USE_RE_EVAL.
5219 * We can't allocate space until we know how big the compiled form will be,
5220 * but we can't compile it (and thus know how big it is) until we've got a
5221 * place to put the code. So we cheat: we compile it twice, once with code
5222 * generation turned off and size counting turned on, and once "for real".
5223 * This also means that we don't allocate space until we are sure that the
5224 * thing really will compile successfully, and we never have to move the
5225 * code and thus invalidate pointers into it. (Note that it has to be in
5226 * one piece because free() must be able to free it all.) [NB: not true in perl]
5228 * Beware that the optimization-preparation code in here knows about some
5229 * of the structure of the compiled regexp. [I'll say.]
5233 Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count,
5234 OP *expr, const regexp_engine* eng, REGEXP *VOL old_re,
5235 bool *is_bare_re, U32 orig_rx_flags, U32 pm_flags)
5240 register regexp_internal *ri;
5250 /* these are all flags - maybe they should be turned
5251 * into a single int with different bit masks */
5252 I32 sawlookahead = 0;
5255 bool used_setjump = FALSE;
5256 regex_charset initial_charset = get_regex_charset(orig_rx_flags);
5257 bool code_is_utf8 = 0;
5258 bool VOL recompile = 0;
5259 bool runtime_code = 0;
5263 RExC_state_t RExC_state;
5264 RExC_state_t * const pRExC_state = &RExC_state;
5265 #ifdef TRIE_STUDY_OPT
5267 RExC_state_t copyRExC_state;
5269 GET_RE_DEBUG_FLAGS_DECL;
5271 PERL_ARGS_ASSERT_RE_OP_COMPILE;
5273 DEBUG_r(if (!PL_colorset) reginitcolors());
5275 #ifndef PERL_IN_XSUB_RE
5276 /* Initialize these here instead of as-needed, as is quick and avoids
5277 * having to test them each time otherwise */
5278 if (! PL_AboveLatin1) {
5279 PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
5280 PL_ASCII = _new_invlist_C_array(ASCII_invlist);
5281 PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
5283 PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
5284 PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
5286 PL_L1PosixAlpha = _new_invlist_C_array(L1PosixAlpha_invlist);
5287 PL_PosixAlpha = _new_invlist_C_array(PosixAlpha_invlist);
5289 PL_PosixBlank = _new_invlist_C_array(PosixBlank_invlist);
5290 PL_XPosixBlank = _new_invlist_C_array(XPosixBlank_invlist);
5292 PL_L1Cased = _new_invlist_C_array(L1Cased_invlist);
5294 PL_PosixCntrl = _new_invlist_C_array(PosixCntrl_invlist);
5295 PL_XPosixCntrl = _new_invlist_C_array(XPosixCntrl_invlist);
5297 PL_PosixDigit = _new_invlist_C_array(PosixDigit_invlist);
5299 PL_L1PosixGraph = _new_invlist_C_array(L1PosixGraph_invlist);
5300 PL_PosixGraph = _new_invlist_C_array(PosixGraph_invlist);
5302 PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
5303 PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
5305 PL_L1PosixLower = _new_invlist_C_array(L1PosixLower_invlist);
5306 PL_PosixLower = _new_invlist_C_array(PosixLower_invlist);
5308 PL_L1PosixPrint = _new_invlist_C_array(L1PosixPrint_invlist);
5309 PL_PosixPrint = _new_invlist_C_array(PosixPrint_invlist);
5311 PL_L1PosixPunct = _new_invlist_C_array(L1PosixPunct_invlist);
5312 PL_PosixPunct = _new_invlist_C_array(PosixPunct_invlist);
5314 PL_PerlSpace = _new_invlist_C_array(PerlSpace_invlist);
5315 PL_XPerlSpace = _new_invlist_C_array(XPerlSpace_invlist);
5317 PL_PosixSpace = _new_invlist_C_array(PosixSpace_invlist);
5318 PL_XPosixSpace = _new_invlist_C_array(XPosixSpace_invlist);
5320 PL_L1PosixUpper = _new_invlist_C_array(L1PosixUpper_invlist);
5321 PL_PosixUpper = _new_invlist_C_array(PosixUpper_invlist);
5323 PL_VertSpace = _new_invlist_C_array(VertSpace_invlist);
5325 PL_PosixWord = _new_invlist_C_array(PosixWord_invlist);
5326 PL_L1PosixWord = _new_invlist_C_array(L1PosixWord_invlist);
5328 PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
5329 PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
5333 pRExC_state->code_blocks = NULL;
5334 pRExC_state->num_code_blocks = 0;
5337 *is_bare_re = FALSE;
5339 if (expr && (expr->op_type == OP_LIST ||
5340 (expr->op_type == OP_NULL && expr->op_targ == OP_LIST))) {
5342 /* is the source UTF8, and how many code blocks are there? */
5346 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5347 if (o->op_type == OP_CONST && SvUTF8(cSVOPo_sv))
5349 else if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL))
5350 /* count of DO blocks */
5354 pRExC_state->num_code_blocks = ncode;
5355 Newx(pRExC_state->code_blocks, ncode, struct reg_code_block);
5360 /* handle a list of SVs */
5364 /* apply magic and RE overloading to each arg */
5365 for (svp = patternp; svp < patternp + pat_count; svp++) {
5368 if (SvROK(rx) && SvAMAGIC(rx)) {
5369 SV *sv = AMG_CALLunary(rx, regexp_amg);
5373 if (SvTYPE(sv) != SVt_REGEXP)
5374 Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP");
5380 if (pat_count > 1) {
5381 /* concat multiple args and find any code block indexes */
5386 STRLEN orig_patlen = 0;
5388 if (pRExC_state->num_code_blocks) {
5389 o = cLISTOPx(expr)->op_first;
5390 assert(o->op_type == OP_PUSHMARK);
5394 pat = newSVpvn("", 0);
5397 /* determine if the pattern is going to be utf8 (needed
5398 * in advance to align code block indices correctly).
5399 * XXX This could fail to be detected for an arg with
5400 * overloading but not concat overloading; but the main effect
5401 * in this obscure case is to need a 'use re eval' for a
5402 * literal code block */
5403 for (svp = patternp; svp < patternp + pat_count; svp++) {
5410 for (svp = patternp; svp < patternp + pat_count; svp++) {
5411 SV *sv, *msv = *svp;
5415 if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5416 assert(n < pRExC_state->num_code_blocks);
5417 pRExC_state->code_blocks[n].start = SvCUR(pat);
5418 pRExC_state->code_blocks[n].block = o;
5419 pRExC_state->code_blocks[n].src_regex = NULL;
5422 o = o->op_sibling; /* skip CONST */
5428 if ((SvAMAGIC(pat) || SvAMAGIC(msv)) &&
5429 (sv = amagic_call(pat, msv, concat_amg, AMGf_assign)))
5432 /* overloading involved: all bets are off over literal
5433 * code. Pretend we haven't seen it */
5434 pRExC_state->num_code_blocks -= n;
5440 while (SvAMAGIC(msv)
5441 && (sv = AMG_CALLunary(msv, string_amg))
5447 if (SvROK(msv) && SvTYPE(SvRV(msv)) == SVt_REGEXP)
5449 orig_patlen = SvCUR(pat);
5450 sv_catsv_nomg(pat, msv);
5453 pRExC_state->code_blocks[n-1].end = SvCUR(pat)-1;
5456 /* extract any code blocks within any embedded qr//'s */
5457 if (rx && SvTYPE(rx) == SVt_REGEXP
5458 && RX_ENGINE((REGEXP*)rx)->op_comp)
5461 RXi_GET_DECL(((struct regexp*)SvANY(rx)), ri);
5462 if (ri->num_code_blocks) {
5464 /* the presence of an embedded qr// with code means
5465 * we should always recompile: the text of the
5466 * qr// may not have changed, but it may be a
5467 * different closure than last time */
5469 Renew(pRExC_state->code_blocks,
5470 pRExC_state->num_code_blocks + ri->num_code_blocks,
5471 struct reg_code_block);
5472 pRExC_state->num_code_blocks += ri->num_code_blocks;
5473 for (i=0; i < ri->num_code_blocks; i++) {
5474 struct reg_code_block *src, *dst;
5475 STRLEN offset = orig_patlen
5476 + ((struct regexp *)SvANY(rx))->pre_prefix;
5477 assert(n < pRExC_state->num_code_blocks);
5478 src = &ri->code_blocks[i];
5479 dst = &pRExC_state->code_blocks[n];
5480 dst->start = src->start + offset;
5481 dst->end = src->end + offset;
5482 dst->block = src->block;
5483 dst->src_regex = (REGEXP*) SvREFCNT_inc( (SV*)
5497 while (SvAMAGIC(pat)
5498 && (sv = AMG_CALLunary(pat, string_amg))
5506 /* handle bare regex: foo =~ $re */
5511 if (SvTYPE(re) == SVt_REGEXP) {
5515 Safefree(pRExC_state->code_blocks);
5521 /* not a list of SVs, so must be a list of OPs */
5523 if (expr->op_type == OP_LIST) {
5528 pat = newSVpvn("", 0);
5533 /* given a list of CONSTs and DO blocks in expr, append all
5534 * the CONSTs to pat, and record the start and end of each
5535 * code block in code_blocks[] (each DO{} op is followed by an
5536 * OP_CONST containing the corresponding literal '(?{...})
5539 for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
5540 if (o->op_type == OP_CONST) {
5541 sv_catsv(pat, cSVOPo_sv);
5543 pRExC_state->code_blocks[i].end = SvCUR(pat)-1;
5547 else if (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)) {
5548 assert(i+1 < pRExC_state->num_code_blocks);
5549 pRExC_state->code_blocks[++i].start = SvCUR(pat);
5550 pRExC_state->code_blocks[i].block = o;
5551 pRExC_state->code_blocks[i].src_regex = NULL;
5557 assert(expr->op_type == OP_CONST);
5558 pat = cSVOPx_sv(expr);
5562 exp = SvPV_nomg(pat, plen);
5564 if (!eng->op_comp) {
5565 if ((SvUTF8(pat) && IN_BYTES)
5566 || SvGMAGICAL(pat) || SvAMAGIC(pat))
5568 /* make a temporary copy; either to convert to bytes,
5569 * or to avoid repeating get-magic / overloaded stringify */
5570 pat = newSVpvn_flags(exp, plen, SVs_TEMP |
5571 (IN_BYTES ? 0 : SvUTF8(pat)));
5573 Safefree(pRExC_state->code_blocks);
5574 return CALLREGCOMP_ENG(eng, pat, orig_rx_flags);
5577 /* ignore the utf8ness if the pattern is 0 length */
5578 RExC_utf8 = RExC_orig_utf8 = (plen == 0 || IN_BYTES) ? 0 : SvUTF8(pat);
5579 RExC_uni_semantics = 0;
5580 RExC_contains_locale = 0;
5581 pRExC_state->runtime_code_qr = NULL;
5583 /****************** LONG JUMP TARGET HERE***********************/
5584 /* Longjmp back to here if have to switch in midstream to utf8 */
5585 if (! RExC_orig_utf8) {
5586 JMPENV_PUSH(jump_ret);
5587 used_setjump = TRUE;
5590 if (jump_ret == 0) { /* First time through */
5594 SV *dsv= sv_newmortal();
5595 RE_PV_QUOTED_DECL(s, RExC_utf8,
5596 dsv, exp, plen, 60);
5597 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
5598 PL_colors[4],PL_colors[5],s);
5601 else { /* longjumped back */
5604 STRLEN s = 0, d = 0;
5607 /* If the cause for the longjmp was other than changing to utf8, pop
5608 * our own setjmp, and longjmp to the correct handler */
5609 if (jump_ret != UTF8_LONGJMP) {
5611 JMPENV_JUMP(jump_ret);
5616 /* It's possible to write a regexp in ascii that represents Unicode
5617 codepoints outside of the byte range, such as via \x{100}. If we
5618 detect such a sequence we have to convert the entire pattern to utf8
5619 and then recompile, as our sizing calculation will have been based
5620 on 1 byte == 1 character, but we will need to use utf8 to encode
5621 at least some part of the pattern, and therefore must convert the whole
5624 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5625 "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5627 /* upgrade pattern to UTF8, and if there are code blocks,
5628 * recalculate the indices.
5629 * This is essentially an unrolled Perl_bytes_to_utf8() */
5631 src = (U8*)SvPV_nomg(pat, plen);
5632 Newx(dst, plen * 2 + 1, U8);
5635 const UV uv = NATIVE_TO_ASCII(src[s]);
5636 if (UNI_IS_INVARIANT(uv))
5637 dst[d] = (U8)UTF_TO_NATIVE(uv);
5639 dst[d++] = (U8)UTF8_EIGHT_BIT_HI(uv);
5640 dst[d] = (U8)UTF8_EIGHT_BIT_LO(uv);
5642 if (n < pRExC_state->num_code_blocks) {
5643 if (!do_end && pRExC_state->code_blocks[n].start == s) {
5644 pRExC_state->code_blocks[n].start = d;
5645 assert(dst[d] == '(');
5648 else if (do_end && pRExC_state->code_blocks[n].end == s) {
5649 pRExC_state->code_blocks[n].end = d;
5650 assert(dst[d] == ')');
5663 RExC_orig_utf8 = RExC_utf8 = 1;
5666 /* return old regex if pattern hasn't changed */
5670 && !!RX_UTF8(old_re) == !!RExC_utf8
5671 && RX_PRECOMP(old_re)
5672 && RX_PRELEN(old_re) == plen
5673 && memEQ(RX_PRECOMP(old_re), exp, plen))
5675 /* with runtime code, always recompile */
5676 runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags,
5678 if (!runtime_code) {
5679 ReREFCNT_inc(old_re);
5683 Safefree(pRExC_state->code_blocks);
5687 else if ((pm_flags & PMf_USE_RE_EVAL)
5688 /* this second condition covers the non-regex literal case,
5689 * i.e. $foo =~ '(?{})'. */
5690 || ( !PL_reg_state.re_reparsing && IN_PERL_COMPILETIME
5691 && (PL_hints & HINT_RE_EVAL))
5693 runtime_code = S_has_runtime_code(aTHX_ pRExC_state, expr, pm_flags,
5696 #ifdef TRIE_STUDY_OPT
5700 rx_flags = orig_rx_flags;
5702 if (initial_charset == REGEX_LOCALE_CHARSET) {
5703 RExC_contains_locale = 1;
5705 else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5707 /* Set to use unicode semantics if the pattern is in utf8 and has the
5708 * 'depends' charset specified, as it means unicode when utf8 */
5709 set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5713 RExC_flags = rx_flags;
5714 RExC_pm_flags = pm_flags;
5717 if (PL_tainting && PL_tainted)
5718 Perl_croak(aTHX_ "Eval-group in insecure regular expression");
5720 if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) {
5721 /* whoops, we have a non-utf8 pattern, whilst run-time code
5722 * got compiled as utf8. Try again with a utf8 pattern */
5723 JMPENV_JUMP(UTF8_LONGJMP);
5726 assert(!pRExC_state->runtime_code_qr);
5731 RExC_in_lookbehind = 0;
5732 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5734 RExC_override_recoding = 0;
5736 /* First pass: determine size, legality. */
5744 RExC_emit = &PL_regdummy;
5745 RExC_whilem_seen = 0;
5746 RExC_open_parens = NULL;
5747 RExC_close_parens = NULL;
5749 RExC_paren_names = NULL;
5751 RExC_paren_name_list = NULL;
5753 RExC_recurse = NULL;
5754 RExC_recurse_count = 0;
5755 pRExC_state->code_index = 0;
5757 #if 0 /* REGC() is (currently) a NOP at the first pass.
5758 * Clever compilers notice this and complain. --jhi */
5759 REGC((U8)REG_MAGIC, (char*)RExC_emit);
5762 PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5764 RExC_lastparse=NULL;
5766 if (reg(pRExC_state, 0, &flags,1) == NULL) {
5767 RExC_precomp = NULL;
5768 Safefree(pRExC_state->code_blocks);
5772 /* Here, finished first pass. Get rid of any added setjmp */
5778 PerlIO_printf(Perl_debug_log,
5779 "Required size %"IVdf" nodes\n"
5780 "Starting second pass (creation)\n",
5783 RExC_lastparse=NULL;
5786 /* The first pass could have found things that force Unicode semantics */
5787 if ((RExC_utf8 || RExC_uni_semantics)
5788 && get_regex_charset(rx_flags) == REGEX_DEPENDS_CHARSET)
5790 set_regex_charset(&rx_flags, REGEX_UNICODE_CHARSET);
5793 /* Small enough for pointer-storage convention?
5794 If extralen==0, this means that we will not need long jumps. */
5795 if (RExC_size >= 0x10000L && RExC_extralen)
5796 RExC_size += RExC_extralen;
5799 if (RExC_whilem_seen > 15)
5800 RExC_whilem_seen = 15;
5802 /* Allocate space and zero-initialize. Note, the two step process
5803 of zeroing when in debug mode, thus anything assigned has to
5804 happen after that */
5805 rx = (REGEXP*) newSV_type(SVt_REGEXP);
5806 r = (struct regexp*)SvANY(rx);
5807 Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5808 char, regexp_internal);
5809 if ( r == NULL || ri == NULL )
5810 FAIL("Regexp out of space");
5812 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5813 Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5815 /* bulk initialize base fields with 0. */
5816 Zero(ri, sizeof(regexp_internal), char);
5819 /* non-zero initialization begins here */
5822 r->extflags = rx_flags;
5823 if (pm_flags & PMf_IS_QR) {
5824 ri->code_blocks = pRExC_state->code_blocks;
5825 ri->num_code_blocks = pRExC_state->num_code_blocks;
5828 SAVEFREEPV(pRExC_state->code_blocks);
5831 bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5832 bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5834 /* The caret is output if there are any defaults: if not all the STD
5835 * flags are set, or if no character set specifier is needed */
5837 (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5839 bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5840 U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5841 >> RXf_PMf_STD_PMMOD_SHIFT);
5842 const char *fptr = STD_PAT_MODS; /*"msix"*/
5844 /* Allocate for the worst case, which is all the std flags are turned
5845 * on. If more precision is desired, we could do a population count of
5846 * the flags set. This could be done with a small lookup table, or by
5847 * shifting, masking and adding, or even, when available, assembly
5848 * language for a machine-language population count.
5849 * We never output a minus, as all those are defaults, so are
5850 * covered by the caret */
5851 const STRLEN wraplen = plen + has_p + has_runon
5852 + has_default /* If needs a caret */
5854 /* If needs a character set specifier */
5855 + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5856 + (sizeof(STD_PAT_MODS) - 1)
5857 + (sizeof("(?:)") - 1);
5859 p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
5862 SvFLAGS(rx) |= SVf_UTF8;
5865 /* If a default, cover it using the caret */
5867 *p++= DEFAULT_PAT_MOD;
5871 const char* const name = get_regex_charset_name(r->extflags, &len);
5872 Copy(name, p, len, char);
5876 *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5879 while((ch = *fptr++)) {
5887 Copy(RExC_precomp, p, plen, char);
5888 assert ((RX_WRAPPED(rx) - p) < 16);
5889 r->pre_prefix = p - RX_WRAPPED(rx);
5895 SvCUR_set(rx, p - SvPVX_const(rx));
5899 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5901 if (RExC_seen & REG_SEEN_RECURSE) {
5902 Newxz(RExC_open_parens, RExC_npar,regnode *);
5903 SAVEFREEPV(RExC_open_parens);
5904 Newxz(RExC_close_parens,RExC_npar,regnode *);
5905 SAVEFREEPV(RExC_close_parens);
5908 /* Useful during FAIL. */
5909 #ifdef RE_TRACK_PATTERN_OFFSETS
5910 Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5911 DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5912 "%s %"UVuf" bytes for offset annotations.\n",
5913 ri->u.offsets ? "Got" : "Couldn't get",
5914 (UV)((2*RExC_size+1) * sizeof(U32))));
5916 SetProgLen(ri,RExC_size);
5921 /* Second pass: emit code. */
5922 RExC_flags = rx_flags; /* don't let top level (?i) bleed */
5923 RExC_pm_flags = pm_flags;
5928 RExC_emit_start = ri->program;
5929 RExC_emit = ri->program;
5930 RExC_emit_bound = ri->program + RExC_size + 1;
5931 pRExC_state->code_index = 0;
5933 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5934 if (reg(pRExC_state, 0, &flags,1) == NULL) {
5938 /* XXXX To minimize changes to RE engine we always allocate
5939 3-units-long substrs field. */
5940 Newx(r->substrs, 1, struct reg_substr_data);
5941 if (RExC_recurse_count) {
5942 Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5943 SAVEFREEPV(RExC_recurse);
5947 r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
5948 Zero(r->substrs, 1, struct reg_substr_data);
5950 #ifdef TRIE_STUDY_OPT
5952 StructCopy(&zero_scan_data, &data, scan_data_t);
5953 copyRExC_state = RExC_state;
5956 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
5958 RExC_state = copyRExC_state;
5959 if (seen & REG_TOP_LEVEL_BRANCHES)
5960 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5962 RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
5963 if (data.last_found) {
5964 SvREFCNT_dec(data.longest_fixed);
5965 SvREFCNT_dec(data.longest_float);
5966 SvREFCNT_dec(data.last_found);
5968 StructCopy(&zero_scan_data, &data, scan_data_t);
5971 StructCopy(&zero_scan_data, &data, scan_data_t);
5974 /* Dig out information for optimizations. */
5975 r->extflags = RExC_flags; /* was pm_op */
5976 /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
5979 SvUTF8_on(rx); /* Unicode in it? */
5980 ri->regstclass = NULL;
5981 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
5982 r->intflags |= PREGf_NAUGHTY;
5983 scan = ri->program + 1; /* First BRANCH. */
5985 /* testing for BRANCH here tells us whether there is "must appear"
5986 data in the pattern. If there is then we can use it for optimisations */
5987 if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */
5989 STRLEN longest_float_length, longest_fixed_length;
5990 struct regnode_charclass_class ch_class; /* pointed to by data */
5992 I32 last_close = 0; /* pointed to by data */
5993 regnode *first= scan;
5994 regnode *first_next= regnext(first);
5996 * Skip introductions and multiplicators >= 1
5997 * so that we can extract the 'meat' of the pattern that must
5998 * match in the large if() sequence following.
5999 * NOTE that EXACT is NOT covered here, as it is normally
6000 * picked up by the optimiser separately.
6002 * This is unfortunate as the optimiser isnt handling lookahead
6003 * properly currently.
6006 while ((OP(first) == OPEN && (sawopen = 1)) ||
6007 /* An OR of *one* alternative - should not happen now. */
6008 (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
6009 /* for now we can't handle lookbehind IFMATCH*/
6010 (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
6011 (OP(first) == PLUS) ||
6012 (OP(first) == MINMOD) ||
6013 /* An {n,m} with n>0 */
6014 (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
6015 (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
6018 * the only op that could be a regnode is PLUS, all the rest
6019 * will be regnode_1 or regnode_2.
6022 if (OP(first) == PLUS)
6025 first += regarglen[OP(first)];
6027 first = NEXTOPER(first);
6028 first_next= regnext(first);
6031 /* Starting-point info. */
6033 DEBUG_PEEP("first:",first,0);
6034 /* Ignore EXACT as we deal with it later. */
6035 if (PL_regkind[OP(first)] == EXACT) {
6036 if (OP(first) == EXACT)
6037 NOOP; /* Empty, get anchored substr later. */
6039 ri->regstclass = first;
6042 else if (PL_regkind[OP(first)] == TRIE &&
6043 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
6046 /* this can happen only on restudy */
6047 if ( OP(first) == TRIE ) {
6048 struct regnode_1 *trieop = (struct regnode_1 *)
6049 PerlMemShared_calloc(1, sizeof(struct regnode_1));
6050 StructCopy(first,trieop,struct regnode_1);
6051 trie_op=(regnode *)trieop;
6053 struct regnode_charclass *trieop = (struct regnode_charclass *)
6054 PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
6055 StructCopy(first,trieop,struct regnode_charclass);
6056 trie_op=(regnode *)trieop;
6059 make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
6060 ri->regstclass = trie_op;
6063 else if (REGNODE_SIMPLE(OP(first)))
6064 ri->regstclass = first;
6065 else if (PL_regkind[OP(first)] == BOUND ||
6066 PL_regkind[OP(first)] == NBOUND)
6067 ri->regstclass = first;
6068 else if (PL_regkind[OP(first)] == BOL) {
6069 r->extflags |= (OP(first) == MBOL
6071 : (OP(first) == SBOL
6074 first = NEXTOPER(first);
6077 else if (OP(first) == GPOS) {
6078 r->extflags |= RXf_ANCH_GPOS;
6079 first = NEXTOPER(first);
6082 else if ((!sawopen || !RExC_sawback) &&
6083 (OP(first) == STAR &&
6084 PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
6085 !(r->extflags & RXf_ANCH) && !pRExC_state->num_code_blocks)
6087 /* turn .* into ^.* with an implied $*=1 */
6089 (OP(NEXTOPER(first)) == REG_ANY)
6092 r->extflags |= type;
6093 r->intflags |= PREGf_IMPLICIT;
6094 first = NEXTOPER(first);
6097 if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
6098 && !pRExC_state->num_code_blocks) /* May examine pos and $& */
6099 /* x+ must match at the 1st pos of run of x's */
6100 r->intflags |= PREGf_SKIP;
6102 /* Scan is after the zeroth branch, first is atomic matcher. */
6103 #ifdef TRIE_STUDY_OPT
6106 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6107 (IV)(first - scan + 1))
6111 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
6112 (IV)(first - scan + 1))
6118 * If there's something expensive in the r.e., find the
6119 * longest literal string that must appear and make it the
6120 * regmust. Resolve ties in favor of later strings, since
6121 * the regstart check works with the beginning of the r.e.
6122 * and avoiding duplication strengthens checking. Not a
6123 * strong reason, but sufficient in the absence of others.
6124 * [Now we resolve ties in favor of the earlier string if
6125 * it happens that c_offset_min has been invalidated, since the
6126 * earlier string may buy us something the later one won't.]
6129 data.longest_fixed = newSVpvs("");
6130 data.longest_float = newSVpvs("");
6131 data.last_found = newSVpvs("");
6132 data.longest = &(data.longest_fixed);
6134 if (!ri->regstclass) {
6135 cl_init(pRExC_state, &ch_class);
6136 data.start_class = &ch_class;
6137 stclass_flag = SCF_DO_STCLASS_AND;
6138 } else /* XXXX Check for BOUND? */
6140 data.last_closep = &last_close;
6142 minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
6143 &data, -1, NULL, NULL,
6144 SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
6150 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
6151 && data.last_start_min == 0 && data.last_end > 0
6152 && !RExC_seen_zerolen
6153 && !(RExC_seen & REG_SEEN_VERBARG)
6154 && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
6155 r->extflags |= RXf_CHECK_ALL;
6156 scan_commit(pRExC_state, &data,&minlen,0);
6157 SvREFCNT_dec(data.last_found);
6159 /* Note that code very similar to this but for anchored string
6160 follows immediately below, changes may need to be made to both.
6163 longest_float_length = CHR_SVLEN(data.longest_float);
6164 if (longest_float_length
6165 || (data.flags & SF_FL_BEFORE_EOL
6166 && (!(data.flags & SF_FL_BEFORE_MEOL)
6167 || (RExC_flags & RXf_PMf_MULTILINE))))
6171 /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
6172 if ((RExC_seen & REG_SEEN_EXACTF_SHARP_S)
6173 || (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
6174 && data.offset_fixed == data.offset_float_min
6175 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
6176 goto remove_float; /* As in (a)+. */
6178 /* copy the information about the longest float from the reg_scan_data
6179 over to the program. */
6180 if (SvUTF8(data.longest_float)) {
6181 r->float_utf8 = data.longest_float;
6182 r->float_substr = NULL;
6184 r->float_substr = data.longest_float;
6185 r->float_utf8 = NULL;
6187 /* float_end_shift is how many chars that must be matched that
6188 follow this item. We calculate it ahead of time as once the
6189 lookbehind offset is added in we lose the ability to correctly
6191 ml = data.minlen_float ? *(data.minlen_float)
6192 : (I32)longest_float_length;
6193 r->float_end_shift = ml - data.offset_float_min
6194 - longest_float_length + (SvTAIL(data.longest_float) != 0)
6195 + data.lookbehind_float;
6196 r->float_min_offset = data.offset_float_min - data.lookbehind_float;
6197 r->float_max_offset = data.offset_float_max;
6198 if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
6199 r->float_max_offset -= data.lookbehind_float;
6201 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
6202 && (!(data.flags & SF_FL_BEFORE_MEOL)
6203 || (RExC_flags & RXf_PMf_MULTILINE)));
6204 fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
6208 r->float_substr = r->float_utf8 = NULL;
6209 SvREFCNT_dec(data.longest_float);
6210 longest_float_length = 0;
6213 /* Note that code very similar to this but for floating string
6214 is immediately above, changes may need to be made to both.
6217 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
6219 /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
6220 if (! (RExC_seen & REG_SEEN_EXACTF_SHARP_S)
6221 && (longest_fixed_length
6222 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
6223 && (!(data.flags & SF_FIX_BEFORE_MEOL)
6224 || (RExC_flags & RXf_PMf_MULTILINE)))) )
6228 /* copy the information about the longest fixed
6229 from the reg_scan_data over to the program. */
6230 if (SvUTF8(data.longest_fixed)) {
6231 r->anchored_utf8 = data.longest_fixed;
6232 r->anchored_substr = NULL;
6234 r->anchored_substr = data.longest_fixed;
6235 r->anchored_utf8 = NULL;
6237 /* fixed_end_shift is how many chars that must be matched that
6238 follow this item. We calculate it ahead of time as once the
6239 lookbehind offset is added in we lose the ability to correctly
6241 ml = data.minlen_fixed ? *(data.minlen_fixed)
6242 : (I32)longest_fixed_length;
6243 r->anchored_end_shift = ml - data.offset_fixed
6244 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
6245 + data.lookbehind_fixed;
6246 r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
6248 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
6249 && (!(data.flags & SF_FIX_BEFORE_MEOL)
6250 || (RExC_flags & RXf_PMf_MULTILINE)));
6251 fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
6254 r->anchored_substr = r->anchored_utf8 = NULL;
6255 SvREFCNT_dec(data.longest_fixed);
6256 longest_fixed_length = 0;
6259 && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
6260 ri->regstclass = NULL;
6262 if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
6264 && !(data.start_class->flags & ANYOF_EOS)
6265 && !cl_is_anything(data.start_class))
6267 const U32 n = add_data(pRExC_state, 1, "f");
6268 data.start_class->flags |= ANYOF_IS_SYNTHETIC;
6270 Newx(RExC_rxi->data->data[n], 1,
6271 struct regnode_charclass_class);
6272 StructCopy(data.start_class,
6273 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6274 struct regnode_charclass_class);
6275 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6276 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6277 DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
6278 regprop(r, sv, (regnode*)data.start_class);
6279 PerlIO_printf(Perl_debug_log,
6280 "synthetic stclass \"%s\".\n",
6281 SvPVX_const(sv));});
6284 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
6285 if (longest_fixed_length > longest_float_length) {
6286 r->check_end_shift = r->anchored_end_shift;
6287 r->check_substr = r->anchored_substr;
6288 r->check_utf8 = r->anchored_utf8;
6289 r->check_offset_min = r->check_offset_max = r->anchored_offset;
6290 if (r->extflags & RXf_ANCH_SINGLE)
6291 r->extflags |= RXf_NOSCAN;
6294 r->check_end_shift = r->float_end_shift;
6295 r->check_substr = r->float_substr;
6296 r->check_utf8 = r->float_utf8;
6297 r->check_offset_min = r->float_min_offset;
6298 r->check_offset_max = r->float_max_offset;
6300 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
6301 This should be changed ASAP! */
6302 if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
6303 r->extflags |= RXf_USE_INTUIT;
6304 if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
6305 r->extflags |= RXf_INTUIT_TAIL;
6307 /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
6308 if ( (STRLEN)minlen < longest_float_length )
6309 minlen= longest_float_length;
6310 if ( (STRLEN)minlen < longest_fixed_length )
6311 minlen= longest_fixed_length;
6315 /* Several toplevels. Best we can is to set minlen. */
6317 struct regnode_charclass_class ch_class;
6320 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
6322 scan = ri->program + 1;
6323 cl_init(pRExC_state, &ch_class);
6324 data.start_class = &ch_class;
6325 data.last_closep = &last_close;
6328 minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
6329 &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
6333 r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
6334 = r->float_substr = r->float_utf8 = NULL;
6336 if (!(data.start_class->flags & ANYOF_EOS)
6337 && !cl_is_anything(data.start_class))
6339 const U32 n = add_data(pRExC_state, 1, "f");
6340 data.start_class->flags |= ANYOF_IS_SYNTHETIC;
6342 Newx(RExC_rxi->data->data[n], 1,
6343 struct regnode_charclass_class);
6344 StructCopy(data.start_class,
6345 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
6346 struct regnode_charclass_class);
6347 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
6348 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
6349 DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
6350 regprop(r, sv, (regnode*)data.start_class);
6351 PerlIO_printf(Perl_debug_log,
6352 "synthetic stclass \"%s\".\n",
6353 SvPVX_const(sv));});
6357 /* Guard against an embedded (?=) or (?<=) with a longer minlen than
6358 the "real" pattern. */
6360 PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
6361 (IV)minlen, (IV)r->minlen);
6363 r->minlenret = minlen;
6364 if (r->minlen < minlen)
6367 if (RExC_seen & REG_SEEN_GPOS)
6368 r->extflags |= RXf_GPOS_SEEN;
6369 if (RExC_seen & REG_SEEN_LOOKBEHIND)
6370 r->extflags |= RXf_LOOKBEHIND_SEEN;
6371 if (pRExC_state->num_code_blocks)
6372 r->extflags |= RXf_EVAL_SEEN;
6373 if (RExC_seen & REG_SEEN_CANY)
6374 r->extflags |= RXf_CANY_SEEN;
6375 if (RExC_seen & REG_SEEN_VERBARG)
6376 r->intflags |= PREGf_VERBARG_SEEN;
6377 if (RExC_seen & REG_SEEN_CUTGROUP)
6378 r->intflags |= PREGf_CUTGROUP_SEEN;
6379 if (pm_flags & PMf_USE_RE_EVAL)
6380 r->intflags |= PREGf_USE_RE_EVAL;
6381 if (RExC_paren_names)
6382 RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
6384 RXp_PAREN_NAMES(r) = NULL;
6386 #ifdef STUPID_PATTERN_CHECKS
6387 if (RX_PRELEN(rx) == 0)
6388 r->extflags |= RXf_NULL;
6389 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
6390 /* XXX: this should happen BEFORE we compile */
6391 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
6392 else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
6393 r->extflags |= RXf_WHITE;
6394 else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
6395 r->extflags |= RXf_START_ONLY;
6397 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
6398 /* XXX: this should happen BEFORE we compile */
6399 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
6401 regnode *first = ri->program + 1;
6404 if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
6405 r->extflags |= RXf_NULL;
6406 else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
6407 r->extflags |= RXf_START_ONLY;
6408 else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
6409 && OP(regnext(first)) == END)
6410 r->extflags |= RXf_WHITE;
6414 if (RExC_paren_names) {
6415 ri->name_list_idx = add_data( pRExC_state, 1, "a" );
6416 ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
6419 ri->name_list_idx = 0;
6421 if (RExC_recurse_count) {
6422 for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
6423 const regnode *scan = RExC_recurse[RExC_recurse_count-1];
6424 ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
6427 Newxz(r->offs, RExC_npar, regexp_paren_pair);
6428 /* assume we don't need to swap parens around before we match */
6431 PerlIO_printf(Perl_debug_log,"Final program:\n");
6434 #ifdef RE_TRACK_PATTERN_OFFSETS
6435 DEBUG_OFFSETS_r(if (ri->u.offsets) {
6436 const U32 len = ri->u.offsets[0];
6438 GET_RE_DEBUG_FLAGS_DECL;
6439 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
6440 for (i = 1; i <= len; i++) {
6441 if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
6442 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
6443 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
6445 PerlIO_printf(Perl_debug_log, "\n");
6453 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
6456 PERL_ARGS_ASSERT_REG_NAMED_BUFF;
6458 PERL_UNUSED_ARG(value);
6460 if (flags & RXapif_FETCH) {
6461 return reg_named_buff_fetch(rx, key, flags);
6462 } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
6463 Perl_croak_no_modify(aTHX);
6465 } else if (flags & RXapif_EXISTS) {
6466 return reg_named_buff_exists(rx, key, flags)
6469 } else if (flags & RXapif_REGNAMES) {
6470 return reg_named_buff_all(rx, flags);
6471 } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
6472 return reg_named_buff_scalar(rx, flags);
6474 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
6480 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
6483 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
6484 PERL_UNUSED_ARG(lastkey);
6486 if (flags & RXapif_FIRSTKEY)
6487 return reg_named_buff_firstkey(rx, flags);
6488 else if (flags & RXapif_NEXTKEY)
6489 return reg_named_buff_nextkey(rx, flags);
6491 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
6497 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
6500 AV *retarray = NULL;
6502 struct regexp *const rx = (struct regexp *)SvANY(r);
6504 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
6506 if (flags & RXapif_ALL)
6509 if (rx && RXp_PAREN_NAMES(rx)) {
6510 HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
6513 SV* sv_dat=HeVAL(he_str);
6514 I32 *nums=(I32*)SvPVX(sv_dat);
6515 for ( i=0; i<SvIVX(sv_dat); i++ ) {
6516 if ((I32)(rx->nparens) >= nums[i]
6517 && rx->offs[nums[i]].start != -1
6518 && rx->offs[nums[i]].end != -1)
6521 CALLREG_NUMBUF_FETCH(r,nums[i],ret);
6526 ret = newSVsv(&PL_sv_undef);
6529 av_push(retarray, ret);
6532 return newRV_noinc(MUTABLE_SV(retarray));
6539 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
6542 struct regexp *const rx = (struct regexp *)SvANY(r);
6544 PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
6546 if (rx && RXp_PAREN_NAMES(rx)) {
6547 if (flags & RXapif_ALL) {
6548 return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
6550 SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
6564 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
6566 struct regexp *const rx = (struct regexp *)SvANY(r);
6568 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
6570 if ( rx && RXp_PAREN_NAMES(rx) ) {
6571 (void)hv_iterinit(RXp_PAREN_NAMES(rx));
6573 return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
6580 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
6582 struct regexp *const rx = (struct regexp *)SvANY(r);
6583 GET_RE_DEBUG_FLAGS_DECL;
6585 PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
6587 if (rx && RXp_PAREN_NAMES(rx)) {
6588 HV *hv = RXp_PAREN_NAMES(rx);
6590 while ( (temphe = hv_iternext_flags(hv,0)) ) {
6593 SV* sv_dat = HeVAL(temphe);
6594 I32 *nums = (I32*)SvPVX(sv_dat);
6595 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6596 if ((I32)(rx->lastparen) >= nums[i] &&
6597 rx->offs[nums[i]].start != -1 &&
6598 rx->offs[nums[i]].end != -1)
6604 if (parno || flags & RXapif_ALL) {
6605 return newSVhek(HeKEY_hek(temphe));
6613 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
6618 struct regexp *const rx = (struct regexp *)SvANY(r);
6620 PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
6622 if (rx && RXp_PAREN_NAMES(rx)) {
6623 if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
6624 return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
6625 } else if (flags & RXapif_ONE) {
6626 ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
6627 av = MUTABLE_AV(SvRV(ret));
6628 length = av_len(av);
6630 return newSViv(length + 1);
6632 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
6636 return &PL_sv_undef;
6640 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
6642 struct regexp *const rx = (struct regexp *)SvANY(r);
6645 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
6647 if (rx && RXp_PAREN_NAMES(rx)) {
6648 HV *hv= RXp_PAREN_NAMES(rx);
6650 (void)hv_iterinit(hv);
6651 while ( (temphe = hv_iternext_flags(hv,0)) ) {
6654 SV* sv_dat = HeVAL(temphe);
6655 I32 *nums = (I32*)SvPVX(sv_dat);
6656 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
6657 if ((I32)(rx->lastparen) >= nums[i] &&
6658 rx->offs[nums[i]].start != -1 &&
6659 rx->offs[nums[i]].end != -1)
6665 if (parno || flags & RXapif_ALL) {
6666 av_push(av, newSVhek(HeKEY_hek(temphe)));
6671 return newRV_noinc(MUTABLE_SV(av));
6675 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
6678 struct regexp *const rx = (struct regexp *)SvANY(r);
6683 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
6686 sv_setsv(sv,&PL_sv_undef);
6690 if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
6692 i = rx->offs[0].start;
6696 if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
6698 s = rx->subbeg + rx->offs[0].end;
6699 i = rx->sublen - rx->offs[0].end;
6702 if ( 0 <= paren && paren <= (I32)rx->nparens &&
6703 (s1 = rx->offs[paren].start) != -1 &&
6704 (t1 = rx->offs[paren].end) != -1)
6708 s = rx->subbeg + s1;
6710 sv_setsv(sv,&PL_sv_undef);
6713 assert(rx->sublen >= (s - rx->subbeg) + i );
6715 const int oldtainted = PL_tainted;
6717 sv_setpvn(sv, s, i);
6718 PL_tainted = oldtainted;
6719 if ( (rx->extflags & RXf_CANY_SEEN)
6720 ? (RXp_MATCH_UTF8(rx)
6721 && (!i || is_utf8_string((U8*)s, i)))
6722 : (RXp_MATCH_UTF8(rx)) )
6729 if (RXp_MATCH_TAINTED(rx)) {
6730 if (SvTYPE(sv) >= SVt_PVMG) {
6731 MAGIC* const mg = SvMAGIC(sv);
6734 SvMAGIC_set(sv, mg->mg_moremagic);
6736 if ((mgt = SvMAGIC(sv))) {
6737 mg->mg_moremagic = mgt;
6738 SvMAGIC_set(sv, mg);
6748 sv_setsv(sv,&PL_sv_undef);
6754 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6755 SV const * const value)
6757 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6759 PERL_UNUSED_ARG(rx);
6760 PERL_UNUSED_ARG(paren);
6761 PERL_UNUSED_ARG(value);
6764 Perl_croak_no_modify(aTHX);
6768 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6771 struct regexp *const rx = (struct regexp *)SvANY(r);
6775 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6777 /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6779 /* $` / ${^PREMATCH} */
6780 case RX_BUFF_IDX_PREMATCH:
6781 if (rx->offs[0].start != -1) {
6782 i = rx->offs[0].start;
6790 /* $' / ${^POSTMATCH} */
6791 case RX_BUFF_IDX_POSTMATCH:
6792 if (rx->offs[0].end != -1) {
6793 i = rx->sublen - rx->offs[0].end;
6795 s1 = rx->offs[0].end;
6801 /* $& / ${^MATCH}, $1, $2, ... */
6803 if (paren <= (I32)rx->nparens &&
6804 (s1 = rx->offs[paren].start) != -1 &&
6805 (t1 = rx->offs[paren].end) != -1)
6810 if (ckWARN(WARN_UNINITIALIZED))
6811 report_uninit((const SV *)sv);
6816 if (i > 0 && RXp_MATCH_UTF8(rx)) {
6817 const char * const s = rx->subbeg + s1;
6822 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6829 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6831 PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6832 PERL_UNUSED_ARG(rx);
6836 return newSVpvs("Regexp");
6839 /* Scans the name of a named buffer from the pattern.
6840 * If flags is REG_RSN_RETURN_NULL returns null.
6841 * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6842 * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6843 * to the parsed name as looked up in the RExC_paren_names hash.
6844 * If there is an error throws a vFAIL().. type exception.
6847 #define REG_RSN_RETURN_NULL 0
6848 #define REG_RSN_RETURN_NAME 1
6849 #define REG_RSN_RETURN_DATA 2
6852 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6854 char *name_start = RExC_parse;
6856 PERL_ARGS_ASSERT_REG_SCAN_NAME;
6858 if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6859 /* skip IDFIRST by using do...while */
6862 RExC_parse += UTF8SKIP(RExC_parse);
6863 } while (isALNUM_utf8((U8*)RExC_parse));
6867 } while (isALNUM(*RExC_parse));
6872 = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6873 SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6874 if ( flags == REG_RSN_RETURN_NAME)
6876 else if (flags==REG_RSN_RETURN_DATA) {
6879 if ( ! sv_name ) /* should not happen*/
6880 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6881 if (RExC_paren_names)
6882 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6884 sv_dat = HeVAL(he_str);
6886 vFAIL("Reference to nonexistent named group");
6890 Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6891 (unsigned long) flags);
6893 assert(0); /* NOT REACHED */
6898 #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
6899 int rem=(int)(RExC_end - RExC_parse); \
6908 if (RExC_lastparse!=RExC_parse) \
6909 PerlIO_printf(Perl_debug_log," >%.*s%-*s", \
6912 iscut ? "..." : "<" \
6915 PerlIO_printf(Perl_debug_log,"%16s",""); \
6918 num = RExC_size + 1; \
6920 num=REG_NODE_NUM(RExC_emit); \
6921 if (RExC_lastnum!=num) \
6922 PerlIO_printf(Perl_debug_log,"|%4d",num); \
6924 PerlIO_printf(Perl_debug_log,"|%4s",""); \
6925 PerlIO_printf(Perl_debug_log,"|%*s%-4s", \
6926 (int)((depth*2)), "", \
6930 RExC_lastparse=RExC_parse; \
6935 #define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
6936 DEBUG_PARSE_MSG((funcname)); \
6937 PerlIO_printf(Perl_debug_log,"%4s","\n"); \
6939 #define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({ \
6940 DEBUG_PARSE_MSG((funcname)); \
6941 PerlIO_printf(Perl_debug_log,fmt "\n",args); \
6944 /* This section of code defines the inversion list object and its methods. The
6945 * interfaces are highly subject to change, so as much as possible is static to
6946 * this file. An inversion list is here implemented as a malloc'd C UV array
6947 * with some added info that is placed as UVs at the beginning in a header
6948 * portion. An inversion list for Unicode is an array of code points, sorted
6949 * by ordinal number. The zeroth element is the first code point in the list.
6950 * The 1th element is the first element beyond that not in the list. In other
6951 * words, the first range is
6952 * invlist[0]..(invlist[1]-1)
6953 * The other ranges follow. Thus every element whose index is divisible by two
6954 * marks the beginning of a range that is in the list, and every element not
6955 * divisible by two marks the beginning of a range not in the list. A single
6956 * element inversion list that contains the single code point N generally
6957 * consists of two elements
6960 * (The exception is when N is the highest representable value on the
6961 * machine, in which case the list containing just it would be a single
6962 * element, itself. By extension, if the last range in the list extends to
6963 * infinity, then the first element of that range will be in the inversion list
6964 * at a position that is divisible by two, and is the final element in the
6966 * Taking the complement (inverting) an inversion list is quite simple, if the
6967 * first element is 0, remove it; otherwise add a 0 element at the beginning.
6968 * This implementation reserves an element at the beginning of each inversion list
6969 * to contain 0 when the list contains 0, and contains 1 otherwise. The actual
6970 * beginning of the list is either that element if 0, or the next one if 1.
6972 * More about inversion lists can be found in "Unicode Demystified"
6973 * Chapter 13 by Richard Gillam, published by Addison-Wesley.
6974 * More will be coming when functionality is added later.
6976 * The inversion list data structure is currently implemented as an SV pointing
6977 * to an array of UVs that the SV thinks are bytes. This allows us to have an
6978 * array of UV whose memory management is automatically handled by the existing
6979 * facilities for SV's.
6981 * Some of the methods should always be private to the implementation, and some
6982 * should eventually be made public */
6984 #define INVLIST_LEN_OFFSET 0 /* Number of elements in the inversion list */
6985 #define INVLIST_ITER_OFFSET 1 /* Current iteration position */
6987 /* This is a combination of a version and data structure type, so that one
6988 * being passed in can be validated to be an inversion list of the correct
6989 * vintage. When the structure of the header is changed, a new random number
6990 * in the range 2**31-1 should be generated and the new() method changed to
6991 * insert that at this location. Then, if an auxiliary program doesn't change
6992 * correspondingly, it will be discovered immediately */
6993 #define INVLIST_VERSION_ID_OFFSET 2
6994 #define INVLIST_VERSION_ID 1064334010
6996 /* For safety, when adding new elements, remember to #undef them at the end of
6997 * the inversion list code section */
6999 #define INVLIST_ZERO_OFFSET 3 /* 0 or 1; must be last element in header */
7000 /* The UV at position ZERO contains either 0 or 1. If 0, the inversion list
7001 * contains the code point U+00000, and begins here. If 1, the inversion list
7002 * doesn't contain U+0000, and it begins at the next UV in the array.
7003 * Inverting an inversion list consists of adding or removing the 0 at the
7004 * beginning of it. By reserving a space for that 0, inversion can be made
7007 #define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
7009 /* Internally things are UVs */
7010 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
7011 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
7013 #define INVLIST_INITIAL_LEN 10
7015 PERL_STATIC_INLINE UV*
7016 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
7018 /* Returns a pointer to the first element in the inversion list's array.
7019 * This is called upon initialization of an inversion list. Where the
7020 * array begins depends on whether the list has the code point U+0000
7021 * in it or not. The other parameter tells it whether the code that
7022 * follows this call is about to put a 0 in the inversion list or not.
7023 * The first element is either the element with 0, if 0, or the next one,
7026 UV* zero = get_invlist_zero_addr(invlist);
7028 PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
7031 assert(! *get_invlist_len_addr(invlist));
7033 /* 1^1 = 0; 1^0 = 1 */
7034 *zero = 1 ^ will_have_0;
7035 return zero + *zero;
7038 PERL_STATIC_INLINE UV*
7039 S_invlist_array(pTHX_ SV* const invlist)
7041 /* Returns the pointer to the inversion list's array. Every time the
7042 * length changes, this needs to be called in case malloc or realloc moved
7045 PERL_ARGS_ASSERT_INVLIST_ARRAY;
7047 /* Must not be empty. If these fail, you probably didn't check for <len>
7048 * being non-zero before trying to get the array */
7049 assert(*get_invlist_len_addr(invlist));
7050 assert(*get_invlist_zero_addr(invlist) == 0
7051 || *get_invlist_zero_addr(invlist) == 1);
7053 /* The array begins either at the element reserved for zero if the
7054 * list contains 0 (that element will be set to 0), or otherwise the next
7055 * element (in which case the reserved element will be set to 1). */
7056 return (UV *) (get_invlist_zero_addr(invlist)
7057 + *get_invlist_zero_addr(invlist));
7060 PERL_STATIC_INLINE UV*
7061 S_get_invlist_len_addr(pTHX_ SV* invlist)
7063 /* Return the address of the UV that contains the current number
7064 * of used elements in the inversion list */
7066 PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
7068 return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
7071 PERL_STATIC_INLINE UV
7072 S_invlist_len(pTHX_ SV* const invlist)
7074 /* Returns the current number of elements stored in the inversion list's
7077 PERL_ARGS_ASSERT_INVLIST_LEN;
7079 return *get_invlist_len_addr(invlist);
7082 PERL_STATIC_INLINE void
7083 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
7085 /* Sets the current number of elements stored in the inversion list */
7087 PERL_ARGS_ASSERT_INVLIST_SET_LEN;
7089 *get_invlist_len_addr(invlist) = len;
7091 assert(len <= SvLEN(invlist));
7093 SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
7094 /* If the list contains U+0000, that element is part of the header,
7095 * and should not be counted as part of the array. It will contain
7096 * 0 in that case, and 1 otherwise. So we could flop 0=>1, 1=>0 and
7098 * SvCUR_set(invlist,
7099 * TO_INTERNAL_SIZE(len
7100 * - (*get_invlist_zero_addr(inv_list) ^ 1)));
7101 * But, this is only valid if len is not 0. The consequences of not doing
7102 * this is that the memory allocation code may think that 1 more UV is
7103 * being used than actually is, and so might do an unnecessary grow. That
7104 * seems worth not bothering to make this the precise amount.
7106 * Note that when inverting, SvCUR shouldn't change */
7109 PERL_STATIC_INLINE UV
7110 S_invlist_max(pTHX_ SV* const invlist)
7112 /* Returns the maximum number of elements storable in the inversion list's
7113 * array, without having to realloc() */
7115 PERL_ARGS_ASSERT_INVLIST_MAX;
7117 return FROM_INTERNAL_SIZE(SvLEN(invlist));
7120 PERL_STATIC_INLINE UV*
7121 S_get_invlist_zero_addr(pTHX_ SV* invlist)
7123 /* Return the address of the UV that is reserved to hold 0 if the inversion
7124 * list contains 0. This has to be the last element of the heading, as the
7125 * list proper starts with either it if 0, or the next element if not.
7126 * (But we force it to contain either 0 or 1) */
7128 PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
7130 return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
7133 #ifndef PERL_IN_XSUB_RE
7135 Perl__new_invlist(pTHX_ IV initial_size)
7138 /* Return a pointer to a newly constructed inversion list, with enough
7139 * space to store 'initial_size' elements. If that number is negative, a
7140 * system default is used instead */
7144 if (initial_size < 0) {
7145 initial_size = INVLIST_INITIAL_LEN;
7148 /* Allocate the initial space */
7149 new_list = newSV(TO_INTERNAL_SIZE(initial_size));
7150 invlist_set_len(new_list, 0);
7152 /* Force iterinit() to be used to get iteration to work */
7153 *get_invlist_iter_addr(new_list) = UV_MAX;
7155 /* This should force a segfault if a method doesn't initialize this
7157 *get_invlist_zero_addr(new_list) = UV_MAX;
7159 *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
7160 #if HEADER_LENGTH != 4
7161 # 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
7169 S__new_invlist_C_array(pTHX_ UV* list)
7171 /* Return a pointer to a newly constructed inversion list, initialized to
7172 * point to <list>, which has to be in the exact correct inversion list
7173 * form, including internal fields. Thus this is a dangerous routine that
7174 * should not be used in the wrong hands */
7176 SV* invlist = newSV_type(SVt_PV);
7178 PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
7180 SvPV_set(invlist, (char *) list);
7181 SvLEN_set(invlist, 0); /* Means we own the contents, and the system
7182 shouldn't touch it */
7183 SvCUR_set(invlist, TO_INTERNAL_SIZE(invlist_len(invlist)));
7185 if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
7186 Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
7193 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
7195 /* Grow the maximum size of an inversion list */
7197 PERL_ARGS_ASSERT_INVLIST_EXTEND;
7199 SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
7202 PERL_STATIC_INLINE void
7203 S_invlist_trim(pTHX_ SV* const invlist)
7205 PERL_ARGS_ASSERT_INVLIST_TRIM;
7207 /* Change the length of the inversion list to how many entries it currently
7210 SvPV_shrink_to_cur((SV *) invlist);
7213 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
7215 #define ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
7216 #define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(i))
7218 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
7221 S__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
7223 /* Subject to change or removal. Append the range from 'start' to 'end' at
7224 * the end of the inversion list. The range must be above any existing
7228 UV max = invlist_max(invlist);
7229 UV len = invlist_len(invlist);
7231 PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
7233 if (len == 0) { /* Empty lists must be initialized */
7234 array = _invlist_array_init(invlist, start == 0);
7237 /* Here, the existing list is non-empty. The current max entry in the
7238 * list is generally the first value not in the set, except when the
7239 * set extends to the end of permissible values, in which case it is
7240 * the first entry in that final set, and so this call is an attempt to
7241 * append out-of-order */
7243 UV final_element = len - 1;
7244 array = invlist_array(invlist);
7245 if (array[final_element] > start
7246 || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
7248 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",
7249 array[final_element], start,
7250 ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
7253 /* Here, it is a legal append. If the new range begins with the first
7254 * value not in the set, it is extending the set, so the new first
7255 * value not in the set is one greater than the newly extended range.
7257 if (array[final_element] == start) {
7258 if (end != UV_MAX) {
7259 array[final_element] = end + 1;
7262 /* But if the end is the maximum representable on the machine,
7263 * just let the range that this would extend to have no end */
7264 invlist_set_len(invlist, len - 1);
7270 /* Here the new range doesn't extend any existing set. Add it */
7272 len += 2; /* Includes an element each for the start and end of range */
7274 /* If overflows the existing space, extend, which may cause the array to be
7277 invlist_extend(invlist, len);
7278 invlist_set_len(invlist, len); /* Have to set len here to avoid assert
7279 failure in invlist_array() */
7280 array = invlist_array(invlist);
7283 invlist_set_len(invlist, len);
7286 /* The next item on the list starts the range, the one after that is
7287 * one past the new range. */
7288 array[len - 2] = start;
7289 if (end != UV_MAX) {
7290 array[len - 1] = end + 1;
7293 /* But if the end is the maximum representable on the machine, just let
7294 * the range have no end */
7295 invlist_set_len(invlist, len - 1);
7299 #ifndef PERL_IN_XSUB_RE
7302 S_invlist_search(pTHX_ SV* const invlist, const UV cp)
7304 /* Searches the inversion list for the entry that contains the input code
7305 * point <cp>. If <cp> is not in the list, -1 is returned. Otherwise, the
7306 * return value is the index into the list's array of the range that
7310 IV high = invlist_len(invlist);
7311 const UV * const array = invlist_array(invlist);
7313 PERL_ARGS_ASSERT_INVLIST_SEARCH;
7315 /* If list is empty or the code point is before the first element, return
7317 if (high == 0 || cp < array[0]) {
7321 /* Binary search. What we are looking for is <i> such that
7322 * array[i] <= cp < array[i+1]
7323 * The loop below converges on the i+1. */
7324 while (low < high) {
7325 IV mid = (low + high) / 2;
7326 if (array[mid] <= cp) {
7329 /* We could do this extra test to exit the loop early.
7330 if (cp < array[low]) {
7335 else { /* cp < array[mid] */
7344 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
7346 /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
7347 * but is used when the swash has an inversion list. This makes this much
7348 * faster, as it uses a binary search instead of a linear one. This is
7349 * intimately tied to that function, and perhaps should be in utf8.c,
7350 * except it is intimately tied to inversion lists as well. It assumes
7351 * that <swatch> is all 0's on input */
7354 const IV len = invlist_len(invlist);
7358 PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
7360 if (len == 0) { /* Empty inversion list */
7364 array = invlist_array(invlist);
7366 /* Find which element it is */
7367 i = invlist_search(invlist, start);
7369 /* We populate from <start> to <end> */
7370 while (current < end) {
7373 /* The inversion list gives the results for every possible code point
7374 * after the first one in the list. Only those ranges whose index is
7375 * even are ones that the inversion list matches. For the odd ones,
7376 * and if the initial code point is not in the list, we have to skip
7377 * forward to the next element */
7378 if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
7380 if (i >= len) { /* Finished if beyond the end of the array */
7384 if (current >= end) { /* Finished if beyond the end of what we
7389 assert(current >= start);
7391 /* The current range ends one below the next one, except don't go past
7394 upper = (i < len && array[i] < end) ? array[i] : end;
7396 /* Here we are in a range that matches. Populate a bit in the 3-bit U8
7397 * for each code point in it */
7398 for (; current < upper; current++) {
7399 const STRLEN offset = (STRLEN)(current - start);
7400 swatch[offset >> 3] |= 1 << (offset & 7);
7403 /* Quit if at the end of the list */
7406 /* But first, have to deal with the highest possible code point on
7407 * the platform. The previous code assumes that <end> is one
7408 * beyond where we want to populate, but that is impossible at the
7409 * platform's infinity, so have to handle it specially */
7410 if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
7412 const STRLEN offset = (STRLEN)(end - start);
7413 swatch[offset >> 3] |= 1 << (offset & 7);
7418 /* Advance to the next range, which will be for code points not in the
7428 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
7430 /* Take the union of two inversion lists and point <output> to it. *output
7431 * should be defined upon input, and if it points to one of the two lists,
7432 * the reference count to that list will be decremented. The first list,
7433 * <a>, may be NULL, in which case a copy of the second list is returned.
7434 * If <complement_b> is TRUE, the union is taken of the complement
7435 * (inversion) of <b> instead of b itself.
7437 * The basis for this comes from "Unicode Demystified" Chapter 13 by
7438 * Richard Gillam, published by Addison-Wesley, and explained at some
7439 * length there. The preface says to incorporate its examples into your
7440 * code at your own risk.
7442 * The algorithm is like a merge sort.
7444 * XXX A potential performance improvement is to keep track as we go along
7445 * if only one of the inputs contributes to the result, meaning the other
7446 * is a subset of that one. In that case, we can skip the final copy and
7447 * return the larger of the input lists, but then outside code might need
7448 * to keep track of whether to free the input list or not */
7450 UV* array_a; /* a's array */
7452 UV len_a; /* length of a's array */
7455 SV* u; /* the resulting union */
7459 UV i_a = 0; /* current index into a's array */
7463 /* running count, as explained in the algorithm source book; items are
7464 * stopped accumulating and are output when the count changes to/from 0.
7465 * The count is incremented when we start a range that's in the set, and
7466 * decremented when we start a range that's not in the set. So its range
7467 * is 0 to 2. Only when the count is zero is something not in the set.
7471 PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
7474 /* If either one is empty, the union is the other one */
7475 if (a == NULL || ((len_a = invlist_len(a)) == 0)) {
7482 *output = invlist_clone(b);
7484 _invlist_invert(*output);
7486 } /* else *output already = b; */
7489 else if ((len_b = invlist_len(b)) == 0) {
7494 /* The complement of an empty list is a list that has everything in it,
7495 * so the union with <a> includes everything too */
7500 *output = _new_invlist(1);
7501 _append_range_to_invlist(*output, 0, UV_MAX);
7503 else if (*output != a) {
7504 *output = invlist_clone(a);
7506 /* else *output already = a; */
7510 /* Here both lists exist and are non-empty */
7511 array_a = invlist_array(a);
7512 array_b = invlist_array(b);
7514 /* If are to take the union of 'a' with the complement of b, set it
7515 * up so are looking at b's complement. */
7518 /* To complement, we invert: if the first element is 0, remove it. To
7519 * do this, we just pretend the array starts one later, and clear the
7520 * flag as we don't have to do anything else later */
7521 if (array_b[0] == 0) {
7524 complement_b = FALSE;
7528 /* But if the first element is not zero, we unshift a 0 before the
7529 * array. The data structure reserves a space for that 0 (which
7530 * should be a '1' right now), so physical shifting is unneeded,
7531 * but temporarily change that element to 0. Before exiting the
7532 * routine, we must restore the element to '1' */
7539 /* Size the union for the worst case: that the sets are completely
7541 u = _new_invlist(len_a + len_b);
7543 /* Will contain U+0000 if either component does */
7544 array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
7545 || (len_b > 0 && array_b[0] == 0));
7547 /* Go through each list item by item, stopping when exhausted one of
7549 while (i_a < len_a && i_b < len_b) {
7550 UV cp; /* The element to potentially add to the union's array */
7551 bool cp_in_set; /* is it in the the input list's set or not */
7553 /* We need to take one or the other of the two inputs for the union.
7554 * Since we are merging two sorted lists, we take the smaller of the
7555 * next items. In case of a tie, we take the one that is in its set
7556 * first. If we took one not in the set first, it would decrement the
7557 * count, possibly to 0 which would cause it to be output as ending the
7558 * range, and the next time through we would take the same number, and
7559 * output it again as beginning the next range. By doing it the
7560 * opposite way, there is no possibility that the count will be
7561 * momentarily decremented to 0, and thus the two adjoining ranges will
7562 * be seamlessly merged. (In a tie and both are in the set or both not
7563 * in the set, it doesn't matter which we take first.) */
7564 if (array_a[i_a] < array_b[i_b]
7565 || (array_a[i_a] == array_b[i_b]
7566 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7568 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7572 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7576 /* Here, have chosen which of the two inputs to look at. Only output
7577 * if the running count changes to/from 0, which marks the
7578 * beginning/end of a range in that's in the set */
7581 array_u[i_u++] = cp;
7588 array_u[i_u++] = cp;
7593 /* Here, we are finished going through at least one of the lists, which
7594 * means there is something remaining in at most one. We check if the list
7595 * that hasn't been exhausted is positioned such that we are in the middle
7596 * of a range in its set or not. (i_a and i_b point to the element beyond
7597 * the one we care about.) If in the set, we decrement 'count'; if 0, there
7598 * is potentially more to output.
7599 * There are four cases:
7600 * 1) Both weren't in their sets, count is 0, and remains 0. What's left
7601 * in the union is entirely from the non-exhausted set.
7602 * 2) Both were in their sets, count is 2. Nothing further should
7603 * be output, as everything that remains will be in the exhausted
7604 * list's set, hence in the union; decrementing to 1 but not 0 insures
7606 * 3) the exhausted was in its set, non-exhausted isn't, count is 1.
7607 * Nothing further should be output because the union includes
7608 * everything from the exhausted set. Not decrementing ensures that.
7609 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
7610 * decrementing to 0 insures that we look at the remainder of the
7611 * non-exhausted set */
7612 if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7613 || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7618 /* The final length is what we've output so far, plus what else is about to
7619 * be output. (If 'count' is non-zero, then the input list we exhausted
7620 * has everything remaining up to the machine's limit in its set, and hence
7621 * in the union, so there will be no further output. */
7624 /* At most one of the subexpressions will be non-zero */
7625 len_u += (len_a - i_a) + (len_b - i_b);
7628 /* Set result to final length, which can change the pointer to array_u, so
7630 if (len_u != invlist_len(u)) {
7631 invlist_set_len(u, len_u);
7633 array_u = invlist_array(u);
7636 /* When 'count' is 0, the list that was exhausted (if one was shorter than
7637 * the other) ended with everything above it not in its set. That means
7638 * that the remaining part of the union is precisely the same as the
7639 * non-exhausted list, so can just copy it unchanged. (If both list were
7640 * exhausted at the same time, then the operations below will be both 0.)
7643 IV copy_count; /* At most one will have a non-zero copy count */
7644 if ((copy_count = len_a - i_a) > 0) {
7645 Copy(array_a + i_a, array_u + i_u, copy_count, UV);
7647 else if ((copy_count = len_b - i_b) > 0) {
7648 Copy(array_b + i_b, array_u + i_u, copy_count, UV);
7652 /* We may be removing a reference to one of the inputs */
7653 if (a == *output || b == *output) {
7654 SvREFCNT_dec(*output);
7657 /* If we've changed b, restore it */
7667 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
7669 /* Take the intersection of two inversion lists and point <i> to it. *i
7670 * should be defined upon input, and if it points to one of the two lists,
7671 * the reference count to that list will be decremented.
7672 * If <complement_b> is TRUE, the result will be the intersection of <a>
7673 * and the complement (or inversion) of <b> instead of <b> directly.
7675 * The basis for this comes from "Unicode Demystified" Chapter 13 by
7676 * Richard Gillam, published by Addison-Wesley, and explained at some
7677 * length there. The preface says to incorporate its examples into your
7678 * code at your own risk. In fact, it had bugs
7680 * The algorithm is like a merge sort, and is essentially the same as the
7684 UV* array_a; /* a's array */
7686 UV len_a; /* length of a's array */
7689 SV* r; /* the resulting intersection */
7693 UV i_a = 0; /* current index into a's array */
7697 /* running count, as explained in the algorithm source book; items are
7698 * stopped accumulating and are output when the count changes to/from 2.
7699 * The count is incremented when we start a range that's in the set, and
7700 * decremented when we start a range that's not in the set. So its range
7701 * is 0 to 2. Only when the count is 2 is something in the intersection.
7705 PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7708 /* Special case if either one is empty */
7709 len_a = invlist_len(a);
7710 if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
7712 if (len_a != 0 && complement_b) {
7714 /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7715 * be empty. Here, also we are using 'b's complement, which hence
7716 * must be every possible code point. Thus the intersection is
7719 *i = invlist_clone(a);
7725 /* else *i is already 'a' */
7729 /* Here, 'a' or 'b' is empty and not using the complement of 'b'. The
7730 * intersection must be empty */
7737 *i = _new_invlist(0);
7741 /* Here both lists exist and are non-empty */
7742 array_a = invlist_array(a);
7743 array_b = invlist_array(b);
7745 /* If are to take the intersection of 'a' with the complement of b, set it
7746 * up so are looking at b's complement. */
7749 /* To complement, we invert: if the first element is 0, remove it. To
7750 * do this, we just pretend the array starts one later, and clear the
7751 * flag as we don't have to do anything else later */
7752 if (array_b[0] == 0) {
7755 complement_b = FALSE;
7759 /* But if the first element is not zero, we unshift a 0 before the
7760 * array. The data structure reserves a space for that 0 (which
7761 * should be a '1' right now), so physical shifting is unneeded,
7762 * but temporarily change that element to 0. Before exiting the
7763 * routine, we must restore the element to '1' */
7770 /* Size the intersection for the worst case: that the intersection ends up
7771 * fragmenting everything to be completely disjoint */
7772 r= _new_invlist(len_a + len_b);
7774 /* Will contain U+0000 iff both components do */
7775 array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7776 && len_b > 0 && array_b[0] == 0);
7778 /* Go through each list item by item, stopping when exhausted one of
7780 while (i_a < len_a && i_b < len_b) {
7781 UV cp; /* The element to potentially add to the intersection's
7783 bool cp_in_set; /* Is it in the input list's set or not */
7785 /* We need to take one or the other of the two inputs for the
7786 * intersection. Since we are merging two sorted lists, we take the
7787 * smaller of the next items. In case of a tie, we take the one that
7788 * is not in its set first (a difference from the union algorithm). If
7789 * we took one in the set first, it would increment the count, possibly
7790 * to 2 which would cause it to be output as starting a range in the
7791 * intersection, and the next time through we would take that same
7792 * number, and output it again as ending the set. By doing it the
7793 * opposite of this, there is no possibility that the count will be
7794 * momentarily incremented to 2. (In a tie and both are in the set or
7795 * both not in the set, it doesn't matter which we take first.) */
7796 if (array_a[i_a] < array_b[i_b]
7797 || (array_a[i_a] == array_b[i_b]
7798 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7800 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7804 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7808 /* Here, have chosen which of the two inputs to look at. Only output
7809 * if the running count changes to/from 2, which marks the
7810 * beginning/end of a range that's in the intersection */
7814 array_r[i_r++] = cp;
7819 array_r[i_r++] = cp;
7825 /* Here, we are finished going through at least one of the lists, which
7826 * means there is something remaining in at most one. We check if the list
7827 * that has been exhausted is positioned such that we are in the middle
7828 * of a range in its set or not. (i_a and i_b point to elements 1 beyond
7829 * the ones we care about.) There are four cases:
7830 * 1) Both weren't in their sets, count is 0, and remains 0. There's
7831 * nothing left in the intersection.
7832 * 2) Both were in their sets, count is 2 and perhaps is incremented to
7833 * above 2. What should be output is exactly that which is in the
7834 * non-exhausted set, as everything it has is also in the intersection
7835 * set, and everything it doesn't have can't be in the intersection
7836 * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7837 * gets incremented to 2. Like the previous case, the intersection is
7838 * everything that remains in the non-exhausted set.
7839 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7840 * remains 1. And the intersection has nothing more. */
7841 if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7842 || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7847 /* The final length is what we've output so far plus what else is in the
7848 * intersection. At most one of the subexpressions below will be non-zero */
7851 len_r += (len_a - i_a) + (len_b - i_b);
7854 /* Set result to final length, which can change the pointer to array_r, so
7856 if (len_r != invlist_len(r)) {
7857 invlist_set_len(r, len_r);
7859 array_r = invlist_array(r);
7862 /* Finish outputting any remaining */
7863 if (count >= 2) { /* At most one will have a non-zero copy count */
7865 if ((copy_count = len_a - i_a) > 0) {
7866 Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7868 else if ((copy_count = len_b - i_b) > 0) {
7869 Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7873 /* We may be removing a reference to one of the inputs */
7874 if (a == *i || b == *i) {
7878 /* If we've changed b, restore it */
7888 Perl__add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7890 /* Add the range from 'start' to 'end' inclusive to the inversion list's
7891 * set. A pointer to the inversion list is returned. This may actually be
7892 * a new list, in which case the passed in one has been destroyed. The
7893 * passed in inversion list can be NULL, in which case a new one is created
7894 * with just the one range in it */
7899 if (invlist == NULL) {
7900 invlist = _new_invlist(2);
7904 len = invlist_len(invlist);
7907 /* If comes after the final entry, can just append it to the end */
7909 || start >= invlist_array(invlist)
7910 [invlist_len(invlist) - 1])
7912 _append_range_to_invlist(invlist, start, end);
7916 /* Here, can't just append things, create and return a new inversion list
7917 * which is the union of this range and the existing inversion list */
7918 range_invlist = _new_invlist(2);
7919 _append_range_to_invlist(range_invlist, start, end);
7921 _invlist_union(invlist, range_invlist, &invlist);
7923 /* The temporary can be freed */
7924 SvREFCNT_dec(range_invlist);
7931 PERL_STATIC_INLINE SV*
7932 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
7933 return _add_range_to_invlist(invlist, cp, cp);
7936 #ifndef PERL_IN_XSUB_RE
7938 Perl__invlist_invert(pTHX_ SV* const invlist)
7940 /* Complement the input inversion list. This adds a 0 if the list didn't
7941 * have a zero; removes it otherwise. As described above, the data
7942 * structure is set up so that this is very efficient */
7944 UV* len_pos = get_invlist_len_addr(invlist);
7946 PERL_ARGS_ASSERT__INVLIST_INVERT;
7948 /* The inverse of matching nothing is matching everything */
7949 if (*len_pos == 0) {
7950 _append_range_to_invlist(invlist, 0, UV_MAX);
7954 /* The exclusive or complents 0 to 1; and 1 to 0. If the result is 1, the
7955 * zero element was a 0, so it is being removed, so the length decrements
7956 * by 1; and vice-versa. SvCUR is unaffected */
7957 if (*get_invlist_zero_addr(invlist) ^= 1) {
7966 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
7968 /* Complement the input inversion list (which must be a Unicode property,
7969 * all of which don't match above the Unicode maximum code point.) And
7970 * Perl has chosen to not have the inversion match above that either. This
7971 * adds a 0x110000 if the list didn't end with it, and removes it if it did
7977 PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
7979 _invlist_invert(invlist);
7981 len = invlist_len(invlist);
7983 if (len != 0) { /* If empty do nothing */
7984 array = invlist_array(invlist);
7985 if (array[len - 1] != PERL_UNICODE_MAX + 1) {
7986 /* Add 0x110000. First, grow if necessary */
7988 if (invlist_max(invlist) < len) {
7989 invlist_extend(invlist, len);
7990 array = invlist_array(invlist);
7992 invlist_set_len(invlist, len);
7993 array[len - 1] = PERL_UNICODE_MAX + 1;
7995 else { /* Remove the 0x110000 */
7996 invlist_set_len(invlist, len - 1);
8004 PERL_STATIC_INLINE SV*
8005 S_invlist_clone(pTHX_ SV* const invlist)
8008 /* Return a new inversion list that is a copy of the input one, which is
8011 /* Need to allocate extra space to accommodate Perl's addition of a
8012 * trailing NUL to SvPV's, since it thinks they are always strings */
8013 SV* new_invlist = _new_invlist(invlist_len(invlist) + 1);
8014 STRLEN length = SvCUR(invlist);
8016 PERL_ARGS_ASSERT_INVLIST_CLONE;
8018 SvCUR_set(new_invlist, length); /* This isn't done automatically */
8019 Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
8024 PERL_STATIC_INLINE UV*
8025 S_get_invlist_iter_addr(pTHX_ SV* invlist)
8027 /* Return the address of the UV that contains the current iteration
8030 PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
8032 return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
8035 PERL_STATIC_INLINE UV*
8036 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
8038 /* Return the address of the UV that contains the version id. */
8040 PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
8042 return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
8045 PERL_STATIC_INLINE void
8046 S_invlist_iterinit(pTHX_ SV* invlist) /* Initialize iterator for invlist */
8048 PERL_ARGS_ASSERT_INVLIST_ITERINIT;
8050 *get_invlist_iter_addr(invlist) = 0;
8054 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
8056 /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
8057 * This call sets in <*start> and <*end>, the next range in <invlist>.
8058 * Returns <TRUE> if successful and the next call will return the next
8059 * range; <FALSE> if was already at the end of the list. If the latter,
8060 * <*start> and <*end> are unchanged, and the next call to this function
8061 * will start over at the beginning of the list */
8063 UV* pos = get_invlist_iter_addr(invlist);
8064 UV len = invlist_len(invlist);
8067 PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
8070 *pos = UV_MAX; /* Force iternit() to be required next time */
8074 array = invlist_array(invlist);
8076 *start = array[(*pos)++];
8082 *end = array[(*pos)++] - 1;
8088 #ifndef PERL_IN_XSUB_RE
8090 Perl__invlist_contents(pTHX_ SV* const invlist)
8092 /* Get the contents of an inversion list into a string SV so that they can
8093 * be printed out. It uses the format traditionally done for debug tracing
8097 SV* output = newSVpvs("\n");
8099 PERL_ARGS_ASSERT__INVLIST_CONTENTS;
8101 invlist_iterinit(invlist);
8102 while (invlist_iternext(invlist, &start, &end)) {
8103 if (end == UV_MAX) {
8104 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
8106 else if (end != start) {
8107 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
8111 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
8121 S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
8123 /* Dumps out the ranges in an inversion list. The string 'header'
8124 * if present is output on a line before the first range */
8128 if (header && strlen(header)) {
8129 PerlIO_printf(Perl_debug_log, "%s\n", header);
8131 invlist_iterinit(invlist);
8132 while (invlist_iternext(invlist, &start, &end)) {
8133 if (end == UV_MAX) {
8134 PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
8137 PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
8143 #undef HEADER_LENGTH
8144 #undef INVLIST_INITIAL_LENGTH
8145 #undef TO_INTERNAL_SIZE
8146 #undef FROM_INTERNAL_SIZE
8147 #undef INVLIST_LEN_OFFSET
8148 #undef INVLIST_ZERO_OFFSET
8149 #undef INVLIST_ITER_OFFSET
8150 #undef INVLIST_VERSION_ID
8152 /* End of inversion list object */
8155 - reg - regular expression, i.e. main body or parenthesized thing
8157 * Caller must absorb opening parenthesis.
8159 * Combining parenthesis handling with the base level of regular expression
8160 * is a trifle forced, but the need to tie the tails of the branches to what
8161 * follows makes it hard to avoid.
8163 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
8165 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
8167 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
8171 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
8172 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
8175 register regnode *ret; /* Will be the head of the group. */
8176 register regnode *br;
8177 register regnode *lastbr;
8178 register regnode *ender = NULL;
8179 register I32 parno = 0;
8181 U32 oregflags = RExC_flags;
8182 bool have_branch = 0;
8184 I32 freeze_paren = 0;
8185 I32 after_freeze = 0;
8187 /* for (?g), (?gc), and (?o) warnings; warning
8188 about (?c) will warn about (?g) -- japhy */
8190 #define WASTED_O 0x01
8191 #define WASTED_G 0x02
8192 #define WASTED_C 0x04
8193 #define WASTED_GC (0x02|0x04)
8194 I32 wastedflags = 0x00;
8196 char * parse_start = RExC_parse; /* MJD */
8197 char * const oregcomp_parse = RExC_parse;
8199 GET_RE_DEBUG_FLAGS_DECL;
8201 PERL_ARGS_ASSERT_REG;
8202 DEBUG_PARSE("reg ");
8204 *flagp = 0; /* Tentatively. */
8207 /* Make an OPEN node, if parenthesized. */
8209 if ( *RExC_parse == '*') { /* (*VERB:ARG) */
8210 char *start_verb = RExC_parse;
8211 STRLEN verb_len = 0;
8212 char *start_arg = NULL;
8213 unsigned char op = 0;
8215 int internal_argval = 0; /* internal_argval is only useful if !argok */
8216 while ( *RExC_parse && *RExC_parse != ')' ) {
8217 if ( *RExC_parse == ':' ) {
8218 start_arg = RExC_parse + 1;
8224 verb_len = RExC_parse - start_verb;
8227 while ( *RExC_parse && *RExC_parse != ')' )
8229 if ( *RExC_parse != ')' )
8230 vFAIL("Unterminated verb pattern argument");
8231 if ( RExC_parse == start_arg )
8234 if ( *RExC_parse != ')' )
8235 vFAIL("Unterminated verb pattern");
8238 switch ( *start_verb ) {
8239 case 'A': /* (*ACCEPT) */
8240 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
8242 internal_argval = RExC_nestroot;
8245 case 'C': /* (*COMMIT) */
8246 if ( memEQs(start_verb,verb_len,"COMMIT") )
8249 case 'F': /* (*FAIL) */
8250 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
8255 case ':': /* (*:NAME) */
8256 case 'M': /* (*MARK:NAME) */
8257 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
8262 case 'P': /* (*PRUNE) */
8263 if ( memEQs(start_verb,verb_len,"PRUNE") )
8266 case 'S': /* (*SKIP) */
8267 if ( memEQs(start_verb,verb_len,"SKIP") )
8270 case 'T': /* (*THEN) */
8271 /* [19:06] <TimToady> :: is then */
8272 if ( memEQs(start_verb,verb_len,"THEN") ) {
8274 RExC_seen |= REG_SEEN_CUTGROUP;
8280 vFAIL3("Unknown verb pattern '%.*s'",
8281 verb_len, start_verb);
8284 if ( start_arg && internal_argval ) {
8285 vFAIL3("Verb pattern '%.*s' may not have an argument",
8286 verb_len, start_verb);
8287 } else if ( argok < 0 && !start_arg ) {
8288 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
8289 verb_len, start_verb);
8291 ret = reganode(pRExC_state, op, internal_argval);
8292 if ( ! internal_argval && ! SIZE_ONLY ) {
8294 SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
8295 ARG(ret) = add_data( pRExC_state, 1, "S" );
8296 RExC_rxi->data->data[ARG(ret)]=(void*)sv;
8303 if (!internal_argval)
8304 RExC_seen |= REG_SEEN_VERBARG;
8305 } else if ( start_arg ) {
8306 vFAIL3("Verb pattern '%.*s' may not have an argument",
8307 verb_len, start_verb);
8309 ret = reg_node(pRExC_state, op);
8311 nextchar(pRExC_state);
8314 if (*RExC_parse == '?') { /* (?...) */
8315 bool is_logical = 0;
8316 const char * const seqstart = RExC_parse;
8317 bool has_use_defaults = FALSE;
8320 paren = *RExC_parse++;
8321 ret = NULL; /* For look-ahead/behind. */
8324 case 'P': /* (?P...) variants for those used to PCRE/Python */
8325 paren = *RExC_parse++;
8326 if ( paren == '<') /* (?P<...>) named capture */
8328 else if (paren == '>') { /* (?P>name) named recursion */
8329 goto named_recursion;
8331 else if (paren == '=') { /* (?P=...) named backref */
8332 /* this pretty much dupes the code for \k<NAME> in regatom(), if
8333 you change this make sure you change that */
8334 char* name_start = RExC_parse;
8336 SV *sv_dat = reg_scan_name(pRExC_state,
8337 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8338 if (RExC_parse == name_start || *RExC_parse != ')')
8339 vFAIL2("Sequence %.3s... not terminated",parse_start);
8342 num = add_data( pRExC_state, 1, "S" );
8343 RExC_rxi->data->data[num]=(void*)sv_dat;
8344 SvREFCNT_inc_simple_void(sv_dat);
8347 ret = reganode(pRExC_state,
8350 : (MORE_ASCII_RESTRICTED)
8352 : (AT_LEAST_UNI_SEMANTICS)
8360 Set_Node_Offset(ret, parse_start+1);
8361 Set_Node_Cur_Length(ret); /* MJD */
8363 nextchar(pRExC_state);
8367 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8369 case '<': /* (?<...) */
8370 if (*RExC_parse == '!')
8372 else if (*RExC_parse != '=')
8378 case '\'': /* (?'...') */
8379 name_start= RExC_parse;
8380 svname = reg_scan_name(pRExC_state,
8381 SIZE_ONLY ? /* reverse test from the others */
8382 REG_RSN_RETURN_NAME :
8383 REG_RSN_RETURN_NULL);
8384 if (RExC_parse == name_start) {
8386 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8389 if (*RExC_parse != paren)
8390 vFAIL2("Sequence (?%c... not terminated",
8391 paren=='>' ? '<' : paren);
8395 if (!svname) /* shouldn't happen */
8397 "panic: reg_scan_name returned NULL");
8398 if (!RExC_paren_names) {
8399 RExC_paren_names= newHV();
8400 sv_2mortal(MUTABLE_SV(RExC_paren_names));
8402 RExC_paren_name_list= newAV();
8403 sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
8406 he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
8408 sv_dat = HeVAL(he_str);
8410 /* croak baby croak */
8412 "panic: paren_name hash element allocation failed");
8413 } else if ( SvPOK(sv_dat) ) {
8414 /* (?|...) can mean we have dupes so scan to check
8415 its already been stored. Maybe a flag indicating
8416 we are inside such a construct would be useful,
8417 but the arrays are likely to be quite small, so
8418 for now we punt -- dmq */
8419 IV count = SvIV(sv_dat);
8420 I32 *pv = (I32*)SvPVX(sv_dat);
8422 for ( i = 0 ; i < count ; i++ ) {
8423 if ( pv[i] == RExC_npar ) {
8429 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
8430 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
8431 pv[count] = RExC_npar;
8432 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
8435 (void)SvUPGRADE(sv_dat,SVt_PVNV);
8436 sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
8438 SvIV_set(sv_dat, 1);
8441 /* Yes this does cause a memory leak in debugging Perls */
8442 if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
8443 SvREFCNT_dec(svname);
8446 /*sv_dump(sv_dat);*/
8448 nextchar(pRExC_state);
8450 goto capturing_parens;
8452 RExC_seen |= REG_SEEN_LOOKBEHIND;
8453 RExC_in_lookbehind++;
8455 case '=': /* (?=...) */
8456 RExC_seen_zerolen++;
8458 case '!': /* (?!...) */
8459 RExC_seen_zerolen++;
8460 if (*RExC_parse == ')') {
8461 ret=reg_node(pRExC_state, OPFAIL);
8462 nextchar(pRExC_state);
8466 case '|': /* (?|...) */
8467 /* branch reset, behave like a (?:...) except that
8468 buffers in alternations share the same numbers */
8470 after_freeze = freeze_paren = RExC_npar;
8472 case ':': /* (?:...) */
8473 case '>': /* (?>...) */
8475 case '$': /* (?$...) */
8476 case '@': /* (?@...) */
8477 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
8479 case '#': /* (?#...) */
8480 while (*RExC_parse && *RExC_parse != ')')
8482 if (*RExC_parse != ')')
8483 FAIL("Sequence (?#... not terminated");
8484 nextchar(pRExC_state);
8487 case '0' : /* (?0) */
8488 case 'R' : /* (?R) */
8489 if (*RExC_parse != ')')
8490 FAIL("Sequence (?R) not terminated");
8491 ret = reg_node(pRExC_state, GOSTART);
8492 *flagp |= POSTPONED;
8493 nextchar(pRExC_state);
8496 { /* named and numeric backreferences */
8498 case '&': /* (?&NAME) */
8499 parse_start = RExC_parse - 1;
8502 SV *sv_dat = reg_scan_name(pRExC_state,
8503 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8504 num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8506 goto gen_recurse_regop;
8507 assert(0); /* NOT REACHED */
8509 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8511 vFAIL("Illegal pattern");
8513 goto parse_recursion;
8515 case '-': /* (?-1) */
8516 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
8517 RExC_parse--; /* rewind to let it be handled later */
8521 case '1': case '2': case '3': case '4': /* (?1) */
8522 case '5': case '6': case '7': case '8': case '9':
8525 num = atoi(RExC_parse);
8526 parse_start = RExC_parse - 1; /* MJD */
8527 if (*RExC_parse == '-')
8529 while (isDIGIT(*RExC_parse))
8531 if (*RExC_parse!=')')
8532 vFAIL("Expecting close bracket");
8535 if ( paren == '-' ) {
8537 Diagram of capture buffer numbering.
8538 Top line is the normal capture buffer numbers
8539 Bottom line is the negative indexing as from
8543 /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
8547 num = RExC_npar + num;
8550 vFAIL("Reference to nonexistent group");
8552 } else if ( paren == '+' ) {
8553 num = RExC_npar + num - 1;
8556 ret = reganode(pRExC_state, GOSUB, num);
8558 if (num > (I32)RExC_rx->nparens) {
8560 vFAIL("Reference to nonexistent group");
8562 ARG2L_SET( ret, RExC_recurse_count++);
8564 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8565 "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
8569 RExC_seen |= REG_SEEN_RECURSE;
8570 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
8571 Set_Node_Offset(ret, parse_start); /* MJD */
8573 *flagp |= POSTPONED;
8574 nextchar(pRExC_state);
8576 } /* named and numeric backreferences */
8577 assert(0); /* NOT REACHED */
8579 case '?': /* (??...) */
8581 if (*RExC_parse != '{') {
8583 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8586 *flagp |= POSTPONED;
8587 paren = *RExC_parse++;
8589 case '{': /* (?{...}) */
8592 struct reg_code_block *cb;
8594 RExC_seen_zerolen++;
8596 if ( !pRExC_state->num_code_blocks
8597 || pRExC_state->code_index >= pRExC_state->num_code_blocks
8598 || pRExC_state->code_blocks[pRExC_state->code_index].start
8599 != (STRLEN)((RExC_parse -3 - (is_logical ? 1 : 0))
8602 if (RExC_pm_flags & PMf_USE_RE_EVAL)
8603 FAIL("panic: Sequence (?{...}): no code block found\n");
8604 FAIL("Eval-group not allowed at runtime, use re 'eval'");
8606 /* this is a pre-compiled code block (?{...}) */
8607 cb = &pRExC_state->code_blocks[pRExC_state->code_index];
8608 RExC_parse = RExC_start + cb->end;
8611 if (cb->src_regex) {
8612 n = add_data(pRExC_state, 2, "rl");
8613 RExC_rxi->data->data[n] =
8614 (void*)SvREFCNT_inc((SV*)cb->src_regex);
8615 RExC_rxi->data->data[n+1] = (void*)o;
8618 n = add_data(pRExC_state, 1,
8619 (RExC_pm_flags & PMf_HAS_CV) ? "L" : "l");
8620 RExC_rxi->data->data[n] = (void*)o;
8623 pRExC_state->code_index++;
8624 nextchar(pRExC_state);
8628 ret = reg_node(pRExC_state, LOGICAL);
8629 eval = reganode(pRExC_state, EVAL, n);
8632 /* for later propagation into (??{}) return value */
8633 eval->flags = (U8) (RExC_flags & RXf_PMf_COMPILETIME);
8635 REGTAIL(pRExC_state, ret, eval);
8636 /* deal with the length of this later - MJD */
8639 ret = reganode(pRExC_state, EVAL, n);
8640 Set_Node_Length(ret, RExC_parse - parse_start + 1);
8641 Set_Node_Offset(ret, parse_start);
8644 case '(': /* (?(?{...})...) and (?(?=...)...) */
8647 if (RExC_parse[0] == '?') { /* (?(?...)) */
8648 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
8649 || RExC_parse[1] == '<'
8650 || RExC_parse[1] == '{') { /* Lookahead or eval. */
8653 ret = reg_node(pRExC_state, LOGICAL);
8656 REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
8660 else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
8661 || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
8663 char ch = RExC_parse[0] == '<' ? '>' : '\'';
8664 char *name_start= RExC_parse++;
8666 SV *sv_dat=reg_scan_name(pRExC_state,
8667 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8668 if (RExC_parse == name_start || *RExC_parse != ch)
8669 vFAIL2("Sequence (?(%c... not terminated",
8670 (ch == '>' ? '<' : ch));
8673 num = add_data( pRExC_state, 1, "S" );
8674 RExC_rxi->data->data[num]=(void*)sv_dat;
8675 SvREFCNT_inc_simple_void(sv_dat);
8677 ret = reganode(pRExC_state,NGROUPP,num);
8678 goto insert_if_check_paren;
8680 else if (RExC_parse[0] == 'D' &&
8681 RExC_parse[1] == 'E' &&
8682 RExC_parse[2] == 'F' &&
8683 RExC_parse[3] == 'I' &&
8684 RExC_parse[4] == 'N' &&
8685 RExC_parse[5] == 'E')
8687 ret = reganode(pRExC_state,DEFINEP,0);
8690 goto insert_if_check_paren;
8692 else if (RExC_parse[0] == 'R') {
8695 if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8696 parno = atoi(RExC_parse++);
8697 while (isDIGIT(*RExC_parse))
8699 } else if (RExC_parse[0] == '&') {
8702 sv_dat = reg_scan_name(pRExC_state,
8703 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8704 parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8706 ret = reganode(pRExC_state,INSUBP,parno);
8707 goto insert_if_check_paren;
8709 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8712 parno = atoi(RExC_parse++);
8714 while (isDIGIT(*RExC_parse))
8716 ret = reganode(pRExC_state, GROUPP, parno);
8718 insert_if_check_paren:
8719 if ((c = *nextchar(pRExC_state)) != ')')
8720 vFAIL("Switch condition not recognized");
8722 REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
8723 br = regbranch(pRExC_state, &flags, 1,depth+1);
8725 br = reganode(pRExC_state, LONGJMP, 0);
8727 REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
8728 c = *nextchar(pRExC_state);
8733 vFAIL("(?(DEFINE)....) does not allow branches");
8734 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
8735 regbranch(pRExC_state, &flags, 1,depth+1);
8736 REGTAIL(pRExC_state, ret, lastbr);
8739 c = *nextchar(pRExC_state);
8744 vFAIL("Switch (?(condition)... contains too many branches");
8745 ender = reg_node(pRExC_state, TAIL);
8746 REGTAIL(pRExC_state, br, ender);
8748 REGTAIL(pRExC_state, lastbr, ender);
8749 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
8752 REGTAIL(pRExC_state, ret, ender);
8753 RExC_size++; /* XXX WHY do we need this?!!
8754 For large programs it seems to be required
8755 but I can't figure out why. -- dmq*/
8759 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
8763 RExC_parse--; /* for vFAIL to print correctly */
8764 vFAIL("Sequence (? incomplete");
8766 case DEFAULT_PAT_MOD: /* Use default flags with the exceptions
8768 has_use_defaults = TRUE;
8769 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8770 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8771 ? REGEX_UNICODE_CHARSET
8772 : REGEX_DEPENDS_CHARSET);
8776 parse_flags: /* (?i) */
8778 U32 posflags = 0, negflags = 0;
8779 U32 *flagsp = &posflags;
8780 char has_charset_modifier = '\0';
8781 regex_charset cs = get_regex_charset(RExC_flags);
8782 if (cs == REGEX_DEPENDS_CHARSET
8783 && (RExC_utf8 || RExC_uni_semantics))
8785 cs = REGEX_UNICODE_CHARSET;
8788 while (*RExC_parse) {
8789 /* && strchr("iogcmsx", *RExC_parse) */
8790 /* (?g), (?gc) and (?o) are useless here
8791 and must be globally applied -- japhy */
8792 switch (*RExC_parse) {
8793 CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8794 case LOCALE_PAT_MOD:
8795 if (has_charset_modifier) {
8796 goto excess_modifier;
8798 else if (flagsp == &negflags) {
8801 cs = REGEX_LOCALE_CHARSET;
8802 has_charset_modifier = LOCALE_PAT_MOD;
8803 RExC_contains_locale = 1;
8805 case UNICODE_PAT_MOD:
8806 if (has_charset_modifier) {
8807 goto excess_modifier;
8809 else if (flagsp == &negflags) {
8812 cs = REGEX_UNICODE_CHARSET;
8813 has_charset_modifier = UNICODE_PAT_MOD;
8815 case ASCII_RESTRICT_PAT_MOD:
8816 if (flagsp == &negflags) {
8819 if (has_charset_modifier) {
8820 if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8821 goto excess_modifier;
8823 /* Doubled modifier implies more restricted */
8824 cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8827 cs = REGEX_ASCII_RESTRICTED_CHARSET;
8829 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8831 case DEPENDS_PAT_MOD:
8832 if (has_use_defaults) {
8833 goto fail_modifiers;
8835 else if (flagsp == &negflags) {
8838 else if (has_charset_modifier) {
8839 goto excess_modifier;
8842 /* The dual charset means unicode semantics if the
8843 * pattern (or target, not known until runtime) are
8844 * utf8, or something in the pattern indicates unicode
8846 cs = (RExC_utf8 || RExC_uni_semantics)
8847 ? REGEX_UNICODE_CHARSET
8848 : REGEX_DEPENDS_CHARSET;
8849 has_charset_modifier = DEPENDS_PAT_MOD;
8853 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8854 vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8856 else if (has_charset_modifier == *(RExC_parse - 1)) {
8857 vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8860 vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8865 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8867 case ONCE_PAT_MOD: /* 'o' */
8868 case GLOBAL_PAT_MOD: /* 'g' */
8869 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8870 const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8871 if (! (wastedflags & wflagbit) ) {
8872 wastedflags |= wflagbit;
8875 "Useless (%s%c) - %suse /%c modifier",
8876 flagsp == &negflags ? "?-" : "?",
8878 flagsp == &negflags ? "don't " : "",
8885 case CONTINUE_PAT_MOD: /* 'c' */
8886 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8887 if (! (wastedflags & WASTED_C) ) {
8888 wastedflags |= WASTED_GC;
8891 "Useless (%sc) - %suse /gc modifier",
8892 flagsp == &negflags ? "?-" : "?",
8893 flagsp == &negflags ? "don't " : ""
8898 case KEEPCOPY_PAT_MOD: /* 'p' */
8899 if (flagsp == &negflags) {
8901 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8903 *flagsp |= RXf_PMf_KEEPCOPY;
8907 /* A flag is a default iff it is following a minus, so
8908 * if there is a minus, it means will be trying to
8909 * re-specify a default which is an error */
8910 if (has_use_defaults || flagsp == &negflags) {
8913 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8917 wastedflags = 0; /* reset so (?g-c) warns twice */
8923 RExC_flags |= posflags;
8924 RExC_flags &= ~negflags;
8925 set_regex_charset(&RExC_flags, cs);
8927 oregflags |= posflags;
8928 oregflags &= ~negflags;
8929 set_regex_charset(&oregflags, cs);
8931 nextchar(pRExC_state);
8942 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8947 }} /* one for the default block, one for the switch */
8954 ret = reganode(pRExC_state, OPEN, parno);
8957 RExC_nestroot = parno;
8958 if (RExC_seen & REG_SEEN_RECURSE
8959 && !RExC_open_parens[parno-1])
8961 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8962 "Setting open paren #%"IVdf" to %d\n",
8963 (IV)parno, REG_NODE_NUM(ret)));
8964 RExC_open_parens[parno-1]= ret;
8967 Set_Node_Length(ret, 1); /* MJD */
8968 Set_Node_Offset(ret, RExC_parse); /* MJD */
8976 /* Pick up the branches, linking them together. */
8977 parse_start = RExC_parse; /* MJD */
8978 br = regbranch(pRExC_state, &flags, 1,depth+1);
8980 /* branch_len = (paren != 0); */
8984 if (*RExC_parse == '|') {
8985 if (!SIZE_ONLY && RExC_extralen) {
8986 reginsert(pRExC_state, BRANCHJ, br, depth+1);
8989 reginsert(pRExC_state, BRANCH, br, depth+1);
8990 Set_Node_Length(br, paren != 0);
8991 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
8995 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
8997 else if (paren == ':') {
8998 *flagp |= flags&SIMPLE;
9000 if (is_open) { /* Starts with OPEN. */
9001 REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
9003 else if (paren != '?') /* Not Conditional */
9005 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9007 while (*RExC_parse == '|') {
9008 if (!SIZE_ONLY && RExC_extralen) {
9009 ender = reganode(pRExC_state, LONGJMP,0);
9010 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
9013 RExC_extralen += 2; /* Account for LONGJMP. */
9014 nextchar(pRExC_state);
9016 if (RExC_npar > after_freeze)
9017 after_freeze = RExC_npar;
9018 RExC_npar = freeze_paren;
9020 br = regbranch(pRExC_state, &flags, 0, depth+1);
9024 REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
9026 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
9029 if (have_branch || paren != ':') {
9030 /* Make a closing node, and hook it on the end. */
9033 ender = reg_node(pRExC_state, TAIL);
9036 ender = reganode(pRExC_state, CLOSE, parno);
9037 if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
9038 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
9039 "Setting close paren #%"IVdf" to %d\n",
9040 (IV)parno, REG_NODE_NUM(ender)));
9041 RExC_close_parens[parno-1]= ender;
9042 if (RExC_nestroot == parno)
9045 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
9046 Set_Node_Length(ender,1); /* MJD */
9052 *flagp &= ~HASWIDTH;
9055 ender = reg_node(pRExC_state, SUCCEED);
9058 ender = reg_node(pRExC_state, END);
9060 assert(!RExC_opend); /* there can only be one! */
9065 DEBUG_PARSE_r(if (!SIZE_ONLY) {
9066 SV * const mysv_val1=sv_newmortal();
9067 SV * const mysv_val2=sv_newmortal();
9068 DEBUG_PARSE_MSG("lsbr");
9069 regprop(RExC_rx, mysv_val1, lastbr);
9070 regprop(RExC_rx, mysv_val2, ender);
9071 PerlIO_printf(Perl_debug_log, "~ tying lastbr %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9072 SvPV_nolen_const(mysv_val1),
9073 (IV)REG_NODE_NUM(lastbr),
9074 SvPV_nolen_const(mysv_val2),
9075 (IV)REG_NODE_NUM(ender),
9076 (IV)(ender - lastbr)
9079 REGTAIL(pRExC_state, lastbr, ender);
9081 if (have_branch && !SIZE_ONLY) {
9084 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
9086 /* Hook the tails of the branches to the closing node. */
9087 for (br = ret; br; br = regnext(br)) {
9088 const U8 op = PL_regkind[OP(br)];
9090 REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
9091 if (OP(NEXTOPER(br)) != NOTHING || regnext(NEXTOPER(br)) != ender)
9094 else if (op == BRANCHJ) {
9095 REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
9096 /* for now we always disable this optimisation * /
9097 if (OP(NEXTOPER(NEXTOPER(br))) != NOTHING || regnext(NEXTOPER(NEXTOPER(br))) != ender)
9103 br= PL_regkind[OP(ret)] != BRANCH ? regnext(ret) : ret;
9104 DEBUG_PARSE_r(if (!SIZE_ONLY) {
9105 SV * const mysv_val1=sv_newmortal();
9106 SV * const mysv_val2=sv_newmortal();
9107 DEBUG_PARSE_MSG("NADA");
9108 regprop(RExC_rx, mysv_val1, ret);
9109 regprop(RExC_rx, mysv_val2, ender);
9110 PerlIO_printf(Perl_debug_log, "~ converting ret %s (%"IVdf") to ender %s (%"IVdf") offset %"IVdf"\n",
9111 SvPV_nolen_const(mysv_val1),
9112 (IV)REG_NODE_NUM(ret),
9113 SvPV_nolen_const(mysv_val2),
9114 (IV)REG_NODE_NUM(ender),
9119 if (OP(ender) == TAIL) {
9124 for ( opt= br + 1; opt < ender ; opt++ )
9126 NEXT_OFF(br)= ender - br;
9134 static const char parens[] = "=!<,>";
9136 if (paren && (p = strchr(parens, paren))) {
9137 U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
9138 int flag = (p - parens) > 1;
9141 node = SUSPEND, flag = 0;
9142 reginsert(pRExC_state, node,ret, depth+1);
9143 Set_Node_Cur_Length(ret);
9144 Set_Node_Offset(ret, parse_start + 1);
9146 REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
9150 /* Check for proper termination. */
9152 RExC_flags = oregflags;
9153 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
9154 RExC_parse = oregcomp_parse;
9155 vFAIL("Unmatched (");
9158 else if (!paren && RExC_parse < RExC_end) {
9159 if (*RExC_parse == ')') {
9161 vFAIL("Unmatched )");
9164 FAIL("Junk on end of regexp"); /* "Can't happen". */
9165 assert(0); /* NOTREACHED */
9168 if (RExC_in_lookbehind) {
9169 RExC_in_lookbehind--;
9171 if (after_freeze > RExC_npar)
9172 RExC_npar = after_freeze;
9177 - regbranch - one alternative of an | operator
9179 * Implements the concatenation operator.
9182 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
9185 register regnode *ret;
9186 register regnode *chain = NULL;
9187 register regnode *latest;
9188 I32 flags = 0, c = 0;
9189 GET_RE_DEBUG_FLAGS_DECL;
9191 PERL_ARGS_ASSERT_REGBRANCH;
9193 DEBUG_PARSE("brnc");
9198 if (!SIZE_ONLY && RExC_extralen)
9199 ret = reganode(pRExC_state, BRANCHJ,0);
9201 ret = reg_node(pRExC_state, BRANCH);
9202 Set_Node_Length(ret, 1);
9206 if (!first && SIZE_ONLY)
9207 RExC_extralen += 1; /* BRANCHJ */
9209 *flagp = WORST; /* Tentatively. */
9212 nextchar(pRExC_state);
9213 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
9215 latest = regpiece(pRExC_state, &flags,depth+1);
9216 if (latest == NULL) {
9217 if (flags & TRYAGAIN)
9221 else if (ret == NULL)
9223 *flagp |= flags&(HASWIDTH|POSTPONED);
9224 if (chain == NULL) /* First piece. */
9225 *flagp |= flags&SPSTART;
9228 REGTAIL(pRExC_state, chain, latest);
9233 if (chain == NULL) { /* Loop ran zero times. */
9234 chain = reg_node(pRExC_state, NOTHING);
9239 *flagp |= flags&SIMPLE;
9246 - regpiece - something followed by possible [*+?]
9248 * Note that the branching code sequences used for ? and the general cases
9249 * of * and + are somewhat optimized: they use the same NOTHING node as
9250 * both the endmarker for their branch list and the body of the last branch.
9251 * It might seem that this node could be dispensed with entirely, but the
9252 * endmarker role is not redundant.
9255 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9258 register regnode *ret;
9260 register char *next;
9262 const char * const origparse = RExC_parse;
9264 I32 max = REG_INFTY;
9265 #ifdef RE_TRACK_PATTERN_OFFSETS
9268 const char *maxpos = NULL;
9269 GET_RE_DEBUG_FLAGS_DECL;
9271 PERL_ARGS_ASSERT_REGPIECE;
9273 DEBUG_PARSE("piec");
9275 ret = regatom(pRExC_state, &flags,depth+1);
9277 if (flags & TRYAGAIN)
9284 if (op == '{' && regcurly(RExC_parse)) {
9286 #ifdef RE_TRACK_PATTERN_OFFSETS
9287 parse_start = RExC_parse; /* MJD */
9289 next = RExC_parse + 1;
9290 while (isDIGIT(*next) || *next == ',') {
9299 if (*next == '}') { /* got one */
9303 min = atoi(RExC_parse);
9307 maxpos = RExC_parse;
9309 if (!max && *maxpos != '0')
9310 max = REG_INFTY; /* meaning "infinity" */
9311 else if (max >= REG_INFTY)
9312 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
9314 nextchar(pRExC_state);
9317 if ((flags&SIMPLE)) {
9318 RExC_naughty += 2 + RExC_naughty / 2;
9319 reginsert(pRExC_state, CURLY, ret, depth+1);
9320 Set_Node_Offset(ret, parse_start+1); /* MJD */
9321 Set_Node_Cur_Length(ret);
9324 regnode * const w = reg_node(pRExC_state, WHILEM);
9327 REGTAIL(pRExC_state, ret, w);
9328 if (!SIZE_ONLY && RExC_extralen) {
9329 reginsert(pRExC_state, LONGJMP,ret, depth+1);
9330 reginsert(pRExC_state, NOTHING,ret, depth+1);
9331 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
9333 reginsert(pRExC_state, CURLYX,ret, depth+1);
9335 Set_Node_Offset(ret, parse_start+1);
9336 Set_Node_Length(ret,
9337 op == '{' ? (RExC_parse - parse_start) : 1);
9339 if (!SIZE_ONLY && RExC_extralen)
9340 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
9341 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
9343 RExC_whilem_seen++, RExC_extralen += 3;
9344 RExC_naughty += 4 + RExC_naughty; /* compound interest */
9353 vFAIL("Can't do {n,m} with n > m");
9355 ARG1_SET(ret, (U16)min);
9356 ARG2_SET(ret, (U16)max);
9368 #if 0 /* Now runtime fix should be reliable. */
9370 /* if this is reinstated, don't forget to put this back into perldiag:
9372 =item Regexp *+ operand could be empty at {#} in regex m/%s/
9374 (F) The part of the regexp subject to either the * or + quantifier
9375 could match an empty string. The {#} shows in the regular
9376 expression about where the problem was discovered.
9380 if (!(flags&HASWIDTH) && op != '?')
9381 vFAIL("Regexp *+ operand could be empty");
9384 #ifdef RE_TRACK_PATTERN_OFFSETS
9385 parse_start = RExC_parse;
9387 nextchar(pRExC_state);
9389 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
9391 if (op == '*' && (flags&SIMPLE)) {
9392 reginsert(pRExC_state, STAR, ret, depth+1);
9396 else if (op == '*') {
9400 else if (op == '+' && (flags&SIMPLE)) {
9401 reginsert(pRExC_state, PLUS, ret, depth+1);
9405 else if (op == '+') {
9409 else if (op == '?') {
9414 if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
9415 ckWARN3reg(RExC_parse,
9416 "%.*s matches null string many times",
9417 (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
9421 if (RExC_parse < RExC_end && *RExC_parse == '?') {
9422 nextchar(pRExC_state);
9423 reginsert(pRExC_state, MINMOD, ret, depth+1);
9424 REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
9426 #ifndef REG_ALLOW_MINMOD_SUSPEND
9429 if (RExC_parse < RExC_end && *RExC_parse == '+') {
9431 nextchar(pRExC_state);
9432 ender = reg_node(pRExC_state, SUCCEED);
9433 REGTAIL(pRExC_state, ret, ender);
9434 reginsert(pRExC_state, SUSPEND, ret, depth+1);
9436 ender = reg_node(pRExC_state, TAIL);
9437 REGTAIL(pRExC_state, ret, ender);
9441 if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
9443 vFAIL("Nested quantifiers");
9450 /* reg_namedseq(pRExC_state,UVp, UV depth)
9452 This is expected to be called by a parser routine that has
9453 recognized '\N' and needs to handle the rest. RExC_parse is
9454 expected to point at the first char following the N at the time
9457 The \N may be inside (indicated by valuep not being NULL) or outside a
9460 \N may begin either a named sequence, or if outside a character class, mean
9461 to match a non-newline. For non single-quoted regexes, the tokenizer has
9462 attempted to decide which, and in the case of a named sequence converted it
9463 into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
9464 where c1... are the characters in the sequence. For single-quoted regexes,
9465 the tokenizer passes the \N sequence through unchanged; this code will not
9466 attempt to determine this nor expand those. The net effect is that if the
9467 beginning of the passed-in pattern isn't '{U+' or there is no '}', it
9468 signals that this \N occurrence means to match a non-newline.
9470 Only the \N{U+...} form should occur in a character class, for the same
9471 reason that '.' inside a character class means to just match a period: it
9472 just doesn't make sense.
9474 If valuep is non-null then it is assumed that we are parsing inside
9475 of a charclass definition and the first codepoint in the resolved
9476 string is returned via *valuep and the routine will return NULL.
9477 In this mode if a multichar string is returned from the charnames
9478 handler, a warning will be issued, and only the first char in the
9479 sequence will be examined. If the string returned is zero length
9480 then the value of *valuep is undefined and NON-NULL will
9481 be returned to indicate failure. (This will NOT be a valid pointer
9484 If valuep is null then it is assumed that we are parsing normal text and a
9485 new EXACT node is inserted into the program containing the resolved string,
9486 and a pointer to the new node is returned. But if the string is zero length
9487 a NOTHING node is emitted instead.
9489 On success RExC_parse is set to the char following the endbrace.
9490 Parsing failures will generate a fatal error via vFAIL(...)
9493 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
9495 char * endbrace; /* '}' following the name */
9496 regnode *ret = NULL;
9499 GET_RE_DEBUG_FLAGS_DECL;
9501 PERL_ARGS_ASSERT_REG_NAMEDSEQ;
9505 /* The [^\n] meaning of \N ignores spaces and comments under the /x
9506 * modifier. The other meaning does not */
9507 p = (RExC_flags & RXf_PMf_EXTENDED)
9508 ? regwhite( pRExC_state, RExC_parse )
9511 /* Disambiguate between \N meaning a named character versus \N meaning
9512 * [^\n]. The former is assumed when it can't be the latter. */
9513 if (*p != '{' || regcurly(p)) {
9516 /* no bare \N in a charclass */
9517 vFAIL("\\N in a character class must be a named character: \\N{...}");
9519 nextchar(pRExC_state);
9520 ret = reg_node(pRExC_state, REG_ANY);
9521 *flagp |= HASWIDTH|SIMPLE;
9524 Set_Node_Length(ret, 1); /* MJD */
9528 /* Here, we have decided it should be a named sequence */
9530 /* The test above made sure that the next real character is a '{', but
9531 * under the /x modifier, it could be separated by space (or a comment and
9532 * \n) and this is not allowed (for consistency with \x{...} and the
9533 * tokenizer handling of \N{NAME}). */
9534 if (*RExC_parse != '{') {
9535 vFAIL("Missing braces on \\N{}");
9538 RExC_parse++; /* Skip past the '{' */
9540 if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
9541 || ! (endbrace == RExC_parse /* nothing between the {} */
9542 || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below */
9543 && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
9545 if (endbrace) RExC_parse = endbrace; /* position msg's '<--HERE' */
9546 vFAIL("\\N{NAME} must be resolved by the lexer");
9549 if (endbrace == RExC_parse) { /* empty: \N{} */
9551 RExC_parse = endbrace + 1;
9552 return reg_node(pRExC_state,NOTHING);
9556 ckWARNreg(RExC_parse,
9557 "Ignoring zero length \\N{} in character class"
9559 RExC_parse = endbrace + 1;
9562 return (regnode *) &RExC_parse; /* Invalid regnode pointer */
9565 REQUIRE_UTF8; /* named sequences imply Unicode semantics */
9566 RExC_parse += 2; /* Skip past the 'U+' */
9568 if (valuep) { /* In a bracketed char class */
9569 /* We only pay attention to the first char of
9570 multichar strings being returned. I kinda wonder
9571 if this makes sense as it does change the behaviour
9572 from earlier versions, OTOH that behaviour was broken
9573 as well. XXX Solution is to recharacterize as
9574 [rest-of-class]|multi1|multi2... */
9576 STRLEN length_of_hex;
9577 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9578 | PERL_SCAN_DISALLOW_PREFIX
9579 | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
9581 char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
9582 if (endchar < endbrace) {
9583 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
9586 length_of_hex = (STRLEN)(endchar - RExC_parse);
9587 *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
9589 /* The tokenizer should have guaranteed validity, but it's possible to
9590 * bypass it by using single quoting, so check */
9591 if (length_of_hex == 0
9592 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
9594 RExC_parse += length_of_hex; /* Includes all the valid */
9595 RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
9596 ? UTF8SKIP(RExC_parse)
9598 /* Guard against malformed utf8 */
9599 if (RExC_parse >= endchar) RExC_parse = endchar;
9600 vFAIL("Invalid hexadecimal number in \\N{U+...}");
9603 RExC_parse = endbrace + 1;
9604 if (endchar == endbrace) return NULL;
9606 ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */
9608 else { /* Not a char class */
9610 /* What is done here is to convert this to a sub-pattern of the form
9611 * (?:\x{char1}\x{char2}...)
9612 * and then call reg recursively. That way, it retains its atomicness,
9613 * while not having to worry about special handling that some code
9614 * points may have. toke.c has converted the original Unicode values
9615 * to native, so that we can just pass on the hex values unchanged. We
9616 * do have to set a flag to keep recoding from happening in the
9619 SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
9621 char *endchar; /* Points to '.' or '}' ending cur char in the input
9623 char *orig_end = RExC_end;
9625 while (RExC_parse < endbrace) {
9627 /* Code points are separated by dots. If none, there is only one
9628 * code point, and is terminated by the brace */
9629 endchar = RExC_parse + strcspn(RExC_parse, ".}");
9631 /* Convert to notation the rest of the code understands */
9632 sv_catpv(substitute_parse, "\\x{");
9633 sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
9634 sv_catpv(substitute_parse, "}");
9636 /* Point to the beginning of the next character in the sequence. */
9637 RExC_parse = endchar + 1;
9639 sv_catpv(substitute_parse, ")");
9641 RExC_parse = SvPV(substitute_parse, len);
9643 /* Don't allow empty number */
9645 vFAIL("Invalid hexadecimal number in \\N{U+...}");
9647 RExC_end = RExC_parse + len;
9649 /* The values are Unicode, and therefore not subject to recoding */
9650 RExC_override_recoding = 1;
9652 ret = reg(pRExC_state, 1, flagp, depth+1);
9654 RExC_parse = endbrace;
9655 RExC_end = orig_end;
9656 RExC_override_recoding = 0;
9658 nextchar(pRExC_state);
9668 * It returns the code point in utf8 for the value in *encp.
9669 * value: a code value in the source encoding
9670 * encp: a pointer to an Encode object
9672 * If the result from Encode is not a single character,
9673 * it returns U+FFFD (Replacement character) and sets *encp to NULL.
9676 S_reg_recode(pTHX_ const char value, SV **encp)
9679 SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
9680 const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
9681 const STRLEN newlen = SvCUR(sv);
9682 UV uv = UNICODE_REPLACEMENT;
9684 PERL_ARGS_ASSERT_REG_RECODE;
9688 ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
9691 if (!newlen || numlen != newlen) {
9692 uv = UNICODE_REPLACEMENT;
9700 - regatom - the lowest level
9702 Try to identify anything special at the start of the pattern. If there
9703 is, then handle it as required. This may involve generating a single regop,
9704 such as for an assertion; or it may involve recursing, such as to
9705 handle a () structure.
9707 If the string doesn't start with something special then we gobble up
9708 as much literal text as we can.
9710 Once we have been able to handle whatever type of thing started the
9711 sequence, we return.
9713 Note: we have to be careful with escapes, as they can be both literal
9714 and special, and in the case of \10 and friends, context determines which.
9716 A summary of the code structure is:
9718 switch (first_byte) {
9719 cases for each special:
9720 handle this special;
9724 cases for each unambiguous special:
9725 handle this special;
9727 cases for each ambigous special/literal:
9729 if (special) handle here
9731 default: // unambiguously literal:
9734 default: // is a literal char
9737 create EXACTish node for literal;
9738 while (more input and node isn't full) {
9739 switch (input_byte) {
9740 cases for each special;
9741 make sure parse pointer is set so that the next call to
9742 regatom will see this special first
9743 goto loopdone; // EXACTish node terminated by prev. char
9745 append char to EXACTISH node;
9747 get next input byte;
9751 return the generated node;
9753 Specifically there are two separate switches for handling
9754 escape sequences, with the one for handling literal escapes requiring
9755 a dummy entry for all of the special escapes that are actually handled
9760 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
9763 register regnode *ret = NULL;
9765 char *parse_start = RExC_parse;
9767 GET_RE_DEBUG_FLAGS_DECL;
9768 DEBUG_PARSE("atom");
9769 *flagp = WORST; /* Tentatively. */
9771 PERL_ARGS_ASSERT_REGATOM;
9774 switch ((U8)*RExC_parse) {
9776 RExC_seen_zerolen++;
9777 nextchar(pRExC_state);
9778 if (RExC_flags & RXf_PMf_MULTILINE)
9779 ret = reg_node(pRExC_state, MBOL);
9780 else if (RExC_flags & RXf_PMf_SINGLELINE)
9781 ret = reg_node(pRExC_state, SBOL);
9783 ret = reg_node(pRExC_state, BOL);
9784 Set_Node_Length(ret, 1); /* MJD */
9787 nextchar(pRExC_state);
9789 RExC_seen_zerolen++;
9790 if (RExC_flags & RXf_PMf_MULTILINE)
9791 ret = reg_node(pRExC_state, MEOL);
9792 else if (RExC_flags & RXf_PMf_SINGLELINE)
9793 ret = reg_node(pRExC_state, SEOL);
9795 ret = reg_node(pRExC_state, EOL);
9796 Set_Node_Length(ret, 1); /* MJD */
9799 nextchar(pRExC_state);
9800 if (RExC_flags & RXf_PMf_SINGLELINE)
9801 ret = reg_node(pRExC_state, SANY);
9803 ret = reg_node(pRExC_state, REG_ANY);
9804 *flagp |= HASWIDTH|SIMPLE;
9806 Set_Node_Length(ret, 1); /* MJD */
9810 char * const oregcomp_parse = ++RExC_parse;
9811 ret = regclass(pRExC_state,depth+1);
9812 if (*RExC_parse != ']') {
9813 RExC_parse = oregcomp_parse;
9814 vFAIL("Unmatched [");
9816 nextchar(pRExC_state);
9817 *flagp |= HASWIDTH|SIMPLE;
9818 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
9822 nextchar(pRExC_state);
9823 ret = reg(pRExC_state, 1, &flags,depth+1);
9825 if (flags & TRYAGAIN) {
9826 if (RExC_parse == RExC_end) {
9827 /* Make parent create an empty node if needed. */
9835 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
9839 if (flags & TRYAGAIN) {
9843 vFAIL("Internal urp");
9844 /* Supposed to be caught earlier. */
9850 vFAIL("Quantifier follows nothing");
9855 This switch handles escape sequences that resolve to some kind
9856 of special regop and not to literal text. Escape sequnces that
9857 resolve to literal text are handled below in the switch marked
9860 Every entry in this switch *must* have a corresponding entry
9861 in the literal escape switch. However, the opposite is not
9862 required, as the default for this switch is to jump to the
9863 literal text handling code.
9865 switch ((U8)*++RExC_parse) {
9866 /* Special Escapes */
9868 RExC_seen_zerolen++;
9869 ret = reg_node(pRExC_state, SBOL);
9871 goto finish_meta_pat;
9873 ret = reg_node(pRExC_state, GPOS);
9874 RExC_seen |= REG_SEEN_GPOS;
9876 goto finish_meta_pat;
9878 RExC_seen_zerolen++;
9879 ret = reg_node(pRExC_state, KEEPS);
9881 /* XXX:dmq : disabling in-place substitution seems to
9882 * be necessary here to avoid cases of memory corruption, as
9883 * with: C<$_="x" x 80; s/x\K/y/> -- rgs
9885 RExC_seen |= REG_SEEN_LOOKBEHIND;
9886 goto finish_meta_pat;
9888 ret = reg_node(pRExC_state, SEOL);
9890 RExC_seen_zerolen++; /* Do not optimize RE away */
9891 goto finish_meta_pat;
9893 ret = reg_node(pRExC_state, EOS);
9895 RExC_seen_zerolen++; /* Do not optimize RE away */
9896 goto finish_meta_pat;
9898 ret = reg_node(pRExC_state, CANY);
9899 RExC_seen |= REG_SEEN_CANY;
9900 *flagp |= HASWIDTH|SIMPLE;
9901 goto finish_meta_pat;
9903 ret = reg_node(pRExC_state, CLUMP);
9905 goto finish_meta_pat;
9907 switch (get_regex_charset(RExC_flags)) {
9908 case REGEX_LOCALE_CHARSET:
9911 case REGEX_UNICODE_CHARSET:
9914 case REGEX_ASCII_RESTRICTED_CHARSET:
9915 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9918 case REGEX_DEPENDS_CHARSET:
9924 ret = reg_node(pRExC_state, op);
9925 *flagp |= HASWIDTH|SIMPLE;
9926 goto finish_meta_pat;
9928 switch (get_regex_charset(RExC_flags)) {
9929 case REGEX_LOCALE_CHARSET:
9932 case REGEX_UNICODE_CHARSET:
9935 case REGEX_ASCII_RESTRICTED_CHARSET:
9936 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9939 case REGEX_DEPENDS_CHARSET:
9945 ret = reg_node(pRExC_state, op);
9946 *flagp |= HASWIDTH|SIMPLE;
9947 goto finish_meta_pat;
9949 RExC_seen_zerolen++;
9950 RExC_seen |= REG_SEEN_LOOKBEHIND;
9951 switch (get_regex_charset(RExC_flags)) {
9952 case REGEX_LOCALE_CHARSET:
9955 case REGEX_UNICODE_CHARSET:
9958 case REGEX_ASCII_RESTRICTED_CHARSET:
9959 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9962 case REGEX_DEPENDS_CHARSET:
9968 ret = reg_node(pRExC_state, op);
9969 FLAGS(ret) = get_regex_charset(RExC_flags);
9971 goto finish_meta_pat;
9973 RExC_seen_zerolen++;
9974 RExC_seen |= REG_SEEN_LOOKBEHIND;
9975 switch (get_regex_charset(RExC_flags)) {
9976 case REGEX_LOCALE_CHARSET:
9979 case REGEX_UNICODE_CHARSET:
9982 case REGEX_ASCII_RESTRICTED_CHARSET:
9983 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9986 case REGEX_DEPENDS_CHARSET:
9992 ret = reg_node(pRExC_state, op);
9993 FLAGS(ret) = get_regex_charset(RExC_flags);
9995 goto finish_meta_pat;
9997 switch (get_regex_charset(RExC_flags)) {
9998 case REGEX_LOCALE_CHARSET:
10001 case REGEX_UNICODE_CHARSET:
10004 case REGEX_ASCII_RESTRICTED_CHARSET:
10005 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10008 case REGEX_DEPENDS_CHARSET:
10014 ret = reg_node(pRExC_state, op);
10015 *flagp |= HASWIDTH|SIMPLE;
10016 goto finish_meta_pat;
10018 switch (get_regex_charset(RExC_flags)) {
10019 case REGEX_LOCALE_CHARSET:
10022 case REGEX_UNICODE_CHARSET:
10025 case REGEX_ASCII_RESTRICTED_CHARSET:
10026 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10029 case REGEX_DEPENDS_CHARSET:
10035 ret = reg_node(pRExC_state, op);
10036 *flagp |= HASWIDTH|SIMPLE;
10037 goto finish_meta_pat;
10039 switch (get_regex_charset(RExC_flags)) {
10040 case REGEX_LOCALE_CHARSET:
10043 case REGEX_ASCII_RESTRICTED_CHARSET:
10044 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10047 case REGEX_DEPENDS_CHARSET: /* No difference between these */
10048 case REGEX_UNICODE_CHARSET:
10054 ret = reg_node(pRExC_state, op);
10055 *flagp |= HASWIDTH|SIMPLE;
10056 goto finish_meta_pat;
10058 switch (get_regex_charset(RExC_flags)) {
10059 case REGEX_LOCALE_CHARSET:
10062 case REGEX_ASCII_RESTRICTED_CHARSET:
10063 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
10066 case REGEX_DEPENDS_CHARSET: /* No difference between these */
10067 case REGEX_UNICODE_CHARSET:
10073 ret = reg_node(pRExC_state, op);
10074 *flagp |= HASWIDTH|SIMPLE;
10075 goto finish_meta_pat;
10077 ret = reg_node(pRExC_state, LNBREAK);
10078 *flagp |= HASWIDTH|SIMPLE;
10079 goto finish_meta_pat;
10081 ret = reg_node(pRExC_state, HORIZWS);
10082 *flagp |= HASWIDTH|SIMPLE;
10083 goto finish_meta_pat;
10085 ret = reg_node(pRExC_state, NHORIZWS);
10086 *flagp |= HASWIDTH|SIMPLE;
10087 goto finish_meta_pat;
10089 ret = reg_node(pRExC_state, VERTWS);
10090 *flagp |= HASWIDTH|SIMPLE;
10091 goto finish_meta_pat;
10093 ret = reg_node(pRExC_state, NVERTWS);
10094 *flagp |= HASWIDTH|SIMPLE;
10096 nextchar(pRExC_state);
10097 Set_Node_Length(ret, 2); /* MJD */
10102 char* const oldregxend = RExC_end;
10104 char* parse_start = RExC_parse - 2;
10107 if (RExC_parse[1] == '{') {
10108 /* a lovely hack--pretend we saw [\pX] instead */
10109 RExC_end = strchr(RExC_parse, '}');
10111 const U8 c = (U8)*RExC_parse;
10113 RExC_end = oldregxend;
10114 vFAIL2("Missing right brace on \\%c{}", c);
10119 RExC_end = RExC_parse + 2;
10120 if (RExC_end > oldregxend)
10121 RExC_end = oldregxend;
10125 ret = regclass(pRExC_state,depth+1);
10127 RExC_end = oldregxend;
10130 Set_Node_Offset(ret, parse_start + 2);
10131 Set_Node_Cur_Length(ret);
10132 nextchar(pRExC_state);
10133 *flagp |= HASWIDTH|SIMPLE;
10137 /* Handle \N and \N{NAME} here and not below because it can be
10138 multicharacter. join_exact() will join them up later on.
10139 Also this makes sure that things like /\N{BLAH}+/ and
10140 \N{BLAH} being multi char Just Happen. dmq*/
10142 ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
10144 case 'k': /* Handle \k<NAME> and \k'NAME' */
10147 char ch= RExC_parse[1];
10148 if (ch != '<' && ch != '\'' && ch != '{') {
10150 vFAIL2("Sequence %.2s... not terminated",parse_start);
10152 /* this pretty much dupes the code for (?P=...) in reg(), if
10153 you change this make sure you change that */
10154 char* name_start = (RExC_parse += 2);
10156 SV *sv_dat = reg_scan_name(pRExC_state,
10157 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
10158 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
10159 if (RExC_parse == name_start || *RExC_parse != ch)
10160 vFAIL2("Sequence %.3s... not terminated",parse_start);
10163 num = add_data( pRExC_state, 1, "S" );
10164 RExC_rxi->data->data[num]=(void*)sv_dat;
10165 SvREFCNT_inc_simple_void(sv_dat);
10169 ret = reganode(pRExC_state,
10172 : (MORE_ASCII_RESTRICTED)
10174 : (AT_LEAST_UNI_SEMANTICS)
10180 *flagp |= HASWIDTH;
10182 /* override incorrect value set in reganode MJD */
10183 Set_Node_Offset(ret, parse_start+1);
10184 Set_Node_Cur_Length(ret); /* MJD */
10185 nextchar(pRExC_state);
10191 case '1': case '2': case '3': case '4':
10192 case '5': case '6': case '7': case '8': case '9':
10195 bool isg = *RExC_parse == 'g';
10200 if (*RExC_parse == '{') {
10204 if (*RExC_parse == '-') {
10208 if (hasbrace && !isDIGIT(*RExC_parse)) {
10209 if (isrel) RExC_parse--;
10211 goto parse_named_seq;
10213 num = atoi(RExC_parse);
10214 if (isg && num == 0)
10215 vFAIL("Reference to invalid group 0");
10217 num = RExC_npar - num;
10219 vFAIL("Reference to nonexistent or unclosed group");
10221 if (!isg && num > 9 && num >= RExC_npar)
10222 /* Probably a character specified in octal, e.g. \35 */
10225 char * const parse_start = RExC_parse - 1; /* MJD */
10226 while (isDIGIT(*RExC_parse))
10228 if (parse_start == RExC_parse - 1)
10229 vFAIL("Unterminated \\g... pattern");
10231 if (*RExC_parse != '}')
10232 vFAIL("Unterminated \\g{...} pattern");
10236 if (num > (I32)RExC_rx->nparens)
10237 vFAIL("Reference to nonexistent group");
10240 ret = reganode(pRExC_state,
10243 : (MORE_ASCII_RESTRICTED)
10245 : (AT_LEAST_UNI_SEMANTICS)
10251 *flagp |= HASWIDTH;
10253 /* override incorrect value set in reganode MJD */
10254 Set_Node_Offset(ret, parse_start+1);
10255 Set_Node_Cur_Length(ret); /* MJD */
10257 nextchar(pRExC_state);
10262 if (RExC_parse >= RExC_end)
10263 FAIL("Trailing \\");
10266 /* Do not generate "unrecognized" warnings here, we fall
10267 back into the quick-grab loop below */
10274 if (RExC_flags & RXf_PMf_EXTENDED) {
10275 if ( reg_skipcomment( pRExC_state ) )
10282 parse_start = RExC_parse - 1;
10287 register STRLEN len;
10292 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
10295 /* Is this a LATIN LOWER CASE SHARP S in an EXACTFU node? If so,
10296 * it is folded to 'ss' even if not utf8 */
10297 bool is_exactfu_sharp_s;
10300 node_type = ((! FOLD) ? EXACT
10303 : (MORE_ASCII_RESTRICTED)
10305 : (AT_LEAST_UNI_SEMANTICS)
10308 ret = reg_node(pRExC_state, node_type);
10311 /* XXX The node can hold up to 255 bytes, yet this only goes to
10312 * 127. I (khw) do not know why. Keeping it somewhat less than
10313 * 255 allows us to not have to worry about overflow due to
10314 * converting to utf8 and fold expansion, but that value is
10315 * 255-UTF8_MAXBYTES_CASE. join_exact() may join adjacent nodes
10316 * split up by this limit into a single one using the real max of
10317 * 255. Even at 127, this breaks under rare circumstances. If
10318 * folding, we do not want to split a node at a character that is a
10319 * non-final in a multi-char fold, as an input string could just
10320 * happen to want to match across the node boundary. The join
10321 * would solve that problem if the join actually happens. But a
10322 * series of more than two nodes in a row each of 127 would cause
10323 * the first join to succeed to get to 254, but then there wouldn't
10324 * be room for the next one, which could at be one of those split
10325 * multi-char folds. I don't know of any fool-proof solution. One
10326 * could back off to end with only a code point that isn't such a
10327 * non-final, but it is possible for there not to be any in the
10329 for (len = 0, p = RExC_parse - 1;
10330 len < 127 && p < RExC_end;
10333 char * const oldp = p;
10335 if (RExC_flags & RXf_PMf_EXTENDED)
10336 p = regwhite( pRExC_state, p );
10347 /* Literal Escapes Switch
10349 This switch is meant to handle escape sequences that
10350 resolve to a literal character.
10352 Every escape sequence that represents something
10353 else, like an assertion or a char class, is handled
10354 in the switch marked 'Special Escapes' above in this
10355 routine, but also has an entry here as anything that
10356 isn't explicitly mentioned here will be treated as
10357 an unescaped equivalent literal.
10360 switch ((U8)*++p) {
10361 /* These are all the special escapes. */
10362 case 'A': /* Start assertion */
10363 case 'b': case 'B': /* Word-boundary assertion*/
10364 case 'C': /* Single char !DANGEROUS! */
10365 case 'd': case 'D': /* digit class */
10366 case 'g': case 'G': /* generic-backref, pos assertion */
10367 case 'h': case 'H': /* HORIZWS */
10368 case 'k': case 'K': /* named backref, keep marker */
10369 case 'N': /* named char sequence */
10370 case 'p': case 'P': /* Unicode property */
10371 case 'R': /* LNBREAK */
10372 case 's': case 'S': /* space class */
10373 case 'v': case 'V': /* VERTWS */
10374 case 'w': case 'W': /* word class */
10375 case 'X': /* eXtended Unicode "combining character sequence" */
10376 case 'z': case 'Z': /* End of line/string assertion */
10380 /* Anything after here is an escape that resolves to a
10381 literal. (Except digits, which may or may not)
10400 ender = ASCII_TO_NATIVE('\033');
10404 ender = ASCII_TO_NATIVE('\007');
10409 STRLEN brace_len = len;
10411 const char* error_msg;
10413 bool valid = grok_bslash_o(p,
10420 RExC_parse = p; /* going to die anyway; point
10421 to exact spot of failure */
10428 if (PL_encoding && ender < 0x100) {
10429 goto recode_encoding;
10431 if (ender > 0xff) {
10438 STRLEN brace_len = len;
10440 const char* error_msg;
10442 bool valid = grok_bslash_x(p,
10449 RExC_parse = p; /* going to die anyway; point
10450 to exact spot of failure */
10456 if (PL_encoding && ender < 0x100) {
10457 goto recode_encoding;
10459 if (ender > 0xff) {
10466 ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
10468 case '0': case '1': case '2': case '3':case '4':
10469 case '5': case '6': case '7':
10471 (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
10473 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10475 ender = grok_oct(p, &numlen, &flags, NULL);
10476 if (ender > 0xff) {
10485 if (PL_encoding && ender < 0x100)
10486 goto recode_encoding;
10489 if (! RExC_override_recoding) {
10490 SV* enc = PL_encoding;
10491 ender = reg_recode((const char)(U8)ender, &enc);
10492 if (!enc && SIZE_ONLY)
10493 ckWARNreg(p, "Invalid escape in the specified encoding");
10499 FAIL("Trailing \\");
10502 if (!SIZE_ONLY&& isALNUMC(*p)) {
10503 ckWARN2reg(p + 1, "Unrecognized escape \\%.1s passed through", p);
10505 goto normal_default;
10509 /* Currently we don't warn when the lbrace is at the start
10510 * of a construct. This catches it in the middle of a
10511 * literal string, or when its the first thing after
10512 * something like "\b" */
10514 && (len || (p > RExC_start && isALPHA_A(*(p -1)))))
10516 ckWARNregdep(p + 1, "Unescaped left brace in regex is deprecated, passed through");
10521 if (UTF8_IS_START(*p) && UTF) {
10523 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
10524 &numlen, UTF8_ALLOW_DEFAULT);
10530 } /* End of switch on the literal */
10532 is_exactfu_sharp_s = (node_type == EXACTFU
10533 && ender == LATIN_SMALL_LETTER_SHARP_S);
10534 if ( RExC_flags & RXf_PMf_EXTENDED)
10535 p = regwhite( pRExC_state, p );
10536 if ((UTF && FOLD) || is_exactfu_sharp_s) {
10537 /* Prime the casefolded buffer. Locale rules, which apply
10538 * only to code points < 256, aren't known until execution,
10539 * so for them, just output the original character using
10540 * utf8. If we start to fold non-UTF patterns, be sure to
10541 * update join_exact() */
10542 if (LOC && ender < 256) {
10543 if (UNI_IS_INVARIANT(ender)) {
10544 *tmpbuf = (U8) ender;
10547 *tmpbuf = UTF8_TWO_BYTE_HI(ender);
10548 *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
10552 else if (isASCII(ender)) { /* Note: Here can't also be LOC
10554 ender = toLOWER(ender);
10555 *tmpbuf = (U8) ender;
10558 else if (! MORE_ASCII_RESTRICTED && ! LOC) {
10560 /* Locale and /aa require more selectivity about the
10561 * fold, so are handled below. Otherwise, here, just
10563 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
10566 /* Under locale rules or /aa we are not to mix,
10567 * respectively, ords < 256 or ASCII with non-. So
10568 * reject folds that mix them, using only the
10569 * non-folded code point. So do the fold to a
10570 * temporary, and inspect each character in it. */
10571 U8 trialbuf[UTF8_MAXBYTES_CASE+1];
10573 UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
10574 U8* e = s + foldlen;
10575 bool fold_ok = TRUE;
10579 || (LOC && (UTF8_IS_INVARIANT(*s)
10580 || UTF8_IS_DOWNGRADEABLE_START(*s))))
10588 Copy(trialbuf, tmpbuf, foldlen, U8);
10592 uvuni_to_utf8(tmpbuf, ender);
10593 foldlen = UNISKIP(ender);
10597 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
10600 else if (UTF || is_exactfu_sharp_s) {
10602 /* Emit all the Unicode characters. */
10604 for (foldbuf = tmpbuf;
10606 foldlen -= numlen) {
10608 /* tmpbuf has been constructed by us, so we
10609 * know it is valid utf8 */
10610 ender = valid_utf8_to_uvchr(foldbuf, &numlen);
10612 const STRLEN unilen = reguni(pRExC_state, ender, s);
10615 /* In EBCDIC the numlen
10616 * and unilen can differ. */
10618 if (numlen >= foldlen)
10622 break; /* "Can't happen." */
10626 const STRLEN unilen = reguni(pRExC_state, ender, s);
10635 REGC((char)ender, s++);
10639 if (UTF || is_exactfu_sharp_s) {
10641 /* Emit all the Unicode characters. */
10643 for (foldbuf = tmpbuf;
10645 foldlen -= numlen) {
10646 ender = valid_utf8_to_uvchr(foldbuf, &numlen);
10648 const STRLEN unilen = reguni(pRExC_state, ender, s);
10651 /* In EBCDIC the numlen
10652 * and unilen can differ. */
10654 if (numlen >= foldlen)
10662 const STRLEN unilen = reguni(pRExC_state, ender, s);
10671 REGC((char)ender, s++);
10674 loopdone: /* Jumped to when encounters something that shouldn't be in
10676 RExC_parse = p - 1;
10677 Set_Node_Cur_Length(ret); /* MJD */
10678 nextchar(pRExC_state);
10680 /* len is STRLEN which is unsigned, need to copy to signed */
10683 vFAIL("Internal disaster");
10686 *flagp |= HASWIDTH;
10687 if (len == 1 && UNI_IS_INVARIANT(ender))
10691 RExC_size += STR_SZ(len);
10693 STR_LEN(ret) = len;
10694 RExC_emit += STR_SZ(len);
10702 /* Jumped to when an unrecognized character set is encountered */
10704 Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
10709 S_regwhite( RExC_state_t *pRExC_state, char *p )
10711 const char *e = RExC_end;
10713 PERL_ARGS_ASSERT_REGWHITE;
10718 else if (*p == '#') {
10721 if (*p++ == '\n') {
10727 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
10735 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
10736 Character classes ([:foo:]) can also be negated ([:^foo:]).
10737 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
10738 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
10739 but trigger failures because they are currently unimplemented. */
10741 #define POSIXCC_DONE(c) ((c) == ':')
10742 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
10743 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
10746 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
10749 I32 namedclass = OOB_NAMEDCLASS;
10751 PERL_ARGS_ASSERT_REGPPOSIXCC;
10753 if (value == '[' && RExC_parse + 1 < RExC_end &&
10754 /* I smell either [: or [= or [. -- POSIX has been here, right? */
10755 POSIXCC(UCHARAT(RExC_parse))) {
10756 const char c = UCHARAT(RExC_parse);
10757 char* const s = RExC_parse++;
10759 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
10761 if (RExC_parse == RExC_end)
10762 /* Grandfather lone [:, [=, [. */
10765 const char* const t = RExC_parse++; /* skip over the c */
10768 if (UCHARAT(RExC_parse) == ']') {
10769 const char *posixcc = s + 1;
10770 RExC_parse++; /* skip over the ending ] */
10773 const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
10774 const I32 skip = t - posixcc;
10776 /* Initially switch on the length of the name. */
10779 if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
10780 namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
10783 /* Names all of length 5. */
10784 /* alnum alpha ascii blank cntrl digit graph lower
10785 print punct space upper */
10786 /* Offset 4 gives the best switch position. */
10787 switch (posixcc[4]) {
10789 if (memEQ(posixcc, "alph", 4)) /* alpha */
10790 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
10793 if (memEQ(posixcc, "spac", 4)) /* space */
10794 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
10797 if (memEQ(posixcc, "grap", 4)) /* graph */
10798 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
10801 if (memEQ(posixcc, "asci", 4)) /* ascii */
10802 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
10805 if (memEQ(posixcc, "blan", 4)) /* blank */
10806 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
10809 if (memEQ(posixcc, "cntr", 4)) /* cntrl */
10810 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
10813 if (memEQ(posixcc, "alnu", 4)) /* alnum */
10814 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
10817 if (memEQ(posixcc, "lowe", 4)) /* lower */
10818 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
10819 else if (memEQ(posixcc, "uppe", 4)) /* upper */
10820 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
10823 if (memEQ(posixcc, "digi", 4)) /* digit */
10824 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
10825 else if (memEQ(posixcc, "prin", 4)) /* print */
10826 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
10827 else if (memEQ(posixcc, "punc", 4)) /* punct */
10828 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
10833 if (memEQ(posixcc, "xdigit", 6))
10834 namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
10838 if (namedclass == OOB_NAMEDCLASS)
10839 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
10841 assert (posixcc[skip] == ':');
10842 assert (posixcc[skip+1] == ']');
10843 } else if (!SIZE_ONLY) {
10844 /* [[=foo=]] and [[.foo.]] are still future. */
10846 /* adjust RExC_parse so the warning shows after
10847 the class closes */
10848 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
10850 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10853 /* Maternal grandfather:
10854 * "[:" ending in ":" but not in ":]" */
10864 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
10868 PERL_ARGS_ASSERT_CHECKPOSIXCC;
10870 if (POSIXCC(UCHARAT(RExC_parse))) {
10871 const char *s = RExC_parse;
10872 const char c = *s++;
10874 while (isALNUM(*s))
10876 if (*s && c == *s && s[1] == ']') {
10878 "POSIX syntax [%c %c] belongs inside character classes",
10881 /* [[=foo=]] and [[.foo.]] are still future. */
10882 if (POSIXCC_NOTYET(c)) {
10883 /* adjust RExC_parse so the error shows after
10884 the class closes */
10885 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
10887 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10893 /* Generate the code to add a full posix character <class> to the bracketed
10894 * character class given by <node>. (<node> is needed only under locale rules)
10895 * destlist is the inversion list for non-locale rules that this class is
10897 * sourcelist is the ASCII-range inversion list to add under /a rules
10898 * Xsourcelist is the full Unicode range list to use otherwise. */
10899 #define DO_POSIX(node, class, destlist, sourcelist, Xsourcelist) \
10901 SV* scratch_list = NULL; \
10903 /* Set this class in the node for runtime matching */ \
10904 ANYOF_CLASS_SET(node, class); \
10906 /* For above Latin1 code points, we use the full Unicode range */ \
10907 _invlist_intersection(PL_AboveLatin1, \
10910 /* And set the output to it, adding instead if there already is an \
10911 * output. Checking if <destlist> is NULL first saves an extra \
10912 * clone. Its reference count will be decremented at the next \
10913 * union, etc, or if this is the only instance, at the end of the \
10915 if (! destlist) { \
10916 destlist = scratch_list; \
10919 _invlist_union(destlist, scratch_list, &destlist); \
10920 SvREFCNT_dec(scratch_list); \
10924 /* For non-locale, just add it to any existing list */ \
10925 _invlist_union(destlist, \
10926 (AT_LEAST_ASCII_RESTRICTED) \
10932 /* Like DO_POSIX, but matches the complement of <sourcelist> and <Xsourcelist>.
10934 #define DO_N_POSIX(node, class, destlist, sourcelist, Xsourcelist) \
10936 SV* scratch_list = NULL; \
10937 ANYOF_CLASS_SET(node, class); \
10938 _invlist_subtract(PL_AboveLatin1, Xsourcelist, &scratch_list); \
10939 if (! destlist) { \
10940 destlist = scratch_list; \
10943 _invlist_union(destlist, scratch_list, &destlist); \
10944 SvREFCNT_dec(scratch_list); \
10948 _invlist_union_complement_2nd(destlist, \
10949 (AT_LEAST_ASCII_RESTRICTED) \
10953 /* Under /d, everything in the upper half of the Latin1 range \
10954 * matches this complement */ \
10955 if (DEPENDS_SEMANTICS) { \
10956 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL; \
10960 /* Generate the code to add a posix character <class> to the bracketed
10961 * character class given by <node>. (<node> is needed only under locale rules)
10962 * destlist is the inversion list for non-locale rules that this class is
10964 * sourcelist is the ASCII-range inversion list to add under /a rules
10965 * l1_sourcelist is the Latin1 range list to use otherwise.
10966 * Xpropertyname is the name to add to <run_time_list> of the property to
10967 * specify the code points above Latin1 that will have to be
10968 * determined at run-time
10969 * run_time_list is a SV* that contains text names of properties that are to
10970 * be computed at run time. This concatenates <Xpropertyname>
10971 * to it, apppropriately
10972 * This is essentially DO_POSIX, but we know only the Latin1 values at compile
10974 #define DO_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist, \
10975 l1_sourcelist, Xpropertyname, run_time_list) \
10976 /* First, resolve whether to use the ASCII-only list or the L1 \
10978 DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(node, class, destlist, \
10979 ((AT_LEAST_ASCII_RESTRICTED) ? sourcelist : l1_sourcelist),\
10980 Xpropertyname, run_time_list)
10982 #define DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(node, class, destlist, sourcelist, \
10983 Xpropertyname, run_time_list) \
10984 /* If not /a matching, there are going to be code points we will have \
10985 * to defer to runtime to look-up */ \
10986 if (! AT_LEAST_ASCII_RESTRICTED) { \
10987 Perl_sv_catpvf(aTHX_ run_time_list, "+utf8::%s\n", Xpropertyname); \
10990 ANYOF_CLASS_SET(node, class); \
10993 _invlist_union(destlist, sourcelist, &destlist); \
10996 /* Like DO_POSIX_LATIN1_ONLY_KNOWN, but for the complement. A combination of
10997 * this and DO_N_POSIX */
10998 #define DO_N_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist, \
10999 l1_sourcelist, Xpropertyname, run_time_list) \
11000 if (AT_LEAST_ASCII_RESTRICTED) { \
11001 _invlist_union_complement_2nd(destlist, sourcelist, &destlist); \
11004 Perl_sv_catpvf(aTHX_ run_time_list, "!utf8::%s\n", Xpropertyname); \
11006 ANYOF_CLASS_SET(node, namedclass); \
11009 SV* scratch_list = NULL; \
11010 _invlist_subtract(PL_Latin1, l1_sourcelist, &scratch_list); \
11011 if (! destlist) { \
11012 destlist = scratch_list; \
11015 _invlist_union(destlist, scratch_list, &destlist); \
11016 SvREFCNT_dec(scratch_list); \
11018 if (DEPENDS_SEMANTICS) { \
11019 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL; \
11025 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
11028 /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
11029 * Locale folding is done at run-time, so this function should not be
11030 * called for nodes that are for locales.
11032 * This function sets the bit corresponding to the fold of the input
11033 * 'value', if not already set. The fold of 'f' is 'F', and the fold of
11036 * It also knows about the characters that are in the bitmap that have
11037 * folds that are matchable only outside it, and sets the appropriate lists
11040 * It returns the number of bits that actually changed from 0 to 1 */
11045 PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
11047 fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
11050 /* It assumes the bit for 'value' has already been set */
11051 if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
11052 ANYOF_BITMAP_SET(node, fold);
11055 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
11056 /* Certain Latin1 characters have matches outside the bitmap. To get
11057 * here, 'value' is one of those characters. None of these matches is
11058 * valid for ASCII characters under /aa, which have been excluded by
11059 * the 'if' above. The matches fall into three categories:
11060 * 1) They are singly folded-to or -from an above 255 character, as
11061 * LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
11063 * 2) They are part of a multi-char fold with another character in the
11064 * bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
11065 * 3) They are part of a multi-char fold with a character not in the
11066 * bitmap, such as various ligatures.
11067 * We aren't dealing fully with multi-char folds, except we do deal
11068 * with the pattern containing a character that has a multi-char fold
11069 * (not so much the inverse).
11070 * For types 1) and 3), the matches only happen when the target string
11071 * is utf8; that's not true for 2), and we set a flag for it.
11073 * The code below adds to the passed in inversion list the single fold
11074 * closures for 'value'. The values are hard-coded here so that an
11075 * innocent-looking character class, like /[ks]/i won't have to go out
11076 * to disk to find the possible matches. XXX It would be better to
11077 * generate these via regen, in case a new version of the Unicode
11078 * standard adds new mappings, though that is not really likely. */
11083 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
11087 /* LATIN SMALL LETTER LONG S */
11088 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
11091 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
11092 GREEK_SMALL_LETTER_MU);
11093 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
11094 GREEK_CAPITAL_LETTER_MU);
11096 case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
11097 case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
11098 /* ANGSTROM SIGN */
11099 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
11100 if (DEPENDS_SEMANTICS) { /* See DEPENDS comment below */
11101 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
11102 PL_fold_latin1[value]);
11105 case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
11106 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
11107 LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
11109 case LATIN_SMALL_LETTER_SHARP_S:
11110 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
11111 LATIN_CAPITAL_LETTER_SHARP_S);
11113 /* Under /a, /d, and /u, this can match the two chars "ss" */
11114 if (! MORE_ASCII_RESTRICTED) {
11115 add_alternate(alternate_ptr, (U8 *) "ss", 2);
11117 /* And under /u or /a, it can match even if the target is
11119 if (AT_LEAST_UNI_SEMANTICS) {
11120 ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
11124 case 'F': case 'f':
11125 case 'I': case 'i':
11126 case 'L': case 'l':
11127 case 'T': case 't':
11128 case 'A': case 'a':
11129 case 'H': case 'h':
11130 case 'J': case 'j':
11131 case 'N': case 'n':
11132 case 'W': case 'w':
11133 case 'Y': case 'y':
11134 /* These all are targets of multi-character folds from code
11135 * points that require UTF8 to express, so they can't match
11136 * unless the target string is in UTF-8, so no action here is
11137 * necessary, as regexec.c properly handles the general case
11138 * for UTF-8 matching */
11141 /* Use deprecated warning to increase the chances of this
11143 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
11147 else if (DEPENDS_SEMANTICS
11148 && ! isASCII(value)
11149 && PL_fold_latin1[value] != value)
11151 /* Under DEPENDS rules, non-ASCII Latin1 characters match their
11152 * folds only when the target string is in UTF-8. We add the fold
11153 * here to the list of things to match outside the bitmap, which
11154 * won't be looked at unless it is UTF8 (or else if something else
11155 * says to look even if not utf8, but those things better not happen
11156 * under DEPENDS semantics. */
11157 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
11164 PERL_STATIC_INLINE U8
11165 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
11167 /* This inline function sets a bit in the bitmap if not already set, and if
11168 * appropriate, its fold, returning the number of bits that actually
11169 * changed from 0 to 1 */
11173 PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
11175 if (ANYOF_BITMAP_TEST(node, value)) { /* Already set */
11179 ANYOF_BITMAP_SET(node, value);
11182 if (FOLD && ! LOC) { /* Locale folds aren't known until runtime */
11183 stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
11190 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
11192 /* Adds input 'string' with length 'len' to the ANYOF node's unicode
11193 * alternate list, pointed to by 'alternate_ptr'. This is an array of
11194 * the multi-character folds of characters in the node */
11197 PERL_ARGS_ASSERT_ADD_ALTERNATE;
11199 if (! *alternate_ptr) {
11200 *alternate_ptr = newAV();
11202 sv = newSVpvn_utf8((char*)string, len, TRUE);
11203 av_push(*alternate_ptr, sv);
11208 parse a class specification and produce either an ANYOF node that
11209 matches the pattern or perhaps will be optimized into an EXACTish node
11210 instead. The node contains a bit map for the first 256 characters, with the
11211 corresponding bit set if that character is in the list. For characters
11212 above 255, a range list is used */
11215 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
11218 register UV nextvalue;
11219 register IV prevvalue = OOB_UNICODE;
11220 register IV range = 0;
11221 UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
11222 register regnode *ret;
11225 char *rangebegin = NULL;
11226 bool need_class = 0;
11227 bool allow_full_fold = TRUE; /* Assume wants multi-char folding */
11229 STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
11230 than just initialized. */
11231 SV* properties = NULL; /* Code points that match \p{} \P{} */
11232 UV element_count = 0; /* Number of distinct elements in the class.
11233 Optimizations may be possible if this is tiny */
11236 /* Unicode properties are stored in a swash; this holds the current one
11237 * being parsed. If this swash is the only above-latin1 component of the
11238 * character class, an optimization is to pass it directly on to the
11239 * execution engine. Otherwise, it is set to NULL to indicate that there
11240 * are other things in the class that have to be dealt with at execution
11242 SV* swash = NULL; /* Code points that match \p{} \P{} */
11244 /* Set if a component of this character class is user-defined; just passed
11245 * on to the engine */
11246 UV has_user_defined_property = 0;
11248 /* code points this node matches that can't be stored in the bitmap */
11249 SV* nonbitmap = NULL;
11251 /* The items that are to match that aren't stored in the bitmap, but are a
11252 * result of things that are stored there. This is the fold closure of
11253 * such a character, either because it has DEPENDS semantics and shouldn't
11254 * be matched unless the target string is utf8, or is a code point that is
11255 * too large for the bit map, as for example, the fold of the MICRO SIGN is
11256 * above 255. This all is solely for performance reasons. By having this
11257 * code know the outside-the-bitmap folds that the bitmapped characters are
11258 * involved with, we don't have to go out to disk to find the list of
11259 * matches, unless the character class includes code points that aren't
11260 * storable in the bit map. That means that a character class with an 's'
11261 * in it, for example, doesn't need to go out to disk to find everything
11262 * that matches. A 2nd list is used so that the 'nonbitmap' list is kept
11263 * empty unless there is something whose fold we don't know about, and will
11264 * have to go out to the disk to find. */
11265 SV* l1_fold_invlist = NULL;
11267 /* List of multi-character folds that are matched by this node */
11268 AV* unicode_alternate = NULL;
11270 UV literal_endpoint = 0;
11272 UV stored = 0; /* how many chars stored in the bitmap */
11274 regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
11275 case we need to change the emitted regop to an EXACT. */
11276 const char * orig_parse = RExC_parse;
11277 GET_RE_DEBUG_FLAGS_DECL;
11279 PERL_ARGS_ASSERT_REGCLASS;
11281 PERL_UNUSED_ARG(depth);
11284 DEBUG_PARSE("clas");
11286 /* Assume we are going to generate an ANYOF node. */
11287 ret = reganode(pRExC_state, ANYOF, 0);
11291 ANYOF_FLAGS(ret) = 0;
11294 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
11298 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
11300 /* We have decided to not allow multi-char folds in inverted character
11301 * classes, due to the confusion that can happen, especially with
11302 * classes that are designed for a non-Unicode world: You have the
11303 * peculiar case that:
11304 "s s" =~ /^[^\xDF]+$/i => Y
11305 "ss" =~ /^[^\xDF]+$/i => N
11307 * See [perl #89750] */
11308 allow_full_fold = FALSE;
11312 RExC_size += ANYOF_SKIP;
11313 listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
11316 RExC_emit += ANYOF_SKIP;
11318 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
11320 ANYOF_BITMAP_ZERO(ret);
11321 listsv = newSVpvs("# comment\n");
11322 initial_listsv_len = SvCUR(listsv);
11325 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
11327 if (!SIZE_ONLY && POSIXCC(nextvalue))
11328 checkposixcc(pRExC_state);
11330 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
11331 if (UCHARAT(RExC_parse) == ']')
11332 goto charclassloop;
11335 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
11339 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
11342 rangebegin = RExC_parse;
11346 value = utf8n_to_uvchr((U8*)RExC_parse,
11347 RExC_end - RExC_parse,
11348 &numlen, UTF8_ALLOW_DEFAULT);
11349 RExC_parse += numlen;
11352 value = UCHARAT(RExC_parse++);
11354 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
11355 if (value == '[' && POSIXCC(nextvalue))
11356 namedclass = regpposixcc(pRExC_state, value);
11357 else if (value == '\\') {
11359 value = utf8n_to_uvchr((U8*)RExC_parse,
11360 RExC_end - RExC_parse,
11361 &numlen, UTF8_ALLOW_DEFAULT);
11362 RExC_parse += numlen;
11365 value = UCHARAT(RExC_parse++);
11366 /* Some compilers cannot handle switching on 64-bit integer
11367 * values, therefore value cannot be an UV. Yes, this will
11368 * be a problem later if we want switch on Unicode.
11369 * A similar issue a little bit later when switching on
11370 * namedclass. --jhi */
11371 switch ((I32)value) {
11372 case 'w': namedclass = ANYOF_ALNUM; break;
11373 case 'W': namedclass = ANYOF_NALNUM; break;
11374 case 's': namedclass = ANYOF_SPACE; break;
11375 case 'S': namedclass = ANYOF_NSPACE; break;
11376 case 'd': namedclass = ANYOF_DIGIT; break;
11377 case 'D': namedclass = ANYOF_NDIGIT; break;
11378 case 'v': namedclass = ANYOF_VERTWS; break;
11379 case 'V': namedclass = ANYOF_NVERTWS; break;
11380 case 'h': namedclass = ANYOF_HORIZWS; break;
11381 case 'H': namedclass = ANYOF_NHORIZWS; break;
11382 case 'N': /* Handle \N{NAME} in class */
11384 /* We only pay attention to the first char of
11385 multichar strings being returned. I kinda wonder
11386 if this makes sense as it does change the behaviour
11387 from earlier versions, OTOH that behaviour was broken
11389 UV v; /* value is register so we cant & it /grrr */
11390 if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
11400 if (RExC_parse >= RExC_end)
11401 vFAIL2("Empty \\%c{}", (U8)value);
11402 if (*RExC_parse == '{') {
11403 const U8 c = (U8)value;
11404 e = strchr(RExC_parse++, '}');
11406 vFAIL2("Missing right brace on \\%c{}", c);
11407 while (isSPACE(UCHARAT(RExC_parse)))
11409 if (e == RExC_parse)
11410 vFAIL2("Empty \\%c{}", c);
11411 n = e - RExC_parse;
11412 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
11423 if (UCHARAT(RExC_parse) == '^') {
11426 value = value == 'p' ? 'P' : 'p'; /* toggle */
11427 while (isSPACE(UCHARAT(RExC_parse))) {
11432 /* Try to get the definition of the property into
11433 * <invlist>. If /i is in effect, the effective property
11434 * will have its name be <__NAME_i>. The design is
11435 * discussed in commit
11436 * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
11437 Newx(name, n + sizeof("_i__\n"), char);
11439 sprintf(name, "%s%.*s%s\n",
11440 (FOLD) ? "__" : "",
11446 /* Look up the property name, and get its swash and
11447 * inversion list, if the property is found */
11449 SvREFCNT_dec(swash);
11451 swash = _core_swash_init("utf8", name, &PL_sv_undef,
11454 TRUE, /* this routine will handle
11455 undefined properties */
11456 NULL, FALSE /* No inversion list */
11460 || ! SvTYPE(SvRV(swash)) == SVt_PVHV
11462 hv_fetchs(MUTABLE_HV(SvRV(swash)),
11464 || ! (invlist = *invlistsvp))
11467 SvREFCNT_dec(swash);
11471 /* Here didn't find it. It could be a user-defined
11472 * property that will be available at run-time. Add it
11473 * to the list to look up then */
11474 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
11475 (value == 'p' ? '+' : '!'),
11477 has_user_defined_property = 1;
11479 /* We don't know yet, so have to assume that the
11480 * property could match something in the Latin1 range,
11481 * hence something that isn't utf8 */
11482 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
11486 /* Here, did get the swash and its inversion list. If
11487 * the swash is from a user-defined property, then this
11488 * whole character class should be regarded as such */
11489 SV** user_defined_svp =
11490 hv_fetchs(MUTABLE_HV(SvRV(swash)),
11491 "USER_DEFINED", FALSE);
11492 if (user_defined_svp) {
11493 has_user_defined_property
11494 |= SvUV(*user_defined_svp);
11497 /* Invert if asking for the complement */
11498 if (value == 'P') {
11499 _invlist_union_complement_2nd(properties, invlist, &properties);
11501 /* The swash can't be used as-is, because we've
11502 * inverted things; delay removing it to here after
11503 * have copied its invlist above */
11504 SvREFCNT_dec(swash);
11508 _invlist_union(properties, invlist, &properties);
11513 RExC_parse = e + 1;
11514 namedclass = ANYOF_MAX; /* no official name, but it's named */
11516 /* \p means they want Unicode semantics */
11517 RExC_uni_semantics = 1;
11520 case 'n': value = '\n'; break;
11521 case 'r': value = '\r'; break;
11522 case 't': value = '\t'; break;
11523 case 'f': value = '\f'; break;
11524 case 'b': value = '\b'; break;
11525 case 'e': value = ASCII_TO_NATIVE('\033');break;
11526 case 'a': value = ASCII_TO_NATIVE('\007');break;
11528 RExC_parse--; /* function expects to be pointed at the 'o' */
11530 const char* error_msg;
11531 bool valid = grok_bslash_o(RExC_parse,
11536 RExC_parse += numlen;
11541 if (PL_encoding && value < 0x100) {
11542 goto recode_encoding;
11546 RExC_parse--; /* function expects to be pointed at the 'x' */
11548 const char* error_msg;
11549 bool valid = grok_bslash_x(RExC_parse,
11554 RExC_parse += numlen;
11559 if (PL_encoding && value < 0x100)
11560 goto recode_encoding;
11563 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
11565 case '0': case '1': case '2': case '3': case '4':
11566 case '5': case '6': case '7':
11568 /* Take 1-3 octal digits */
11569 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
11571 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
11572 RExC_parse += numlen;
11573 if (PL_encoding && value < 0x100)
11574 goto recode_encoding;
11578 if (! RExC_override_recoding) {
11579 SV* enc = PL_encoding;
11580 value = reg_recode((const char)(U8)value, &enc);
11581 if (!enc && SIZE_ONLY)
11582 ckWARNreg(RExC_parse,
11583 "Invalid escape in the specified encoding");
11587 /* Allow \_ to not give an error */
11588 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
11589 ckWARN2reg(RExC_parse,
11590 "Unrecognized escape \\%c in character class passed through",
11595 } /* end of \blah */
11598 literal_endpoint++;
11601 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
11603 /* What matches in a locale is not known until runtime, so need to
11604 * (one time per class) allocate extra space to pass to regexec.
11605 * The space will contain a bit for each named class that is to be
11606 * matched against. This isn't needed for \p{} and pseudo-classes,
11607 * as they are not affected by locale, and hence are dealt with
11609 if (LOC && namedclass < ANYOF_MAX && ! need_class) {
11612 RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
11615 RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
11616 ANYOF_CLASS_ZERO(ret);
11618 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
11621 /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a
11622 * literal, as is the character that began the false range, i.e.
11623 * the 'a' in the examples */
11627 RExC_parse >= rangebegin ?
11628 RExC_parse - rangebegin : 0;
11629 ckWARN4reg(RExC_parse,
11630 "False [] range \"%*.*s\"",
11634 set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
11635 if (prevvalue < 256) {
11637 set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
11640 nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
11644 range = 0; /* this was not a true range */
11649 /* Possible truncation here but in some 64-bit environments
11650 * the compiler gets heartburn about switch on 64-bit values.
11651 * A similar issue a little earlier when switching on value.
11653 switch ((I32)namedclass) {
11655 case ANYOF_ALNUMC: /* C's alnum, in contrast to \w */
11656 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11657 PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
11659 case ANYOF_NALNUMC:
11660 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11661 PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
11664 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11665 PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
11668 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11669 PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
11673 ANYOF_CLASS_SET(ret, namedclass);
11676 _invlist_union(properties, PL_ASCII, &properties);
11681 ANYOF_CLASS_SET(ret, namedclass);
11684 _invlist_union_complement_2nd(properties,
11685 PL_ASCII, &properties);
11686 if (DEPENDS_SEMANTICS) {
11687 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
11692 DO_POSIX(ret, namedclass, properties,
11693 PL_PosixBlank, PL_XPosixBlank);
11696 DO_N_POSIX(ret, namedclass, properties,
11697 PL_PosixBlank, PL_XPosixBlank);
11700 DO_POSIX(ret, namedclass, properties,
11701 PL_PosixCntrl, PL_XPosixCntrl);
11704 DO_N_POSIX(ret, namedclass, properties,
11705 PL_PosixCntrl, PL_XPosixCntrl);
11708 /* There are no digits in the Latin1 range outside of
11709 * ASCII, so call the macro that doesn't have to resolve
11711 DO_POSIX_LATIN1_ONLY_KNOWN_L1_RESOLVED(ret, namedclass, properties,
11712 PL_PosixDigit, "XPosixDigit", listsv);
11715 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11716 PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
11719 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11720 PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
11723 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11724 PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
11726 case ANYOF_HORIZWS:
11727 /* For these, we use the nonbitmap, as /d doesn't make a
11728 * difference in what these match. There would be problems
11729 * if these characters had folds other than themselves, as
11730 * nonbitmap is subject to folding. It turns out that \h
11731 * is just a synonym for XPosixBlank */
11732 _invlist_union(nonbitmap, PL_XPosixBlank, &nonbitmap);
11734 case ANYOF_NHORIZWS:
11735 _invlist_union_complement_2nd(nonbitmap,
11736 PL_XPosixBlank, &nonbitmap);
11740 { /* These require special handling, as they differ under
11741 folding, matching Cased there (which in the ASCII range
11742 is the same as Alpha */
11748 if (FOLD && ! LOC) {
11749 ascii_source = PL_PosixAlpha;
11750 l1_source = PL_L1Cased;
11754 ascii_source = PL_PosixLower;
11755 l1_source = PL_L1PosixLower;
11756 Xname = "XPosixLower";
11758 if (namedclass == ANYOF_LOWER) {
11759 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11760 ascii_source, l1_source, Xname, listsv);
11763 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11764 properties, ascii_source, l1_source, Xname, listsv);
11769 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11770 PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11773 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11774 PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11777 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11778 PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11781 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11782 PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11785 DO_POSIX(ret, namedclass, properties,
11786 PL_PosixSpace, PL_XPosixSpace);
11788 case ANYOF_NPSXSPC:
11789 DO_N_POSIX(ret, namedclass, properties,
11790 PL_PosixSpace, PL_XPosixSpace);
11793 DO_POSIX(ret, namedclass, properties,
11794 PL_PerlSpace, PL_XPerlSpace);
11797 DO_N_POSIX(ret, namedclass, properties,
11798 PL_PerlSpace, PL_XPerlSpace);
11800 case ANYOF_UPPER: /* Same as LOWER, above */
11807 if (FOLD && ! LOC) {
11808 ascii_source = PL_PosixAlpha;
11809 l1_source = PL_L1Cased;
11813 ascii_source = PL_PosixUpper;
11814 l1_source = PL_L1PosixUpper;
11815 Xname = "XPosixUpper";
11817 if (namedclass == ANYOF_UPPER) {
11818 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11819 ascii_source, l1_source, Xname, listsv);
11822 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11823 properties, ascii_source, l1_source, Xname, listsv);
11827 case ANYOF_ALNUM: /* Really is 'Word' */
11828 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11829 PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11832 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11833 PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11836 /* For these, we use the nonbitmap, as /d doesn't make a
11837 * difference in what these match. There would be problems
11838 * if these characters had folds other than themselves, as
11839 * nonbitmap is subject to folding */
11840 _invlist_union(nonbitmap, PL_VertSpace, &nonbitmap);
11842 case ANYOF_NVERTWS:
11843 _invlist_union_complement_2nd(nonbitmap,
11844 PL_VertSpace, &nonbitmap);
11847 DO_POSIX(ret, namedclass, properties,
11848 PL_PosixXDigit, PL_XPosixXDigit);
11850 case ANYOF_NXDIGIT:
11851 DO_N_POSIX(ret, namedclass, properties,
11852 PL_PosixXDigit, PL_XPosixXDigit);
11855 /* this is to handle \p and \P */
11858 vFAIL("Invalid [::] class");
11864 } /* end of namedclass \blah */
11867 if (prevvalue > (IV)value) /* b-a */ {
11868 const int w = RExC_parse - rangebegin;
11869 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
11870 range = 0; /* not a valid range */
11874 prevvalue = value; /* save the beginning of the range */
11875 if (RExC_parse+1 < RExC_end
11876 && *RExC_parse == '-'
11877 && RExC_parse[1] != ']')
11881 /* a bad range like \w-, [:word:]- ? */
11882 if (namedclass > OOB_NAMEDCLASS) {
11883 if (ckWARN(WARN_REGEXP)) {
11885 RExC_parse >= rangebegin ?
11886 RExC_parse - rangebegin : 0;
11888 "False [] range \"%*.*s\"",
11893 set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
11895 range = 1; /* yeah, it's a range! */
11896 continue; /* but do it the next time */
11900 /* non-Latin1 code point implies unicode semantics. Must be set in
11901 * pass1 so is there for the whole of pass 2 */
11903 RExC_uni_semantics = 1;
11906 /* now is the next time */
11908 if (prevvalue < 256) {
11909 const IV ceilvalue = value < 256 ? value : 255;
11912 /* In EBCDIC [\x89-\x91] should include
11913 * the \x8e but [i-j] should not. */
11914 if (literal_endpoint == 2 &&
11915 ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
11916 (isUPPER(prevvalue) && isUPPER(ceilvalue))))
11918 if (isLOWER(prevvalue)) {
11919 for (i = prevvalue; i <= ceilvalue; i++)
11920 if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11922 set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11925 for (i = prevvalue; i <= ceilvalue; i++)
11926 if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11928 set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11934 for (i = prevvalue; i <= ceilvalue; i++) {
11935 stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11939 const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
11940 const UV natvalue = NATIVE_TO_UNI(value);
11941 nonbitmap = _add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
11944 literal_endpoint = 0;
11948 range = 0; /* this range (if it was one) is done now */
11955 /****** !SIZE_ONLY AFTER HERE *********/
11957 /* If folding and there are code points above 255, we calculate all
11958 * characters that could fold to or from the ones already on the list */
11959 if (FOLD && nonbitmap) {
11960 UV start, end; /* End points of code point ranges */
11962 SV* fold_intersection = NULL;
11964 /* This is a list of all the characters that participate in folds
11965 * (except marks, etc in multi-char folds */
11966 if (! PL_utf8_foldable) {
11967 SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
11968 PL_utf8_foldable = _swash_to_invlist(swash);
11969 SvREFCNT_dec(swash);
11972 /* This is a hash that for a particular fold gives all characters
11973 * that are involved in it */
11974 if (! PL_utf8_foldclosures) {
11976 /* If we were unable to find any folds, then we likely won't be
11977 * able to find the closures. So just create an empty list.
11978 * Folding will effectively be restricted to the non-Unicode rules
11979 * hard-coded into Perl. (This case happens legitimately during
11980 * compilation of Perl itself before the Unicode tables are
11982 if (invlist_len(PL_utf8_foldable) == 0) {
11983 PL_utf8_foldclosures = newHV();
11985 /* If the folds haven't been read in, call a fold function
11987 if (! PL_utf8_tofold) {
11988 U8 dummy[UTF8_MAXBYTES+1];
11991 /* This particular string is above \xff in both UTF-8 and
11993 to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
11994 assert(PL_utf8_tofold); /* Verify that worked */
11996 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
12000 /* Only the characters in this class that participate in folds need be
12001 * checked. Get the intersection of this class and all the possible
12002 * characters that are foldable. This can quickly narrow down a large
12004 _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection);
12006 /* Now look at the foldable characters in this class individually */
12007 invlist_iterinit(fold_intersection);
12008 while (invlist_iternext(fold_intersection, &start, &end)) {
12011 /* Look at every character in the range */
12012 for (j = start; j <= end; j++) {
12015 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
12018 _to_uni_fold_flags(j, foldbuf, &foldlen,
12019 (allow_full_fold) ? FOLD_FLAGS_FULL : 0);
12021 if (foldlen > (STRLEN)UNISKIP(f)) {
12023 /* Any multicharacter foldings (disallowed in lookbehind
12024 * patterns) require the following transform: [ABCDEF] ->
12025 * (?:[ABCabcDEFd]|pq|rst) where E folds into "pq" and F
12026 * folds into "rst", all other characters fold to single
12027 * characters. We save away these multicharacter foldings,
12028 * to be later saved as part of the additional "s" data. */
12029 if (! RExC_in_lookbehind) {
12031 U8* e = foldbuf + foldlen;
12033 /* If any of the folded characters of this are in the
12034 * Latin1 range, tell the regex engine that this can
12035 * match a non-utf8 target string. The only multi-byte
12036 * fold whose source is in the Latin1 range (U+00DF)
12037 * applies only when the target string is utf8, or
12038 * under unicode rules */
12039 if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
12042 /* Can't mix ascii with non- under /aa */
12043 if (MORE_ASCII_RESTRICTED
12044 && (isASCII(*loc) != isASCII(j)))
12046 goto end_multi_fold;
12048 if (UTF8_IS_INVARIANT(*loc)
12049 || UTF8_IS_DOWNGRADEABLE_START(*loc))
12051 /* Can't mix above and below 256 under LOC
12054 goto end_multi_fold;
12057 |= ANYOF_NONBITMAP_NON_UTF8;
12060 loc += UTF8SKIP(loc);
12064 add_alternate(&unicode_alternate, foldbuf, foldlen);
12068 /* This is special-cased, as it is the only letter which
12069 * has both a multi-fold and single-fold in Latin1. All
12070 * the other chars that have single and multi-folds are
12071 * always in utf8, and the utf8 folding algorithm catches
12073 if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
12074 stored += set_regclass_bit(pRExC_state,
12076 LATIN_SMALL_LETTER_SHARP_S,
12077 &l1_fold_invlist, &unicode_alternate);
12081 /* Single character fold. Add everything in its fold
12082 * closure to the list that this node should match */
12085 /* The fold closures data structure is a hash with the keys
12086 * being every character that is folded to, like 'k', and
12087 * the values each an array of everything that folds to its
12088 * key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
12089 if ((listp = hv_fetch(PL_utf8_foldclosures,
12090 (char *) foldbuf, foldlen, FALSE)))
12092 AV* list = (AV*) *listp;
12094 for (k = 0; k <= av_len(list); k++) {
12095 SV** c_p = av_fetch(list, k, FALSE);
12098 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
12102 /* /aa doesn't allow folds between ASCII and non-;
12103 * /l doesn't allow them between above and below
12105 if ((MORE_ASCII_RESTRICTED
12106 && (isASCII(c) != isASCII(j)))
12107 || (LOC && ((c < 256) != (j < 256))))
12112 if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
12113 stored += set_regclass_bit(pRExC_state,
12116 &l1_fold_invlist, &unicode_alternate);
12118 /* It may be that the code point is already in
12119 * this range or already in the bitmap, in
12120 * which case we need do nothing */
12121 else if ((c < start || c > end)
12123 || ! ANYOF_BITMAP_TEST(ret, c)))
12125 nonbitmap = add_cp_to_invlist(nonbitmap, c);
12132 SvREFCNT_dec(fold_intersection);
12135 /* Combine the two lists into one. */
12136 if (l1_fold_invlist) {
12138 _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap);
12139 SvREFCNT_dec(l1_fold_invlist);
12142 nonbitmap = l1_fold_invlist;
12146 /* And combine the result (if any) with any inversion list from properties.
12147 * The lists are kept separate up to now because we don't want to fold the
12151 _invlist_union(nonbitmap, properties, &nonbitmap);
12152 SvREFCNT_dec(properties);
12155 nonbitmap = properties;
12159 /* Here, <nonbitmap> contains all the code points we can determine at
12160 * compile time that we haven't put into the bitmap. Go through it, and
12161 * for things that belong in the bitmap, put them there, and delete from
12165 /* Above-ASCII code points in /d have to stay in <nonbitmap>, as they
12166 * possibly only should match when the target string is UTF-8 */
12167 UV max_cp_to_set = (DEPENDS_SEMANTICS) ? 127 : 255;
12169 /* This gets set if we actually need to modify things */
12170 bool change_invlist = FALSE;
12174 /* Start looking through <nonbitmap> */
12175 invlist_iterinit(nonbitmap);
12176 while (invlist_iternext(nonbitmap, &start, &end)) {
12180 /* Quit if are above what we should change */
12181 if (start > max_cp_to_set) {
12185 change_invlist = TRUE;
12187 /* Set all the bits in the range, up to the max that we are doing */
12188 high = (end < max_cp_to_set) ? end : max_cp_to_set;
12189 for (i = start; i <= (int) high; i++) {
12190 if (! ANYOF_BITMAP_TEST(ret, i)) {
12191 ANYOF_BITMAP_SET(ret, i);
12199 /* Done with loop; remove any code points that are in the bitmap from
12201 if (change_invlist) {
12202 _invlist_subtract(nonbitmap,
12203 (DEPENDS_SEMANTICS)
12209 /* If have completely emptied it, remove it completely */
12210 if (invlist_len(nonbitmap) == 0) {
12211 SvREFCNT_dec(nonbitmap);
12216 /* Here, we have calculated what code points should be in the character
12217 * class. <nonbitmap> does not overlap the bitmap except possibly in the
12218 * case of DEPENDS rules.
12220 * Now we can see about various optimizations. Fold calculation (which we
12221 * did above) needs to take place before inversion. Otherwise /[^k]/i
12222 * would invert to include K, which under /i would match k, which it
12225 /* Optimize inverted simple patterns (e.g. [^a-z]). Note that we haven't
12226 * set the FOLD flag yet, so this does optimize those. It doesn't
12227 * optimize locale. Doing so perhaps could be done as long as there is
12228 * nothing like \w in it; some thought also would have to be given to the
12229 * interaction with above 0x100 chars */
12230 if ((ANYOF_FLAGS(ret) & ANYOF_INVERT)
12232 && ! unicode_alternate
12233 /* In case of /d, there are some things that should match only when in
12234 * not in the bitmap, i.e., they require UTF8 to match. These are
12235 * listed in nonbitmap, but if ANYOF_NONBITMAP_NON_UTF8 is set in this
12236 * case, they don't require UTF8, so can invert here */
12238 || ! DEPENDS_SEMANTICS
12239 || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
12240 && SvCUR(listsv) == initial_listsv_len)
12244 for (i = 0; i < 256; ++i) {
12245 if (ANYOF_BITMAP_TEST(ret, i)) {
12246 ANYOF_BITMAP_CLEAR(ret, i);
12249 ANYOF_BITMAP_SET(ret, i);
12254 /* The inversion means that everything above 255 is matched */
12255 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
12258 /* Here, also has things outside the bitmap that may overlap with
12259 * the bitmap. We have to sync them up, so that they get inverted
12260 * in both places. Earlier, we removed all overlaps except in the
12261 * case of /d rules, so no syncing is needed except for this case
12263 SV *remove_list = NULL;
12265 if (DEPENDS_SEMANTICS) {
12268 /* Set the bits that correspond to the ones that aren't in the
12269 * bitmap. Otherwise, when we invert, we'll miss these.
12270 * Earlier, we removed from the nonbitmap all code points
12271 * < 128, so there is no extra work here */
12272 invlist_iterinit(nonbitmap);
12273 while (invlist_iternext(nonbitmap, &start, &end)) {
12274 if (start > 255) { /* The bit map goes to 255 */
12280 for (i = start; i <= (int) end; ++i) {
12281 ANYOF_BITMAP_SET(ret, i);
12288 /* Now invert both the bitmap and the nonbitmap. Anything in the
12289 * bitmap has to also be removed from the non-bitmap, but again,
12290 * there should not be overlap unless is /d rules. */
12291 _invlist_invert(nonbitmap);
12293 /* Any swash can't be used as-is, because we've inverted things */
12295 SvREFCNT_dec(swash);
12299 for (i = 0; i < 256; ++i) {
12300 if (ANYOF_BITMAP_TEST(ret, i)) {
12301 ANYOF_BITMAP_CLEAR(ret, i);
12302 if (DEPENDS_SEMANTICS) {
12303 if (! remove_list) {
12304 remove_list = _new_invlist(2);
12306 remove_list = add_cp_to_invlist(remove_list, i);
12310 ANYOF_BITMAP_SET(ret, i);
12316 /* And do the removal */
12317 if (DEPENDS_SEMANTICS) {
12319 _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
12320 SvREFCNT_dec(remove_list);
12324 /* There is no overlap for non-/d, so just delete anything
12326 _invlist_intersection(nonbitmap, PL_AboveLatin1, &nonbitmap);
12330 stored = 256 - stored;
12332 /* Clear the invert flag since have just done it here */
12333 ANYOF_FLAGS(ret) &= ~ANYOF_INVERT;
12336 /* Folding in the bitmap is taken care of above, but not for locale (for
12337 * which we have to wait to see what folding is in effect at runtime), and
12338 * for some things not in the bitmap (only the upper latin folds in this
12339 * case, as all other single-char folding has been set above). Set
12340 * run-time fold flag for these */
12342 || (DEPENDS_SEMANTICS
12344 && ! (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
12345 || unicode_alternate))
12347 ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
12350 /* A single character class can be "optimized" into an EXACTish node.
12351 * Note that since we don't currently count how many characters there are
12352 * outside the bitmap, we are XXX missing optimization possibilities for
12353 * them. This optimization can't happen unless this is a truly single
12354 * character class, which means that it can't be an inversion into a
12355 * many-character class, and there must be no possibility of there being
12356 * things outside the bitmap. 'stored' (only) for locales doesn't include
12357 * \w, etc, so have to make a special test that they aren't present
12359 * Similarly A 2-character class of the very special form like [bB] can be
12360 * optimized into an EXACTFish node, but only for non-locales, and for
12361 * characters which only have the two folds; so things like 'fF' and 'Ii'
12362 * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
12365 && ! unicode_alternate
12366 && SvCUR(listsv) == initial_listsv_len
12367 && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
12368 && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
12369 || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
12370 || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
12371 && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
12372 /* If the latest code point has a fold whose
12373 * bit is set, it must be the only other one */
12374 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
12375 && ANYOF_BITMAP_TEST(ret, prevvalue)))))
12377 /* Note that the information needed to decide to do this optimization
12378 * is not currently available until the 2nd pass, and that the actually
12379 * used EXACTish node takes less space than the calculated ANYOF node,
12380 * and hence the amount of space calculated in the first pass is larger
12381 * than actually used, so this optimization doesn't gain us any space.
12382 * But an EXACT node is faster than an ANYOF node, and can be combined
12383 * with any adjacent EXACT nodes later by the optimizer for further
12384 * gains. The speed of executing an EXACTF is similar to an ANYOF
12385 * node, so the optimization advantage comes from the ability to join
12386 * it to adjacent EXACT nodes */
12388 const char * cur_parse= RExC_parse;
12390 RExC_emit = (regnode *)orig_emit;
12391 RExC_parse = (char *)orig_parse;
12395 /* A locale node with one point can be folded; all the other cases
12396 * with folding will have two points, since we calculate them above
12398 if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
12405 else { /* else 2 chars in the bit map: the folds of each other */
12407 /* Use the folded value, which for the cases where we get here,
12408 * is just the lower case of the current one (which may resolve to
12409 * itself, or to the other one */
12410 value = toLOWER_LATIN1(value);
12412 /* To join adjacent nodes, they must be the exact EXACTish type.
12413 * Try to use the most likely type, by using EXACTFA if possible,
12414 * then EXACTFU if the regex calls for it, or is required because
12415 * the character is non-ASCII. (If <value> is ASCII, its fold is
12416 * also ASCII for the cases where we get here.) */
12417 if (MORE_ASCII_RESTRICTED && isASCII(value)) {
12420 else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
12423 else { /* Otherwise, more likely to be EXACTF type */
12428 ret = reg_node(pRExC_state, op);
12429 RExC_parse = (char *)cur_parse;
12430 if (UTF && ! NATIVE_IS_INVARIANT(value)) {
12431 *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
12432 *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
12434 RExC_emit += STR_SZ(2);
12437 *STRING(ret)= (char)value;
12439 RExC_emit += STR_SZ(1);
12441 SvREFCNT_dec(listsv);
12445 /* If there is a swash and more than one element, we can't use the swash in
12446 * the optimization below. */
12447 if (swash && element_count > 1) {
12448 SvREFCNT_dec(swash);
12452 && SvCUR(listsv) == initial_listsv_len
12453 && ! unicode_alternate)
12455 ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
12456 SvREFCNT_dec(listsv);
12457 SvREFCNT_dec(unicode_alternate);
12460 /* av[0] stores the character class description in its textual form:
12461 * used later (regexec.c:Perl_regclass_swash()) to initialize the
12462 * appropriate swash, and is also useful for dumping the regnode.
12463 * av[1] if NULL, is a placeholder to later contain the swash computed
12464 * from av[0]. But if no further computation need be done, the
12465 * swash is stored there now.
12466 * av[2] stores the multicharacter foldings, used later in
12467 * regexec.c:S_reginclass().
12468 * av[3] stores the nonbitmap inversion list for use in addition or
12469 * instead of av[0]; not used if av[1] isn't NULL
12470 * av[4] is set if any component of the class is from a user-defined
12471 * property; not used if av[1] isn't NULL */
12472 AV * const av = newAV();
12475 av_store(av, 0, (SvCUR(listsv) == initial_listsv_len)
12479 av_store(av, 1, swash);
12480 SvREFCNT_dec(nonbitmap);
12483 av_store(av, 1, NULL);
12485 av_store(av, 3, nonbitmap);
12486 av_store(av, 4, newSVuv(has_user_defined_property));
12490 /* Store any computed multi-char folds only if we are allowing
12492 if (allow_full_fold) {
12493 av_store(av, 2, MUTABLE_SV(unicode_alternate));
12494 if (unicode_alternate) { /* This node is variable length */
12499 av_store(av, 2, NULL);
12501 rv = newRV_noinc(MUTABLE_SV(av));
12502 n = add_data(pRExC_state, 1, "s");
12503 RExC_rxi->data->data[n] = (void*)rv;
12510 /* reg_skipcomment()
12512 Absorbs an /x style # comments from the input stream.
12513 Returns true if there is more text remaining in the stream.
12514 Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
12515 terminates the pattern without including a newline.
12517 Note its the callers responsibility to ensure that we are
12518 actually in /x mode
12523 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
12527 PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
12529 while (RExC_parse < RExC_end)
12530 if (*RExC_parse++ == '\n') {
12535 /* we ran off the end of the pattern without ending
12536 the comment, so we have to add an \n when wrapping */
12537 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
12545 Advances the parse position, and optionally absorbs
12546 "whitespace" from the inputstream.
12548 Without /x "whitespace" means (?#...) style comments only,
12549 with /x this means (?#...) and # comments and whitespace proper.
12551 Returns the RExC_parse point from BEFORE the scan occurs.
12553 This is the /x friendly way of saying RExC_parse++.
12557 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
12559 char* const retval = RExC_parse++;
12561 PERL_ARGS_ASSERT_NEXTCHAR;
12564 if (RExC_end - RExC_parse >= 3
12565 && *RExC_parse == '('
12566 && RExC_parse[1] == '?'
12567 && RExC_parse[2] == '#')
12569 while (*RExC_parse != ')') {
12570 if (RExC_parse == RExC_end)
12571 FAIL("Sequence (?#... not terminated");
12577 if (RExC_flags & RXf_PMf_EXTENDED) {
12578 if (isSPACE(*RExC_parse)) {
12582 else if (*RExC_parse == '#') {
12583 if ( reg_skipcomment( pRExC_state ) )
12592 - reg_node - emit a node
12594 STATIC regnode * /* Location. */
12595 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
12598 register regnode *ptr;
12599 regnode * const ret = RExC_emit;
12600 GET_RE_DEBUG_FLAGS_DECL;
12602 PERL_ARGS_ASSERT_REG_NODE;
12605 SIZE_ALIGN(RExC_size);
12609 if (RExC_emit >= RExC_emit_bound)
12610 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
12611 op, RExC_emit, RExC_emit_bound);
12613 NODE_ALIGN_FILL(ret);
12615 FILL_ADVANCE_NODE(ptr, op);
12616 #ifdef RE_TRACK_PATTERN_OFFSETS
12617 if (RExC_offsets) { /* MJD */
12618 MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
12619 "reg_node", __LINE__,
12621 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
12622 ? "Overwriting end of array!\n" : "OK",
12623 (UV)(RExC_emit - RExC_emit_start),
12624 (UV)(RExC_parse - RExC_start),
12625 (UV)RExC_offsets[0]));
12626 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
12634 - reganode - emit a node with an argument
12636 STATIC regnode * /* Location. */
12637 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
12640 register regnode *ptr;
12641 regnode * const ret = RExC_emit;
12642 GET_RE_DEBUG_FLAGS_DECL;
12644 PERL_ARGS_ASSERT_REGANODE;
12647 SIZE_ALIGN(RExC_size);
12652 assert(2==regarglen[op]+1);
12654 Anything larger than this has to allocate the extra amount.
12655 If we changed this to be:
12657 RExC_size += (1 + regarglen[op]);
12659 then it wouldn't matter. Its not clear what side effect
12660 might come from that so its not done so far.
12665 if (RExC_emit >= RExC_emit_bound)
12666 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
12667 op, RExC_emit, RExC_emit_bound);
12669 NODE_ALIGN_FILL(ret);
12671 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
12672 #ifdef RE_TRACK_PATTERN_OFFSETS
12673 if (RExC_offsets) { /* MJD */
12674 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
12678 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
12679 "Overwriting end of array!\n" : "OK",
12680 (UV)(RExC_emit - RExC_emit_start),
12681 (UV)(RExC_parse - RExC_start),
12682 (UV)RExC_offsets[0]));
12683 Set_Cur_Node_Offset;
12691 - reguni - emit (if appropriate) a Unicode character
12694 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
12698 PERL_ARGS_ASSERT_REGUNI;
12700 return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
12704 - reginsert - insert an operator in front of already-emitted operand
12706 * Means relocating the operand.
12709 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
12712 register regnode *src;
12713 register regnode *dst;
12714 register regnode *place;
12715 const int offset = regarglen[(U8)op];
12716 const int size = NODE_STEP_REGNODE + offset;
12717 GET_RE_DEBUG_FLAGS_DECL;
12719 PERL_ARGS_ASSERT_REGINSERT;
12720 PERL_UNUSED_ARG(depth);
12721 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
12722 DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
12731 if (RExC_open_parens) {
12733 /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
12734 for ( paren=0 ; paren < RExC_npar ; paren++ ) {
12735 if ( RExC_open_parens[paren] >= opnd ) {
12736 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
12737 RExC_open_parens[paren] += size;
12739 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
12741 if ( RExC_close_parens[paren] >= opnd ) {
12742 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
12743 RExC_close_parens[paren] += size;
12745 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
12750 while (src > opnd) {
12751 StructCopy(--src, --dst, regnode);
12752 #ifdef RE_TRACK_PATTERN_OFFSETS
12753 if (RExC_offsets) { /* MJD 20010112 */
12754 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
12758 (UV)(dst - RExC_emit_start) > RExC_offsets[0]
12759 ? "Overwriting end of array!\n" : "OK",
12760 (UV)(src - RExC_emit_start),
12761 (UV)(dst - RExC_emit_start),
12762 (UV)RExC_offsets[0]));
12763 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
12764 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
12770 place = opnd; /* Op node, where operand used to be. */
12771 #ifdef RE_TRACK_PATTERN_OFFSETS
12772 if (RExC_offsets) { /* MJD */
12773 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
12777 (UV)(place - RExC_emit_start) > RExC_offsets[0]
12778 ? "Overwriting end of array!\n" : "OK",
12779 (UV)(place - RExC_emit_start),
12780 (UV)(RExC_parse - RExC_start),
12781 (UV)RExC_offsets[0]));
12782 Set_Node_Offset(place, RExC_parse);
12783 Set_Node_Length(place, 1);
12786 src = NEXTOPER(place);
12787 FILL_ADVANCE_NODE(place, op);
12788 Zero(src, offset, regnode);
12792 - regtail - set the next-pointer at the end of a node chain of p to val.
12793 - SEE ALSO: regtail_study
12795 /* TODO: All three parms should be const */
12797 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12800 register regnode *scan;
12801 GET_RE_DEBUG_FLAGS_DECL;
12803 PERL_ARGS_ASSERT_REGTAIL;
12805 PERL_UNUSED_ARG(depth);
12811 /* Find last node. */
12814 regnode * const temp = regnext(scan);
12816 SV * const mysv=sv_newmortal();
12817 DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
12818 regprop(RExC_rx, mysv, scan);
12819 PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
12820 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
12821 (temp == NULL ? "->" : ""),
12822 (temp == NULL ? PL_reg_name[OP(val)] : "")
12830 if (reg_off_by_arg[OP(scan)]) {
12831 ARG_SET(scan, val - scan);
12834 NEXT_OFF(scan) = val - scan;
12840 - regtail_study - set the next-pointer at the end of a node chain of p to val.
12841 - Look for optimizable sequences at the same time.
12842 - currently only looks for EXACT chains.
12844 This is experimental code. The idea is to use this routine to perform
12845 in place optimizations on branches and groups as they are constructed,
12846 with the long term intention of removing optimization from study_chunk so
12847 that it is purely analytical.
12849 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
12850 to control which is which.
12853 /* TODO: All four parms should be const */
12856 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12859 register regnode *scan;
12861 #ifdef EXPERIMENTAL_INPLACESCAN
12864 GET_RE_DEBUG_FLAGS_DECL;
12866 PERL_ARGS_ASSERT_REGTAIL_STUDY;
12872 /* Find last node. */
12876 regnode * const temp = regnext(scan);
12877 #ifdef EXPERIMENTAL_INPLACESCAN
12878 if (PL_regkind[OP(scan)] == EXACT) {
12879 bool has_exactf_sharp_s; /* Unexamined in this routine */
12880 if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
12885 switch (OP(scan)) {
12891 case EXACTFU_TRICKYFOLD:
12893 if( exact == PSEUDO )
12895 else if ( exact != OP(scan) )
12904 SV * const mysv=sv_newmortal();
12905 DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
12906 regprop(RExC_rx, mysv, scan);
12907 PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
12908 SvPV_nolen_const(mysv),
12909 REG_NODE_NUM(scan),
12910 PL_reg_name[exact]);
12917 SV * const mysv_val=sv_newmortal();
12918 DEBUG_PARSE_MSG("");
12919 regprop(RExC_rx, mysv_val, val);
12920 PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
12921 SvPV_nolen_const(mysv_val),
12922 (IV)REG_NODE_NUM(val),
12926 if (reg_off_by_arg[OP(scan)]) {
12927 ARG_SET(scan, val - scan);
12930 NEXT_OFF(scan) = val - scan;
12938 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
12942 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
12948 for (bit=0; bit<32; bit++) {
12949 if (flags & (1<<bit)) {
12950 if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */
12953 if (!set++ && lead)
12954 PerlIO_printf(Perl_debug_log, "%s",lead);
12955 PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
12958 if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
12959 if (!set++ && lead) {
12960 PerlIO_printf(Perl_debug_log, "%s",lead);
12963 case REGEX_UNICODE_CHARSET:
12964 PerlIO_printf(Perl_debug_log, "UNICODE");
12966 case REGEX_LOCALE_CHARSET:
12967 PerlIO_printf(Perl_debug_log, "LOCALE");
12969 case REGEX_ASCII_RESTRICTED_CHARSET:
12970 PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
12972 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
12973 PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
12976 PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
12982 PerlIO_printf(Perl_debug_log, "\n");
12984 PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
12990 Perl_regdump(pTHX_ const regexp *r)
12994 SV * const sv = sv_newmortal();
12995 SV *dsv= sv_newmortal();
12996 RXi_GET_DECL(r,ri);
12997 GET_RE_DEBUG_FLAGS_DECL;
12999 PERL_ARGS_ASSERT_REGDUMP;
13001 (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
13003 /* Header fields of interest. */
13004 if (r->anchored_substr) {
13005 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
13006 RE_SV_DUMPLEN(r->anchored_substr), 30);
13007 PerlIO_printf(Perl_debug_log,
13008 "anchored %s%s at %"IVdf" ",
13009 s, RE_SV_TAIL(r->anchored_substr),
13010 (IV)r->anchored_offset);
13011 } else if (r->anchored_utf8) {
13012 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
13013 RE_SV_DUMPLEN(r->anchored_utf8), 30);
13014 PerlIO_printf(Perl_debug_log,
13015 "anchored utf8 %s%s at %"IVdf" ",
13016 s, RE_SV_TAIL(r->anchored_utf8),
13017 (IV)r->anchored_offset);
13019 if (r->float_substr) {
13020 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
13021 RE_SV_DUMPLEN(r->float_substr), 30);
13022 PerlIO_printf(Perl_debug_log,
13023 "floating %s%s at %"IVdf"..%"UVuf" ",
13024 s, RE_SV_TAIL(r->float_substr),
13025 (IV)r->float_min_offset, (UV)r->float_max_offset);
13026 } else if (r->float_utf8) {
13027 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
13028 RE_SV_DUMPLEN(r->float_utf8), 30);
13029 PerlIO_printf(Perl_debug_log,
13030 "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
13031 s, RE_SV_TAIL(r->float_utf8),
13032 (IV)r->float_min_offset, (UV)r->float_max_offset);
13034 if (r->check_substr || r->check_utf8)
13035 PerlIO_printf(Perl_debug_log,
13037 (r->check_substr == r->float_substr
13038 && r->check_utf8 == r->float_utf8
13039 ? "(checking floating" : "(checking anchored"));
13040 if (r->extflags & RXf_NOSCAN)
13041 PerlIO_printf(Perl_debug_log, " noscan");
13042 if (r->extflags & RXf_CHECK_ALL)
13043 PerlIO_printf(Perl_debug_log, " isall");
13044 if (r->check_substr || r->check_utf8)
13045 PerlIO_printf(Perl_debug_log, ") ");
13047 if (ri->regstclass) {
13048 regprop(r, sv, ri->regstclass);
13049 PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
13051 if (r->extflags & RXf_ANCH) {
13052 PerlIO_printf(Perl_debug_log, "anchored");
13053 if (r->extflags & RXf_ANCH_BOL)
13054 PerlIO_printf(Perl_debug_log, "(BOL)");
13055 if (r->extflags & RXf_ANCH_MBOL)
13056 PerlIO_printf(Perl_debug_log, "(MBOL)");
13057 if (r->extflags & RXf_ANCH_SBOL)
13058 PerlIO_printf(Perl_debug_log, "(SBOL)");
13059 if (r->extflags & RXf_ANCH_GPOS)
13060 PerlIO_printf(Perl_debug_log, "(GPOS)");
13061 PerlIO_putc(Perl_debug_log, ' ');
13063 if (r->extflags & RXf_GPOS_SEEN)
13064 PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
13065 if (r->intflags & PREGf_SKIP)
13066 PerlIO_printf(Perl_debug_log, "plus ");
13067 if (r->intflags & PREGf_IMPLICIT)
13068 PerlIO_printf(Perl_debug_log, "implicit ");
13069 PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
13070 if (r->extflags & RXf_EVAL_SEEN)
13071 PerlIO_printf(Perl_debug_log, "with eval ");
13072 PerlIO_printf(Perl_debug_log, "\n");
13073 DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));
13075 PERL_ARGS_ASSERT_REGDUMP;
13076 PERL_UNUSED_CONTEXT;
13077 PERL_UNUSED_ARG(r);
13078 #endif /* DEBUGGING */
13082 - regprop - printable representation of opcode
13084 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
13087 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
13088 if (flags & ANYOF_INVERT) \
13089 /*make sure the invert info is in each */ \
13090 sv_catpvs(sv, "^"); \
13096 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
13101 RXi_GET_DECL(prog,progi);
13102 GET_RE_DEBUG_FLAGS_DECL;
13104 PERL_ARGS_ASSERT_REGPROP;
13108 if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */
13109 /* It would be nice to FAIL() here, but this may be called from
13110 regexec.c, and it would be hard to supply pRExC_state. */
13111 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
13112 sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
13114 k = PL_regkind[OP(o)];
13117 sv_catpvs(sv, " ");
13118 /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
13119 * is a crude hack but it may be the best for now since
13120 * we have no flag "this EXACTish node was UTF-8"
13122 pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
13123 PERL_PV_ESCAPE_UNI_DETECT |
13124 PERL_PV_ESCAPE_NONASCII |
13125 PERL_PV_PRETTY_ELLIPSES |
13126 PERL_PV_PRETTY_LTGT |
13127 PERL_PV_PRETTY_NOCLEAR
13129 } else if (k == TRIE) {
13130 /* print the details of the trie in dumpuntil instead, as
13131 * progi->data isn't available here */
13132 const char op = OP(o);
13133 const U32 n = ARG(o);
13134 const reg_ac_data * const ac = IS_TRIE_AC(op) ?
13135 (reg_ac_data *)progi->data->data[n] :
13137 const reg_trie_data * const trie
13138 = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
13140 Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
13141 DEBUG_TRIE_COMPILE_r(
13142 Perl_sv_catpvf(aTHX_ sv,
13143 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
13144 (UV)trie->startstate,
13145 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
13146 (UV)trie->wordcount,
13149 (UV)TRIE_CHARCOUNT(trie),
13150 (UV)trie->uniquecharcount
13153 if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
13155 int rangestart = -1;
13156 U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
13157 sv_catpvs(sv, "[");
13158 for (i = 0; i <= 256; i++) {
13159 if (i < 256 && BITMAP_TEST(bitmap,i)) {
13160 if (rangestart == -1)
13162 } else if (rangestart != -1) {
13163 if (i <= rangestart + 3)
13164 for (; rangestart < i; rangestart++)
13165 put_byte(sv, rangestart);
13167 put_byte(sv, rangestart);
13168 sv_catpvs(sv, "-");
13169 put_byte(sv, i - 1);
13174 sv_catpvs(sv, "]");
13177 } else if (k == CURLY) {
13178 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
13179 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
13180 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
13182 else if (k == WHILEM && o->flags) /* Ordinal/of */
13183 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
13184 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
13185 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
13186 if ( RXp_PAREN_NAMES(prog) ) {
13187 if ( k != REF || (OP(o) < NREF)) {
13188 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
13189 SV **name= av_fetch(list, ARG(o), 0 );
13191 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
13194 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
13195 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
13196 I32 *nums=(I32*)SvPVX(sv_dat);
13197 SV **name= av_fetch(list, nums[0], 0 );
13200 for ( n=0; n<SvIVX(sv_dat); n++ ) {
13201 Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
13202 (n ? "," : ""), (IV)nums[n]);
13204 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
13208 } else if (k == GOSUB)
13209 Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
13210 else if (k == VERB) {
13212 Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
13213 SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
13214 } else if (k == LOGICAL)
13215 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
13216 else if (k == ANYOF) {
13217 int i, rangestart = -1;
13218 const U8 flags = ANYOF_FLAGS(o);
13221 /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
13222 static const char * const anyofs[] = {
13255 if (flags & ANYOF_LOCALE)
13256 sv_catpvs(sv, "{loc}");
13257 if (flags & ANYOF_LOC_NONBITMAP_FOLD)
13258 sv_catpvs(sv, "{i}");
13259 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
13260 if (flags & ANYOF_INVERT)
13261 sv_catpvs(sv, "^");
13263 /* output what the standard cp 0-255 bitmap matches */
13264 for (i = 0; i <= 256; i++) {
13265 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
13266 if (rangestart == -1)
13268 } else if (rangestart != -1) {
13269 if (i <= rangestart + 3)
13270 for (; rangestart < i; rangestart++)
13271 put_byte(sv, rangestart);
13273 put_byte(sv, rangestart);
13274 sv_catpvs(sv, "-");
13275 put_byte(sv, i - 1);
13282 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
13283 /* output any special charclass tests (used entirely under use locale) */
13284 if (ANYOF_CLASS_TEST_ANY_SET(o))
13285 for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
13286 if (ANYOF_CLASS_TEST(o,i)) {
13287 sv_catpv(sv, anyofs[i]);
13291 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
13293 if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
13294 sv_catpvs(sv, "{non-utf8-latin1-all}");
13297 /* output information about the unicode matching */
13298 if (flags & ANYOF_UNICODE_ALL)
13299 sv_catpvs(sv, "{unicode_all}");
13300 else if (ANYOF_NONBITMAP(o))
13301 sv_catpvs(sv, "{unicode}");
13302 if (flags & ANYOF_NONBITMAP_NON_UTF8)
13303 sv_catpvs(sv, "{outside bitmap}");
13305 if (ANYOF_NONBITMAP(o)) {
13306 SV *lv; /* Set if there is something outside the bit map */
13307 SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
13308 bool byte_output = FALSE; /* If something in the bitmap has been
13311 if (lv && lv != &PL_sv_undef) {
13313 U8 s[UTF8_MAXBYTES_CASE+1];
13315 for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
13316 uvchr_to_utf8(s, i);
13319 && ! ANYOF_BITMAP_TEST(o, i) /* Don't duplicate
13323 && swash_fetch(sw, s, TRUE))
13325 if (rangestart == -1)
13327 } else if (rangestart != -1) {
13328 byte_output = TRUE;
13329 if (i <= rangestart + 3)
13330 for (; rangestart < i; rangestart++) {
13331 put_byte(sv, rangestart);
13334 put_byte(sv, rangestart);
13335 sv_catpvs(sv, "-");
13344 char *s = savesvpv(lv);
13345 char * const origs = s;
13347 while (*s && *s != '\n')
13351 const char * const t = ++s;
13354 sv_catpvs(sv, " ");
13360 /* Truncate very long output */
13361 if (s - origs > 256) {
13362 Perl_sv_catpvf(aTHX_ sv,
13364 (int) (s - origs - 1),
13370 else if (*s == '\t') {
13389 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
13391 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
13392 Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
13394 PERL_UNUSED_CONTEXT;
13395 PERL_UNUSED_ARG(sv);
13396 PERL_UNUSED_ARG(o);
13397 PERL_UNUSED_ARG(prog);
13398 #endif /* DEBUGGING */
13402 Perl_re_intuit_string(pTHX_ REGEXP * const r)
13403 { /* Assume that RE_INTUIT is set */
13405 struct regexp *const prog = (struct regexp *)SvANY(r);
13406 GET_RE_DEBUG_FLAGS_DECL;
13408 PERL_ARGS_ASSERT_RE_INTUIT_STRING;
13409 PERL_UNUSED_CONTEXT;
13413 const char * const s = SvPV_nolen_const(prog->check_substr
13414 ? prog->check_substr : prog->check_utf8);
13416 if (!PL_colorset) reginitcolors();
13417 PerlIO_printf(Perl_debug_log,
13418 "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
13420 prog->check_substr ? "" : "utf8 ",
13421 PL_colors[5],PL_colors[0],
13424 (strlen(s) > 60 ? "..." : ""));
13427 return prog->check_substr ? prog->check_substr : prog->check_utf8;
13433 handles refcounting and freeing the perl core regexp structure. When
13434 it is necessary to actually free the structure the first thing it
13435 does is call the 'free' method of the regexp_engine associated to
13436 the regexp, allowing the handling of the void *pprivate; member
13437 first. (This routine is not overridable by extensions, which is why
13438 the extensions free is called first.)
13440 See regdupe and regdupe_internal if you change anything here.
13442 #ifndef PERL_IN_XSUB_RE
13444 Perl_pregfree(pTHX_ REGEXP *r)
13450 Perl_pregfree2(pTHX_ REGEXP *rx)
13453 struct regexp *const r = (struct regexp *)SvANY(rx);
13454 GET_RE_DEBUG_FLAGS_DECL;
13456 PERL_ARGS_ASSERT_PREGFREE2;
13458 if (r->mother_re) {
13459 ReREFCNT_dec(r->mother_re);
13461 CALLREGFREE_PVT(rx); /* free the private data */
13462 SvREFCNT_dec(RXp_PAREN_NAMES(r));
13465 SvREFCNT_dec(r->anchored_substr);
13466 SvREFCNT_dec(r->anchored_utf8);
13467 SvREFCNT_dec(r->float_substr);
13468 SvREFCNT_dec(r->float_utf8);
13469 Safefree(r->substrs);
13471 RX_MATCH_COPY_FREE(rx);
13472 #ifdef PERL_OLD_COPY_ON_WRITE
13473 SvREFCNT_dec(r->saved_copy);
13476 SvREFCNT_dec(r->qr_anoncv);
13481 This is a hacky workaround to the structural issue of match results
13482 being stored in the regexp structure which is in turn stored in
13483 PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
13484 could be PL_curpm in multiple contexts, and could require multiple
13485 result sets being associated with the pattern simultaneously, such
13486 as when doing a recursive match with (??{$qr})
13488 The solution is to make a lightweight copy of the regexp structure
13489 when a qr// is returned from the code executed by (??{$qr}) this
13490 lightweight copy doesn't actually own any of its data except for
13491 the starp/end and the actual regexp structure itself.
13497 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
13499 struct regexp *ret;
13500 struct regexp *const r = (struct regexp *)SvANY(rx);
13501 register const I32 npar = r->nparens+1;
13503 PERL_ARGS_ASSERT_REG_TEMP_COPY;
13506 ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
13507 ret = (struct regexp *)SvANY(ret_x);
13509 (void)ReREFCNT_inc(rx);
13510 /* We can take advantage of the existing "copied buffer" mechanism in SVs
13511 by pointing directly at the buffer, but flagging that the allocated
13512 space in the copy is zero. As we've just done a struct copy, it's now
13513 a case of zero-ing that, rather than copying the current length. */
13514 SvPV_set(ret_x, RX_WRAPPED(rx));
13515 SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
13516 memcpy(&(ret->xpv_cur), &(r->xpv_cur),
13517 sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
13518 SvLEN_set(ret_x, 0);
13519 SvSTASH_set(ret_x, NULL);
13520 SvMAGIC_set(ret_x, NULL);
13521 Newx(ret->offs, npar, regexp_paren_pair);
13522 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
13524 Newx(ret->substrs, 1, struct reg_substr_data);
13525 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
13527 SvREFCNT_inc_void(ret->anchored_substr);
13528 SvREFCNT_inc_void(ret->anchored_utf8);
13529 SvREFCNT_inc_void(ret->float_substr);
13530 SvREFCNT_inc_void(ret->float_utf8);
13532 /* check_substr and check_utf8, if non-NULL, point to either their
13533 anchored or float namesakes, and don't hold a second reference. */
13535 RX_MATCH_COPIED_off(ret_x);
13536 #ifdef PERL_OLD_COPY_ON_WRITE
13537 ret->saved_copy = NULL;
13539 ret->mother_re = rx;
13540 SvREFCNT_inc_void(ret->qr_anoncv);
13546 /* regfree_internal()
13548 Free the private data in a regexp. This is overloadable by
13549 extensions. Perl takes care of the regexp structure in pregfree(),
13550 this covers the *pprivate pointer which technically perl doesn't
13551 know about, however of course we have to handle the
13552 regexp_internal structure when no extension is in use.
13554 Note this is called before freeing anything in the regexp
13559 Perl_regfree_internal(pTHX_ REGEXP * const rx)
13562 struct regexp *const r = (struct regexp *)SvANY(rx);
13563 RXi_GET_DECL(r,ri);
13564 GET_RE_DEBUG_FLAGS_DECL;
13566 PERL_ARGS_ASSERT_REGFREE_INTERNAL;
13572 SV *dsv= sv_newmortal();
13573 RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
13574 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
13575 PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
13576 PL_colors[4],PL_colors[5],s);
13579 #ifdef RE_TRACK_PATTERN_OFFSETS
13581 Safefree(ri->u.offsets); /* 20010421 MJD */
13583 if (ri->code_blocks) {
13585 for (n = 0; n < ri->num_code_blocks; n++)
13586 SvREFCNT_dec(ri->code_blocks[n].src_regex);
13587 Safefree(ri->code_blocks);
13591 int n = ri->data->count;
13594 /* If you add a ->what type here, update the comment in regcomp.h */
13595 switch (ri->data->what[n]) {
13601 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
13604 Safefree(ri->data->data[n]);
13610 { /* Aho Corasick add-on structure for a trie node.
13611 Used in stclass optimization only */
13613 reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
13615 refcount = --aho->refcount;
13618 PerlMemShared_free(aho->states);
13619 PerlMemShared_free(aho->fail);
13620 /* do this last!!!! */
13621 PerlMemShared_free(ri->data->data[n]);
13622 PerlMemShared_free(ri->regstclass);
13628 /* trie structure. */
13630 reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
13632 refcount = --trie->refcount;
13635 PerlMemShared_free(trie->charmap);
13636 PerlMemShared_free(trie->states);
13637 PerlMemShared_free(trie->trans);
13639 PerlMemShared_free(trie->bitmap);
13641 PerlMemShared_free(trie->jump);
13642 PerlMemShared_free(trie->wordinfo);
13643 /* do this last!!!! */
13644 PerlMemShared_free(ri->data->data[n]);
13649 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
13652 Safefree(ri->data->what);
13653 Safefree(ri->data);
13659 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
13660 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
13661 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
13664 re_dup - duplicate a regexp.
13666 This routine is expected to clone a given regexp structure. It is only
13667 compiled under USE_ITHREADS.
13669 After all of the core data stored in struct regexp is duplicated
13670 the regexp_engine.dupe method is used to copy any private data
13671 stored in the *pprivate pointer. This allows extensions to handle
13672 any duplication it needs to do.
13674 See pregfree() and regfree_internal() if you change anything here.
13676 #if defined(USE_ITHREADS)
13677 #ifndef PERL_IN_XSUB_RE
13679 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
13683 const struct regexp *r = (const struct regexp *)SvANY(sstr);
13684 struct regexp *ret = (struct regexp *)SvANY(dstr);
13686 PERL_ARGS_ASSERT_RE_DUP_GUTS;
13688 npar = r->nparens+1;
13689 Newx(ret->offs, npar, regexp_paren_pair);
13690 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
13692 /* no need to copy these */
13693 Newx(ret->swap, npar, regexp_paren_pair);
13696 if (ret->substrs) {
13697 /* Do it this way to avoid reading from *r after the StructCopy().
13698 That way, if any of the sv_dup_inc()s dislodge *r from the L1
13699 cache, it doesn't matter. */
13700 const bool anchored = r->check_substr
13701 ? r->check_substr == r->anchored_substr
13702 : r->check_utf8 == r->anchored_utf8;
13703 Newx(ret->substrs, 1, struct reg_substr_data);
13704 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
13706 ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
13707 ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
13708 ret->float_substr = sv_dup_inc(ret->float_substr, param);
13709 ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
13711 /* check_substr and check_utf8, if non-NULL, point to either their
13712 anchored or float namesakes, and don't hold a second reference. */
13714 if (ret->check_substr) {
13716 assert(r->check_utf8 == r->anchored_utf8);
13717 ret->check_substr = ret->anchored_substr;
13718 ret->check_utf8 = ret->anchored_utf8;
13720 assert(r->check_substr == r->float_substr);
13721 assert(r->check_utf8 == r->float_utf8);
13722 ret->check_substr = ret->float_substr;
13723 ret->check_utf8 = ret->float_utf8;
13725 } else if (ret->check_utf8) {
13727 ret->check_utf8 = ret->anchored_utf8;
13729 ret->check_utf8 = ret->float_utf8;
13734 RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
13735 ret->qr_anoncv = MUTABLE_CV(sv_dup_inc((const SV *)ret->qr_anoncv, param));
13738 RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
13740 if (RX_MATCH_COPIED(dstr))
13741 ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
13743 ret->subbeg = NULL;
13744 #ifdef PERL_OLD_COPY_ON_WRITE
13745 ret->saved_copy = NULL;
13748 if (ret->mother_re) {
13749 if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
13750 /* Our storage points directly to our mother regexp, but that's
13751 1: a buffer in a different thread
13752 2: something we no longer hold a reference on
13753 so we need to copy it locally. */
13754 /* Note we need to use SvCUR(), rather than
13755 SvLEN(), on our mother_re, because it, in
13756 turn, may well be pointing to its own mother_re. */
13757 SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
13758 SvCUR(ret->mother_re)+1));
13759 SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
13761 ret->mother_re = NULL;
13765 #endif /* PERL_IN_XSUB_RE */
13770 This is the internal complement to regdupe() which is used to copy
13771 the structure pointed to by the *pprivate pointer in the regexp.
13772 This is the core version of the extension overridable cloning hook.
13773 The regexp structure being duplicated will be copied by perl prior
13774 to this and will be provided as the regexp *r argument, however
13775 with the /old/ structures pprivate pointer value. Thus this routine
13776 may override any copying normally done by perl.
13778 It returns a pointer to the new regexp_internal structure.
13782 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
13785 struct regexp *const r = (struct regexp *)SvANY(rx);
13786 regexp_internal *reti;
13788 RXi_GET_DECL(r,ri);
13790 PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
13794 Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
13795 Copy(ri->program, reti->program, len+1, regnode);
13797 reti->num_code_blocks = ri->num_code_blocks;
13798 if (ri->code_blocks) {
13800 Newxc(reti->code_blocks, ri->num_code_blocks, struct reg_code_block,
13801 struct reg_code_block);
13802 Copy(ri->code_blocks, reti->code_blocks, ri->num_code_blocks,
13803 struct reg_code_block);
13804 for (n = 0; n < ri->num_code_blocks; n++)
13805 reti->code_blocks[n].src_regex = (REGEXP*)
13806 sv_dup_inc((SV*)(ri->code_blocks[n].src_regex), param);
13809 reti->code_blocks = NULL;
13811 reti->regstclass = NULL;
13814 struct reg_data *d;
13815 const int count = ri->data->count;
13818 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
13819 char, struct reg_data);
13820 Newx(d->what, count, U8);
13823 for (i = 0; i < count; i++) {
13824 d->what[i] = ri->data->what[i];
13825 switch (d->what[i]) {
13826 /* see also regcomp.h and regfree_internal() */
13827 case 'a': /* actually an AV, but the dup function is identical. */
13831 case 'u': /* actually an HV, but the dup function is identical. */
13832 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
13835 /* This is cheating. */
13836 Newx(d->data[i], 1, struct regnode_charclass_class);
13837 StructCopy(ri->data->data[i], d->data[i],
13838 struct regnode_charclass_class);
13839 reti->regstclass = (regnode*)d->data[i];
13842 /* Trie stclasses are readonly and can thus be shared
13843 * without duplication. We free the stclass in pregfree
13844 * when the corresponding reg_ac_data struct is freed.
13846 reti->regstclass= ri->regstclass;
13850 ((reg_trie_data*)ri->data->data[i])->refcount++;
13855 d->data[i] = ri->data->data[i];
13858 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
13867 reti->name_list_idx = ri->name_list_idx;
13869 #ifdef RE_TRACK_PATTERN_OFFSETS
13870 if (ri->u.offsets) {
13871 Newx(reti->u.offsets, 2*len+1, U32);
13872 Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
13875 SetProgLen(reti,len);
13878 return (void*)reti;
13881 #endif /* USE_ITHREADS */
13883 #ifndef PERL_IN_XSUB_RE
13886 - regnext - dig the "next" pointer out of a node
13889 Perl_regnext(pTHX_ register regnode *p)
13892 register I32 offset;
13897 if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */
13898 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
13901 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
13910 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
13913 STRLEN l1 = strlen(pat1);
13914 STRLEN l2 = strlen(pat2);
13917 const char *message;
13919 PERL_ARGS_ASSERT_RE_CROAK2;
13925 Copy(pat1, buf, l1 , char);
13926 Copy(pat2, buf + l1, l2 , char);
13927 buf[l1 + l2] = '\n';
13928 buf[l1 + l2 + 1] = '\0';
13930 /* ANSI variant takes additional second argument */
13931 va_start(args, pat2);
13935 msv = vmess(buf, &args);
13937 message = SvPV_const(msv,l1);
13940 Copy(message, buf, l1 , char);
13941 buf[l1-1] = '\0'; /* Overwrite \n */
13942 Perl_croak(aTHX_ "%s", buf);
13945 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
13947 #ifndef PERL_IN_XSUB_RE
13949 Perl_save_re_context(pTHX)
13953 struct re_save_state *state;
13955 SAVEVPTR(PL_curcop);
13956 SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
13958 state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
13959 PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
13960 SSPUSHUV(SAVEt_RE_STATE);
13962 Copy(&PL_reg_state, state, 1, struct re_save_state);
13964 PL_reg_oldsaved = NULL;
13965 PL_reg_oldsavedlen = 0;
13966 PL_reg_maxiter = 0;
13967 PL_reg_leftiter = 0;
13968 PL_reg_poscache = NULL;
13969 PL_reg_poscache_size = 0;
13970 #ifdef PERL_OLD_COPY_ON_WRITE
13974 /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
13976 const REGEXP * const rx = PM_GETRE(PL_curpm);
13979 for (i = 1; i <= RX_NPARENS(rx); i++) {
13980 char digits[TYPE_CHARS(long)];
13981 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
13982 GV *const *const gvp
13983 = (GV**)hv_fetch(PL_defstash, digits, len, 0);
13986 GV * const gv = *gvp;
13987 if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
13997 clear_re(pTHX_ void *r)
14000 ReREFCNT_dec((REGEXP *)r);
14006 S_put_byte(pTHX_ SV *sv, int c)
14008 PERL_ARGS_ASSERT_PUT_BYTE;
14010 /* Our definition of isPRINT() ignores locales, so only bytes that are
14011 not part of UTF-8 are considered printable. I assume that the same
14012 holds for UTF-EBCDIC.
14013 Also, code point 255 is not printable in either (it's E0 in EBCDIC,
14014 which Wikipedia says:
14016 EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
14017 ones (binary 1111 1111, hexadecimal FF). It is similar, but not
14018 identical, to the ASCII delete (DEL) or rubout control character.
14019 ) So the old condition can be simplified to !isPRINT(c) */
14022 Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
14025 Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
14029 const char string = c;
14030 if (c == '-' || c == ']' || c == '\\' || c == '^')
14031 sv_catpvs(sv, "\\");
14032 sv_catpvn(sv, &string, 1);
14037 #define CLEAR_OPTSTART \
14038 if (optstart) STMT_START { \
14039 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
14043 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
14045 STATIC const regnode *
14046 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
14047 const regnode *last, const regnode *plast,
14048 SV* sv, I32 indent, U32 depth)
14051 register U8 op = PSEUDO; /* Arbitrary non-END op. */
14052 register const regnode *next;
14053 const regnode *optstart= NULL;
14055 RXi_GET_DECL(r,ri);
14056 GET_RE_DEBUG_FLAGS_DECL;
14058 PERL_ARGS_ASSERT_DUMPUNTIL;
14060 #ifdef DEBUG_DUMPUNTIL
14061 PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
14062 last ? last-start : 0,plast ? plast-start : 0);
14065 if (plast && plast < last)
14068 while (PL_regkind[op] != END && (!last || node < last)) {
14069 /* While that wasn't END last time... */
14072 if (op == CLOSE || op == WHILEM)
14074 next = regnext((regnode *)node);
14077 if (OP(node) == OPTIMIZED) {
14078 if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
14085 regprop(r, sv, node);
14086 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
14087 (int)(2*indent + 1), "", SvPVX_const(sv));
14089 if (OP(node) != OPTIMIZED) {
14090 if (next == NULL) /* Next ptr. */
14091 PerlIO_printf(Perl_debug_log, " (0)");
14092 else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
14093 PerlIO_printf(Perl_debug_log, " (FAIL)");
14095 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
14096 (void)PerlIO_putc(Perl_debug_log, '\n');
14100 if (PL_regkind[(U8)op] == BRANCHJ) {
14103 register const regnode *nnode = (OP(next) == LONGJMP
14104 ? regnext((regnode *)next)
14106 if (last && nnode > last)
14108 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
14111 else if (PL_regkind[(U8)op] == BRANCH) {
14113 DUMPUNTIL(NEXTOPER(node), next);
14115 else if ( PL_regkind[(U8)op] == TRIE ) {
14116 const regnode *this_trie = node;
14117 const char op = OP(node);
14118 const U32 n = ARG(node);
14119 const reg_ac_data * const ac = op>=AHOCORASICK ?
14120 (reg_ac_data *)ri->data->data[n] :
14122 const reg_trie_data * const trie =
14123 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
14125 AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
14127 const regnode *nextbranch= NULL;
14130 for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
14131 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
14133 PerlIO_printf(Perl_debug_log, "%*s%s ",
14134 (int)(2*(indent+3)), "",
14135 elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
14136 PL_colors[0], PL_colors[1],
14137 (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
14138 PERL_PV_PRETTY_ELLIPSES |
14139 PERL_PV_PRETTY_LTGT
14144 U16 dist= trie->jump[word_idx+1];
14145 PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
14146 (UV)((dist ? this_trie + dist : next) - start));
14149 nextbranch= this_trie + trie->jump[0];
14150 DUMPUNTIL(this_trie + dist, nextbranch);
14152 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
14153 nextbranch= regnext((regnode *)nextbranch);
14155 PerlIO_printf(Perl_debug_log, "\n");
14158 if (last && next > last)
14163 else if ( op == CURLY ) { /* "next" might be very big: optimizer */
14164 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
14165 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
14167 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
14169 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
14171 else if ( op == PLUS || op == STAR) {
14172 DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
14174 else if (PL_regkind[(U8)op] == ANYOF) {
14175 /* arglen 1 + class block */
14176 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
14177 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
14178 node = NEXTOPER(node);
14180 else if (PL_regkind[(U8)op] == EXACT) {
14181 /* Literal string, where present. */
14182 node += NODE_SZ_STR(node) - 1;
14183 node = NEXTOPER(node);
14186 node = NEXTOPER(node);
14187 node += regarglen[(U8)op];
14189 if (op == CURLYX || op == OPEN)
14193 #ifdef DEBUG_DUMPUNTIL
14194 PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
14199 #endif /* DEBUGGING */
14203 * c-indentation-style: bsd
14204 * c-basic-offset: 4
14205 * indent-tabs-mode: nil
14208 * ex: set ts=8 sts=4 sw=4 et:
https://perl5.git.perl.org / perl5.git / blob