5 * 'A fair jaw-cracker dwarf-language must be.' --Samwise Gamgee
7 * [p.285 of _The Lord of the Rings_, II/iii: "The Ring Goes South"]
10 /* This file contains functions for compiling a regular expression. See
11 * also regexec.c which funnily enough, contains functions for executing
12 * a regular expression.
14 * This file is also copied at build time to ext/re/re_comp.c, where
15 * it's built with -DPERL_EXT_RE_BUILD -DPERL_EXT_RE_DEBUG -DPERL_EXT.
16 * This causes the main functions to be compiled under new names and with
17 * debugging support added, which makes "use re 'debug'" work.
20 /* NOTE: this is derived from Henry Spencer's regexp code, and should not
21 * confused with the original package (see point 3 below). Thanks, Henry!
24 /* Additional note: this code is very heavily munged from Henry's version
25 * in places. In some spots I've traded clarity for efficiency, so don't
26 * blame Henry for some of the lack of readability.
29 /* The names of the functions have been changed from regcomp and
30 * regexec to pregcomp and pregexec in order to avoid conflicts
31 * with the POSIX routines of the same names.
34 #ifdef PERL_EXT_RE_BUILD
39 * pregcomp and pregexec -- regsub and regerror are not used in perl
41 * Copyright (c) 1986 by University of Toronto.
42 * Written by Henry Spencer. Not derived from licensed software.
44 * Permission is granted to anyone to use this software for any
45 * purpose on any computer system, and to redistribute it freely,
46 * subject to the following restrictions:
48 * 1. The author is not responsible for the consequences of use of
49 * this software, no matter how awful, even if they arise
52 * 2. The origin of this software must not be misrepresented, either
53 * by explicit claim or by omission.
55 * 3. Altered versions must be plainly marked as such, and must not
56 * be misrepresented as being the original software.
59 **** Alterations to Henry's code are...
61 **** Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
62 **** 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008
63 **** by Larry Wall and others
65 **** You may distribute under the terms of either the GNU General Public
66 **** License or the Artistic License, as specified in the README file.
69 * Beware that some of this code is subtly aware of the way operator
70 * precedence is structured in regular expressions. Serious changes in
71 * regular-expression syntax might require a total rethink.
74 #define PERL_IN_REGCOMP_C
77 #ifndef PERL_IN_XSUB_RE
82 #ifdef PERL_IN_XSUB_RE
88 #include "dquote_static.c"
89 #ifndef PERL_IN_XSUB_RE
90 # include "charclass_invlists.h"
98 # if defined(BUGGY_MSC6)
99 /* MSC 6.00A breaks on op/regexp.t test 85 unless we turn this off */
100 # pragma optimize("a",off)
101 /* But MSC 6.00A is happy with 'w', for aliases only across function calls*/
102 # pragma optimize("w",on )
103 # endif /* BUGGY_MSC6 */
107 #define STATIC static
110 typedef struct RExC_state_t {
111 U32 flags; /* are we folding, multilining? */
112 char *precomp; /* uncompiled string. */
113 REGEXP *rx_sv; /* The SV that is the regexp. */
114 regexp *rx; /* perl core regexp structure */
115 regexp_internal *rxi; /* internal data for regexp object pprivate field */
116 char *start; /* Start of input for compile */
117 char *end; /* End of input for compile */
118 char *parse; /* Input-scan pointer. */
119 I32 whilem_seen; /* number of WHILEM in this expr */
120 regnode *emit_start; /* Start of emitted-code area */
121 regnode *emit_bound; /* First regnode outside of the allocated space */
122 regnode *emit; /* Code-emit pointer; ®dummy = don't = compiling */
123 I32 naughty; /* How bad is this pattern? */
124 I32 sawback; /* Did we see \1, ...? */
126 I32 size; /* Code size. */
127 I32 npar; /* Capture buffer count, (OPEN). */
128 I32 cpar; /* Capture buffer count, (CLOSE). */
129 I32 nestroot; /* root parens we are in - used by accept */
133 regnode **open_parens; /* pointers to open parens */
134 regnode **close_parens; /* pointers to close parens */
135 regnode *opend; /* END node in program */
136 I32 utf8; /* whether the pattern is utf8 or not */
137 I32 orig_utf8; /* whether the pattern was originally in utf8 */
138 /* XXX use this for future optimisation of case
139 * where pattern must be upgraded to utf8. */
140 I32 uni_semantics; /* If a d charset modifier should use unicode
141 rules, even if the pattern is not in
143 HV *paren_names; /* Paren names */
145 regnode **recurse; /* Recurse regops */
146 I32 recurse_count; /* Number of recurse regops */
149 I32 override_recoding;
151 char *starttry; /* -Dr: where regtry was called. */
152 #define RExC_starttry (pRExC_state->starttry)
155 const char *lastparse;
157 AV *paren_name_list; /* idx -> name */
158 #define RExC_lastparse (pRExC_state->lastparse)
159 #define RExC_lastnum (pRExC_state->lastnum)
160 #define RExC_paren_name_list (pRExC_state->paren_name_list)
164 #define RExC_flags (pRExC_state->flags)
165 #define RExC_precomp (pRExC_state->precomp)
166 #define RExC_rx_sv (pRExC_state->rx_sv)
167 #define RExC_rx (pRExC_state->rx)
168 #define RExC_rxi (pRExC_state->rxi)
169 #define RExC_start (pRExC_state->start)
170 #define RExC_end (pRExC_state->end)
171 #define RExC_parse (pRExC_state->parse)
172 #define RExC_whilem_seen (pRExC_state->whilem_seen)
173 #ifdef RE_TRACK_PATTERN_OFFSETS
174 #define RExC_offsets (pRExC_state->rxi->u.offsets) /* I am not like the others */
176 #define RExC_emit (pRExC_state->emit)
177 #define RExC_emit_start (pRExC_state->emit_start)
178 #define RExC_emit_bound (pRExC_state->emit_bound)
179 #define RExC_naughty (pRExC_state->naughty)
180 #define RExC_sawback (pRExC_state->sawback)
181 #define RExC_seen (pRExC_state->seen)
182 #define RExC_size (pRExC_state->size)
183 #define RExC_npar (pRExC_state->npar)
184 #define RExC_nestroot (pRExC_state->nestroot)
185 #define RExC_extralen (pRExC_state->extralen)
186 #define RExC_seen_zerolen (pRExC_state->seen_zerolen)
187 #define RExC_seen_evals (pRExC_state->seen_evals)
188 #define RExC_utf8 (pRExC_state->utf8)
189 #define RExC_uni_semantics (pRExC_state->uni_semantics)
190 #define RExC_orig_utf8 (pRExC_state->orig_utf8)
191 #define RExC_open_parens (pRExC_state->open_parens)
192 #define RExC_close_parens (pRExC_state->close_parens)
193 #define RExC_opend (pRExC_state->opend)
194 #define RExC_paren_names (pRExC_state->paren_names)
195 #define RExC_recurse (pRExC_state->recurse)
196 #define RExC_recurse_count (pRExC_state->recurse_count)
197 #define RExC_in_lookbehind (pRExC_state->in_lookbehind)
198 #define RExC_contains_locale (pRExC_state->contains_locale)
199 #define RExC_override_recoding (pRExC_state->override_recoding)
202 #define ISMULT1(c) ((c) == '*' || (c) == '+' || (c) == '?')
203 #define ISMULT2(s) ((*s) == '*' || (*s) == '+' || (*s) == '?' || \
204 ((*s) == '{' && regcurly(s)))
207 #undef SPSTART /* dratted cpp namespace... */
210 * Flags to be passed up and down.
212 #define WORST 0 /* Worst case. */
213 #define HASWIDTH 0x01 /* Known to match non-null strings. */
215 /* Simple enough to be STAR/PLUS operand, in an EXACT node must be a single
216 * character, and if utf8, must be invariant. Note that this is not the same thing as REGNODE_SIMPLE */
218 #define SPSTART 0x04 /* Starts with * or +. */
219 #define TRYAGAIN 0x08 /* Weeded out a declaration. */
220 #define POSTPONED 0x10 /* (?1),(?&name), (??{...}) or similar */
222 #define REG_NODE_NUM(x) ((x) ? (int)((x)-RExC_emit_start) : -1)
224 /* whether trie related optimizations are enabled */
225 #if PERL_ENABLE_EXTENDED_TRIE_OPTIMISATION
226 #define TRIE_STUDY_OPT
227 #define FULL_TRIE_STUDY
233 #define PBYTE(u8str,paren) ((U8*)(u8str))[(paren) >> 3]
234 #define PBITVAL(paren) (1 << ((paren) & 7))
235 #define PAREN_TEST(u8str,paren) ( PBYTE(u8str,paren) & PBITVAL(paren))
236 #define PAREN_SET(u8str,paren) PBYTE(u8str,paren) |= PBITVAL(paren)
237 #define PAREN_UNSET(u8str,paren) PBYTE(u8str,paren) &= (~PBITVAL(paren))
239 /* If not already in utf8, do a longjmp back to the beginning */
240 #define UTF8_LONGJMP 42 /* Choose a value not likely to ever conflict */
241 #define REQUIRE_UTF8 STMT_START { \
242 if (! UTF) JMPENV_JUMP(UTF8_LONGJMP); \
245 /* About scan_data_t.
247 During optimisation we recurse through the regexp program performing
248 various inplace (keyhole style) optimisations. In addition study_chunk
249 and scan_commit populate this data structure with information about
250 what strings MUST appear in the pattern. We look for the longest
251 string that must appear at a fixed location, and we look for the
252 longest string that may appear at a floating location. So for instance
257 Both 'FOO' and 'A' are fixed strings. Both 'B' and 'BAR' are floating
258 strings (because they follow a .* construct). study_chunk will identify
259 both FOO and BAR as being the longest fixed and floating strings respectively.
261 The strings can be composites, for instance
265 will result in a composite fixed substring 'foo'.
267 For each string some basic information is maintained:
269 - offset or min_offset
270 This is the position the string must appear at, or not before.
271 It also implicitly (when combined with minlenp) tells us how many
272 characters must match before the string we are searching for.
273 Likewise when combined with minlenp and the length of the string it
274 tells us how many characters must appear after the string we have
278 Only used for floating strings. This is the rightmost point that
279 the string can appear at. If set to I32 max it indicates that the
280 string can occur infinitely far to the right.
283 A pointer to the minimum length of the pattern that the string
284 was found inside. This is important as in the case of positive
285 lookahead or positive lookbehind we can have multiple patterns
290 The minimum length of the pattern overall is 3, the minimum length
291 of the lookahead part is 3, but the minimum length of the part that
292 will actually match is 1. So 'FOO's minimum length is 3, but the
293 minimum length for the F is 1. This is important as the minimum length
294 is used to determine offsets in front of and behind the string being
295 looked for. Since strings can be composites this is the length of the
296 pattern at the time it was committed with a scan_commit. Note that
297 the length is calculated by study_chunk, so that the minimum lengths
298 are not known until the full pattern has been compiled, thus the
299 pointer to the value.
303 In the case of lookbehind the string being searched for can be
304 offset past the start point of the final matching string.
305 If this value was just blithely removed from the min_offset it would
306 invalidate some of the calculations for how many chars must match
307 before or after (as they are derived from min_offset and minlen and
308 the length of the string being searched for).
309 When the final pattern is compiled and the data is moved from the
310 scan_data_t structure into the regexp structure the information
311 about lookbehind is factored in, with the information that would
312 have been lost precalculated in the end_shift field for the
315 The fields pos_min and pos_delta are used to store the minimum offset
316 and the delta to the maximum offset at the current point in the pattern.
320 typedef struct scan_data_t {
321 /*I32 len_min; unused */
322 /*I32 len_delta; unused */
326 I32 last_end; /* min value, <0 unless valid. */
329 SV **longest; /* Either &l_fixed, or &l_float. */
330 SV *longest_fixed; /* longest fixed string found in pattern */
331 I32 offset_fixed; /* offset where it starts */
332 I32 *minlen_fixed; /* pointer to the minlen relevant to the string */
333 I32 lookbehind_fixed; /* is the position of the string modfied by LB */
334 SV *longest_float; /* longest floating string found in pattern */
335 I32 offset_float_min; /* earliest point in string it can appear */
336 I32 offset_float_max; /* latest point in string it can appear */
337 I32 *minlen_float; /* pointer to the minlen relevant to the string */
338 I32 lookbehind_float; /* is the position of the string modified by LB */
342 struct regnode_charclass_class *start_class;
346 * Forward declarations for pregcomp()'s friends.
349 static const scan_data_t zero_scan_data =
350 { 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 ,0};
352 #define SF_BEFORE_EOL (SF_BEFORE_SEOL|SF_BEFORE_MEOL)
353 #define SF_BEFORE_SEOL 0x0001
354 #define SF_BEFORE_MEOL 0x0002
355 #define SF_FIX_BEFORE_EOL (SF_FIX_BEFORE_SEOL|SF_FIX_BEFORE_MEOL)
356 #define SF_FL_BEFORE_EOL (SF_FL_BEFORE_SEOL|SF_FL_BEFORE_MEOL)
359 # define SF_FIX_SHIFT_EOL (0+2)
360 # define SF_FL_SHIFT_EOL (0+4)
362 # define SF_FIX_SHIFT_EOL (+2)
363 # define SF_FL_SHIFT_EOL (+4)
366 #define SF_FIX_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FIX_SHIFT_EOL)
367 #define SF_FIX_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FIX_SHIFT_EOL)
369 #define SF_FL_BEFORE_SEOL (SF_BEFORE_SEOL << SF_FL_SHIFT_EOL)
370 #define SF_FL_BEFORE_MEOL (SF_BEFORE_MEOL << SF_FL_SHIFT_EOL) /* 0x20 */
371 #define SF_IS_INF 0x0040
372 #define SF_HAS_PAR 0x0080
373 #define SF_IN_PAR 0x0100
374 #define SF_HAS_EVAL 0x0200
375 #define SCF_DO_SUBSTR 0x0400
376 #define SCF_DO_STCLASS_AND 0x0800
377 #define SCF_DO_STCLASS_OR 0x1000
378 #define SCF_DO_STCLASS (SCF_DO_STCLASS_AND|SCF_DO_STCLASS_OR)
379 #define SCF_WHILEM_VISITED_POS 0x2000
381 #define SCF_TRIE_RESTUDY 0x4000 /* Do restudy? */
382 #define SCF_SEEN_ACCEPT 0x8000
384 #define UTF cBOOL(RExC_utf8)
386 /* The enums for all these are ordered so things work out correctly */
387 #define LOC (get_regex_charset(RExC_flags) == REGEX_LOCALE_CHARSET)
388 #define DEPENDS_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_DEPENDS_CHARSET)
389 #define UNI_SEMANTICS (get_regex_charset(RExC_flags) == REGEX_UNICODE_CHARSET)
390 #define AT_LEAST_UNI_SEMANTICS (get_regex_charset(RExC_flags) >= REGEX_UNICODE_CHARSET)
391 #define ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_RESTRICTED_CHARSET)
392 #define MORE_ASCII_RESTRICTED (get_regex_charset(RExC_flags) == REGEX_ASCII_MORE_RESTRICTED_CHARSET)
393 #define AT_LEAST_ASCII_RESTRICTED (get_regex_charset(RExC_flags) >= REGEX_ASCII_RESTRICTED_CHARSET)
395 #define FOLD cBOOL(RExC_flags & RXf_PMf_FOLD)
397 #define OOB_UNICODE 12345678
398 #define OOB_NAMEDCLASS -1
400 #define CHR_SVLEN(sv) (UTF ? sv_len_utf8(sv) : SvCUR(sv))
401 #define CHR_DIST(a,b) (UTF ? utf8_distance(a,b) : a - b)
404 /* length of regex to show in messages that don't mark a position within */
405 #define RegexLengthToShowInErrorMessages 127
408 * If MARKER[12] are adjusted, be sure to adjust the constants at the top
409 * of t/op/regmesg.t, the tests in t/op/re_tests, and those in
410 * op/pragma/warn/regcomp.
412 #define MARKER1 "<-- HERE" /* marker as it appears in the description */
413 #define MARKER2 " <-- HERE " /* marker as it appears within the regex */
415 #define REPORT_LOCATION " in regex; marked by " MARKER1 " in m/%.*s" MARKER2 "%s/"
418 * Calls SAVEDESTRUCTOR_X if needed, then calls Perl_croak with the given
419 * arg. Show regex, up to a maximum length. If it's too long, chop and add
422 #define _FAIL(code) STMT_START { \
423 const char *ellipses = ""; \
424 IV len = RExC_end - RExC_precomp; \
427 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
428 if (len > RegexLengthToShowInErrorMessages) { \
429 /* chop 10 shorter than the max, to ensure meaning of "..." */ \
430 len = RegexLengthToShowInErrorMessages - 10; \
436 #define FAIL(msg) _FAIL( \
437 Perl_croak(aTHX_ "%s in regex m/%.*s%s/", \
438 msg, (int)len, RExC_precomp, ellipses))
440 #define FAIL2(msg,arg) _FAIL( \
441 Perl_croak(aTHX_ msg " in regex m/%.*s%s/", \
442 arg, (int)len, RExC_precomp, ellipses))
445 * Simple_vFAIL -- like FAIL, but marks the current location in the scan
447 #define Simple_vFAIL(m) STMT_START { \
448 const IV offset = RExC_parse - RExC_precomp; \
449 Perl_croak(aTHX_ "%s" REPORT_LOCATION, \
450 m, (int)offset, RExC_precomp, RExC_precomp + offset); \
454 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL()
456 #define vFAIL(m) STMT_START { \
458 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
463 * Like Simple_vFAIL(), but accepts two arguments.
465 #define Simple_vFAIL2(m,a1) STMT_START { \
466 const IV offset = RExC_parse - RExC_precomp; \
467 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, \
468 (int)offset, RExC_precomp, RExC_precomp + offset); \
472 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL2().
474 #define vFAIL2(m,a1) STMT_START { \
476 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
477 Simple_vFAIL2(m, a1); \
482 * Like Simple_vFAIL(), but accepts three arguments.
484 #define Simple_vFAIL3(m, a1, a2) STMT_START { \
485 const IV offset = RExC_parse - RExC_precomp; \
486 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, \
487 (int)offset, RExC_precomp, RExC_precomp + offset); \
491 * Calls SAVEDESTRUCTOR_X if needed, then Simple_vFAIL3().
493 #define vFAIL3(m,a1,a2) STMT_START { \
495 SAVEDESTRUCTOR_X(clear_re,(void*)RExC_rx_sv); \
496 Simple_vFAIL3(m, a1, a2); \
500 * Like Simple_vFAIL(), but accepts four arguments.
502 #define Simple_vFAIL4(m, a1, a2, a3) STMT_START { \
503 const IV offset = RExC_parse - RExC_precomp; \
504 S_re_croak2(aTHX_ m, REPORT_LOCATION, a1, a2, a3, \
505 (int)offset, RExC_precomp, RExC_precomp + offset); \
508 #define ckWARNreg(loc,m) STMT_START { \
509 const IV offset = loc - RExC_precomp; \
510 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
511 (int)offset, RExC_precomp, RExC_precomp + offset); \
514 #define ckWARNregdep(loc,m) STMT_START { \
515 const IV offset = loc - RExC_precomp; \
516 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
518 (int)offset, RExC_precomp, RExC_precomp + offset); \
521 #define ckWARN2regdep(loc,m, a1) STMT_START { \
522 const IV offset = loc - RExC_precomp; \
523 Perl_ck_warner_d(aTHX_ packWARN2(WARN_DEPRECATED, WARN_REGEXP), \
525 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
528 #define ckWARN2reg(loc, m, a1) STMT_START { \
529 const IV offset = loc - RExC_precomp; \
530 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
531 a1, (int)offset, RExC_precomp, RExC_precomp + offset); \
534 #define vWARN3(loc, m, a1, a2) STMT_START { \
535 const IV offset = loc - RExC_precomp; \
536 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
537 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
540 #define ckWARN3reg(loc, m, a1, a2) STMT_START { \
541 const IV offset = loc - RExC_precomp; \
542 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
543 a1, a2, (int)offset, RExC_precomp, RExC_precomp + offset); \
546 #define vWARN4(loc, m, a1, a2, a3) STMT_START { \
547 const IV offset = loc - RExC_precomp; \
548 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
549 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
552 #define ckWARN4reg(loc, m, a1, a2, a3) STMT_START { \
553 const IV offset = loc - RExC_precomp; \
554 Perl_ck_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
555 a1, a2, a3, (int)offset, RExC_precomp, RExC_precomp + offset); \
558 #define vWARN5(loc, m, a1, a2, a3, a4) STMT_START { \
559 const IV offset = loc - RExC_precomp; \
560 Perl_warner(aTHX_ packWARN(WARN_REGEXP), m REPORT_LOCATION, \
561 a1, a2, a3, a4, (int)offset, RExC_precomp, RExC_precomp + offset); \
565 /* Allow for side effects in s */
566 #define REGC(c,s) STMT_START { \
567 if (!SIZE_ONLY) *(s) = (c); else (void)(s); \
570 /* Macros for recording node offsets. 20001227 mjd@plover.com
571 * Nodes are numbered 1, 2, 3, 4. Node #n's position is recorded in
572 * element 2*n-1 of the array. Element #2n holds the byte length node #n.
573 * Element 0 holds the number n.
574 * Position is 1 indexed.
576 #ifndef RE_TRACK_PATTERN_OFFSETS
577 #define Set_Node_Offset_To_R(node,byte)
578 #define Set_Node_Offset(node,byte)
579 #define Set_Cur_Node_Offset
580 #define Set_Node_Length_To_R(node,len)
581 #define Set_Node_Length(node,len)
582 #define Set_Node_Cur_Length(node)
583 #define Node_Offset(n)
584 #define Node_Length(n)
585 #define Set_Node_Offset_Length(node,offset,len)
586 #define ProgLen(ri) ri->u.proglen
587 #define SetProgLen(ri,x) ri->u.proglen = x
589 #define ProgLen(ri) ri->u.offsets[0]
590 #define SetProgLen(ri,x) ri->u.offsets[0] = x
591 #define Set_Node_Offset_To_R(node,byte) STMT_START { \
593 MJD_OFFSET_DEBUG(("** (%d) offset of node %d is %d.\n", \
594 __LINE__, (int)(node), (int)(byte))); \
596 Perl_croak(aTHX_ "value of node is %d in Offset macro", (int)(node)); \
598 RExC_offsets[2*(node)-1] = (byte); \
603 #define Set_Node_Offset(node,byte) \
604 Set_Node_Offset_To_R((node)-RExC_emit_start, (byte)-RExC_start)
605 #define Set_Cur_Node_Offset Set_Node_Offset(RExC_emit, RExC_parse)
607 #define Set_Node_Length_To_R(node,len) STMT_START { \
609 MJD_OFFSET_DEBUG(("** (%d) size of node %d is %d.\n", \
610 __LINE__, (int)(node), (int)(len))); \
612 Perl_croak(aTHX_ "value of node is %d in Length macro", (int)(node)); \
614 RExC_offsets[2*(node)] = (len); \
619 #define Set_Node_Length(node,len) \
620 Set_Node_Length_To_R((node)-RExC_emit_start, len)
621 #define Set_Cur_Node_Length(len) Set_Node_Length(RExC_emit, len)
622 #define Set_Node_Cur_Length(node) \
623 Set_Node_Length(node, RExC_parse - parse_start)
625 /* Get offsets and lengths */
626 #define Node_Offset(n) (RExC_offsets[2*((n)-RExC_emit_start)-1])
627 #define Node_Length(n) (RExC_offsets[2*((n)-RExC_emit_start)])
629 #define Set_Node_Offset_Length(node,offset,len) STMT_START { \
630 Set_Node_Offset_To_R((node)-RExC_emit_start, (offset)); \
631 Set_Node_Length_To_R((node)-RExC_emit_start, (len)); \
635 #if PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS
636 #define EXPERIMENTAL_INPLACESCAN
637 #endif /*PERL_ENABLE_EXPERIMENTAL_REGEX_OPTIMISATIONS*/
639 #define DEBUG_STUDYDATA(str,data,depth) \
640 DEBUG_OPTIMISE_MORE_r(if(data){ \
641 PerlIO_printf(Perl_debug_log, \
642 "%*s" str "Pos:%"IVdf"/%"IVdf \
643 " Flags: 0x%"UVXf" Whilem_c: %"IVdf" Lcp: %"IVdf" %s", \
644 (int)(depth)*2, "", \
645 (IV)((data)->pos_min), \
646 (IV)((data)->pos_delta), \
647 (UV)((data)->flags), \
648 (IV)((data)->whilem_c), \
649 (IV)((data)->last_closep ? *((data)->last_closep) : -1), \
650 is_inf ? "INF " : "" \
652 if ((data)->last_found) \
653 PerlIO_printf(Perl_debug_log, \
654 "Last:'%s' %"IVdf":%"IVdf"/%"IVdf" %sFixed:'%s' @ %"IVdf \
655 " %sFloat: '%s' @ %"IVdf"/%"IVdf"", \
656 SvPVX_const((data)->last_found), \
657 (IV)((data)->last_end), \
658 (IV)((data)->last_start_min), \
659 (IV)((data)->last_start_max), \
660 ((data)->longest && \
661 (data)->longest==&((data)->longest_fixed)) ? "*" : "", \
662 SvPVX_const((data)->longest_fixed), \
663 (IV)((data)->offset_fixed), \
664 ((data)->longest && \
665 (data)->longest==&((data)->longest_float)) ? "*" : "", \
666 SvPVX_const((data)->longest_float), \
667 (IV)((data)->offset_float_min), \
668 (IV)((data)->offset_float_max) \
670 PerlIO_printf(Perl_debug_log,"\n"); \
673 static void clear_re(pTHX_ void *r);
675 /* Mark that we cannot extend a found fixed substring at this point.
676 Update the longest found anchored substring and the longest found
677 floating substrings if needed. */
680 S_scan_commit(pTHX_ const RExC_state_t *pRExC_state, scan_data_t *data, I32 *minlenp, int is_inf)
682 const STRLEN l = CHR_SVLEN(data->last_found);
683 const STRLEN old_l = CHR_SVLEN(*data->longest);
684 GET_RE_DEBUG_FLAGS_DECL;
686 PERL_ARGS_ASSERT_SCAN_COMMIT;
688 if ((l >= old_l) && ((l > old_l) || (data->flags & SF_BEFORE_EOL))) {
689 SvSetMagicSV(*data->longest, data->last_found);
690 if (*data->longest == data->longest_fixed) {
691 data->offset_fixed = l ? data->last_start_min : data->pos_min;
692 if (data->flags & SF_BEFORE_EOL)
694 |= ((data->flags & SF_BEFORE_EOL) << SF_FIX_SHIFT_EOL);
696 data->flags &= ~SF_FIX_BEFORE_EOL;
697 data->minlen_fixed=minlenp;
698 data->lookbehind_fixed=0;
700 else { /* *data->longest == data->longest_float */
701 data->offset_float_min = l ? data->last_start_min : data->pos_min;
702 data->offset_float_max = (l
703 ? data->last_start_max
704 : data->pos_min + data->pos_delta);
705 if (is_inf || (U32)data->offset_float_max > (U32)I32_MAX)
706 data->offset_float_max = I32_MAX;
707 if (data->flags & SF_BEFORE_EOL)
709 |= ((data->flags & SF_BEFORE_EOL) << SF_FL_SHIFT_EOL);
711 data->flags &= ~SF_FL_BEFORE_EOL;
712 data->minlen_float=minlenp;
713 data->lookbehind_float=0;
716 SvCUR_set(data->last_found, 0);
718 SV * const sv = data->last_found;
719 if (SvUTF8(sv) && SvMAGICAL(sv)) {
720 MAGIC * const mg = mg_find(sv, PERL_MAGIC_utf8);
726 data->flags &= ~SF_BEFORE_EOL;
727 DEBUG_STUDYDATA("commit: ",data,0);
730 /* Can match anything (initialization) */
732 S_cl_anything(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
734 PERL_ARGS_ASSERT_CL_ANYTHING;
736 ANYOF_BITMAP_SETALL(cl);
737 cl->flags = ANYOF_CLASS|ANYOF_EOS|ANYOF_UNICODE_ALL
738 |ANYOF_LOC_NONBITMAP_FOLD|ANYOF_NON_UTF8_LATIN1_ALL;
740 /* If any portion of the regex is to operate under locale rules,
741 * initialization includes it. The reason this isn't done for all regexes
742 * is that the optimizer was written under the assumption that locale was
743 * all-or-nothing. Given the complexity and lack of documentation in the
744 * optimizer, and that there are inadequate test cases for locale, so many
745 * parts of it may not work properly, it is safest to avoid locale unless
747 if (RExC_contains_locale) {
748 ANYOF_CLASS_SETALL(cl); /* /l uses class */
749 cl->flags |= ANYOF_LOCALE;
752 ANYOF_CLASS_ZERO(cl); /* Only /l uses class now */
756 /* Can match anything (initialization) */
758 S_cl_is_anything(const struct regnode_charclass_class *cl)
762 PERL_ARGS_ASSERT_CL_IS_ANYTHING;
764 for (value = 0; value <= ANYOF_MAX; value += 2)
765 if (ANYOF_CLASS_TEST(cl, value) && ANYOF_CLASS_TEST(cl, value + 1))
767 if (!(cl->flags & ANYOF_UNICODE_ALL))
769 if (!ANYOF_BITMAP_TESTALLSET((const void*)cl))
774 /* Can match anything (initialization) */
776 S_cl_init(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl)
778 PERL_ARGS_ASSERT_CL_INIT;
780 Zero(cl, 1, struct regnode_charclass_class);
782 cl_anything(pRExC_state, cl);
783 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
786 /* These two functions currently do the exact same thing */
787 #define cl_init_zero S_cl_init
789 /* 'AND' a given class with another one. Can create false positives. 'cl'
790 * should not be inverted. 'and_with->flags & ANYOF_CLASS' should be 0 if
791 * 'and_with' is a regnode_charclass instead of a regnode_charclass_class. */
793 S_cl_and(struct regnode_charclass_class *cl,
794 const struct regnode_charclass_class *and_with)
796 PERL_ARGS_ASSERT_CL_AND;
798 assert(and_with->type == ANYOF);
800 /* I (khw) am not sure all these restrictions are necessary XXX */
801 if (!(ANYOF_CLASS_TEST_ANY_SET(and_with))
802 && !(ANYOF_CLASS_TEST_ANY_SET(cl))
803 && (and_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
804 && !(and_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
805 && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) {
808 if (and_with->flags & ANYOF_INVERT)
809 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
810 cl->bitmap[i] &= ~and_with->bitmap[i];
812 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
813 cl->bitmap[i] &= and_with->bitmap[i];
814 } /* XXXX: logic is complicated otherwise, leave it along for a moment. */
816 if (and_with->flags & ANYOF_INVERT) {
818 /* Here, the and'ed node is inverted. Get the AND of the flags that
819 * aren't affected by the inversion. Those that are affected are
820 * handled individually below */
821 U8 affected_flags = cl->flags & ~INVERSION_UNAFFECTED_FLAGS;
822 cl->flags &= (and_with->flags & INVERSION_UNAFFECTED_FLAGS);
823 cl->flags |= affected_flags;
825 /* We currently don't know how to deal with things that aren't in the
826 * bitmap, but we know that the intersection is no greater than what
827 * is already in cl, so let there be false positives that get sorted
828 * out after the synthetic start class succeeds, and the node is
829 * matched for real. */
831 /* The inversion of these two flags indicate that the resulting
832 * intersection doesn't have them */
833 if (and_with->flags & ANYOF_UNICODE_ALL) {
834 cl->flags &= ~ANYOF_UNICODE_ALL;
836 if (and_with->flags & ANYOF_NON_UTF8_LATIN1_ALL) {
837 cl->flags &= ~ANYOF_NON_UTF8_LATIN1_ALL;
840 else { /* and'd node is not inverted */
841 U8 outside_bitmap_but_not_utf8; /* Temp variable */
843 if (! ANYOF_NONBITMAP(and_with)) {
845 /* Here 'and_with' doesn't match anything outside the bitmap
846 * (except possibly ANYOF_UNICODE_ALL), which means the
847 * intersection can't either, except for ANYOF_UNICODE_ALL, in
848 * which case we don't know what the intersection is, but it's no
849 * greater than what cl already has, so can just leave it alone,
850 * with possible false positives */
851 if (! (and_with->flags & ANYOF_UNICODE_ALL)) {
852 ARG_SET(cl, ANYOF_NONBITMAP_EMPTY);
853 cl->flags &= ~ANYOF_NONBITMAP_NON_UTF8;
856 else if (! ANYOF_NONBITMAP(cl)) {
858 /* Here, 'and_with' does match something outside the bitmap, and cl
859 * doesn't have a list of things to match outside the bitmap. If
860 * cl can match all code points above 255, the intersection will
861 * be those above-255 code points that 'and_with' matches. If cl
862 * can't match all Unicode code points, it means that it can't
863 * match anything outside the bitmap (since the 'if' that got us
864 * into this block tested for that), so we leave the bitmap empty.
866 if (cl->flags & ANYOF_UNICODE_ALL) {
867 ARG_SET(cl, ARG(and_with));
869 /* and_with's ARG may match things that don't require UTF8.
870 * And now cl's will too, in spite of this being an 'and'. See
871 * the comments below about the kludge */
872 cl->flags |= and_with->flags & ANYOF_NONBITMAP_NON_UTF8;
876 /* Here, both 'and_with' and cl match something outside the
877 * bitmap. Currently we do not do the intersection, so just match
878 * whatever cl had at the beginning. */
882 /* Take the intersection of the two sets of flags. However, the
883 * ANYOF_NONBITMAP_NON_UTF8 flag is treated as an 'or'. This is a
884 * kludge around the fact that this flag is not treated like the others
885 * which are initialized in cl_anything(). The way the optimizer works
886 * is that the synthetic start class (SSC) is initialized to match
887 * anything, and then the first time a real node is encountered, its
888 * values are AND'd with the SSC's with the result being the values of
889 * the real node. However, there are paths through the optimizer where
890 * the AND never gets called, so those initialized bits are set
891 * inappropriately, which is not usually a big deal, as they just cause
892 * false positives in the SSC, which will just mean a probably
893 * imperceptible slow down in execution. However this bit has a
894 * higher false positive consequence in that it can cause utf8.pm,
895 * utf8_heavy.pl ... to be loaded when not necessary, which is a much
896 * bigger slowdown and also causes significant extra memory to be used.
897 * In order to prevent this, the code now takes a different tack. The
898 * bit isn't set unless some part of the regular expression needs it,
899 * but once set it won't get cleared. This means that these extra
900 * modules won't get loaded unless there was some path through the
901 * pattern that would have required them anyway, and so any false
902 * positives that occur by not ANDing them out when they could be
903 * aren't as severe as they would be if we treated this bit like all
905 outside_bitmap_but_not_utf8 = (cl->flags | and_with->flags)
906 & ANYOF_NONBITMAP_NON_UTF8;
907 cl->flags &= and_with->flags;
908 cl->flags |= outside_bitmap_but_not_utf8;
912 /* 'OR' a given class with another one. Can create false positives. 'cl'
913 * should not be inverted. 'or_with->flags & ANYOF_CLASS' should be 0 if
914 * 'or_with' is a regnode_charclass instead of a regnode_charclass_class. */
916 S_cl_or(const RExC_state_t *pRExC_state, struct regnode_charclass_class *cl, const struct regnode_charclass_class *or_with)
918 PERL_ARGS_ASSERT_CL_OR;
920 if (or_with->flags & ANYOF_INVERT) {
922 /* Here, the or'd node is to be inverted. This means we take the
923 * complement of everything not in the bitmap, but currently we don't
924 * know what that is, so give up and match anything */
925 if (ANYOF_NONBITMAP(or_with)) {
926 cl_anything(pRExC_state, cl);
929 * (B1 | CL1) | (!B2 & !CL2) = (B1 | !B2 & !CL2) | (CL1 | (!B2 & !CL2))
930 * <= (B1 | !B2) | (CL1 | !CL2)
931 * which is wasteful if CL2 is small, but we ignore CL2:
932 * (B1 | CL1) | (!B2 & !CL2) <= (B1 | CL1) | !B2 = (B1 | !B2) | CL1
933 * XXXX Can we handle case-fold? Unclear:
934 * (OK1(i) | OK1(i')) | !(OK1(i) | OK1(i')) =
935 * (OK1(i) | OK1(i')) | (!OK1(i) & !OK1(i'))
937 else if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
938 && !(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
939 && !(cl->flags & ANYOF_LOC_NONBITMAP_FOLD) ) {
942 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
943 cl->bitmap[i] |= ~or_with->bitmap[i];
944 } /* XXXX: logic is complicated otherwise */
946 cl_anything(pRExC_state, cl);
949 /* And, we can just take the union of the flags that aren't affected
950 * by the inversion */
951 cl->flags |= or_with->flags & INVERSION_UNAFFECTED_FLAGS;
953 /* For the remaining flags:
954 ANYOF_UNICODE_ALL and inverted means to not match anything above
955 255, which means that the union with cl should just be
956 what cl has in it, so can ignore this flag
957 ANYOF_NON_UTF8_LATIN1_ALL and inverted means if not utf8 and ord
958 is 127-255 to match them, but then invert that, so the
959 union with cl should just be what cl has in it, so can
962 } else { /* 'or_with' is not inverted */
963 /* (B1 | CL1) | (B2 | CL2) = (B1 | B2) | (CL1 | CL2)) */
964 if ( (or_with->flags & ANYOF_LOCALE) == (cl->flags & ANYOF_LOCALE)
965 && (!(or_with->flags & ANYOF_LOC_NONBITMAP_FOLD)
966 || (cl->flags & ANYOF_LOC_NONBITMAP_FOLD)) ) {
969 /* OR char bitmap and class bitmap separately */
970 for (i = 0; i < ANYOF_BITMAP_SIZE; i++)
971 cl->bitmap[i] |= or_with->bitmap[i];
972 if (ANYOF_CLASS_TEST_ANY_SET(or_with)) {
973 for (i = 0; i < ANYOF_CLASSBITMAP_SIZE; i++)
974 cl->classflags[i] |= or_with->classflags[i];
975 cl->flags |= ANYOF_CLASS;
978 else { /* XXXX: logic is complicated, leave it along for a moment. */
979 cl_anything(pRExC_state, cl);
982 if (ANYOF_NONBITMAP(or_with)) {
984 /* Use the added node's outside-the-bit-map match if there isn't a
985 * conflict. If there is a conflict (both nodes match something
986 * outside the bitmap, but what they match outside is not the same
987 * pointer, and hence not easily compared until XXX we extend
988 * inversion lists this far), give up and allow the start class to
989 * match everything outside the bitmap. If that stuff is all above
990 * 255, can just set UNICODE_ALL, otherwise caould be anything. */
991 if (! ANYOF_NONBITMAP(cl)) {
992 ARG_SET(cl, ARG(or_with));
994 else if (ARG(cl) != ARG(or_with)) {
996 if ((or_with->flags & ANYOF_NONBITMAP_NON_UTF8)) {
997 cl_anything(pRExC_state, cl);
1000 cl->flags |= ANYOF_UNICODE_ALL;
1005 /* Take the union */
1006 cl->flags |= or_with->flags;
1010 #define TRIE_LIST_ITEM(state,idx) (trie->states[state].trans.list)[ idx ]
1011 #define TRIE_LIST_CUR(state) ( TRIE_LIST_ITEM( state, 0 ).forid )
1012 #define TRIE_LIST_LEN(state) ( TRIE_LIST_ITEM( state, 0 ).newstate )
1013 #define TRIE_LIST_USED(idx) ( trie->states[state].trans.list ? (TRIE_LIST_CUR( idx ) - 1) : 0 )
1018 dump_trie(trie,widecharmap,revcharmap)
1019 dump_trie_interim_list(trie,widecharmap,revcharmap,next_alloc)
1020 dump_trie_interim_table(trie,widecharmap,revcharmap,next_alloc)
1022 These routines dump out a trie in a somewhat readable format.
1023 The _interim_ variants are used for debugging the interim
1024 tables that are used to generate the final compressed
1025 representation which is what dump_trie expects.
1027 Part of the reason for their existence is to provide a form
1028 of documentation as to how the different representations function.
1033 Dumps the final compressed table form of the trie to Perl_debug_log.
1034 Used for debugging make_trie().
1038 S_dump_trie(pTHX_ const struct _reg_trie_data *trie, HV *widecharmap,
1039 AV *revcharmap, U32 depth)
1042 SV *sv=sv_newmortal();
1043 int colwidth= widecharmap ? 6 : 4;
1045 GET_RE_DEBUG_FLAGS_DECL;
1047 PERL_ARGS_ASSERT_DUMP_TRIE;
1049 PerlIO_printf( Perl_debug_log, "%*sChar : %-6s%-6s%-4s ",
1050 (int)depth * 2 + 2,"",
1051 "Match","Base","Ofs" );
1053 for( state = 0 ; state < trie->uniquecharcount ; state++ ) {
1054 SV ** const tmp = av_fetch( revcharmap, state, 0);
1056 PerlIO_printf( Perl_debug_log, "%*s",
1058 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1059 PL_colors[0], PL_colors[1],
1060 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1061 PERL_PV_ESCAPE_FIRSTCHAR
1066 PerlIO_printf( Perl_debug_log, "\n%*sState|-----------------------",
1067 (int)depth * 2 + 2,"");
1069 for( state = 0 ; state < trie->uniquecharcount ; state++ )
1070 PerlIO_printf( Perl_debug_log, "%.*s", colwidth, "--------");
1071 PerlIO_printf( Perl_debug_log, "\n");
1073 for( state = 1 ; state < trie->statecount ; state++ ) {
1074 const U32 base = trie->states[ state ].trans.base;
1076 PerlIO_printf( Perl_debug_log, "%*s#%4"UVXf"|", (int)depth * 2 + 2,"", (UV)state);
1078 if ( trie->states[ state ].wordnum ) {
1079 PerlIO_printf( Perl_debug_log, " W%4X", trie->states[ state ].wordnum );
1081 PerlIO_printf( Perl_debug_log, "%6s", "" );
1084 PerlIO_printf( Perl_debug_log, " @%4"UVXf" ", (UV)base );
1089 while( ( base + ofs < trie->uniquecharcount ) ||
1090 ( base + ofs - trie->uniquecharcount < trie->lasttrans
1091 && trie->trans[ base + ofs - trie->uniquecharcount ].check != state))
1094 PerlIO_printf( Perl_debug_log, "+%2"UVXf"[ ", (UV)ofs);
1096 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
1097 if ( ( base + ofs >= trie->uniquecharcount ) &&
1098 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
1099 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
1101 PerlIO_printf( Perl_debug_log, "%*"UVXf,
1103 (UV)trie->trans[ base + ofs - trie->uniquecharcount ].next );
1105 PerlIO_printf( Perl_debug_log, "%*s",colwidth," ." );
1109 PerlIO_printf( Perl_debug_log, "]");
1112 PerlIO_printf( Perl_debug_log, "\n" );
1114 PerlIO_printf(Perl_debug_log, "%*sword_info N:(prev,len)=", (int)depth*2, "");
1115 for (word=1; word <= trie->wordcount; word++) {
1116 PerlIO_printf(Perl_debug_log, " %d:(%d,%d)",
1117 (int)word, (int)(trie->wordinfo[word].prev),
1118 (int)(trie->wordinfo[word].len));
1120 PerlIO_printf(Perl_debug_log, "\n" );
1123 Dumps a fully constructed but uncompressed trie in list form.
1124 List tries normally only are used for construction when the number of
1125 possible chars (trie->uniquecharcount) is very high.
1126 Used for debugging make_trie().
1129 S_dump_trie_interim_list(pTHX_ const struct _reg_trie_data *trie,
1130 HV *widecharmap, AV *revcharmap, U32 next_alloc,
1134 SV *sv=sv_newmortal();
1135 int colwidth= widecharmap ? 6 : 4;
1136 GET_RE_DEBUG_FLAGS_DECL;
1138 PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_LIST;
1140 /* print out the table precompression. */
1141 PerlIO_printf( Perl_debug_log, "%*sState :Word | Transition Data\n%*s%s",
1142 (int)depth * 2 + 2,"", (int)depth * 2 + 2,"",
1143 "------:-----+-----------------\n" );
1145 for( state=1 ; state < next_alloc ; state ++ ) {
1148 PerlIO_printf( Perl_debug_log, "%*s %4"UVXf" :",
1149 (int)depth * 2 + 2,"", (UV)state );
1150 if ( ! trie->states[ state ].wordnum ) {
1151 PerlIO_printf( Perl_debug_log, "%5s| ","");
1153 PerlIO_printf( Perl_debug_log, "W%4x| ",
1154 trie->states[ state ].wordnum
1157 for( charid = 1 ; charid <= TRIE_LIST_USED( state ) ; charid++ ) {
1158 SV ** const tmp = av_fetch( revcharmap, TRIE_LIST_ITEM(state,charid).forid, 0);
1160 PerlIO_printf( Perl_debug_log, "%*s:%3X=%4"UVXf" | ",
1162 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1163 PL_colors[0], PL_colors[1],
1164 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1165 PERL_PV_ESCAPE_FIRSTCHAR
1167 TRIE_LIST_ITEM(state,charid).forid,
1168 (UV)TRIE_LIST_ITEM(state,charid).newstate
1171 PerlIO_printf(Perl_debug_log, "\n%*s| ",
1172 (int)((depth * 2) + 14), "");
1175 PerlIO_printf( Perl_debug_log, "\n");
1180 Dumps a fully constructed but uncompressed trie in table form.
1181 This is the normal DFA style state transition table, with a few
1182 twists to facilitate compression later.
1183 Used for debugging make_trie().
1186 S_dump_trie_interim_table(pTHX_ const struct _reg_trie_data *trie,
1187 HV *widecharmap, AV *revcharmap, U32 next_alloc,
1192 SV *sv=sv_newmortal();
1193 int colwidth= widecharmap ? 6 : 4;
1194 GET_RE_DEBUG_FLAGS_DECL;
1196 PERL_ARGS_ASSERT_DUMP_TRIE_INTERIM_TABLE;
1199 print out the table precompression so that we can do a visual check
1200 that they are identical.
1203 PerlIO_printf( Perl_debug_log, "%*sChar : ",(int)depth * 2 + 2,"" );
1205 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1206 SV ** const tmp = av_fetch( revcharmap, charid, 0);
1208 PerlIO_printf( Perl_debug_log, "%*s",
1210 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), colwidth,
1211 PL_colors[0], PL_colors[1],
1212 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
1213 PERL_PV_ESCAPE_FIRSTCHAR
1219 PerlIO_printf( Perl_debug_log, "\n%*sState+-",(int)depth * 2 + 2,"" );
1221 for( charid=0 ; charid < trie->uniquecharcount ; charid++ ) {
1222 PerlIO_printf( Perl_debug_log, "%.*s", colwidth,"--------");
1225 PerlIO_printf( Perl_debug_log, "\n" );
1227 for( state=1 ; state < next_alloc ; state += trie->uniquecharcount ) {
1229 PerlIO_printf( Perl_debug_log, "%*s%4"UVXf" : ",
1230 (int)depth * 2 + 2,"",
1231 (UV)TRIE_NODENUM( state ) );
1233 for( charid = 0 ; charid < trie->uniquecharcount ; charid++ ) {
1234 UV v=(UV)SAFE_TRIE_NODENUM( trie->trans[ state + charid ].next );
1236 PerlIO_printf( Perl_debug_log, "%*"UVXf, colwidth, v );
1238 PerlIO_printf( Perl_debug_log, "%*s", colwidth, "." );
1240 if ( ! trie->states[ TRIE_NODENUM( state ) ].wordnum ) {
1241 PerlIO_printf( Perl_debug_log, " (%4"UVXf")\n", (UV)trie->trans[ state ].check );
1243 PerlIO_printf( Perl_debug_log, " (%4"UVXf") W%4X\n", (UV)trie->trans[ state ].check,
1244 trie->states[ TRIE_NODENUM( state ) ].wordnum );
1252 /* make_trie(startbranch,first,last,tail,word_count,flags,depth)
1253 startbranch: the first branch in the whole branch sequence
1254 first : start branch of sequence of branch-exact nodes.
1255 May be the same as startbranch
1256 last : Thing following the last branch.
1257 May be the same as tail.
1258 tail : item following the branch sequence
1259 count : words in the sequence
1260 flags : currently the OP() type we will be building one of /EXACT(|F|Fl)/
1261 depth : indent depth
1263 Inplace optimizes a sequence of 2 or more Branch-Exact nodes into a TRIE node.
1265 A trie is an N'ary tree where the branches are determined by digital
1266 decomposition of the key. IE, at the root node you look up the 1st character and
1267 follow that branch repeat until you find the end of the branches. Nodes can be
1268 marked as "accepting" meaning they represent a complete word. Eg:
1272 would convert into the following structure. Numbers represent states, letters
1273 following numbers represent valid transitions on the letter from that state, if
1274 the number is in square brackets it represents an accepting state, otherwise it
1275 will be in parenthesis.
1277 +-h->+-e->[3]-+-r->(8)-+-s->[9]
1281 (1) +-i->(6)-+-s->[7]
1283 +-s->(3)-+-h->(4)-+-e->[5]
1285 Accept Word Mapping: 3=>1 (he),5=>2 (she), 7=>3 (his), 9=>4 (hers)
1287 This shows that when matching against the string 'hers' we will begin at state 1
1288 read 'h' and move to state 2, read 'e' and move to state 3 which is accepting,
1289 then read 'r' and go to state 8 followed by 's' which takes us to state 9 which
1290 is also accepting. Thus we know that we can match both 'he' and 'hers' with a
1291 single traverse. We store a mapping from accepting to state to which word was
1292 matched, and then when we have multiple possibilities we try to complete the
1293 rest of the regex in the order in which they occured in the alternation.
1295 The only prior NFA like behaviour that would be changed by the TRIE support is
1296 the silent ignoring of duplicate alternations which are of the form:
1298 / (DUPE|DUPE) X? (?{ ... }) Y /x
1300 Thus EVAL blocks following a trie may be called a different number of times with
1301 and without the optimisation. With the optimisations dupes will be silently
1302 ignored. This inconsistent behaviour of EVAL type nodes is well established as
1303 the following demonstrates:
1305 'words'=~/(word|word|word)(?{ print $1 })[xyz]/
1307 which prints out 'word' three times, but
1309 'words'=~/(word|word|word)(?{ print $1 })S/
1311 which doesnt print it out at all. This is due to other optimisations kicking in.
1313 Example of what happens on a structural level:
1315 The regexp /(ac|ad|ab)+/ will produce the following debug output:
1317 1: CURLYM[1] {1,32767}(18)
1328 This would be optimizable with startbranch=5, first=5, last=16, tail=16
1329 and should turn into:
1331 1: CURLYM[1] {1,32767}(18)
1333 [Words:3 Chars Stored:6 Unique Chars:4 States:5 NCP:1]
1341 Cases where tail != last would be like /(?foo|bar)baz/:
1351 which would be optimizable with startbranch=1, first=1, last=7, tail=8
1352 and would end up looking like:
1355 [Words:2 Chars Stored:6 Unique Chars:5 States:7 NCP:1]
1362 d = uvuni_to_utf8_flags(d, uv, 0);
1364 is the recommended Unicode-aware way of saying
1369 #define TRIE_STORE_REVCHAR(val) \
1372 SV *zlopp = newSV(7); /* XXX: optimize me */ \
1373 unsigned char *flrbbbbb = (unsigned char *) SvPVX(zlopp); \
1374 unsigned const char *const kapow = uvuni_to_utf8(flrbbbbb, val); \
1375 SvCUR_set(zlopp, kapow - flrbbbbb); \
1378 av_push(revcharmap, zlopp); \
1380 char ooooff = (char)val; \
1381 av_push(revcharmap, newSVpvn(&ooooff, 1)); \
1385 #define TRIE_READ_CHAR STMT_START { \
1388 /* if it is UTF then it is either already folded, or does not need folding */ \
1389 uvc = utf8n_to_uvuni( (const U8*) uc, UTF8_MAXLEN, &len, uniflags); \
1391 else if (folder == PL_fold_latin1) { \
1392 /* if we use this folder we have to obey unicode rules on latin-1 data */ \
1393 if ( foldlen > 0 ) { \
1394 uvc = utf8n_to_uvuni( (const U8*) scan, UTF8_MAXLEN, &len, uniflags ); \
1400 uvc = _to_fold_latin1( (U8) *uc, foldbuf, &foldlen, 1); \
1401 skiplen = UNISKIP(uvc); \
1402 foldlen -= skiplen; \
1403 scan = foldbuf + skiplen; \
1406 /* raw data, will be folded later if needed */ \
1414 #define TRIE_LIST_PUSH(state,fid,ns) STMT_START { \
1415 if ( TRIE_LIST_CUR( state ) >=TRIE_LIST_LEN( state ) ) { \
1416 U32 ging = TRIE_LIST_LEN( state ) *= 2; \
1417 Renew( trie->states[ state ].trans.list, ging, reg_trie_trans_le ); \
1419 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).forid = fid; \
1420 TRIE_LIST_ITEM( state, TRIE_LIST_CUR( state ) ).newstate = ns; \
1421 TRIE_LIST_CUR( state )++; \
1424 #define TRIE_LIST_NEW(state) STMT_START { \
1425 Newxz( trie->states[ state ].trans.list, \
1426 4, reg_trie_trans_le ); \
1427 TRIE_LIST_CUR( state ) = 1; \
1428 TRIE_LIST_LEN( state ) = 4; \
1431 #define TRIE_HANDLE_WORD(state) STMT_START { \
1432 U16 dupe= trie->states[ state ].wordnum; \
1433 regnode * const noper_next = regnext( noper ); \
1436 /* store the word for dumping */ \
1438 if (OP(noper) != NOTHING) \
1439 tmp = newSVpvn_utf8(STRING(noper), STR_LEN(noper), UTF); \
1441 tmp = newSVpvn_utf8( "", 0, UTF ); \
1442 av_push( trie_words, tmp ); \
1446 trie->wordinfo[curword].prev = 0; \
1447 trie->wordinfo[curword].len = wordlen; \
1448 trie->wordinfo[curword].accept = state; \
1450 if ( noper_next < tail ) { \
1452 trie->jump = (U16 *) PerlMemShared_calloc( word_count + 1, sizeof(U16) ); \
1453 trie->jump[curword] = (U16)(noper_next - convert); \
1455 jumper = noper_next; \
1457 nextbranch= regnext(cur); \
1461 /* It's a dupe. Pre-insert into the wordinfo[].prev */\
1462 /* chain, so that when the bits of chain are later */\
1463 /* linked together, the dups appear in the chain */\
1464 trie->wordinfo[curword].prev = trie->wordinfo[dupe].prev; \
1465 trie->wordinfo[dupe].prev = curword; \
1467 /* we haven't inserted this word yet. */ \
1468 trie->states[ state ].wordnum = curword; \
1473 #define TRIE_TRANS_STATE(state,base,ucharcount,charid,special) \
1474 ( ( base + charid >= ucharcount \
1475 && base + charid < ubound \
1476 && state == trie->trans[ base - ucharcount + charid ].check \
1477 && trie->trans[ base - ucharcount + charid ].next ) \
1478 ? trie->trans[ base - ucharcount + charid ].next \
1479 : ( state==1 ? special : 0 ) \
1483 #define MADE_JUMP_TRIE 2
1484 #define MADE_EXACT_TRIE 4
1487 S_make_trie(pTHX_ RExC_state_t *pRExC_state, regnode *startbranch, regnode *first, regnode *last, regnode *tail, U32 word_count, U32 flags, U32 depth)
1490 /* first pass, loop through and scan words */
1491 reg_trie_data *trie;
1492 HV *widecharmap = NULL;
1493 AV *revcharmap = newAV();
1495 const U32 uniflags = UTF8_ALLOW_DEFAULT;
1500 regnode *jumper = NULL;
1501 regnode *nextbranch = NULL;
1502 regnode *convert = NULL;
1503 U32 *prev_states; /* temp array mapping each state to previous one */
1504 /* we just use folder as a flag in utf8 */
1505 const U8 * folder = NULL;
1508 const U32 data_slot = add_data( pRExC_state, 4, "tuuu" );
1509 AV *trie_words = NULL;
1510 /* along with revcharmap, this only used during construction but both are
1511 * useful during debugging so we store them in the struct when debugging.
1514 const U32 data_slot = add_data( pRExC_state, 2, "tu" );
1515 STRLEN trie_charcount=0;
1517 SV *re_trie_maxbuff;
1518 GET_RE_DEBUG_FLAGS_DECL;
1520 PERL_ARGS_ASSERT_MAKE_TRIE;
1522 PERL_UNUSED_ARG(depth);
1529 case EXACTFU_TRICKYFOLD:
1530 case EXACTFU: folder = PL_fold_latin1; break;
1531 case EXACTF: folder = PL_fold; break;
1532 case EXACTFL: folder = PL_fold_locale; break;
1533 default: Perl_croak( aTHX_ "panic! In trie construction, unknown node type %u %s", (unsigned) flags, PL_reg_name[flags] );
1536 trie = (reg_trie_data *) PerlMemShared_calloc( 1, sizeof(reg_trie_data) );
1538 trie->startstate = 1;
1539 trie->wordcount = word_count;
1540 RExC_rxi->data->data[ data_slot ] = (void*)trie;
1541 trie->charmap = (U16 *) PerlMemShared_calloc( 256, sizeof(U16) );
1543 trie->bitmap = (char *) PerlMemShared_calloc( ANYOF_BITMAP_SIZE, 1 );
1544 trie->wordinfo = (reg_trie_wordinfo *) PerlMemShared_calloc(
1545 trie->wordcount+1, sizeof(reg_trie_wordinfo));
1548 trie_words = newAV();
1551 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
1552 if (!SvIOK(re_trie_maxbuff)) {
1553 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
1556 PerlIO_printf( Perl_debug_log,
1557 "%*smake_trie start==%d, first==%d, last==%d, tail==%d depth=%d\n",
1558 (int)depth * 2 + 2, "",
1559 REG_NODE_NUM(startbranch),REG_NODE_NUM(first),
1560 REG_NODE_NUM(last), REG_NODE_NUM(tail),
1564 /* Find the node we are going to overwrite */
1565 if ( first == startbranch && OP( last ) != BRANCH ) {
1566 /* whole branch chain */
1569 /* branch sub-chain */
1570 convert = NEXTOPER( first );
1573 /* -- First loop and Setup --
1575 We first traverse the branches and scan each word to determine if it
1576 contains widechars, and how many unique chars there are, this is
1577 important as we have to build a table with at least as many columns as we
1580 We use an array of integers to represent the character codes 0..255
1581 (trie->charmap) and we use a an HV* to store Unicode characters. We use the
1582 native representation of the character value as the key and IV's for the
1585 *TODO* If we keep track of how many times each character is used we can
1586 remap the columns so that the table compression later on is more
1587 efficient in terms of memory by ensuring the most common value is in the
1588 middle and the least common are on the outside. IMO this would be better
1589 than a most to least common mapping as theres a decent chance the most
1590 common letter will share a node with the least common, meaning the node
1591 will not be compressible. With a middle is most common approach the worst
1592 case is when we have the least common nodes twice.
1596 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1597 regnode * const noper = NEXTOPER( cur );
1598 const U8 *uc = (U8*)STRING( noper );
1599 const U8 * const e = uc + STR_LEN( noper );
1601 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1603 const U8 *scan = (U8*)NULL;
1604 U32 wordlen = 0; /* required init */
1606 bool set_bit = trie->bitmap ? 1 : 0; /*store the first char in the bitmap?*/
1608 if (OP(noper) == NOTHING) {
1612 if ( set_bit ) { /* bitmap only alloced when !(UTF&&Folding) */
1613 TRIE_BITMAP_SET(trie,*uc); /* store the raw first byte
1614 regardless of encoding */
1615 if (OP( noper ) == EXACTFU_SS) {
1616 /* false positives are ok, so just set this */
1617 TRIE_BITMAP_SET(trie,0xDF);
1620 for ( ; uc < e ; uc += len ) {
1621 TRIE_CHARCOUNT(trie)++;
1626 U8 folded= folder[ (U8) uvc ];
1627 if ( !trie->charmap[ folded ] ) {
1628 trie->charmap[ folded ]=( ++trie->uniquecharcount );
1629 TRIE_STORE_REVCHAR( folded );
1632 if ( !trie->charmap[ uvc ] ) {
1633 trie->charmap[ uvc ]=( ++trie->uniquecharcount );
1634 TRIE_STORE_REVCHAR( uvc );
1637 /* store the codepoint in the bitmap, and its folded
1639 TRIE_BITMAP_SET(trie, uvc);
1641 /* store the folded codepoint */
1642 if ( folder ) TRIE_BITMAP_SET(trie, folder[(U8) uvc ]);
1645 /* store first byte of utf8 representation of
1646 variant codepoints */
1647 if (! UNI_IS_INVARIANT(uvc)) {
1648 TRIE_BITMAP_SET(trie, UTF8_TWO_BYTE_HI(uvc));
1651 set_bit = 0; /* We've done our bit :-) */
1656 widecharmap = newHV();
1658 svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 1 );
1661 Perl_croak( aTHX_ "error creating/fetching widecharmap entry for 0x%"UVXf, uvc );
1663 if ( !SvTRUE( *svpp ) ) {
1664 sv_setiv( *svpp, ++trie->uniquecharcount );
1665 TRIE_STORE_REVCHAR(uvc);
1669 if( cur == first ) {
1670 trie->minlen = chars;
1671 trie->maxlen = chars;
1672 } else if (chars < trie->minlen) {
1673 trie->minlen = chars;
1674 } else if (chars > trie->maxlen) {
1675 trie->maxlen = chars;
1677 if (OP( noper ) == EXACTFU_SS) {
1678 /* XXX: workaround - 'ss' could match "\x{DF}" so minlen could be 1 and not 2*/
1679 if (trie->minlen > 1)
1682 if (OP( noper ) == EXACTFU_TRICKYFOLD) {
1683 /* XXX: workround - things like "\x{1FBE}\x{0308}\x{0301}" can match "\x{0390}"
1684 * - We assume that any such sequence might match a 2 byte string */
1685 if (trie->minlen > 2 )
1689 } /* end first pass */
1690 DEBUG_TRIE_COMPILE_r(
1691 PerlIO_printf( Perl_debug_log, "%*sTRIE(%s): W:%d C:%d Uq:%d Min:%d Max:%d\n",
1692 (int)depth * 2 + 2,"",
1693 ( widecharmap ? "UTF8" : "NATIVE" ), (int)word_count,
1694 (int)TRIE_CHARCOUNT(trie), trie->uniquecharcount,
1695 (int)trie->minlen, (int)trie->maxlen )
1699 We now know what we are dealing with in terms of unique chars and
1700 string sizes so we can calculate how much memory a naive
1701 representation using a flat table will take. If it's over a reasonable
1702 limit (as specified by ${^RE_TRIE_MAXBUF}) we use a more memory
1703 conservative but potentially much slower representation using an array
1706 At the end we convert both representations into the same compressed
1707 form that will be used in regexec.c for matching with. The latter
1708 is a form that cannot be used to construct with but has memory
1709 properties similar to the list form and access properties similar
1710 to the table form making it both suitable for fast searches and
1711 small enough that its feasable to store for the duration of a program.
1713 See the comment in the code where the compressed table is produced
1714 inplace from the flat tabe representation for an explanation of how
1715 the compression works.
1720 Newx(prev_states, TRIE_CHARCOUNT(trie) + 2, U32);
1723 if ( (IV)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1) > SvIV(re_trie_maxbuff) ) {
1725 Second Pass -- Array Of Lists Representation
1727 Each state will be represented by a list of charid:state records
1728 (reg_trie_trans_le) the first such element holds the CUR and LEN
1729 points of the allocated array. (See defines above).
1731 We build the initial structure using the lists, and then convert
1732 it into the compressed table form which allows faster lookups
1733 (but cant be modified once converted).
1736 STRLEN transcount = 1;
1738 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1739 "%*sCompiling trie using list compiler\n",
1740 (int)depth * 2 + 2, ""));
1742 trie->states = (reg_trie_state *)
1743 PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1744 sizeof(reg_trie_state) );
1748 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1750 regnode * const noper = NEXTOPER( cur );
1751 U8 *uc = (U8*)STRING( noper );
1752 const U8 * const e = uc + STR_LEN( noper );
1753 U32 state = 1; /* required init */
1754 U16 charid = 0; /* sanity init */
1755 U8 *scan = (U8*)NULL; /* sanity init */
1756 STRLEN foldlen = 0; /* required init */
1757 U32 wordlen = 0; /* required init */
1758 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1761 if (OP(noper) != NOTHING) {
1762 for ( ; uc < e ; uc += len ) {
1767 charid = trie->charmap[ uvc ];
1769 SV** const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1773 charid=(U16)SvIV( *svpp );
1776 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1783 if ( !trie->states[ state ].trans.list ) {
1784 TRIE_LIST_NEW( state );
1786 for ( check = 1; check <= TRIE_LIST_USED( state ); check++ ) {
1787 if ( TRIE_LIST_ITEM( state, check ).forid == charid ) {
1788 newstate = TRIE_LIST_ITEM( state, check ).newstate;
1793 newstate = next_alloc++;
1794 prev_states[newstate] = state;
1795 TRIE_LIST_PUSH( state, charid, newstate );
1800 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1804 TRIE_HANDLE_WORD(state);
1806 } /* end second pass */
1808 /* next alloc is the NEXT state to be allocated */
1809 trie->statecount = next_alloc;
1810 trie->states = (reg_trie_state *)
1811 PerlMemShared_realloc( trie->states,
1813 * sizeof(reg_trie_state) );
1815 /* and now dump it out before we compress it */
1816 DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_list(trie, widecharmap,
1817 revcharmap, next_alloc,
1821 trie->trans = (reg_trie_trans *)
1822 PerlMemShared_calloc( transcount, sizeof(reg_trie_trans) );
1829 for( state=1 ; state < next_alloc ; state ++ ) {
1833 DEBUG_TRIE_COMPILE_MORE_r(
1834 PerlIO_printf( Perl_debug_log, "tp: %d zp: %d ",tp,zp)
1838 if (trie->states[state].trans.list) {
1839 U16 minid=TRIE_LIST_ITEM( state, 1).forid;
1843 for( idx = 2 ; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1844 const U16 forid = TRIE_LIST_ITEM( state, idx).forid;
1845 if ( forid < minid ) {
1847 } else if ( forid > maxid ) {
1851 if ( transcount < tp + maxid - minid + 1) {
1853 trie->trans = (reg_trie_trans *)
1854 PerlMemShared_realloc( trie->trans,
1856 * sizeof(reg_trie_trans) );
1857 Zero( trie->trans + (transcount / 2), transcount / 2 , reg_trie_trans );
1859 base = trie->uniquecharcount + tp - minid;
1860 if ( maxid == minid ) {
1862 for ( ; zp < tp ; zp++ ) {
1863 if ( ! trie->trans[ zp ].next ) {
1864 base = trie->uniquecharcount + zp - minid;
1865 trie->trans[ zp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1866 trie->trans[ zp ].check = state;
1872 trie->trans[ tp ].next = TRIE_LIST_ITEM( state, 1).newstate;
1873 trie->trans[ tp ].check = state;
1878 for ( idx=1; idx <= TRIE_LIST_USED( state ) ; idx++ ) {
1879 const U32 tid = base - trie->uniquecharcount + TRIE_LIST_ITEM( state, idx ).forid;
1880 trie->trans[ tid ].next = TRIE_LIST_ITEM( state, idx ).newstate;
1881 trie->trans[ tid ].check = state;
1883 tp += ( maxid - minid + 1 );
1885 Safefree(trie->states[ state ].trans.list);
1888 DEBUG_TRIE_COMPILE_MORE_r(
1889 PerlIO_printf( Perl_debug_log, " base: %d\n",base);
1892 trie->states[ state ].trans.base=base;
1894 trie->lasttrans = tp + 1;
1898 Second Pass -- Flat Table Representation.
1900 we dont use the 0 slot of either trans[] or states[] so we add 1 to each.
1901 We know that we will need Charcount+1 trans at most to store the data
1902 (one row per char at worst case) So we preallocate both structures
1903 assuming worst case.
1905 We then construct the trie using only the .next slots of the entry
1908 We use the .check field of the first entry of the node temporarily to
1909 make compression both faster and easier by keeping track of how many non
1910 zero fields are in the node.
1912 Since trans are numbered from 1 any 0 pointer in the table is a FAIL
1915 There are two terms at use here: state as a TRIE_NODEIDX() which is a
1916 number representing the first entry of the node, and state as a
1917 TRIE_NODENUM() which is the trans number. state 1 is TRIE_NODEIDX(1) and
1918 TRIE_NODENUM(1), state 2 is TRIE_NODEIDX(2) and TRIE_NODENUM(3) if there
1919 are 2 entrys per node. eg:
1927 The table is internally in the right hand, idx form. However as we also
1928 have to deal with the states array which is indexed by nodenum we have to
1929 use TRIE_NODENUM() to convert.
1932 DEBUG_TRIE_COMPILE_MORE_r( PerlIO_printf( Perl_debug_log,
1933 "%*sCompiling trie using table compiler\n",
1934 (int)depth * 2 + 2, ""));
1936 trie->trans = (reg_trie_trans *)
1937 PerlMemShared_calloc( ( TRIE_CHARCOUNT(trie) + 1 )
1938 * trie->uniquecharcount + 1,
1939 sizeof(reg_trie_trans) );
1940 trie->states = (reg_trie_state *)
1941 PerlMemShared_calloc( TRIE_CHARCOUNT(trie) + 2,
1942 sizeof(reg_trie_state) );
1943 next_alloc = trie->uniquecharcount + 1;
1946 for ( cur = first ; cur < last ; cur = regnext( cur ) ) {
1948 regnode * const noper = NEXTOPER( cur );
1949 const U8 *uc = (U8*)STRING( noper );
1950 const U8 * const e = uc + STR_LEN( noper );
1952 U32 state = 1; /* required init */
1954 U16 charid = 0; /* sanity init */
1955 U32 accept_state = 0; /* sanity init */
1956 U8 *scan = (U8*)NULL; /* sanity init */
1958 STRLEN foldlen = 0; /* required init */
1959 U32 wordlen = 0; /* required init */
1961 U8 foldbuf[ UTF8_MAXBYTES_CASE + 1 ];
1964 if ( OP(noper) != NOTHING ) {
1965 for ( ; uc < e ; uc += len ) {
1970 charid = trie->charmap[ uvc ];
1972 SV* const * const svpp = hv_fetch( widecharmap, (char*)&uvc, sizeof( UV ), 0);
1973 charid = svpp ? (U16)SvIV(*svpp) : 0;
1977 if ( !trie->trans[ state + charid ].next ) {
1978 trie->trans[ state + charid ].next = next_alloc;
1979 trie->trans[ state ].check++;
1980 prev_states[TRIE_NODENUM(next_alloc)]
1981 = TRIE_NODENUM(state);
1982 next_alloc += trie->uniquecharcount;
1984 state = trie->trans[ state + charid ].next;
1986 Perl_croak( aTHX_ "panic! In trie construction, no char mapping for %"IVdf, uvc );
1988 /* charid is now 0 if we dont know the char read, or nonzero if we do */
1991 accept_state = TRIE_NODENUM( state );
1992 TRIE_HANDLE_WORD(accept_state);
1994 } /* end second pass */
1996 /* and now dump it out before we compress it */
1997 DEBUG_TRIE_COMPILE_MORE_r(dump_trie_interim_table(trie, widecharmap,
1999 next_alloc, depth+1));
2003 * Inplace compress the table.*
2005 For sparse data sets the table constructed by the trie algorithm will
2006 be mostly 0/FAIL transitions or to put it another way mostly empty.
2007 (Note that leaf nodes will not contain any transitions.)
2009 This algorithm compresses the tables by eliminating most such
2010 transitions, at the cost of a modest bit of extra work during lookup:
2012 - Each states[] entry contains a .base field which indicates the
2013 index in the state[] array wheres its transition data is stored.
2015 - If .base is 0 there are no valid transitions from that node.
2017 - If .base is nonzero then charid is added to it to find an entry in
2020 -If trans[states[state].base+charid].check!=state then the
2021 transition is taken to be a 0/Fail transition. Thus if there are fail
2022 transitions at the front of the node then the .base offset will point
2023 somewhere inside the previous nodes data (or maybe even into a node
2024 even earlier), but the .check field determines if the transition is
2028 The following process inplace converts the table to the compressed
2029 table: We first do not compress the root node 1,and mark all its
2030 .check pointers as 1 and set its .base pointer as 1 as well. This
2031 allows us to do a DFA construction from the compressed table later,
2032 and ensures that any .base pointers we calculate later are greater
2035 - We set 'pos' to indicate the first entry of the second node.
2037 - We then iterate over the columns of the node, finding the first and
2038 last used entry at l and m. We then copy l..m into pos..(pos+m-l),
2039 and set the .check pointers accordingly, and advance pos
2040 appropriately and repreat for the next node. Note that when we copy
2041 the next pointers we have to convert them from the original
2042 NODEIDX form to NODENUM form as the former is not valid post
2045 - If a node has no transitions used we mark its base as 0 and do not
2046 advance the pos pointer.
2048 - If a node only has one transition we use a second pointer into the
2049 structure to fill in allocated fail transitions from other states.
2050 This pointer is independent of the main pointer and scans forward
2051 looking for null transitions that are allocated to a state. When it
2052 finds one it writes the single transition into the "hole". If the
2053 pointer doesnt find one the single transition is appended as normal.
2055 - Once compressed we can Renew/realloc the structures to release the
2058 See "Table-Compression Methods" in sec 3.9 of the Red Dragon,
2059 specifically Fig 3.47 and the associated pseudocode.
2063 const U32 laststate = TRIE_NODENUM( next_alloc );
2066 trie->statecount = laststate;
2068 for ( state = 1 ; state < laststate ; state++ ) {
2070 const U32 stateidx = TRIE_NODEIDX( state );
2071 const U32 o_used = trie->trans[ stateidx ].check;
2072 U32 used = trie->trans[ stateidx ].check;
2073 trie->trans[ stateidx ].check = 0;
2075 for ( charid = 0 ; used && charid < trie->uniquecharcount ; charid++ ) {
2076 if ( flag || trie->trans[ stateidx + charid ].next ) {
2077 if ( trie->trans[ stateidx + charid ].next ) {
2079 for ( ; zp < pos ; zp++ ) {
2080 if ( ! trie->trans[ zp ].next ) {
2084 trie->states[ state ].trans.base = zp + trie->uniquecharcount - charid ;
2085 trie->trans[ zp ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2086 trie->trans[ zp ].check = state;
2087 if ( ++zp > pos ) pos = zp;
2094 trie->states[ state ].trans.base = pos + trie->uniquecharcount - charid ;
2096 trie->trans[ pos ].next = SAFE_TRIE_NODENUM( trie->trans[ stateidx + charid ].next );
2097 trie->trans[ pos ].check = state;
2102 trie->lasttrans = pos + 1;
2103 trie->states = (reg_trie_state *)
2104 PerlMemShared_realloc( trie->states, laststate
2105 * sizeof(reg_trie_state) );
2106 DEBUG_TRIE_COMPILE_MORE_r(
2107 PerlIO_printf( Perl_debug_log,
2108 "%*sAlloc: %d Orig: %"IVdf" elements, Final:%"IVdf". Savings of %%%5.2f\n",
2109 (int)depth * 2 + 2,"",
2110 (int)( ( TRIE_CHARCOUNT(trie) + 1 ) * trie->uniquecharcount + 1 ),
2113 ( ( next_alloc - pos ) * 100 ) / (double)next_alloc );
2116 } /* end table compress */
2118 DEBUG_TRIE_COMPILE_MORE_r(
2119 PerlIO_printf(Perl_debug_log, "%*sStatecount:%"UVxf" Lasttrans:%"UVxf"\n",
2120 (int)depth * 2 + 2, "",
2121 (UV)trie->statecount,
2122 (UV)trie->lasttrans)
2124 /* resize the trans array to remove unused space */
2125 trie->trans = (reg_trie_trans *)
2126 PerlMemShared_realloc( trie->trans, trie->lasttrans
2127 * sizeof(reg_trie_trans) );
2129 { /* Modify the program and insert the new TRIE node */
2130 U8 nodetype =(U8)(flags & 0xFF);
2134 regnode *optimize = NULL;
2135 #ifdef RE_TRACK_PATTERN_OFFSETS
2138 U32 mjd_nodelen = 0;
2139 #endif /* RE_TRACK_PATTERN_OFFSETS */
2140 #endif /* DEBUGGING */
2142 This means we convert either the first branch or the first Exact,
2143 depending on whether the thing following (in 'last') is a branch
2144 or not and whther first is the startbranch (ie is it a sub part of
2145 the alternation or is it the whole thing.)
2146 Assuming its a sub part we convert the EXACT otherwise we convert
2147 the whole branch sequence, including the first.
2149 /* Find the node we are going to overwrite */
2150 if ( first != startbranch || OP( last ) == BRANCH ) {
2151 /* branch sub-chain */
2152 NEXT_OFF( first ) = (U16)(last - first);
2153 #ifdef RE_TRACK_PATTERN_OFFSETS
2155 mjd_offset= Node_Offset((convert));
2156 mjd_nodelen= Node_Length((convert));
2159 /* whole branch chain */
2161 #ifdef RE_TRACK_PATTERN_OFFSETS
2164 const regnode *nop = NEXTOPER( convert );
2165 mjd_offset= Node_Offset((nop));
2166 mjd_nodelen= Node_Length((nop));
2170 PerlIO_printf(Perl_debug_log, "%*sMJD offset:%"UVuf" MJD length:%"UVuf"\n",
2171 (int)depth * 2 + 2, "",
2172 (UV)mjd_offset, (UV)mjd_nodelen)
2175 /* But first we check to see if there is a common prefix we can
2176 split out as an EXACT and put in front of the TRIE node. */
2177 trie->startstate= 1;
2178 if ( trie->bitmap && !widecharmap && !trie->jump ) {
2180 for ( state = 1 ; state < trie->statecount-1 ; state++ ) {
2184 const U32 base = trie->states[ state ].trans.base;
2186 if ( trie->states[state].wordnum )
2189 for ( ofs = 0 ; ofs < trie->uniquecharcount ; ofs++ ) {
2190 if ( ( base + ofs >= trie->uniquecharcount ) &&
2191 ( base + ofs - trie->uniquecharcount < trie->lasttrans ) &&
2192 trie->trans[ base + ofs - trie->uniquecharcount ].check == state )
2194 if ( ++count > 1 ) {
2195 SV **tmp = av_fetch( revcharmap, ofs, 0);
2196 const U8 *ch = (U8*)SvPV_nolen_const( *tmp );
2197 if ( state == 1 ) break;
2199 Zero(trie->bitmap, ANYOF_BITMAP_SIZE, char);
2201 PerlIO_printf(Perl_debug_log,
2202 "%*sNew Start State=%"UVuf" Class: [",
2203 (int)depth * 2 + 2, "",
2206 SV ** const tmp = av_fetch( revcharmap, idx, 0);
2207 const U8 * const ch = (U8*)SvPV_nolen_const( *tmp );
2209 TRIE_BITMAP_SET(trie,*ch);
2211 TRIE_BITMAP_SET(trie, folder[ *ch ]);
2213 PerlIO_printf(Perl_debug_log, "%s", (char*)ch)
2217 TRIE_BITMAP_SET(trie,*ch);
2219 TRIE_BITMAP_SET(trie,folder[ *ch ]);
2220 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"%s", ch));
2226 SV **tmp = av_fetch( revcharmap, idx, 0);
2228 char *ch = SvPV( *tmp, len );
2230 SV *sv=sv_newmortal();
2231 PerlIO_printf( Perl_debug_log,
2232 "%*sPrefix State: %"UVuf" Idx:%"UVuf" Char='%s'\n",
2233 (int)depth * 2 + 2, "",
2235 pv_pretty(sv, SvPV_nolen_const(*tmp), SvCUR(*tmp), 6,
2236 PL_colors[0], PL_colors[1],
2237 (SvUTF8(*tmp) ? PERL_PV_ESCAPE_UNI : 0) |
2238 PERL_PV_ESCAPE_FIRSTCHAR
2243 OP( convert ) = nodetype;
2244 str=STRING(convert);
2247 STR_LEN(convert) += len;
2253 DEBUG_OPTIMISE_r(PerlIO_printf( Perl_debug_log,"]\n"));
2258 trie->prefixlen = (state-1);
2260 regnode *n = convert+NODE_SZ_STR(convert);
2261 NEXT_OFF(convert) = NODE_SZ_STR(convert);
2262 trie->startstate = state;
2263 trie->minlen -= (state - 1);
2264 trie->maxlen -= (state - 1);
2266 /* At least the UNICOS C compiler choked on this
2267 * being argument to DEBUG_r(), so let's just have
2270 #ifdef PERL_EXT_RE_BUILD
2276 regnode *fix = convert;
2277 U32 word = trie->wordcount;
2279 Set_Node_Offset_Length(convert, mjd_offset, state - 1);
2280 while( ++fix < n ) {
2281 Set_Node_Offset_Length(fix, 0, 0);
2284 SV ** const tmp = av_fetch( trie_words, word, 0 );
2286 if ( STR_LEN(convert) <= SvCUR(*tmp) )
2287 sv_chop(*tmp, SvPV_nolen(*tmp) + STR_LEN(convert));
2289 sv_chop(*tmp, SvPV_nolen(*tmp) + SvCUR(*tmp));
2297 NEXT_OFF(convert) = (U16)(tail - convert);
2298 DEBUG_r(optimize= n);
2304 if ( trie->maxlen ) {
2305 NEXT_OFF( convert ) = (U16)(tail - convert);
2306 ARG_SET( convert, data_slot );
2307 /* Store the offset to the first unabsorbed branch in
2308 jump[0], which is otherwise unused by the jump logic.
2309 We use this when dumping a trie and during optimisation. */
2311 trie->jump[0] = (U16)(nextbranch - convert);
2313 /* If the start state is not accepting (meaning there is no empty string/NOTHING)
2314 * and there is a bitmap
2315 * and the first "jump target" node we found leaves enough room
2316 * then convert the TRIE node into a TRIEC node, with the bitmap
2317 * embedded inline in the opcode - this is hypothetically faster.
2319 if ( !trie->states[trie->startstate].wordnum
2321 && ( (char *)jumper - (char *)convert) >= (int)sizeof(struct regnode_charclass) )
2323 OP( convert ) = TRIEC;
2324 Copy(trie->bitmap, ((struct regnode_charclass *)convert)->bitmap, ANYOF_BITMAP_SIZE, char);
2325 PerlMemShared_free(trie->bitmap);
2328 OP( convert ) = TRIE;
2330 /* store the type in the flags */
2331 convert->flags = nodetype;
2335 + regarglen[ OP( convert ) ];
2337 /* XXX We really should free up the resource in trie now,
2338 as we won't use them - (which resources?) dmq */
2340 /* needed for dumping*/
2341 DEBUG_r(if (optimize) {
2342 regnode *opt = convert;
2344 while ( ++opt < optimize) {
2345 Set_Node_Offset_Length(opt,0,0);
2348 Try to clean up some of the debris left after the
2351 while( optimize < jumper ) {
2352 mjd_nodelen += Node_Length((optimize));
2353 OP( optimize ) = OPTIMIZED;
2354 Set_Node_Offset_Length(optimize,0,0);
2357 Set_Node_Offset_Length(convert,mjd_offset,mjd_nodelen);
2359 } /* end node insert */
2361 /* Finish populating the prev field of the wordinfo array. Walk back
2362 * from each accept state until we find another accept state, and if
2363 * so, point the first word's .prev field at the second word. If the
2364 * second already has a .prev field set, stop now. This will be the
2365 * case either if we've already processed that word's accept state,
2366 * or that state had multiple words, and the overspill words were
2367 * already linked up earlier.
2374 for (word=1; word <= trie->wordcount; word++) {
2376 if (trie->wordinfo[word].prev)
2378 state = trie->wordinfo[word].accept;
2380 state = prev_states[state];
2383 prev = trie->states[state].wordnum;
2387 trie->wordinfo[word].prev = prev;
2389 Safefree(prev_states);
2393 /* and now dump out the compressed format */
2394 DEBUG_TRIE_COMPILE_r(dump_trie(trie, widecharmap, revcharmap, depth+1));
2396 RExC_rxi->data->data[ data_slot + 1 ] = (void*)widecharmap;
2398 RExC_rxi->data->data[ data_slot + TRIE_WORDS_OFFSET ] = (void*)trie_words;
2399 RExC_rxi->data->data[ data_slot + 3 ] = (void*)revcharmap;
2401 SvREFCNT_dec(revcharmap);
2405 : trie->startstate>1
2411 S_make_trie_failtable(pTHX_ RExC_state_t *pRExC_state, regnode *source, regnode *stclass, U32 depth)
2413 /* The Trie is constructed and compressed now so we can build a fail array if it's needed
2415 This is basically the Aho-Corasick algorithm. Its from exercise 3.31 and 3.32 in the
2416 "Red Dragon" -- Compilers, principles, techniques, and tools. Aho, Sethi, Ullman 1985/88
2419 We find the fail state for each state in the trie, this state is the longest proper
2420 suffix of the current state's 'word' that is also a proper prefix of another word in our
2421 trie. State 1 represents the word '' and is thus the default fail state. This allows
2422 the DFA not to have to restart after its tried and failed a word at a given point, it
2423 simply continues as though it had been matching the other word in the first place.
2425 'abcdgu'=~/abcdefg|cdgu/
2426 When we get to 'd' we are still matching the first word, we would encounter 'g' which would
2427 fail, which would bring us to the state representing 'd' in the second word where we would
2428 try 'g' and succeed, proceeding to match 'cdgu'.
2430 /* add a fail transition */
2431 const U32 trie_offset = ARG(source);
2432 reg_trie_data *trie=(reg_trie_data *)RExC_rxi->data->data[trie_offset];
2434 const U32 ucharcount = trie->uniquecharcount;
2435 const U32 numstates = trie->statecount;
2436 const U32 ubound = trie->lasttrans + ucharcount;
2440 U32 base = trie->states[ 1 ].trans.base;
2443 const U32 data_slot = add_data( pRExC_state, 1, "T" );
2444 GET_RE_DEBUG_FLAGS_DECL;
2446 PERL_ARGS_ASSERT_MAKE_TRIE_FAILTABLE;
2448 PERL_UNUSED_ARG(depth);
2452 ARG_SET( stclass, data_slot );
2453 aho = (reg_ac_data *) PerlMemShared_calloc( 1, sizeof(reg_ac_data) );
2454 RExC_rxi->data->data[ data_slot ] = (void*)aho;
2455 aho->trie=trie_offset;
2456 aho->states=(reg_trie_state *)PerlMemShared_malloc( numstates * sizeof(reg_trie_state) );
2457 Copy( trie->states, aho->states, numstates, reg_trie_state );
2458 Newxz( q, numstates, U32);
2459 aho->fail = (U32 *) PerlMemShared_calloc( numstates, sizeof(U32) );
2462 /* initialize fail[0..1] to be 1 so that we always have
2463 a valid final fail state */
2464 fail[ 0 ] = fail[ 1 ] = 1;
2466 for ( charid = 0; charid < ucharcount ; charid++ ) {
2467 const U32 newstate = TRIE_TRANS_STATE( 1, base, ucharcount, charid, 0 );
2469 q[ q_write ] = newstate;
2470 /* set to point at the root */
2471 fail[ q[ q_write++ ] ]=1;
2474 while ( q_read < q_write) {
2475 const U32 cur = q[ q_read++ % numstates ];
2476 base = trie->states[ cur ].trans.base;
2478 for ( charid = 0 ; charid < ucharcount ; charid++ ) {
2479 const U32 ch_state = TRIE_TRANS_STATE( cur, base, ucharcount, charid, 1 );
2481 U32 fail_state = cur;
2484 fail_state = fail[ fail_state ];
2485 fail_base = aho->states[ fail_state ].trans.base;
2486 } while ( !TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 ) );
2488 fail_state = TRIE_TRANS_STATE( fail_state, fail_base, ucharcount, charid, 1 );
2489 fail[ ch_state ] = fail_state;
2490 if ( !aho->states[ ch_state ].wordnum && aho->states[ fail_state ].wordnum )
2492 aho->states[ ch_state ].wordnum = aho->states[ fail_state ].wordnum;
2494 q[ q_write++ % numstates] = ch_state;
2498 /* restore fail[0..1] to 0 so that we "fall out" of the AC loop
2499 when we fail in state 1, this allows us to use the
2500 charclass scan to find a valid start char. This is based on the principle
2501 that theres a good chance the string being searched contains lots of stuff
2502 that cant be a start char.
2504 fail[ 0 ] = fail[ 1 ] = 0;
2505 DEBUG_TRIE_COMPILE_r({
2506 PerlIO_printf(Perl_debug_log,
2507 "%*sStclass Failtable (%"UVuf" states): 0",
2508 (int)(depth * 2), "", (UV)numstates
2510 for( q_read=1; q_read<numstates; q_read++ ) {
2511 PerlIO_printf(Perl_debug_log, ", %"UVuf, (UV)fail[q_read]);
2513 PerlIO_printf(Perl_debug_log, "\n");
2516 /*RExC_seen |= REG_SEEN_TRIEDFA;*/
2521 * There are strange code-generation bugs caused on sparc64 by gcc-2.95.2.
2522 * These need to be revisited when a newer toolchain becomes available.
2524 #if defined(__sparc64__) && defined(__GNUC__)
2525 # if __GNUC__ < 2 || (__GNUC__ == 2 && __GNUC_MINOR__ < 96)
2526 # undef SPARC64_GCC_WORKAROUND
2527 # define SPARC64_GCC_WORKAROUND 1
2531 #define DEBUG_PEEP(str,scan,depth) \
2532 DEBUG_OPTIMISE_r({if (scan){ \
2533 SV * const mysv=sv_newmortal(); \
2534 regnode *Next = regnext(scan); \
2535 regprop(RExC_rx, mysv, scan); \
2536 PerlIO_printf(Perl_debug_log, "%*s" str ">%3d: %s (%d)\n", \
2537 (int)depth*2, "", REG_NODE_NUM(scan), SvPV_nolen_const(mysv),\
2538 Next ? (REG_NODE_NUM(Next)) : 0 ); \
2542 /* The below joins as many adjacent EXACTish nodes as possible into a single
2543 * one, and looks for problematic sequences of characters whose folds vs.
2544 * non-folds have sufficiently different lengths, that the optimizer would be
2545 * fooled into rejecting legitimate matches of them, and the trie construction
2546 * code can't cope with them. The joining is only done if:
2547 * 1) there is room in the current conglomerated node to entirely contain the
2549 * 2) they are the exact same node type
2551 * The adjacent nodes actually may be separated by NOTHING kind nodes, and
2552 * these get optimized out
2554 * If there are problematic code sequences, *min_subtract is set to the delta
2555 * that the minimum size of the node can be less than its actual size. And,
2556 * the node type of the result is changed to reflect that it contains these
2559 * And *has_exactf_sharp_s is set to indicate whether or not the node is EXACTF
2560 * and contains LATIN SMALL LETTER SHARP S
2562 * This is as good a place as any to discuss the design of handling these
2563 * problematic sequences. It's been wrong in Perl for a very long time. There
2564 * are three code points in Unicode whose folded lengths differ so much from
2565 * the un-folded lengths that it causes problems for the optimizer and trie
2566 * construction. Why only these are problematic, and not others where lengths
2567 * also differ is something I (khw) do not understand. New versions of Unicode
2568 * might add more such code points. Hopefully the logic in fold_grind.t that
2569 * figures out what to test (in part by verifying that each size-combination
2570 * gets tested) will catch any that do come along, so they can be added to the
2571 * special handling below. The chances of new ones are actually rather small,
2572 * as most, if not all, of the world's scripts that have casefolding have
2573 * already been encoded by Unicode. Also, a number of Unicode's decisions were
2574 * made to allow compatibility with pre-existing standards, and almost all of
2575 * those have already been dealt with. These would otherwise be the most
2576 * likely candidates for generating further tricky sequences. In other words,
2577 * Unicode by itself is unlikely to add new ones unless it is for compatibility
2578 * with pre-existing standards, and there aren't many of those left.
2580 * The previous designs for dealing with these involved assigning a special
2581 * node for them. This approach doesn't work, as evidenced by this example:
2582 * "\xDFs" =~ /s\xDF/ui # Used to fail before these patches
2583 * Both these fold to "sss", but if the pattern is parsed to create a node of
2584 * that would match just the \xDF, it won't be able to handle the case where a
2585 * successful match would have to cross the node's boundary. The new approach
2586 * that hopefully generally solves the problem generates an EXACTFU_SS node
2589 * There are a number of components to the approach (a lot of work for just
2590 * three code points!):
2591 * 1) This routine examines each EXACTFish node that could contain the
2592 * problematic sequences. It returns in *min_subtract how much to
2593 * subtract from the the actual length of the string to get a real minimum
2594 * for one that could match it. This number is usually 0 except for the
2595 * problematic sequences. This delta is used by the caller to adjust the
2596 * min length of the match, and the delta between min and max, so that the
2597 * optimizer doesn't reject these possibilities based on size constraints.
2598 * 2) These sequences are not currently correctly handled by the trie code
2599 * either, so it changes the joined node type to ops that are not handled
2600 * by trie's, those new ops being EXACTFU_SS and EXACTFU_TRICKYFOLD.
2601 * 3) This is sufficient for the two Greek sequences (described below), but
2602 * the one involving the Sharp s (\xDF) needs more. The node type
2603 * EXACTFU_SS is used for an EXACTFU node that contains at least one "ss"
2604 * sequence in it. For non-UTF-8 patterns and strings, this is the only
2605 * case where there is a possible fold length change. That means that a
2606 * regular EXACTFU node without UTF-8 involvement doesn't have to concern
2607 * itself with length changes, and so can be processed faster. regexec.c
2608 * takes advantage of this. Generally, an EXACTFish node that is in UTF-8
2609 * is pre-folded by regcomp.c. This saves effort in regex matching.
2610 * However, probably mostly for historical reasons, the pre-folding isn't
2611 * done for non-UTF8 patterns (and it can't be for EXACTF and EXACTFL
2612 * nodes, as what they fold to isn't known until runtime.) The fold
2613 * possibilities for the non-UTF8 patterns are quite simple, except for
2614 * the sharp s. All the ones that don't involve a UTF-8 target string
2615 * are members of a fold-pair, and arrays are set up for all of them
2616 * that quickly find the other member of the pair. It might actually
2617 * be faster to pre-fold these, but it isn't currently done, except for
2618 * the sharp s. Code elsewhere in this file makes sure that it gets
2619 * folded to 'ss', even if the pattern isn't UTF-8. This avoids the
2620 * issues described in the next item.
2621 * 4) A problem remains for the sharp s in EXACTF nodes. Whether it matches
2622 * 'ss' or not is not knowable at compile time. It will match iff the
2623 * target string is in UTF-8, unlike the EXACTFU nodes, where it always
2624 * matches; and the EXACTFL and EXACTFA nodes where it never does. Thus
2625 * it can't be folded to "ss" at compile time, unlike EXACTFU does as
2626 * described in item 3). An assumption that the optimizer part of
2627 * regexec.c (probably unwittingly) makes is that a character in the
2628 * pattern corresponds to at most a single character in the target string.
2629 * (And I do mean character, and not byte here, unlike other parts of the
2630 * documentation that have never been updated to account for multibyte
2631 * Unicode.) This assumption is wrong only in this case, as all other
2632 * cases are either 1-1 folds when no UTF-8 is involved; or is true by
2633 * virtue of having this file pre-fold UTF-8 patterns. I'm
2634 * reluctant to try to change this assumption, so instead the code punts.
2635 * This routine examines EXACTF nodes for the sharp s, and returns a
2636 * boolean indicating whether or not the node is an EXACTF node that
2637 * contains a sharp s. When it is true, the caller sets a flag that later
2638 * causes the optimizer in this file to not set values for the floating
2639 * and fixed string lengths, and thus avoids the optimizer code in
2640 * regexec.c that makes the invalid assumption. Thus, there is no
2641 * optimization based on string lengths for EXACTF nodes that contain the
2642 * sharp s. This only happens for /id rules (which means the pattern
2646 #define JOIN_EXACT(scan,min_subtract,has_exactf_sharp_s, flags) \
2647 if (PL_regkind[OP(scan)] == EXACT) \
2648 join_exact(pRExC_state,(scan),(min_subtract),has_exactf_sharp_s, (flags),NULL,depth+1)
2651 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) {
2652 /* Merge several consecutive EXACTish nodes into one. */
2653 regnode *n = regnext(scan);
2655 regnode *next = scan + NODE_SZ_STR(scan);
2659 regnode *stop = scan;
2660 GET_RE_DEBUG_FLAGS_DECL;
2662 PERL_UNUSED_ARG(depth);
2665 PERL_ARGS_ASSERT_JOIN_EXACT;
2666 #ifndef EXPERIMENTAL_INPLACESCAN
2667 PERL_UNUSED_ARG(flags);
2668 PERL_UNUSED_ARG(val);
2670 DEBUG_PEEP("join",scan,depth);
2672 /* Look through the subsequent nodes in the chain. Skip NOTHING, merge
2673 * EXACT ones that are mergeable to the current one. */
2675 && (PL_regkind[OP(n)] == NOTHING
2676 || (stringok && OP(n) == OP(scan)))
2678 && NEXT_OFF(scan) + NEXT_OFF(n) < I16_MAX)
2681 if (OP(n) == TAIL || n > next)
2683 if (PL_regkind[OP(n)] == NOTHING) {
2684 DEBUG_PEEP("skip:",n,depth);
2685 NEXT_OFF(scan) += NEXT_OFF(n);
2686 next = n + NODE_STEP_REGNODE;
2693 else if (stringok) {
2694 const unsigned int oldl = STR_LEN(scan);
2695 regnode * const nnext = regnext(n);
2697 if (oldl + STR_LEN(n) > U8_MAX)
2700 DEBUG_PEEP("merg",n,depth);
2703 NEXT_OFF(scan) += NEXT_OFF(n);
2704 STR_LEN(scan) += STR_LEN(n);
2705 next = n + NODE_SZ_STR(n);
2706 /* Now we can overwrite *n : */
2707 Move(STRING(n), STRING(scan) + oldl, STR_LEN(n), char);
2715 #ifdef EXPERIMENTAL_INPLACESCAN
2716 if (flags && !NEXT_OFF(n)) {
2717 DEBUG_PEEP("atch", val, depth);
2718 if (reg_off_by_arg[OP(n)]) {
2719 ARG_SET(n, val - n);
2722 NEXT_OFF(n) = val - n;
2730 *has_exactf_sharp_s = FALSE;
2732 /* Here, all the adjacent mergeable EXACTish nodes have been merged. We
2733 * can now analyze for sequences of problematic code points. (Prior to
2734 * this final joining, sequences could have been split over boundaries, and
2735 * hence missed). The sequences only happen in folding, hence for any
2736 * non-EXACT EXACTish node */
2737 if (OP(scan) != EXACT) {
2739 U8 * s0 = (U8*) STRING(scan);
2740 U8 * const s_end = s0 + STR_LEN(scan);
2742 /* The below is perhaps overboard, but this allows us to save a test
2743 * each time through the loop at the expense of a mask. This is
2744 * because on both EBCDIC and ASCII machines, 'S' and 's' differ by a
2745 * single bit. On ASCII they are 32 apart; on EBCDIC, they are 64.
2746 * This uses an exclusive 'or' to find that bit and then inverts it to
2747 * form a mask, with just a single 0, in the bit position where 'S' and
2749 const U8 S_or_s_mask = (U8) ~ ('S' ^ 's');
2750 const U8 s_masked = 's' & S_or_s_mask;
2752 /* One pass is made over the node's string looking for all the
2753 * possibilities. to avoid some tests in the loop, there are two main
2754 * cases, for UTF-8 patterns (which can't have EXACTF nodes) and
2758 /* There are two problematic Greek code points in Unicode
2761 * U+0390 - GREEK SMALL LETTER IOTA WITH DIALYTIKA AND TONOS
2762 * U+03B0 - GREEK SMALL LETTER UPSILON WITH DIALYTIKA AND TONOS
2768 * U+03B9 U+0308 U+0301 0xCE 0xB9 0xCC 0x88 0xCC 0x81
2769 * U+03C5 U+0308 U+0301 0xCF 0x85 0xCC 0x88 0xCC 0x81
2771 * This means that in case-insensitive matching (or "loose
2772 * matching", as Unicode calls it), an EXACTF of length six (the
2773 * UTF-8 encoded byte length of the above casefolded versions) can
2774 * match a target string of length two (the byte length of UTF-8
2775 * encoded U+0390 or U+03B0). This would rather mess up the
2776 * minimum length computation. (there are other code points that
2777 * also fold to these two sequences, but the delta is smaller)
2779 * If these sequences are found, the minimum length is decreased by
2780 * four (six minus two).
2782 * Similarly, 'ss' may match the single char and byte LATIN SMALL
2783 * LETTER SHARP S. We decrease the min length by 1 for each
2784 * occurrence of 'ss' found */
2786 #ifdef EBCDIC /* RD tunifold greek 0390 and 03B0 */
2787 # define U390_first_byte 0xb4
2788 const U8 U390_tail[] = "\x68\xaf\x49\xaf\x42";
2789 # define U3B0_first_byte 0xb5
2790 const U8 U3B0_tail[] = "\x46\xaf\x49\xaf\x42";
2792 # define U390_first_byte 0xce
2793 const U8 U390_tail[] = "\xb9\xcc\x88\xcc\x81";
2794 # define U3B0_first_byte 0xcf
2795 const U8 U3B0_tail[] = "\x85\xcc\x88\xcc\x81";
2797 const U8 len = sizeof(U390_tail); /* (-1 for NUL; +1 for 1st byte;
2798 yields a net of 0 */
2799 /* Examine the string for one of the problematic sequences */
2801 s < s_end - 1; /* Can stop 1 before the end, as minimum length
2802 * sequence we are looking for is 2 */
2806 /* Look for the first byte in each problematic sequence */
2808 /* We don't have to worry about other things that fold to
2809 * 's' (such as the long s, U+017F), as all above-latin1
2810 * code points have been pre-folded */
2814 /* Current character is an 's' or 'S'. If next one is
2815 * as well, we have the dreaded sequence */
2816 if (((*(s+1) & S_or_s_mask) == s_masked)
2817 /* These two node types don't have special handling
2819 && OP(scan) != EXACTFL && OP(scan) != EXACTFA)
2822 OP(scan) = EXACTFU_SS;
2823 s++; /* No need to look at this character again */
2827 case U390_first_byte:
2828 if (s_end - s >= len
2830 /* The 1's are because are skipping comparing the
2832 && memEQ(s + 1, U390_tail, len - 1))
2834 goto greek_sequence;
2838 case U3B0_first_byte:
2839 if (! (s_end - s >= len
2840 && memEQ(s + 1, U3B0_tail, len - 1)))
2847 /* This can't currently be handled by trie's, so change
2848 * the node type to indicate this. If EXACTFA and
2849 * EXACTFL were ever to be handled by trie's, this
2850 * would have to be changed. If this node has already
2851 * been changed to EXACTFU_SS in this loop, leave it as
2852 * is. (I (khw) think it doesn't matter in regexec.c
2853 * for UTF patterns, but no need to change it */
2854 if (OP(scan) == EXACTFU) {
2855 OP(scan) = EXACTFU_TRICKYFOLD;
2857 s += 6; /* We already know what this sequence is. Skip
2863 else if (OP(scan) != EXACTFL && OP(scan) != EXACTFA) {
2865 /* Here, the pattern is not UTF-8. We need to look only for the
2866 * 'ss' sequence, and in the EXACTF case, the sharp s, which can be
2867 * in the final position. Otherwise we can stop looking 1 byte
2868 * earlier because have to find both the first and second 's' */
2869 const U8* upper = (OP(scan) == EXACTF) ? s_end : s_end -1;
2871 for (s = s0; s < upper; s++) {
2876 && ((*(s+1) & S_or_s_mask) == s_masked))
2880 /* EXACTF nodes need to know that the minimum
2881 * length changed so that a sharp s in the string
2882 * can match this ss in the pattern, but they
2883 * remain EXACTF nodes, as they are not trie'able,
2884 * so don't have to invent a new node type to
2885 * exclude them from the trie code */
2886 if (OP(scan) != EXACTF) {
2887 OP(scan) = EXACTFU_SS;
2892 case LATIN_SMALL_LETTER_SHARP_S:
2893 if (OP(scan) == EXACTF) {
2894 *has_exactf_sharp_s = TRUE;
2903 /* Allow dumping but overwriting the collection of skipped
2904 * ops and/or strings with fake optimized ops */
2905 n = scan + NODE_SZ_STR(scan);
2913 DEBUG_OPTIMISE_r(if (merged){DEBUG_PEEP("finl",scan,depth)});
2917 /* REx optimizer. Converts nodes into quicker variants "in place".
2918 Finds fixed substrings. */
2920 /* Stops at toplevel WHILEM as well as at "last". At end *scanp is set
2921 to the position after last scanned or to NULL. */
2923 #define INIT_AND_WITHP \
2924 assert(!and_withp); \
2925 Newx(and_withp,1,struct regnode_charclass_class); \
2926 SAVEFREEPV(and_withp)
2928 /* this is a chain of data about sub patterns we are processing that
2929 need to be handled separately/specially in study_chunk. Its so
2930 we can simulate recursion without losing state. */
2932 typedef struct scan_frame {
2933 regnode *last; /* last node to process in this frame */
2934 regnode *next; /* next node to process when last is reached */
2935 struct scan_frame *prev; /*previous frame*/
2936 I32 stop; /* what stopparen do we use */
2940 #define SCAN_COMMIT(s, data, m) scan_commit(s, data, m, is_inf)
2942 #define CASE_SYNST_FNC(nAmE) \
2944 if (flags & SCF_DO_STCLASS_AND) { \
2945 for (value = 0; value < 256; value++) \
2946 if (!is_ ## nAmE ## _cp(value)) \
2947 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2950 for (value = 0; value < 256; value++) \
2951 if (is_ ## nAmE ## _cp(value)) \
2952 ANYOF_BITMAP_SET(data->start_class, value); \
2956 if (flags & SCF_DO_STCLASS_AND) { \
2957 for (value = 0; value < 256; value++) \
2958 if (is_ ## nAmE ## _cp(value)) \
2959 ANYOF_BITMAP_CLEAR(data->start_class, value); \
2962 for (value = 0; value < 256; value++) \
2963 if (!is_ ## nAmE ## _cp(value)) \
2964 ANYOF_BITMAP_SET(data->start_class, value); \
2971 S_study_chunk(pTHX_ RExC_state_t *pRExC_state, regnode **scanp,
2972 I32 *minlenp, I32 *deltap,
2977 struct regnode_charclass_class *and_withp,
2978 U32 flags, U32 depth)
2979 /* scanp: Start here (read-write). */
2980 /* deltap: Write maxlen-minlen here. */
2981 /* last: Stop before this one. */
2982 /* data: string data about the pattern */
2983 /* stopparen: treat close N as END */
2984 /* recursed: which subroutines have we recursed into */
2985 /* and_withp: Valid if flags & SCF_DO_STCLASS_OR */
2988 I32 min = 0, pars = 0, code;
2989 regnode *scan = *scanp, *next;
2991 int is_inf = (flags & SCF_DO_SUBSTR) && (data->flags & SF_IS_INF);
2992 int is_inf_internal = 0; /* The studied chunk is infinite */
2993 I32 is_par = OP(scan) == OPEN ? ARG(scan) : 0;
2994 scan_data_t data_fake;
2995 SV *re_trie_maxbuff = NULL;
2996 regnode *first_non_open = scan;
2997 I32 stopmin = I32_MAX;
2998 scan_frame *frame = NULL;
2999 GET_RE_DEBUG_FLAGS_DECL;
3001 PERL_ARGS_ASSERT_STUDY_CHUNK;
3004 StructCopy(&zero_scan_data, &data_fake, scan_data_t);
3008 while (first_non_open && OP(first_non_open) == OPEN)
3009 first_non_open=regnext(first_non_open);
3014 while ( scan && OP(scan) != END && scan < last ){
3015 UV min_subtract = 0; /* How much to subtract from the minimum node
3016 length to get a real minimum (because the
3017 folded version may be shorter) */
3018 bool has_exactf_sharp_s = FALSE;
3019 /* Peephole optimizer: */
3020 DEBUG_STUDYDATA("Peep:", data,depth);
3021 DEBUG_PEEP("Peep",scan,depth);
3023 /* Its not clear to khw or hv why this is done here, and not in the
3024 * clauses that deal with EXACT nodes. khw's guess is that it's
3025 * because of a previous design */
3026 JOIN_EXACT(scan,&min_subtract, &has_exactf_sharp_s, 0);
3028 /* Follow the next-chain of the current node and optimize
3029 away all the NOTHINGs from it. */
3030 if (OP(scan) != CURLYX) {
3031 const int max = (reg_off_by_arg[OP(scan)]
3033 /* I32 may be smaller than U16 on CRAYs! */
3034 : (I32_MAX < U16_MAX ? I32_MAX : U16_MAX));
3035 int off = (reg_off_by_arg[OP(scan)] ? ARG(scan) : NEXT_OFF(scan));
3039 /* Skip NOTHING and LONGJMP. */
3040 while ((n = regnext(n))
3041 && ((PL_regkind[OP(n)] == NOTHING && (noff = NEXT_OFF(n)))
3042 || ((OP(n) == LONGJMP) && (noff = ARG(n))))
3043 && off + noff < max)
3045 if (reg_off_by_arg[OP(scan)])
3048 NEXT_OFF(scan) = off;
3053 /* The principal pseudo-switch. Cannot be a switch, since we
3054 look into several different things. */
3055 if (OP(scan) == BRANCH || OP(scan) == BRANCHJ
3056 || OP(scan) == IFTHEN) {
3057 next = regnext(scan);
3059 /* demq: the op(next)==code check is to see if we have "branch-branch" AFAICT */
3061 if (OP(next) == code || code == IFTHEN) {
3062 /* NOTE - There is similar code to this block below for handling
3063 TRIE nodes on a re-study. If you change stuff here check there
3065 I32 max1 = 0, min1 = I32_MAX, num = 0;
3066 struct regnode_charclass_class accum;
3067 regnode * const startbranch=scan;
3069 if (flags & SCF_DO_SUBSTR)
3070 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot merge strings after this. */
3071 if (flags & SCF_DO_STCLASS)
3072 cl_init_zero(pRExC_state, &accum);
3074 while (OP(scan) == code) {
3075 I32 deltanext, minnext, f = 0, fake;
3076 struct regnode_charclass_class this_class;
3079 data_fake.flags = 0;
3081 data_fake.whilem_c = data->whilem_c;
3082 data_fake.last_closep = data->last_closep;
3085 data_fake.last_closep = &fake;
3087 data_fake.pos_delta = delta;
3088 next = regnext(scan);
3089 scan = NEXTOPER(scan);
3091 scan = NEXTOPER(scan);
3092 if (flags & SCF_DO_STCLASS) {
3093 cl_init(pRExC_state, &this_class);
3094 data_fake.start_class = &this_class;
3095 f = SCF_DO_STCLASS_AND;
3097 if (flags & SCF_WHILEM_VISITED_POS)
3098 f |= SCF_WHILEM_VISITED_POS;
3100 /* we suppose the run is continuous, last=next...*/
3101 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3103 stopparen, recursed, NULL, f,depth+1);
3106 if (max1 < minnext + deltanext)
3107 max1 = minnext + deltanext;
3108 if (deltanext == I32_MAX)
3109 is_inf = is_inf_internal = 1;
3111 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
3113 if (data_fake.flags & SCF_SEEN_ACCEPT) {
3114 if ( stopmin > minnext)
3115 stopmin = min + min1;
3116 flags &= ~SCF_DO_SUBSTR;
3118 data->flags |= SCF_SEEN_ACCEPT;
3121 if (data_fake.flags & SF_HAS_EVAL)
3122 data->flags |= SF_HAS_EVAL;
3123 data->whilem_c = data_fake.whilem_c;
3125 if (flags & SCF_DO_STCLASS)
3126 cl_or(pRExC_state, &accum, &this_class);
3128 if (code == IFTHEN && num < 2) /* Empty ELSE branch */
3130 if (flags & SCF_DO_SUBSTR) {
3131 data->pos_min += min1;
3132 data->pos_delta += max1 - min1;
3133 if (max1 != min1 || is_inf)
3134 data->longest = &(data->longest_float);
3137 delta += max1 - min1;
3138 if (flags & SCF_DO_STCLASS_OR) {
3139 cl_or(pRExC_state, data->start_class, &accum);
3141 cl_and(data->start_class, and_withp);
3142 flags &= ~SCF_DO_STCLASS;
3145 else if (flags & SCF_DO_STCLASS_AND) {
3147 cl_and(data->start_class, &accum);
3148 flags &= ~SCF_DO_STCLASS;
3151 /* Switch to OR mode: cache the old value of
3152 * data->start_class */
3154 StructCopy(data->start_class, and_withp,
3155 struct regnode_charclass_class);
3156 flags &= ~SCF_DO_STCLASS_AND;
3157 StructCopy(&accum, data->start_class,
3158 struct regnode_charclass_class);
3159 flags |= SCF_DO_STCLASS_OR;
3160 data->start_class->flags |= ANYOF_EOS;
3164 if (PERL_ENABLE_TRIE_OPTIMISATION && OP( startbranch ) == BRANCH ) {
3167 Assuming this was/is a branch we are dealing with: 'scan' now
3168 points at the item that follows the branch sequence, whatever
3169 it is. We now start at the beginning of the sequence and look
3176 which would be constructed from a pattern like /A|LIST|OF|WORDS/
3178 If we can find such a subsequence we need to turn the first
3179 element into a trie and then add the subsequent branch exact
3180 strings to the trie.
3184 1. patterns where the whole set of branches can be converted.
3186 2. patterns where only a subset can be converted.
3188 In case 1 we can replace the whole set with a single regop
3189 for the trie. In case 2 we need to keep the start and end
3192 'BRANCH EXACT; BRANCH EXACT; BRANCH X'
3193 becomes BRANCH TRIE; BRANCH X;
3195 There is an additional case, that being where there is a
3196 common prefix, which gets split out into an EXACT like node
3197 preceding the TRIE node.
3199 If x(1..n)==tail then we can do a simple trie, if not we make
3200 a "jump" trie, such that when we match the appropriate word
3201 we "jump" to the appropriate tail node. Essentially we turn
3202 a nested if into a case structure of sorts.
3207 if (!re_trie_maxbuff) {
3208 re_trie_maxbuff = get_sv(RE_TRIE_MAXBUF_NAME, 1);
3209 if (!SvIOK(re_trie_maxbuff))
3210 sv_setiv(re_trie_maxbuff, RE_TRIE_MAXBUF_INIT);
3212 if ( SvIV(re_trie_maxbuff)>=0 ) {
3214 regnode *first = (regnode *)NULL;
3215 regnode *last = (regnode *)NULL;
3216 regnode *tail = scan;
3221 SV * const mysv = sv_newmortal(); /* for dumping */
3223 /* var tail is used because there may be a TAIL
3224 regop in the way. Ie, the exacts will point to the
3225 thing following the TAIL, but the last branch will
3226 point at the TAIL. So we advance tail. If we
3227 have nested (?:) we may have to move through several
3231 while ( OP( tail ) == TAIL ) {
3232 /* this is the TAIL generated by (?:) */
3233 tail = regnext( tail );
3238 regprop(RExC_rx, mysv, tail );
3239 PerlIO_printf( Perl_debug_log, "%*s%s%s\n",
3240 (int)depth * 2 + 2, "",
3241 "Looking for TRIE'able sequences. Tail node is: ",
3242 SvPV_nolen_const( mysv )
3248 Step through the branches
3249 cur represents each branch,
3250 noper is the first thing to be matched as part of that branch
3251 noper_next is the regnext() of that node.
3253 We normally handle a case like this /FOO[xyz]|BAR[pqr]/
3254 via a "jump trie" but we also support building with NOJUMPTRIE,
3255 which restricts the trie logic to structures like /FOO|BAR/.
3257 If noper is a trieable nodetype then the branch is a possible optimization
3258 target. If we are building under NOJUMPTRIE then we require that noper_next
3259 is the same as scan (our current position in the regex program).
3261 Once we have two or more consecutive such branches we can create a
3262 trie of the EXACT's contents and stitch it in place into the program.
3264 If the sequence represents all of the branches in the alternation we
3265 replace the entire thing with a single TRIE node.
3267 Otherwise when it is a subsequence we need to stitch it in place and
3268 replace only the relevant branches. This means the first branch has
3269 to remain as it is used by the alternation logic, and its next pointer,
3270 and needs to be repointed at the item on the branch chain following
3271 the last branch we have optimized away.
3273 This could be either a BRANCH, in which case the subsequence is internal,
3274 or it could be the item following the branch sequence in which case the
3275 subsequence is at the end (which does not necessarily mean the first node
3276 is the start of the alternation).
3278 TRIE_TYPE(X) is a define which maps the optype to a trietype.
3281 ----------------+-----------
3285 EXACTFU_SS | EXACTFU
3286 EXACTFU_TRICKYFOLD | EXACTFU
3291 #define TRIE_TYPE(X) ( ( NOTHING == (X) ) ? NOTHING : \
3292 ( EXACT == (X) ) ? EXACT : \
3293 ( EXACTFU == (X) || EXACTFU_SS == (X) || EXACTFU_TRICKYFOLD == (X) ) ? EXACTFU : \
3296 /* dont use tail as the end marker for this traverse */
3297 for ( cur = startbranch ; cur != scan ; cur = regnext( cur ) ) {
3298 regnode * const noper = NEXTOPER( cur );
3299 U8 noper_type = OP( noper );
3300 U8 noper_trietype = TRIE_TYPE( noper_type );
3301 #if defined(DEBUGGING) || defined(NOJUMPTRIE)
3302 regnode * const noper_next = regnext( noper );
3306 regprop(RExC_rx, mysv, cur);
3307 PerlIO_printf( Perl_debug_log, "%*s- %s (%d)",
3308 (int)depth * 2 + 2,"", SvPV_nolen_const( mysv ), REG_NODE_NUM(cur) );
3310 regprop(RExC_rx, mysv, noper);
3311 PerlIO_printf( Perl_debug_log, " -> %s",
3312 SvPV_nolen_const(mysv));
3315 regprop(RExC_rx, mysv, noper_next );
3316 PerlIO_printf( Perl_debug_log,"\t=> %s\t",
3317 SvPV_nolen_const(mysv));
3319 PerlIO_printf( Perl_debug_log, "(First==%d,Last==%d,Cur==%d)\n",
3320 REG_NODE_NUM(first), REG_NODE_NUM(last), REG_NODE_NUM(cur) );
3323 /* Is noper a trieable nodetype that can be merged with the
3324 * current trie (if there is one)? */
3328 /* XXX: Currently we cannot allow a NOTHING node to be the first element
3329 * of a TRIEABLE sequence, Otherwise we will overwrite the regop following
3330 * the NOTHING with the TRIE regop later on. This is because a NOTHING node
3331 * is only one regnode wide, and a TRIE is two regnodes. An example of a
3332 * problematic pattern is: "x" =~ /\A(?>(?:(?:)A|B|C?x))\z/
3333 * At a later point of time we can somewhat workaround this by handling
3334 * NOTHING -> EXACT sequences as generated by /(?:)A|(?:)B/ type patterns,
3335 * as we can effectively ignore the NOTHING regop in that case.
3336 * This clause, which allows NOTHING to start a sequence is left commented
3337 * out as a reference.
3340 ( noper_trietype == NOTHING)
3341 || ( trietype == NOTHING )
3343 ( noper_trietype == NOTHING && trietype )
3344 || ( trietype == noper_trietype )
3347 && noper_next == tail
3351 /* Handle mergable triable node
3352 * Either we are the first node in a new trieable sequence,
3353 * in which case we do some bookkeeping, otherwise we update
3354 * the end pointer. */
3358 trietype = noper_trietype;
3360 if ( trietype == NOTHING )
3361 trietype = noper_trietype;
3364 } /* end handle mergable triable node */
3366 /* handle unmergable node -
3367 * noper may either be a triable node which can not be tried
3368 * together with the current trie, or a non triable node */
3370 /* If last is set and trietype is not NOTHING then we have found
3371 * at least two triable branch sequences in a row of a similar
3372 * trietype so we can turn them into a trie. If/when we
3373 * allow NOTHING to start a trie sequence this condition will be
3374 * required, and it isn't expensive so we leave it in for now. */
3375 if ( trietype != NOTHING )
3376 make_trie( pRExC_state,
3377 startbranch, first, cur, tail, count,
3378 trietype, depth+1 );
3379 last = NULL; /* note: we clear/update first, trietype etc below, so we dont do it here */
3383 && noper_next == tail
3386 /* noper is triable, so we can start a new trie sequence */
3389 trietype = noper_trietype;
3391 /* if we already saw a first but the current node is not triable then we have
3392 * to reset the first information. */
3397 } /* end handle unmergable node */
3398 } /* loop over branches */
3400 regprop(RExC_rx, mysv, cur);
3401 PerlIO_printf( Perl_debug_log,
3402 "%*s- %s (%d) <SCAN FINISHED>\n", (int)depth * 2 + 2,
3403 "", SvPV_nolen_const( mysv ),REG_NODE_NUM(cur));
3406 if ( last && trietype != NOTHING ) {
3407 /* the last branch of the sequence was part of a trie,
3408 * so we have to construct it here outside of the loop
3410 made= make_trie( pRExC_state, startbranch, first, scan, tail, count, trietype, depth+1 );
3411 #ifdef TRIE_STUDY_OPT
3412 if ( ((made == MADE_EXACT_TRIE &&
3413 startbranch == first)
3414 || ( first_non_open == first )) &&
3416 flags |= SCF_TRIE_RESTUDY;
3417 if ( startbranch == first
3420 RExC_seen &=~REG_TOP_LEVEL_BRANCHES;
3424 } /* end if ( last) */
3425 } /* TRIE_MAXBUF is non zero */
3430 else if ( code == BRANCHJ ) { /* single branch is optimized. */
3431 scan = NEXTOPER(NEXTOPER(scan));
3432 } else /* single branch is optimized. */
3433 scan = NEXTOPER(scan);
3435 } else if (OP(scan) == SUSPEND || OP(scan) == GOSUB || OP(scan) == GOSTART) {
3436 scan_frame *newframe = NULL;
3441 if (OP(scan) != SUSPEND) {
3442 /* set the pointer */
3443 if (OP(scan) == GOSUB) {
3445 RExC_recurse[ARG2L(scan)] = scan;
3446 start = RExC_open_parens[paren-1];
3447 end = RExC_close_parens[paren-1];
3450 start = RExC_rxi->program + 1;
3454 Newxz(recursed, (((RExC_npar)>>3) +1), U8);
3455 SAVEFREEPV(recursed);
3457 if (!PAREN_TEST(recursed,paren+1)) {
3458 PAREN_SET(recursed,paren+1);
3459 Newx(newframe,1,scan_frame);
3461 if (flags & SCF_DO_SUBSTR) {
3462 SCAN_COMMIT(pRExC_state,data,minlenp);
3463 data->longest = &(data->longest_float);
3465 is_inf = is_inf_internal = 1;
3466 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
3467 cl_anything(pRExC_state, data->start_class);
3468 flags &= ~SCF_DO_STCLASS;
3471 Newx(newframe,1,scan_frame);
3474 end = regnext(scan);
3479 SAVEFREEPV(newframe);
3480 newframe->next = regnext(scan);
3481 newframe->last = last;
3482 newframe->stop = stopparen;
3483 newframe->prev = frame;
3493 else if (OP(scan) == EXACT) {
3494 I32 l = STR_LEN(scan);
3497 const U8 * const s = (U8*)STRING(scan);
3498 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3499 l = utf8_length(s, s + l);
3501 uc = *((U8*)STRING(scan));
3504 if (flags & SCF_DO_SUBSTR) { /* Update longest substr. */
3505 /* The code below prefers earlier match for fixed
3506 offset, later match for variable offset. */
3507 if (data->last_end == -1) { /* Update the start info. */
3508 data->last_start_min = data->pos_min;
3509 data->last_start_max = is_inf
3510 ? I32_MAX : data->pos_min + data->pos_delta;
3512 sv_catpvn(data->last_found, STRING(scan), STR_LEN(scan));
3514 SvUTF8_on(data->last_found);
3516 SV * const sv = data->last_found;
3517 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
3518 mg_find(sv, PERL_MAGIC_utf8) : NULL;
3519 if (mg && mg->mg_len >= 0)
3520 mg->mg_len += utf8_length((U8*)STRING(scan),
3521 (U8*)STRING(scan)+STR_LEN(scan));
3523 data->last_end = data->pos_min + l;
3524 data->pos_min += l; /* As in the first entry. */
3525 data->flags &= ~SF_BEFORE_EOL;
3527 if (flags & SCF_DO_STCLASS_AND) {
3528 /* Check whether it is compatible with what we know already! */
3532 /* If compatible, we or it in below. It is compatible if is
3533 * in the bitmp and either 1) its bit or its fold is set, or 2)
3534 * it's for a locale. Even if there isn't unicode semantics
3535 * here, at runtime there may be because of matching against a
3536 * utf8 string, so accept a possible false positive for
3537 * latin1-range folds */
3539 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3540 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3541 && (!(data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD)
3542 || !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3547 ANYOF_CLASS_ZERO(data->start_class);
3548 ANYOF_BITMAP_ZERO(data->start_class);
3550 ANYOF_BITMAP_SET(data->start_class, uc);
3551 else if (uc >= 0x100) {
3554 /* Some Unicode code points fold to the Latin1 range; as
3555 * XXX temporary code, instead of figuring out if this is
3556 * one, just assume it is and set all the start class bits
3557 * that could be some such above 255 code point's fold
3558 * which will generate fals positives. As the code
3559 * elsewhere that does compute the fold settles down, it
3560 * can be extracted out and re-used here */
3561 for (i = 0; i < 256; i++){
3562 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3563 ANYOF_BITMAP_SET(data->start_class, i);
3567 data->start_class->flags &= ~ANYOF_EOS;
3569 data->start_class->flags &= ~ANYOF_UNICODE_ALL;
3571 else if (flags & SCF_DO_STCLASS_OR) {
3572 /* false positive possible if the class is case-folded */
3574 ANYOF_BITMAP_SET(data->start_class, uc);
3576 data->start_class->flags |= ANYOF_UNICODE_ALL;
3577 data->start_class->flags &= ~ANYOF_EOS;
3578 cl_and(data->start_class, and_withp);
3580 flags &= ~SCF_DO_STCLASS;
3582 else if (PL_regkind[OP(scan)] == EXACT) { /* But OP != EXACT! */
3583 I32 l = STR_LEN(scan);
3584 UV uc = *((U8*)STRING(scan));
3586 /* Search for fixed substrings supports EXACT only. */
3587 if (flags & SCF_DO_SUBSTR) {
3589 SCAN_COMMIT(pRExC_state, data, minlenp);
3592 const U8 * const s = (U8 *)STRING(scan);
3593 uc = utf8_to_uvchr_buf(s, s + l, NULL);
3594 l = utf8_length(s, s + l);
3596 else if (has_exactf_sharp_s) {
3597 RExC_seen |= REG_SEEN_EXACTF_SHARP_S;
3599 min += l - min_subtract;
3603 delta += min_subtract;
3604 if (flags & SCF_DO_SUBSTR) {
3605 data->pos_min += l - min_subtract;
3606 if (data->pos_min < 0) {
3609 data->pos_delta += min_subtract;
3611 data->longest = &(data->longest_float);
3614 if (flags & SCF_DO_STCLASS_AND) {
3615 /* Check whether it is compatible with what we know already! */
3618 (!(data->start_class->flags & (ANYOF_CLASS | ANYOF_LOCALE))
3619 && !ANYOF_BITMAP_TEST(data->start_class, uc)
3620 && !ANYOF_BITMAP_TEST(data->start_class, PL_fold_latin1[uc])))
3624 ANYOF_CLASS_ZERO(data->start_class);
3625 ANYOF_BITMAP_ZERO(data->start_class);
3627 ANYOF_BITMAP_SET(data->start_class, uc);
3628 data->start_class->flags &= ~ANYOF_EOS;
3629 data->start_class->flags |= ANYOF_LOC_NONBITMAP_FOLD;
3630 if (OP(scan) == EXACTFL) {
3631 /* XXX This set is probably no longer necessary, and
3632 * probably wrong as LOCALE now is on in the initial
3634 data->start_class->flags |= ANYOF_LOCALE;
3638 /* Also set the other member of the fold pair. In case
3639 * that unicode semantics is called for at runtime, use
3640 * the full latin1 fold. (Can't do this for locale,
3641 * because not known until runtime) */
3642 ANYOF_BITMAP_SET(data->start_class, PL_fold_latin1[uc]);
3644 /* All other (EXACTFL handled above) folds except under
3645 * /iaa that include s, S, and sharp_s also may include
3647 if (OP(scan) != EXACTFA) {
3648 if (uc == 's' || uc == 'S') {
3649 ANYOF_BITMAP_SET(data->start_class,
3650 LATIN_SMALL_LETTER_SHARP_S);
3652 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3653 ANYOF_BITMAP_SET(data->start_class, 's');
3654 ANYOF_BITMAP_SET(data->start_class, 'S');
3659 else if (uc >= 0x100) {
3661 for (i = 0; i < 256; i++){
3662 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(i)) {
3663 ANYOF_BITMAP_SET(data->start_class, i);
3668 else if (flags & SCF_DO_STCLASS_OR) {
3669 if (data->start_class->flags & ANYOF_LOC_NONBITMAP_FOLD) {
3670 /* false positive possible if the class is case-folded.
3671 Assume that the locale settings are the same... */
3673 ANYOF_BITMAP_SET(data->start_class, uc);
3674 if (OP(scan) != EXACTFL) {
3676 /* And set the other member of the fold pair, but
3677 * can't do that in locale because not known until
3679 ANYOF_BITMAP_SET(data->start_class,
3680 PL_fold_latin1[uc]);
3682 /* All folds except under /iaa that include s, S,
3683 * and sharp_s also may include the others */
3684 if (OP(scan) != EXACTFA) {
3685 if (uc == 's' || uc == 'S') {
3686 ANYOF_BITMAP_SET(data->start_class,
3687 LATIN_SMALL_LETTER_SHARP_S);
3689 else if (uc == LATIN_SMALL_LETTER_SHARP_S) {
3690 ANYOF_BITMAP_SET(data->start_class, 's');
3691 ANYOF_BITMAP_SET(data->start_class, 'S');
3696 data->start_class->flags &= ~ANYOF_EOS;
3698 cl_and(data->start_class, and_withp);
3700 flags &= ~SCF_DO_STCLASS;
3702 else if (REGNODE_VARIES(OP(scan))) {
3703 I32 mincount, maxcount, minnext, deltanext, fl = 0;
3704 I32 f = flags, pos_before = 0;
3705 regnode * const oscan = scan;
3706 struct regnode_charclass_class this_class;
3707 struct regnode_charclass_class *oclass = NULL;
3708 I32 next_is_eval = 0;
3710 switch (PL_regkind[OP(scan)]) {
3711 case WHILEM: /* End of (?:...)* . */
3712 scan = NEXTOPER(scan);
3715 if (flags & (SCF_DO_SUBSTR | SCF_DO_STCLASS)) {
3716 next = NEXTOPER(scan);
3717 if (OP(next) == EXACT || (flags & SCF_DO_STCLASS)) {
3719 maxcount = REG_INFTY;
3720 next = regnext(scan);
3721 scan = NEXTOPER(scan);
3725 if (flags & SCF_DO_SUBSTR)
3730 if (flags & SCF_DO_STCLASS) {
3732 maxcount = REG_INFTY;
3733 next = regnext(scan);
3734 scan = NEXTOPER(scan);
3737 is_inf = is_inf_internal = 1;
3738 scan = regnext(scan);
3739 if (flags & SCF_DO_SUBSTR) {
3740 SCAN_COMMIT(pRExC_state, data, minlenp); /* Cannot extend fixed substrings */
3741 data->longest = &(data->longest_float);
3743 goto optimize_curly_tail;
3745 if (stopparen>0 && (OP(scan)==CURLYN || OP(scan)==CURLYM)
3746 && (scan->flags == stopparen))
3751 mincount = ARG1(scan);
3752 maxcount = ARG2(scan);
3754 next = regnext(scan);
3755 if (OP(scan) == CURLYX) {
3756 I32 lp = (data ? *(data->last_closep) : 0);
3757 scan->flags = ((lp <= (I32)U8_MAX) ? (U8)lp : U8_MAX);
3759 scan = NEXTOPER(scan) + EXTRA_STEP_2ARGS;
3760 next_is_eval = (OP(scan) == EVAL);
3762 if (flags & SCF_DO_SUBSTR) {
3763 if (mincount == 0) SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot extend fixed substrings */
3764 pos_before = data->pos_min;
3768 data->flags &= ~(SF_HAS_PAR|SF_IN_PAR|SF_HAS_EVAL);
3770 data->flags |= SF_IS_INF;
3772 if (flags & SCF_DO_STCLASS) {
3773 cl_init(pRExC_state, &this_class);
3774 oclass = data->start_class;
3775 data->start_class = &this_class;
3776 f |= SCF_DO_STCLASS_AND;
3777 f &= ~SCF_DO_STCLASS_OR;
3779 /* Exclude from super-linear cache processing any {n,m}
3780 regops for which the combination of input pos and regex
3781 pos is not enough information to determine if a match
3784 For example, in the regex /foo(bar\s*){4,8}baz/ with the
3785 regex pos at the \s*, the prospects for a match depend not
3786 only on the input position but also on how many (bar\s*)
3787 repeats into the {4,8} we are. */
3788 if ((mincount > 1) || (maxcount > 1 && maxcount != REG_INFTY))
3789 f &= ~SCF_WHILEM_VISITED_POS;
3791 /* This will finish on WHILEM, setting scan, or on NULL: */
3792 minnext = study_chunk(pRExC_state, &scan, minlenp, &deltanext,
3793 last, data, stopparen, recursed, NULL,
3795 ? (f & ~SCF_DO_SUBSTR) : f),depth+1);
3797 if (flags & SCF_DO_STCLASS)
3798 data->start_class = oclass;
3799 if (mincount == 0 || minnext == 0) {
3800 if (flags & SCF_DO_STCLASS_OR) {
3801 cl_or(pRExC_state, data->start_class, &this_class);
3803 else if (flags & SCF_DO_STCLASS_AND) {
3804 /* Switch to OR mode: cache the old value of
3805 * data->start_class */
3807 StructCopy(data->start_class, and_withp,
3808 struct regnode_charclass_class);
3809 flags &= ~SCF_DO_STCLASS_AND;
3810 StructCopy(&this_class, data->start_class,
3811 struct regnode_charclass_class);
3812 flags |= SCF_DO_STCLASS_OR;
3813 data->start_class->flags |= ANYOF_EOS;
3815 } else { /* Non-zero len */
3816 if (flags & SCF_DO_STCLASS_OR) {
3817 cl_or(pRExC_state, data->start_class, &this_class);
3818 cl_and(data->start_class, and_withp);
3820 else if (flags & SCF_DO_STCLASS_AND)
3821 cl_and(data->start_class, &this_class);
3822 flags &= ~SCF_DO_STCLASS;
3824 if (!scan) /* It was not CURLYX, but CURLY. */
3826 if ( /* ? quantifier ok, except for (?{ ... }) */
3827 (next_is_eval || !(mincount == 0 && maxcount == 1))
3828 && (minnext == 0) && (deltanext == 0)
3829 && data && !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
3830 && maxcount <= REG_INFTY/3) /* Complement check for big count */
3832 ckWARNreg(RExC_parse,
3833 "Quantifier unexpected on zero-length expression");
3836 min += minnext * mincount;
3837 is_inf_internal |= ((maxcount == REG_INFTY
3838 && (minnext + deltanext) > 0)
3839 || deltanext == I32_MAX);
3840 is_inf |= is_inf_internal;
3841 delta += (minnext + deltanext) * maxcount - minnext * mincount;
3843 /* Try powerful optimization CURLYX => CURLYN. */
3844 if ( OP(oscan) == CURLYX && data
3845 && data->flags & SF_IN_PAR
3846 && !(data->flags & SF_HAS_EVAL)
3847 && !deltanext && minnext == 1 ) {
3848 /* Try to optimize to CURLYN. */
3849 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS;
3850 regnode * const nxt1 = nxt;
3857 if (!REGNODE_SIMPLE(OP(nxt))
3858 && !(PL_regkind[OP(nxt)] == EXACT
3859 && STR_LEN(nxt) == 1))
3865 if (OP(nxt) != CLOSE)
3867 if (RExC_open_parens) {
3868 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3869 RExC_close_parens[ARG(nxt1)-1]=nxt+2; /*close->while*/
3871 /* Now we know that nxt2 is the only contents: */
3872 oscan->flags = (U8)ARG(nxt);
3874 OP(nxt1) = NOTHING; /* was OPEN. */
3877 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3878 NEXT_OFF(nxt1+ 1) = 0; /* just for consistency. */
3879 NEXT_OFF(nxt2) = 0; /* just for consistency with CURLY. */
3880 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3881 OP(nxt + 1) = OPTIMIZED; /* was count. */
3882 NEXT_OFF(nxt+ 1) = 0; /* just for consistency. */
3887 /* Try optimization CURLYX => CURLYM. */
3888 if ( OP(oscan) == CURLYX && data
3889 && !(data->flags & SF_HAS_PAR)
3890 && !(data->flags & SF_HAS_EVAL)
3891 && !deltanext /* atom is fixed width */
3892 && minnext != 0 /* CURLYM can't handle zero width */
3894 /* XXXX How to optimize if data == 0? */
3895 /* Optimize to a simpler form. */
3896 regnode *nxt = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN */
3900 while ( (nxt2 = regnext(nxt)) /* skip over embedded stuff*/
3901 && (OP(nxt2) != WHILEM))
3903 OP(nxt2) = SUCCEED; /* Whas WHILEM */
3904 /* Need to optimize away parenths. */
3905 if ((data->flags & SF_IN_PAR) && OP(nxt) == CLOSE) {
3906 /* Set the parenth number. */
3907 regnode *nxt1 = NEXTOPER(oscan) + EXTRA_STEP_2ARGS; /* OPEN*/
3909 oscan->flags = (U8)ARG(nxt);
3910 if (RExC_open_parens) {
3911 RExC_open_parens[ARG(nxt1)-1]=oscan; /*open->CURLYM*/
3912 RExC_close_parens[ARG(nxt1)-1]=nxt2+1; /*close->NOTHING*/
3914 OP(nxt1) = OPTIMIZED; /* was OPEN. */
3915 OP(nxt) = OPTIMIZED; /* was CLOSE. */
3918 OP(nxt1 + 1) = OPTIMIZED; /* was count. */
3919 OP(nxt + 1) = OPTIMIZED; /* was count. */
3920 NEXT_OFF(nxt1 + 1) = 0; /* just for consistency. */
3921 NEXT_OFF(nxt + 1) = 0; /* just for consistency. */
3924 while ( nxt1 && (OP(nxt1) != WHILEM)) {
3925 regnode *nnxt = regnext(nxt1);
3927 if (reg_off_by_arg[OP(nxt1)])
3928 ARG_SET(nxt1, nxt2 - nxt1);
3929 else if (nxt2 - nxt1 < U16_MAX)
3930 NEXT_OFF(nxt1) = nxt2 - nxt1;
3932 OP(nxt) = NOTHING; /* Cannot beautify */
3937 /* Optimize again: */
3938 study_chunk(pRExC_state, &nxt1, minlenp, &deltanext, nxt,
3939 NULL, stopparen, recursed, NULL, 0,depth+1);
3944 else if ((OP(oscan) == CURLYX)
3945 && (flags & SCF_WHILEM_VISITED_POS)
3946 /* See the comment on a similar expression above.
3947 However, this time it's not a subexpression
3948 we care about, but the expression itself. */
3949 && (maxcount == REG_INFTY)
3950 && data && ++data->whilem_c < 16) {
3951 /* This stays as CURLYX, we can put the count/of pair. */
3952 /* Find WHILEM (as in regexec.c) */
3953 regnode *nxt = oscan + NEXT_OFF(oscan);
3955 if (OP(PREVOPER(nxt)) == NOTHING) /* LONGJMP */
3957 PREVOPER(nxt)->flags = (U8)(data->whilem_c
3958 | (RExC_whilem_seen << 4)); /* On WHILEM */
3960 if (data && fl & (SF_HAS_PAR|SF_IN_PAR))
3962 if (flags & SCF_DO_SUBSTR) {
3963 SV *last_str = NULL;
3964 int counted = mincount != 0;
3966 if (data->last_end > 0 && mincount != 0) { /* Ends with a string. */
3967 #if defined(SPARC64_GCC_WORKAROUND)
3970 const char *s = NULL;
3973 if (pos_before >= data->last_start_min)
3976 b = data->last_start_min;
3979 s = SvPV_const(data->last_found, l);
3980 old = b - data->last_start_min;
3983 I32 b = pos_before >= data->last_start_min
3984 ? pos_before : data->last_start_min;
3986 const char * const s = SvPV_const(data->last_found, l);
3987 I32 old = b - data->last_start_min;
3991 old = utf8_hop((U8*)s, old) - (U8*)s;
3993 /* Get the added string: */
3994 last_str = newSVpvn_utf8(s + old, l, UTF);
3995 if (deltanext == 0 && pos_before == b) {
3996 /* What was added is a constant string */
3998 SvGROW(last_str, (mincount * l) + 1);
3999 repeatcpy(SvPVX(last_str) + l,
4000 SvPVX_const(last_str), l, mincount - 1);
4001 SvCUR_set(last_str, SvCUR(last_str) * mincount);
4002 /* Add additional parts. */
4003 SvCUR_set(data->last_found,
4004 SvCUR(data->last_found) - l);
4005 sv_catsv(data->last_found, last_str);
4007 SV * sv = data->last_found;
4009 SvUTF8(sv) && SvMAGICAL(sv) ?
4010 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4011 if (mg && mg->mg_len >= 0)
4012 mg->mg_len += CHR_SVLEN(last_str) - l;
4014 data->last_end += l * (mincount - 1);
4017 /* start offset must point into the last copy */
4018 data->last_start_min += minnext * (mincount - 1);
4019 data->last_start_max += is_inf ? I32_MAX
4020 : (maxcount - 1) * (minnext + data->pos_delta);
4023 /* It is counted once already... */
4024 data->pos_min += minnext * (mincount - counted);
4025 data->pos_delta += - counted * deltanext +
4026 (minnext + deltanext) * maxcount - minnext * mincount;
4027 if (mincount != maxcount) {
4028 /* Cannot extend fixed substrings found inside
4030 SCAN_COMMIT(pRExC_state,data,minlenp);
4031 if (mincount && last_str) {
4032 SV * const sv = data->last_found;
4033 MAGIC * const mg = SvUTF8(sv) && SvMAGICAL(sv) ?
4034 mg_find(sv, PERL_MAGIC_utf8) : NULL;
4038 sv_setsv(sv, last_str);
4039 data->last_end = data->pos_min;
4040 data->last_start_min =
4041 data->pos_min - CHR_SVLEN(last_str);
4042 data->last_start_max = is_inf
4044 : data->pos_min + data->pos_delta
4045 - CHR_SVLEN(last_str);
4047 data->longest = &(data->longest_float);
4049 SvREFCNT_dec(last_str);
4051 if (data && (fl & SF_HAS_EVAL))
4052 data->flags |= SF_HAS_EVAL;
4053 optimize_curly_tail:
4054 if (OP(oscan) != CURLYX) {
4055 while (PL_regkind[OP(next = regnext(oscan))] == NOTHING
4057 NEXT_OFF(oscan) += NEXT_OFF(next);
4060 default: /* REF, ANYOFV, and CLUMP only? */
4061 if (flags & SCF_DO_SUBSTR) {
4062 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4063 data->longest = &(data->longest_float);
4065 is_inf = is_inf_internal = 1;
4066 if (flags & SCF_DO_STCLASS_OR)
4067 cl_anything(pRExC_state, data->start_class);
4068 flags &= ~SCF_DO_STCLASS;
4072 else if (OP(scan) == LNBREAK) {
4073 if (flags & SCF_DO_STCLASS) {
4075 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4076 if (flags & SCF_DO_STCLASS_AND) {
4077 for (value = 0; value < 256; value++)
4078 if (!is_VERTWS_cp(value))
4079 ANYOF_BITMAP_CLEAR(data->start_class, value);
4082 for (value = 0; value < 256; value++)
4083 if (is_VERTWS_cp(value))
4084 ANYOF_BITMAP_SET(data->start_class, value);
4086 if (flags & SCF_DO_STCLASS_OR)
4087 cl_and(data->start_class, and_withp);
4088 flags &= ~SCF_DO_STCLASS;
4092 if (flags & SCF_DO_SUBSTR) {
4093 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4095 data->pos_delta += 1;
4096 data->longest = &(data->longest_float);
4099 else if (REGNODE_SIMPLE(OP(scan))) {
4102 if (flags & SCF_DO_SUBSTR) {
4103 SCAN_COMMIT(pRExC_state,data,minlenp);
4107 if (flags & SCF_DO_STCLASS) {
4108 data->start_class->flags &= ~ANYOF_EOS; /* No match on empty */
4110 /* Some of the logic below assumes that switching
4111 locale on will only add false positives. */
4112 switch (PL_regkind[OP(scan)]) {
4116 /* Perl_croak(aTHX_ "panic: unexpected simple REx opcode %d", OP(scan)); */
4117 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4118 cl_anything(pRExC_state, data->start_class);
4121 if (OP(scan) == SANY)
4123 if (flags & SCF_DO_STCLASS_OR) { /* Everything but \n */
4124 value = (ANYOF_BITMAP_TEST(data->start_class,'\n')
4125 || ANYOF_CLASS_TEST_ANY_SET(data->start_class));
4126 cl_anything(pRExC_state, data->start_class);
4128 if (flags & SCF_DO_STCLASS_AND || !value)
4129 ANYOF_BITMAP_CLEAR(data->start_class,'\n');
4132 if (flags & SCF_DO_STCLASS_AND)
4133 cl_and(data->start_class,
4134 (struct regnode_charclass_class*)scan);
4136 cl_or(pRExC_state, data->start_class,
4137 (struct regnode_charclass_class*)scan);
4140 if (flags & SCF_DO_STCLASS_AND) {
4141 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4142 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NALNUM);
4143 if (OP(scan) == ALNUMU) {
4144 for (value = 0; value < 256; value++) {
4145 if (!isWORDCHAR_L1(value)) {
4146 ANYOF_BITMAP_CLEAR(data->start_class, value);
4150 for (value = 0; value < 256; value++) {
4151 if (!isALNUM(value)) {
4152 ANYOF_BITMAP_CLEAR(data->start_class, value);
4159 if (data->start_class->flags & ANYOF_LOCALE)
4160 ANYOF_CLASS_SET(data->start_class,ANYOF_ALNUM);
4162 /* Even if under locale, set the bits for non-locale
4163 * in case it isn't a true locale-node. This will
4164 * create false positives if it truly is locale */
4165 if (OP(scan) == ALNUMU) {
4166 for (value = 0; value < 256; value++) {
4167 if (isWORDCHAR_L1(value)) {
4168 ANYOF_BITMAP_SET(data->start_class, value);
4172 for (value = 0; value < 256; value++) {
4173 if (isALNUM(value)) {
4174 ANYOF_BITMAP_SET(data->start_class, value);
4181 if (flags & SCF_DO_STCLASS_AND) {
4182 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4183 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_ALNUM);
4184 if (OP(scan) == NALNUMU) {
4185 for (value = 0; value < 256; value++) {
4186 if (isWORDCHAR_L1(value)) {
4187 ANYOF_BITMAP_CLEAR(data->start_class, value);
4191 for (value = 0; value < 256; value++) {
4192 if (isALNUM(value)) {
4193 ANYOF_BITMAP_CLEAR(data->start_class, value);
4200 if (data->start_class->flags & ANYOF_LOCALE)
4201 ANYOF_CLASS_SET(data->start_class,ANYOF_NALNUM);
4203 /* Even if under locale, set the bits for non-locale in
4204 * case it isn't a true locale-node. This will create
4205 * false positives if it truly is locale */
4206 if (OP(scan) == NALNUMU) {
4207 for (value = 0; value < 256; value++) {
4208 if (! isWORDCHAR_L1(value)) {
4209 ANYOF_BITMAP_SET(data->start_class, value);
4213 for (value = 0; value < 256; value++) {
4214 if (! isALNUM(value)) {
4215 ANYOF_BITMAP_SET(data->start_class, value);
4222 if (flags & SCF_DO_STCLASS_AND) {
4223 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4224 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NSPACE);
4225 if (OP(scan) == SPACEU) {
4226 for (value = 0; value < 256; value++) {
4227 if (!isSPACE_L1(value)) {
4228 ANYOF_BITMAP_CLEAR(data->start_class, value);
4232 for (value = 0; value < 256; value++) {
4233 if (!isSPACE(value)) {
4234 ANYOF_BITMAP_CLEAR(data->start_class, value);
4241 if (data->start_class->flags & ANYOF_LOCALE) {
4242 ANYOF_CLASS_SET(data->start_class,ANYOF_SPACE);
4244 if (OP(scan) == SPACEU) {
4245 for (value = 0; value < 256; value++) {
4246 if (isSPACE_L1(value)) {
4247 ANYOF_BITMAP_SET(data->start_class, value);
4251 for (value = 0; value < 256; value++) {
4252 if (isSPACE(value)) {
4253 ANYOF_BITMAP_SET(data->start_class, value);
4260 if (flags & SCF_DO_STCLASS_AND) {
4261 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4262 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_SPACE);
4263 if (OP(scan) == NSPACEU) {
4264 for (value = 0; value < 256; value++) {
4265 if (isSPACE_L1(value)) {
4266 ANYOF_BITMAP_CLEAR(data->start_class, value);
4270 for (value = 0; value < 256; value++) {
4271 if (isSPACE(value)) {
4272 ANYOF_BITMAP_CLEAR(data->start_class, value);
4279 if (data->start_class->flags & ANYOF_LOCALE)
4280 ANYOF_CLASS_SET(data->start_class,ANYOF_NSPACE);
4281 if (OP(scan) == NSPACEU) {
4282 for (value = 0; value < 256; value++) {
4283 if (!isSPACE_L1(value)) {
4284 ANYOF_BITMAP_SET(data->start_class, value);
4289 for (value = 0; value < 256; value++) {
4290 if (!isSPACE(value)) {
4291 ANYOF_BITMAP_SET(data->start_class, value);
4298 if (flags & SCF_DO_STCLASS_AND) {
4299 if (!(data->start_class->flags & ANYOF_LOCALE)) {
4300 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_NDIGIT);
4301 for (value = 0; value < 256; value++)
4302 if (!isDIGIT(value))
4303 ANYOF_BITMAP_CLEAR(data->start_class, value);
4307 if (data->start_class->flags & ANYOF_LOCALE)
4308 ANYOF_CLASS_SET(data->start_class,ANYOF_DIGIT);
4309 for (value = 0; value < 256; value++)
4311 ANYOF_BITMAP_SET(data->start_class, value);
4315 if (flags & SCF_DO_STCLASS_AND) {
4316 if (!(data->start_class->flags & ANYOF_LOCALE))
4317 ANYOF_CLASS_CLEAR(data->start_class,ANYOF_DIGIT);
4318 for (value = 0; value < 256; value++)
4320 ANYOF_BITMAP_CLEAR(data->start_class, value);
4323 if (data->start_class->flags & ANYOF_LOCALE)
4324 ANYOF_CLASS_SET(data->start_class,ANYOF_NDIGIT);
4325 for (value = 0; value < 256; value++)
4326 if (!isDIGIT(value))
4327 ANYOF_BITMAP_SET(data->start_class, value);
4330 CASE_SYNST_FNC(VERTWS);
4331 CASE_SYNST_FNC(HORIZWS);
4334 if (flags & SCF_DO_STCLASS_OR)
4335 cl_and(data->start_class, and_withp);
4336 flags &= ~SCF_DO_STCLASS;
4339 else if (PL_regkind[OP(scan)] == EOL && flags & SCF_DO_SUBSTR) {
4340 data->flags |= (OP(scan) == MEOL
4344 else if ( PL_regkind[OP(scan)] == BRANCHJ
4345 /* Lookbehind, or need to calculate parens/evals/stclass: */
4346 && (scan->flags || data || (flags & SCF_DO_STCLASS))
4347 && (OP(scan) == IFMATCH || OP(scan) == UNLESSM)) {
4348 if ( !PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4349 || OP(scan) == UNLESSM )
4351 /* Negative Lookahead/lookbehind
4352 In this case we can't do fixed string optimisation.
4355 I32 deltanext, minnext, fake = 0;
4357 struct regnode_charclass_class intrnl;
4360 data_fake.flags = 0;
4362 data_fake.whilem_c = data->whilem_c;
4363 data_fake.last_closep = data->last_closep;
4366 data_fake.last_closep = &fake;
4367 data_fake.pos_delta = delta;
4368 if ( flags & SCF_DO_STCLASS && !scan->flags
4369 && OP(scan) == IFMATCH ) { /* Lookahead */
4370 cl_init(pRExC_state, &intrnl);
4371 data_fake.start_class = &intrnl;
4372 f |= SCF_DO_STCLASS_AND;
4374 if (flags & SCF_WHILEM_VISITED_POS)
4375 f |= SCF_WHILEM_VISITED_POS;
4376 next = regnext(scan);
4377 nscan = NEXTOPER(NEXTOPER(scan));
4378 minnext = study_chunk(pRExC_state, &nscan, minlenp, &deltanext,
4379 last, &data_fake, stopparen, recursed, NULL, f, depth+1);
4382 FAIL("Variable length lookbehind not implemented");
4384 else if (minnext > (I32)U8_MAX) {
4385 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4387 scan->flags = (U8)minnext;
4390 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4392 if (data_fake.flags & SF_HAS_EVAL)
4393 data->flags |= SF_HAS_EVAL;
4394 data->whilem_c = data_fake.whilem_c;
4396 if (f & SCF_DO_STCLASS_AND) {
4397 if (flags & SCF_DO_STCLASS_OR) {
4398 /* OR before, AND after: ideally we would recurse with
4399 * data_fake to get the AND applied by study of the
4400 * remainder of the pattern, and then derecurse;
4401 * *** HACK *** for now just treat as "no information".
4402 * See [perl #56690].
4404 cl_init(pRExC_state, data->start_class);
4406 /* AND before and after: combine and continue */
4407 const int was = (data->start_class->flags & ANYOF_EOS);
4409 cl_and(data->start_class, &intrnl);
4411 data->start_class->flags |= ANYOF_EOS;
4415 #if PERL_ENABLE_POSITIVE_ASSERTION_STUDY
4417 /* Positive Lookahead/lookbehind
4418 In this case we can do fixed string optimisation,
4419 but we must be careful about it. Note in the case of
4420 lookbehind the positions will be offset by the minimum
4421 length of the pattern, something we won't know about
4422 until after the recurse.
4424 I32 deltanext, fake = 0;
4426 struct regnode_charclass_class intrnl;
4428 /* We use SAVEFREEPV so that when the full compile
4429 is finished perl will clean up the allocated
4430 minlens when it's all done. This way we don't
4431 have to worry about freeing them when we know
4432 they wont be used, which would be a pain.
4435 Newx( minnextp, 1, I32 );
4436 SAVEFREEPV(minnextp);
4439 StructCopy(data, &data_fake, scan_data_t);
4440 if ((flags & SCF_DO_SUBSTR) && data->last_found) {
4443 SCAN_COMMIT(pRExC_state, &data_fake,minlenp);
4444 data_fake.last_found=newSVsv(data->last_found);
4448 data_fake.last_closep = &fake;
4449 data_fake.flags = 0;
4450 data_fake.pos_delta = delta;
4452 data_fake.flags |= SF_IS_INF;
4453 if ( flags & SCF_DO_STCLASS && !scan->flags
4454 && OP(scan) == IFMATCH ) { /* Lookahead */
4455 cl_init(pRExC_state, &intrnl);
4456 data_fake.start_class = &intrnl;
4457 f |= SCF_DO_STCLASS_AND;
4459 if (flags & SCF_WHILEM_VISITED_POS)
4460 f |= SCF_WHILEM_VISITED_POS;
4461 next = regnext(scan);
4462 nscan = NEXTOPER(NEXTOPER(scan));
4464 *minnextp = study_chunk(pRExC_state, &nscan, minnextp, &deltanext,
4465 last, &data_fake, stopparen, recursed, NULL, f,depth+1);
4468 FAIL("Variable length lookbehind not implemented");
4470 else if (*minnextp > (I32)U8_MAX) {
4471 FAIL2("Lookbehind longer than %"UVuf" not implemented", (UV)U8_MAX);
4473 scan->flags = (U8)*minnextp;
4478 if (f & SCF_DO_STCLASS_AND) {
4479 const int was = (data->start_class->flags & ANYOF_EOS);
4481 cl_and(data->start_class, &intrnl);
4483 data->start_class->flags |= ANYOF_EOS;
4486 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4488 if (data_fake.flags & SF_HAS_EVAL)
4489 data->flags |= SF_HAS_EVAL;
4490 data->whilem_c = data_fake.whilem_c;
4491 if ((flags & SCF_DO_SUBSTR) && data_fake.last_found) {
4492 if (RExC_rx->minlen<*minnextp)
4493 RExC_rx->minlen=*minnextp;
4494 SCAN_COMMIT(pRExC_state, &data_fake, minnextp);
4495 SvREFCNT_dec(data_fake.last_found);
4497 if ( data_fake.minlen_fixed != minlenp )
4499 data->offset_fixed= data_fake.offset_fixed;
4500 data->minlen_fixed= data_fake.minlen_fixed;
4501 data->lookbehind_fixed+= scan->flags;
4503 if ( data_fake.minlen_float != minlenp )
4505 data->minlen_float= data_fake.minlen_float;
4506 data->offset_float_min=data_fake.offset_float_min;
4507 data->offset_float_max=data_fake.offset_float_max;
4508 data->lookbehind_float+= scan->flags;
4517 else if (OP(scan) == OPEN) {
4518 if (stopparen != (I32)ARG(scan))
4521 else if (OP(scan) == CLOSE) {
4522 if (stopparen == (I32)ARG(scan)) {
4525 if ((I32)ARG(scan) == is_par) {
4526 next = regnext(scan);
4528 if ( next && (OP(next) != WHILEM) && next < last)
4529 is_par = 0; /* Disable optimization */
4532 *(data->last_closep) = ARG(scan);
4534 else if (OP(scan) == EVAL) {
4536 data->flags |= SF_HAS_EVAL;
4538 else if ( PL_regkind[OP(scan)] == ENDLIKE ) {
4539 if (flags & SCF_DO_SUBSTR) {
4540 SCAN_COMMIT(pRExC_state,data,minlenp);
4541 flags &= ~SCF_DO_SUBSTR;
4543 if (data && OP(scan)==ACCEPT) {
4544 data->flags |= SCF_SEEN_ACCEPT;
4549 else if (OP(scan) == LOGICAL && scan->flags == 2) /* Embedded follows */
4551 if (flags & SCF_DO_SUBSTR) {
4552 SCAN_COMMIT(pRExC_state,data,minlenp);
4553 data->longest = &(data->longest_float);
4555 is_inf = is_inf_internal = 1;
4556 if (flags & SCF_DO_STCLASS_OR) /* Allow everything */
4557 cl_anything(pRExC_state, data->start_class);
4558 flags &= ~SCF_DO_STCLASS;
4560 else if (OP(scan) == GPOS) {
4561 if (!(RExC_rx->extflags & RXf_GPOS_FLOAT) &&
4562 !(delta || is_inf || (data && data->pos_delta)))
4564 if (!(RExC_rx->extflags & RXf_ANCH) && (flags & SCF_DO_SUBSTR))
4565 RExC_rx->extflags |= RXf_ANCH_GPOS;
4566 if (RExC_rx->gofs < (U32)min)
4567 RExC_rx->gofs = min;
4569 RExC_rx->extflags |= RXf_GPOS_FLOAT;
4573 #ifdef TRIE_STUDY_OPT
4574 #ifdef FULL_TRIE_STUDY
4575 else if (PL_regkind[OP(scan)] == TRIE) {
4576 /* NOTE - There is similar code to this block above for handling
4577 BRANCH nodes on the initial study. If you change stuff here
4579 regnode *trie_node= scan;
4580 regnode *tail= regnext(scan);
4581 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4582 I32 max1 = 0, min1 = I32_MAX;
4583 struct regnode_charclass_class accum;
4585 if (flags & SCF_DO_SUBSTR) /* XXXX Add !SUSPEND? */
4586 SCAN_COMMIT(pRExC_state, data,minlenp); /* Cannot merge strings after this. */
4587 if (flags & SCF_DO_STCLASS)
4588 cl_init_zero(pRExC_state, &accum);
4594 const regnode *nextbranch= NULL;
4597 for ( word=1 ; word <= trie->wordcount ; word++)
4599 I32 deltanext=0, minnext=0, f = 0, fake;
4600 struct regnode_charclass_class this_class;
4602 data_fake.flags = 0;
4604 data_fake.whilem_c = data->whilem_c;
4605 data_fake.last_closep = data->last_closep;
4608 data_fake.last_closep = &fake;
4609 data_fake.pos_delta = delta;
4610 if (flags & SCF_DO_STCLASS) {
4611 cl_init(pRExC_state, &this_class);
4612 data_fake.start_class = &this_class;
4613 f = SCF_DO_STCLASS_AND;
4615 if (flags & SCF_WHILEM_VISITED_POS)
4616 f |= SCF_WHILEM_VISITED_POS;
4618 if (trie->jump[word]) {
4620 nextbranch = trie_node + trie->jump[0];
4621 scan= trie_node + trie->jump[word];
4622 /* We go from the jump point to the branch that follows
4623 it. Note this means we need the vestigal unused branches
4624 even though they arent otherwise used.
4626 minnext = study_chunk(pRExC_state, &scan, minlenp,
4627 &deltanext, (regnode *)nextbranch, &data_fake,
4628 stopparen, recursed, NULL, f,depth+1);
4630 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
4631 nextbranch= regnext((regnode*)nextbranch);
4633 if (min1 > (I32)(minnext + trie->minlen))
4634 min1 = minnext + trie->minlen;
4635 if (max1 < (I32)(minnext + deltanext + trie->maxlen))
4636 max1 = minnext + deltanext + trie->maxlen;
4637 if (deltanext == I32_MAX)
4638 is_inf = is_inf_internal = 1;
4640 if (data_fake.flags & (SF_HAS_PAR|SF_IN_PAR))
4642 if (data_fake.flags & SCF_SEEN_ACCEPT) {
4643 if ( stopmin > min + min1)
4644 stopmin = min + min1;
4645 flags &= ~SCF_DO_SUBSTR;
4647 data->flags |= SCF_SEEN_ACCEPT;
4650 if (data_fake.flags & SF_HAS_EVAL)
4651 data->flags |= SF_HAS_EVAL;
4652 data->whilem_c = data_fake.whilem_c;
4654 if (flags & SCF_DO_STCLASS)
4655 cl_or(pRExC_state, &accum, &this_class);
4658 if (flags & SCF_DO_SUBSTR) {
4659 data->pos_min += min1;
4660 data->pos_delta += max1 - min1;
4661 if (max1 != min1 || is_inf)
4662 data->longest = &(data->longest_float);
4665 delta += max1 - min1;
4666 if (flags & SCF_DO_STCLASS_OR) {
4667 cl_or(pRExC_state, data->start_class, &accum);
4669 cl_and(data->start_class, and_withp);
4670 flags &= ~SCF_DO_STCLASS;
4673 else if (flags & SCF_DO_STCLASS_AND) {
4675 cl_and(data->start_class, &accum);
4676 flags &= ~SCF_DO_STCLASS;
4679 /* Switch to OR mode: cache the old value of
4680 * data->start_class */
4682 StructCopy(data->start_class, and_withp,
4683 struct regnode_charclass_class);
4684 flags &= ~SCF_DO_STCLASS_AND;
4685 StructCopy(&accum, data->start_class,
4686 struct regnode_charclass_class);
4687 flags |= SCF_DO_STCLASS_OR;
4688 data->start_class->flags |= ANYOF_EOS;
4695 else if (PL_regkind[OP(scan)] == TRIE) {
4696 reg_trie_data *trie = (reg_trie_data*)RExC_rxi->data->data[ ARG(scan) ];
4699 min += trie->minlen;
4700 delta += (trie->maxlen - trie->minlen);
4701 flags &= ~SCF_DO_STCLASS; /* xxx */
4702 if (flags & SCF_DO_SUBSTR) {
4703 SCAN_COMMIT(pRExC_state,data,minlenp); /* Cannot expect anything... */
4704 data->pos_min += trie->minlen;
4705 data->pos_delta += (trie->maxlen - trie->minlen);
4706 if (trie->maxlen != trie->minlen)
4707 data->longest = &(data->longest_float);
4709 if (trie->jump) /* no more substrings -- for now /grr*/
4710 flags &= ~SCF_DO_SUBSTR;
4712 #endif /* old or new */
4713 #endif /* TRIE_STUDY_OPT */
4715 /* Else: zero-length, ignore. */
4716 scan = regnext(scan);
4721 stopparen = frame->stop;
4722 frame = frame->prev;
4723 goto fake_study_recurse;
4728 DEBUG_STUDYDATA("pre-fin:",data,depth);
4731 *deltap = is_inf_internal ? I32_MAX : delta;
4732 if (flags & SCF_DO_SUBSTR && is_inf)
4733 data->pos_delta = I32_MAX - data->pos_min;
4734 if (is_par > (I32)U8_MAX)
4736 if (is_par && pars==1 && data) {
4737 data->flags |= SF_IN_PAR;
4738 data->flags &= ~SF_HAS_PAR;
4740 else if (pars && data) {
4741 data->flags |= SF_HAS_PAR;
4742 data->flags &= ~SF_IN_PAR;
4744 if (flags & SCF_DO_STCLASS_OR)
4745 cl_and(data->start_class, and_withp);
4746 if (flags & SCF_TRIE_RESTUDY)
4747 data->flags |= SCF_TRIE_RESTUDY;
4749 DEBUG_STUDYDATA("post-fin:",data,depth);
4751 return min < stopmin ? min : stopmin;
4755 S_add_data(RExC_state_t *pRExC_state, U32 n, const char *s)
4757 U32 count = RExC_rxi->data ? RExC_rxi->data->count : 0;
4759 PERL_ARGS_ASSERT_ADD_DATA;
4761 Renewc(RExC_rxi->data,
4762 sizeof(*RExC_rxi->data) + sizeof(void*) * (count + n - 1),
4763 char, struct reg_data);
4765 Renew(RExC_rxi->data->what, count + n, U8);
4767 Newx(RExC_rxi->data->what, n, U8);
4768 RExC_rxi->data->count = count + n;
4769 Copy(s, RExC_rxi->data->what + count, n, U8);
4773 /*XXX: todo make this not included in a non debugging perl */
4774 #ifndef PERL_IN_XSUB_RE
4776 Perl_reginitcolors(pTHX)
4779 const char * const s = PerlEnv_getenv("PERL_RE_COLORS");
4781 char *t = savepv(s);
4785 t = strchr(t, '\t');
4791 PL_colors[i] = t = (char *)"";
4796 PL_colors[i++] = (char *)"";
4803 #ifdef TRIE_STUDY_OPT
4804 #define CHECK_RESTUDY_GOTO \
4806 (data.flags & SCF_TRIE_RESTUDY) \
4810 #define CHECK_RESTUDY_GOTO
4814 - pregcomp - compile a regular expression into internal code
4816 * We can't allocate space until we know how big the compiled form will be,
4817 * but we can't compile it (and thus know how big it is) until we've got a
4818 * place to put the code. So we cheat: we compile it twice, once with code
4819 * generation turned off and size counting turned on, and once "for real".
4820 * This also means that we don't allocate space until we are sure that the
4821 * thing really will compile successfully, and we never have to move the
4822 * code and thus invalidate pointers into it. (Note that it has to be in
4823 * one piece because free() must be able to free it all.) [NB: not true in perl]
4825 * Beware that the optimization-preparation code in here knows about some
4826 * of the structure of the compiled regexp. [I'll say.]
4831 #ifndef PERL_IN_XSUB_RE
4832 #define RE_ENGINE_PTR &PL_core_reg_engine
4834 extern const struct regexp_engine my_reg_engine;
4835 #define RE_ENGINE_PTR &my_reg_engine
4838 #ifndef PERL_IN_XSUB_RE
4840 Perl_pregcomp(pTHX_ SV * const pattern, const U32 flags)
4843 HV * const table = GvHV(PL_hintgv);
4845 PERL_ARGS_ASSERT_PREGCOMP;
4847 /* Dispatch a request to compile a regexp to correct
4850 SV **ptr= hv_fetchs(table, "regcomp", FALSE);
4851 GET_RE_DEBUG_FLAGS_DECL;
4852 if (ptr && SvIOK(*ptr) && SvIV(*ptr)) {
4853 const regexp_engine *eng=INT2PTR(regexp_engine*,SvIV(*ptr));
4855 PerlIO_printf(Perl_debug_log, "Using engine %"UVxf"\n",
4858 return CALLREGCOMP_ENG(eng, pattern, flags);
4861 return Perl_re_compile(aTHX_ pattern, flags);
4866 Perl_re_compile(pTHX_ SV * const pattern, U32 orig_pm_flags)
4871 register regexp_internal *ri;
4880 /* these are all flags - maybe they should be turned
4881 * into a single int with different bit masks */
4882 I32 sawlookahead = 0;
4885 bool used_setjump = FALSE;
4886 regex_charset initial_charset = get_regex_charset(orig_pm_flags);
4891 RExC_state_t RExC_state;
4892 RExC_state_t * const pRExC_state = &RExC_state;
4893 #ifdef TRIE_STUDY_OPT
4895 RExC_state_t copyRExC_state;
4897 GET_RE_DEBUG_FLAGS_DECL;
4899 PERL_ARGS_ASSERT_RE_COMPILE;
4901 DEBUG_r(if (!PL_colorset) reginitcolors());
4903 #ifndef PERL_IN_XSUB_RE
4904 /* Initialize these here instead of as-needed, as is quick and avoids
4905 * having to test them each time otherwise */
4906 if (! PL_AboveLatin1) {
4907 PL_AboveLatin1 = _new_invlist_C_array(AboveLatin1_invlist);
4908 PL_ASCII = _new_invlist_C_array(ASCII_invlist);
4909 PL_Latin1 = _new_invlist_C_array(Latin1_invlist);
4911 PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4912 PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4914 PL_L1PosixAlpha = _new_invlist_C_array(L1PosixAlpha_invlist);
4915 PL_PosixAlpha = _new_invlist_C_array(PosixAlpha_invlist);
4917 PL_PosixBlank = _new_invlist_C_array(PosixBlank_invlist);
4918 PL_XPosixBlank = _new_invlist_C_array(XPosixBlank_invlist);
4920 PL_L1Cased = _new_invlist_C_array(L1Cased_invlist);
4922 PL_PosixCntrl = _new_invlist_C_array(PosixCntrl_invlist);
4923 PL_XPosixCntrl = _new_invlist_C_array(XPosixCntrl_invlist);
4925 PL_PosixDigit = _new_invlist_C_array(PosixDigit_invlist);
4927 PL_L1PosixGraph = _new_invlist_C_array(L1PosixGraph_invlist);
4928 PL_PosixGraph = _new_invlist_C_array(PosixGraph_invlist);
4930 PL_L1PosixAlnum = _new_invlist_C_array(L1PosixAlnum_invlist);
4931 PL_PosixAlnum = _new_invlist_C_array(PosixAlnum_invlist);
4933 PL_L1PosixLower = _new_invlist_C_array(L1PosixLower_invlist);
4934 PL_PosixLower = _new_invlist_C_array(PosixLower_invlist);
4936 PL_L1PosixPrint = _new_invlist_C_array(L1PosixPrint_invlist);
4937 PL_PosixPrint = _new_invlist_C_array(PosixPrint_invlist);
4939 PL_L1PosixPunct = _new_invlist_C_array(L1PosixPunct_invlist);
4940 PL_PosixPunct = _new_invlist_C_array(PosixPunct_invlist);
4942 PL_PerlSpace = _new_invlist_C_array(PerlSpace_invlist);
4943 PL_XPerlSpace = _new_invlist_C_array(XPerlSpace_invlist);
4945 PL_PosixSpace = _new_invlist_C_array(PosixSpace_invlist);
4946 PL_XPosixSpace = _new_invlist_C_array(XPosixSpace_invlist);
4948 PL_L1PosixUpper = _new_invlist_C_array(L1PosixUpper_invlist);
4949 PL_PosixUpper = _new_invlist_C_array(PosixUpper_invlist);
4951 PL_VertSpace = _new_invlist_C_array(VertSpace_invlist);
4953 PL_PosixWord = _new_invlist_C_array(PosixWord_invlist);
4954 PL_L1PosixWord = _new_invlist_C_array(L1PosixWord_invlist);
4956 PL_PosixXDigit = _new_invlist_C_array(PosixXDigit_invlist);
4957 PL_XPosixXDigit = _new_invlist_C_array(XPosixXDigit_invlist);
4961 exp = SvPV(pattern, plen);
4963 if (plen == 0) { /* ignore the utf8ness if the pattern is 0 length */
4964 RExC_utf8 = RExC_orig_utf8 = 0;
4967 RExC_utf8 = RExC_orig_utf8 = SvUTF8(pattern);
4969 RExC_uni_semantics = 0;
4970 RExC_contains_locale = 0;
4972 /****************** LONG JUMP TARGET HERE***********************/
4973 /* Longjmp back to here if have to switch in midstream to utf8 */
4974 if (! RExC_orig_utf8) {
4975 JMPENV_PUSH(jump_ret);
4976 used_setjump = TRUE;
4979 if (jump_ret == 0) { /* First time through */
4983 SV *dsv= sv_newmortal();
4984 RE_PV_QUOTED_DECL(s, RExC_utf8,
4985 dsv, exp, plen, 60);
4986 PerlIO_printf(Perl_debug_log, "%sCompiling REx%s %s\n",
4987 PL_colors[4],PL_colors[5],s);
4990 else { /* longjumped back */
4993 /* If the cause for the longjmp was other than changing to utf8, pop
4994 * our own setjmp, and longjmp to the correct handler */
4995 if (jump_ret != UTF8_LONGJMP) {
4997 JMPENV_JUMP(jump_ret);
5002 /* It's possible to write a regexp in ascii that represents Unicode
5003 codepoints outside of the byte range, such as via \x{100}. If we
5004 detect such a sequence we have to convert the entire pattern to utf8
5005 and then recompile, as our sizing calculation will have been based
5006 on 1 byte == 1 character, but we will need to use utf8 to encode
5007 at least some part of the pattern, and therefore must convert the whole
5010 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log,
5011 "UTF8 mismatch! Converting to utf8 for resizing and compile\n"));
5012 exp = (char*)Perl_bytes_to_utf8(aTHX_
5013 (U8*)SvPV_nomg(pattern, plen),
5016 RExC_orig_utf8 = RExC_utf8 = 1;
5020 #ifdef TRIE_STUDY_OPT
5024 pm_flags = orig_pm_flags;
5026 if (initial_charset == REGEX_LOCALE_CHARSET) {
5027 RExC_contains_locale = 1;
5029 else if (RExC_utf8 && initial_charset == REGEX_DEPENDS_CHARSET) {
5031 /* Set to use unicode semantics if the pattern is in utf8 and has the
5032 * 'depends' charset specified, as it means unicode when utf8 */
5033 set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5037 RExC_flags = pm_flags;
5041 RExC_in_lookbehind = 0;
5042 RExC_seen_zerolen = *exp == '^' ? -1 : 0;
5043 RExC_seen_evals = 0;
5045 RExC_override_recoding = 0;
5047 /* First pass: determine size, legality. */
5055 RExC_emit = &PL_regdummy;
5056 RExC_whilem_seen = 0;
5057 RExC_open_parens = NULL;
5058 RExC_close_parens = NULL;
5060 RExC_paren_names = NULL;
5062 RExC_paren_name_list = NULL;
5064 RExC_recurse = NULL;
5065 RExC_recurse_count = 0;
5067 #if 0 /* REGC() is (currently) a NOP at the first pass.
5068 * Clever compilers notice this and complain. --jhi */
5069 REGC((U8)REG_MAGIC, (char*)RExC_emit);
5072 PerlIO_printf(Perl_debug_log, "Starting first pass (sizing)\n");
5074 RExC_lastparse=NULL;
5076 if (reg(pRExC_state, 0, &flags,1) == NULL) {
5077 RExC_precomp = NULL;
5081 /* Here, finished first pass. Get rid of any added setjmp */
5087 PerlIO_printf(Perl_debug_log,
5088 "Required size %"IVdf" nodes\n"
5089 "Starting second pass (creation)\n",
5092 RExC_lastparse=NULL;
5095 /* The first pass could have found things that force Unicode semantics */
5096 if ((RExC_utf8 || RExC_uni_semantics)
5097 && get_regex_charset(pm_flags) == REGEX_DEPENDS_CHARSET)
5099 set_regex_charset(&pm_flags, REGEX_UNICODE_CHARSET);
5102 /* Small enough for pointer-storage convention?
5103 If extralen==0, this means that we will not need long jumps. */
5104 if (RExC_size >= 0x10000L && RExC_extralen)
5105 RExC_size += RExC_extralen;
5108 if (RExC_whilem_seen > 15)
5109 RExC_whilem_seen = 15;
5111 /* Allocate space and zero-initialize. Note, the two step process
5112 of zeroing when in debug mode, thus anything assigned has to
5113 happen after that */
5114 rx = (REGEXP*) newSV_type(SVt_REGEXP);
5115 r = (struct regexp*)SvANY(rx);
5116 Newxc(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode),
5117 char, regexp_internal);
5118 if ( r == NULL || ri == NULL )
5119 FAIL("Regexp out of space");
5121 /* avoid reading uninitialized memory in DEBUGGING code in study_chunk() */
5122 Zero(ri, sizeof(regexp_internal) + (unsigned)RExC_size * sizeof(regnode), char);
5124 /* bulk initialize base fields with 0. */
5125 Zero(ri, sizeof(regexp_internal), char);
5128 /* non-zero initialization begins here */
5130 r->engine= RE_ENGINE_PTR;
5131 r->extflags = pm_flags;
5133 bool has_p = ((r->extflags & RXf_PMf_KEEPCOPY) == RXf_PMf_KEEPCOPY);
5134 bool has_charset = (get_regex_charset(r->extflags) != REGEX_DEPENDS_CHARSET);
5136 /* The caret is output if there are any defaults: if not all the STD
5137 * flags are set, or if no character set specifier is needed */
5139 (((r->extflags & RXf_PMf_STD_PMMOD) != RXf_PMf_STD_PMMOD)
5141 bool has_runon = ((RExC_seen & REG_SEEN_RUN_ON_COMMENT)==REG_SEEN_RUN_ON_COMMENT);
5142 U16 reganch = (U16)((r->extflags & RXf_PMf_STD_PMMOD)
5143 >> RXf_PMf_STD_PMMOD_SHIFT);
5144 const char *fptr = STD_PAT_MODS; /*"msix"*/
5146 /* Allocate for the worst case, which is all the std flags are turned
5147 * on. If more precision is desired, we could do a population count of
5148 * the flags set. This could be done with a small lookup table, or by
5149 * shifting, masking and adding, or even, when available, assembly
5150 * language for a machine-language population count.
5151 * We never output a minus, as all those are defaults, so are
5152 * covered by the caret */
5153 const STRLEN wraplen = plen + has_p + has_runon
5154 + has_default /* If needs a caret */
5156 /* If needs a character set specifier */
5157 + ((has_charset) ? MAX_CHARSET_NAME_LENGTH : 0)
5158 + (sizeof(STD_PAT_MODS) - 1)
5159 + (sizeof("(?:)") - 1);
5161 p = sv_grow(MUTABLE_SV(rx), wraplen + 1); /* +1 for the ending NUL */
5163 SvFLAGS(rx) |= SvUTF8(pattern);
5166 /* If a default, cover it using the caret */
5168 *p++= DEFAULT_PAT_MOD;
5172 const char* const name = get_regex_charset_name(r->extflags, &len);
5173 Copy(name, p, len, char);
5177 *p++ = KEEPCOPY_PAT_MOD; /*'p'*/
5180 while((ch = *fptr++)) {
5188 Copy(RExC_precomp, p, plen, char);
5189 assert ((RX_WRAPPED(rx) - p) < 16);
5190 r->pre_prefix = p - RX_WRAPPED(rx);
5196 SvCUR_set(rx, p - SvPVX_const(rx));
5200 r->nparens = RExC_npar - 1; /* set early to validate backrefs */
5202 if (RExC_seen & REG_SEEN_RECURSE) {
5203 Newxz(RExC_open_parens, RExC_npar,regnode *);
5204 SAVEFREEPV(RExC_open_parens);
5205 Newxz(RExC_close_parens,RExC_npar,regnode *);
5206 SAVEFREEPV(RExC_close_parens);
5209 /* Useful during FAIL. */
5210 #ifdef RE_TRACK_PATTERN_OFFSETS
5211 Newxz(ri->u.offsets, 2*RExC_size+1, U32); /* MJD 20001228 */
5212 DEBUG_OFFSETS_r(PerlIO_printf(Perl_debug_log,
5213 "%s %"UVuf" bytes for offset annotations.\n",
5214 ri->u.offsets ? "Got" : "Couldn't get",
5215 (UV)((2*RExC_size+1) * sizeof(U32))));
5217 SetProgLen(ri,RExC_size);
5222 /* Second pass: emit code. */
5223 RExC_flags = pm_flags; /* don't let top level (?i) bleed */
5228 RExC_emit_start = ri->program;
5229 RExC_emit = ri->program;
5230 RExC_emit_bound = ri->program + RExC_size + 1;
5232 /* Store the count of eval-groups for security checks: */
5233 RExC_rx->seen_evals = RExC_seen_evals;
5234 REGC((U8)REG_MAGIC, (char*) RExC_emit++);
5235 if (reg(pRExC_state, 0, &flags,1) == NULL) {
5239 /* XXXX To minimize changes to RE engine we always allocate
5240 3-units-long substrs field. */
5241 Newx(r->substrs, 1, struct reg_substr_data);
5242 if (RExC_recurse_count) {
5243 Newxz(RExC_recurse,RExC_recurse_count,regnode *);
5244 SAVEFREEPV(RExC_recurse);
5248 r->minlen = minlen = sawlookahead = sawplus = sawopen = 0;
5249 Zero(r->substrs, 1, struct reg_substr_data);
5251 #ifdef TRIE_STUDY_OPT
5253 StructCopy(&zero_scan_data, &data, scan_data_t);
5254 copyRExC_state = RExC_state;
5257 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log,"Restudying\n"));
5259 RExC_state = copyRExC_state;
5260 if (seen & REG_TOP_LEVEL_BRANCHES)
5261 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
5263 RExC_seen &= ~REG_TOP_LEVEL_BRANCHES;
5264 if (data.last_found) {
5265 SvREFCNT_dec(data.longest_fixed);
5266 SvREFCNT_dec(data.longest_float);
5267 SvREFCNT_dec(data.last_found);
5269 StructCopy(&zero_scan_data, &data, scan_data_t);
5272 StructCopy(&zero_scan_data, &data, scan_data_t);
5275 /* Dig out information for optimizations. */
5276 r->extflags = RExC_flags; /* was pm_op */
5277 /*dmq: removed as part of de-PMOP: pm->op_pmflags = RExC_flags; */
5280 SvUTF8_on(rx); /* Unicode in it? */
5281 ri->regstclass = NULL;
5282 if (RExC_naughty >= 10) /* Probably an expensive pattern. */
5283 r->intflags |= PREGf_NAUGHTY;
5284 scan = ri->program + 1; /* First BRANCH. */
5286 /* testing for BRANCH here tells us whether there is "must appear"
5287 data in the pattern. If there is then we can use it for optimisations */
5288 if (!(RExC_seen & REG_TOP_LEVEL_BRANCHES)) { /* Only one top-level choice. */
5290 STRLEN longest_float_length, longest_fixed_length;
5291 struct regnode_charclass_class ch_class; /* pointed to by data */
5293 I32 last_close = 0; /* pointed to by data */
5294 regnode *first= scan;
5295 regnode *first_next= regnext(first);
5297 * Skip introductions and multiplicators >= 1
5298 * so that we can extract the 'meat' of the pattern that must
5299 * match in the large if() sequence following.
5300 * NOTE that EXACT is NOT covered here, as it is normally
5301 * picked up by the optimiser separately.
5303 * This is unfortunate as the optimiser isnt handling lookahead
5304 * properly currently.
5307 while ((OP(first) == OPEN && (sawopen = 1)) ||
5308 /* An OR of *one* alternative - should not happen now. */
5309 (OP(first) == BRANCH && OP(first_next) != BRANCH) ||
5310 /* for now we can't handle lookbehind IFMATCH*/
5311 (OP(first) == IFMATCH && !first->flags && (sawlookahead = 1)) ||
5312 (OP(first) == PLUS) ||
5313 (OP(first) == MINMOD) ||
5314 /* An {n,m} with n>0 */
5315 (PL_regkind[OP(first)] == CURLY && ARG1(first) > 0) ||
5316 (OP(first) == NOTHING && PL_regkind[OP(first_next)] != END ))
5319 * the only op that could be a regnode is PLUS, all the rest
5320 * will be regnode_1 or regnode_2.
5323 if (OP(first) == PLUS)
5326 first += regarglen[OP(first)];
5328 first = NEXTOPER(first);
5329 first_next= regnext(first);
5332 /* Starting-point info. */
5334 DEBUG_PEEP("first:",first,0);
5335 /* Ignore EXACT as we deal with it later. */
5336 if (PL_regkind[OP(first)] == EXACT) {
5337 if (OP(first) == EXACT)
5338 NOOP; /* Empty, get anchored substr later. */
5340 ri->regstclass = first;
5343 else if (PL_regkind[OP(first)] == TRIE &&
5344 ((reg_trie_data *)ri->data->data[ ARG(first) ])->minlen>0)
5347 /* this can happen only on restudy */
5348 if ( OP(first) == TRIE ) {
5349 struct regnode_1 *trieop = (struct regnode_1 *)
5350 PerlMemShared_calloc(1, sizeof(struct regnode_1));
5351 StructCopy(first,trieop,struct regnode_1);
5352 trie_op=(regnode *)trieop;
5354 struct regnode_charclass *trieop = (struct regnode_charclass *)
5355 PerlMemShared_calloc(1, sizeof(struct regnode_charclass));
5356 StructCopy(first,trieop,struct regnode_charclass);
5357 trie_op=(regnode *)trieop;
5360 make_trie_failtable(pRExC_state, (regnode *)first, trie_op, 0);
5361 ri->regstclass = trie_op;
5364 else if (REGNODE_SIMPLE(OP(first)))
5365 ri->regstclass = first;
5366 else if (PL_regkind[OP(first)] == BOUND ||
5367 PL_regkind[OP(first)] == NBOUND)
5368 ri->regstclass = first;
5369 else if (PL_regkind[OP(first)] == BOL) {
5370 r->extflags |= (OP(first) == MBOL
5372 : (OP(first) == SBOL
5375 first = NEXTOPER(first);
5378 else if (OP(first) == GPOS) {
5379 r->extflags |= RXf_ANCH_GPOS;
5380 first = NEXTOPER(first);
5383 else if ((!sawopen || !RExC_sawback) &&
5384 (OP(first) == STAR &&
5385 PL_regkind[OP(NEXTOPER(first))] == REG_ANY) &&
5386 !(r->extflags & RXf_ANCH) && !(RExC_seen & REG_SEEN_EVAL))
5388 /* turn .* into ^.* with an implied $*=1 */
5390 (OP(NEXTOPER(first)) == REG_ANY)
5393 r->extflags |= type;
5394 r->intflags |= PREGf_IMPLICIT;
5395 first = NEXTOPER(first);
5398 if (sawplus && !sawlookahead && (!sawopen || !RExC_sawback)
5399 && !(RExC_seen & REG_SEEN_EVAL)) /* May examine pos and $& */
5400 /* x+ must match at the 1st pos of run of x's */
5401 r->intflags |= PREGf_SKIP;
5403 /* Scan is after the zeroth branch, first is atomic matcher. */
5404 #ifdef TRIE_STUDY_OPT
5407 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5408 (IV)(first - scan + 1))
5412 PerlIO_printf(Perl_debug_log, "first at %"IVdf"\n",
5413 (IV)(first - scan + 1))
5419 * If there's something expensive in the r.e., find the
5420 * longest literal string that must appear and make it the
5421 * regmust. Resolve ties in favor of later strings, since
5422 * the regstart check works with the beginning of the r.e.
5423 * and avoiding duplication strengthens checking. Not a
5424 * strong reason, but sufficient in the absence of others.
5425 * [Now we resolve ties in favor of the earlier string if
5426 * it happens that c_offset_min has been invalidated, since the
5427 * earlier string may buy us something the later one won't.]
5430 data.longest_fixed = newSVpvs("");
5431 data.longest_float = newSVpvs("");
5432 data.last_found = newSVpvs("");
5433 data.longest = &(data.longest_fixed);
5435 if (!ri->regstclass) {
5436 cl_init(pRExC_state, &ch_class);
5437 data.start_class = &ch_class;
5438 stclass_flag = SCF_DO_STCLASS_AND;
5439 } else /* XXXX Check for BOUND? */
5441 data.last_closep = &last_close;
5443 minlen = study_chunk(pRExC_state, &first, &minlen, &fake, scan + RExC_size, /* Up to end */
5444 &data, -1, NULL, NULL,
5445 SCF_DO_SUBSTR | SCF_WHILEM_VISITED_POS | stclass_flag,0);
5451 if ( RExC_npar == 1 && data.longest == &(data.longest_fixed)
5452 && data.last_start_min == 0 && data.last_end > 0
5453 && !RExC_seen_zerolen
5454 && !(RExC_seen & REG_SEEN_VERBARG)
5455 && (!(RExC_seen & REG_SEEN_GPOS) || (r->extflags & RXf_ANCH_GPOS)))
5456 r->extflags |= RXf_CHECK_ALL;
5457 scan_commit(pRExC_state, &data,&minlen,0);
5458 SvREFCNT_dec(data.last_found);
5460 /* Note that code very similar to this but for anchored string
5461 follows immediately below, changes may need to be made to both.
5464 longest_float_length = CHR_SVLEN(data.longest_float);
5465 if (longest_float_length
5466 || (data.flags & SF_FL_BEFORE_EOL
5467 && (!(data.flags & SF_FL_BEFORE_MEOL)
5468 || (RExC_flags & RXf_PMf_MULTILINE))))
5472 /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5473 if ((RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5474 || (SvCUR(data.longest_fixed) /* ok to leave SvCUR */
5475 && data.offset_fixed == data.offset_float_min
5476 && SvCUR(data.longest_fixed) == SvCUR(data.longest_float)))
5477 goto remove_float; /* As in (a)+. */
5479 /* copy the information about the longest float from the reg_scan_data
5480 over to the program. */
5481 if (SvUTF8(data.longest_float)) {
5482 r->float_utf8 = data.longest_float;
5483 r->float_substr = NULL;
5485 r->float_substr = data.longest_float;
5486 r->float_utf8 = NULL;
5488 /* float_end_shift is how many chars that must be matched that
5489 follow this item. We calculate it ahead of time as once the
5490 lookbehind offset is added in we lose the ability to correctly
5492 ml = data.minlen_float ? *(data.minlen_float)
5493 : (I32)longest_float_length;
5494 r->float_end_shift = ml - data.offset_float_min
5495 - longest_float_length + (SvTAIL(data.longest_float) != 0)
5496 + data.lookbehind_float;
5497 r->float_min_offset = data.offset_float_min - data.lookbehind_float;
5498 r->float_max_offset = data.offset_float_max;
5499 if (data.offset_float_max < I32_MAX) /* Don't offset infinity */
5500 r->float_max_offset -= data.lookbehind_float;
5502 t = (data.flags & SF_FL_BEFORE_EOL /* Can't have SEOL and MULTI */
5503 && (!(data.flags & SF_FL_BEFORE_MEOL)
5504 || (RExC_flags & RXf_PMf_MULTILINE)));
5505 fbm_compile(data.longest_float, t ? FBMcf_TAIL : 0);
5509 r->float_substr = r->float_utf8 = NULL;
5510 SvREFCNT_dec(data.longest_float);
5511 longest_float_length = 0;
5514 /* Note that code very similar to this but for floating string
5515 is immediately above, changes may need to be made to both.
5518 longest_fixed_length = CHR_SVLEN(data.longest_fixed);
5520 /* See comments for join_exact for why REG_SEEN_EXACTF_SHARP_S */
5521 if (! (RExC_seen & REG_SEEN_EXACTF_SHARP_S)
5522 && (longest_fixed_length
5523 || (data.flags & SF_FIX_BEFORE_EOL /* Cannot have SEOL and MULTI */
5524 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5525 || (RExC_flags & RXf_PMf_MULTILINE)))) )
5529 /* copy the information about the longest fixed
5530 from the reg_scan_data over to the program. */
5531 if (SvUTF8(data.longest_fixed)) {
5532 r->anchored_utf8 = data.longest_fixed;
5533 r->anchored_substr = NULL;
5535 r->anchored_substr = data.longest_fixed;
5536 r->anchored_utf8 = NULL;
5538 /* fixed_end_shift is how many chars that must be matched that
5539 follow this item. We calculate it ahead of time as once the
5540 lookbehind offset is added in we lose the ability to correctly
5542 ml = data.minlen_fixed ? *(data.minlen_fixed)
5543 : (I32)longest_fixed_length;
5544 r->anchored_end_shift = ml - data.offset_fixed
5545 - longest_fixed_length + (SvTAIL(data.longest_fixed) != 0)
5546 + data.lookbehind_fixed;
5547 r->anchored_offset = data.offset_fixed - data.lookbehind_fixed;
5549 t = (data.flags & SF_FIX_BEFORE_EOL /* Can't have SEOL and MULTI */
5550 && (!(data.flags & SF_FIX_BEFORE_MEOL)
5551 || (RExC_flags & RXf_PMf_MULTILINE)));
5552 fbm_compile(data.longest_fixed, t ? FBMcf_TAIL : 0);
5555 r->anchored_substr = r->anchored_utf8 = NULL;
5556 SvREFCNT_dec(data.longest_fixed);
5557 longest_fixed_length = 0;
5560 && (OP(ri->regstclass) == REG_ANY || OP(ri->regstclass) == SANY))
5561 ri->regstclass = NULL;
5563 if ((!(r->anchored_substr || r->anchored_utf8) || r->anchored_offset)
5565 && !(data.start_class->flags & ANYOF_EOS)
5566 && !cl_is_anything(data.start_class))
5568 const U32 n = add_data(pRExC_state, 1, "f");
5569 data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5571 Newx(RExC_rxi->data->data[n], 1,
5572 struct regnode_charclass_class);
5573 StructCopy(data.start_class,
5574 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5575 struct regnode_charclass_class);
5576 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5577 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5578 DEBUG_COMPILE_r({ SV *sv = sv_newmortal();
5579 regprop(r, sv, (regnode*)data.start_class);
5580 PerlIO_printf(Perl_debug_log,
5581 "synthetic stclass \"%s\".\n",
5582 SvPVX_const(sv));});
5585 /* A temporary algorithm prefers floated substr to fixed one to dig more info. */
5586 if (longest_fixed_length > longest_float_length) {
5587 r->check_end_shift = r->anchored_end_shift;
5588 r->check_substr = r->anchored_substr;
5589 r->check_utf8 = r->anchored_utf8;
5590 r->check_offset_min = r->check_offset_max = r->anchored_offset;
5591 if (r->extflags & RXf_ANCH_SINGLE)
5592 r->extflags |= RXf_NOSCAN;
5595 r->check_end_shift = r->float_end_shift;
5596 r->check_substr = r->float_substr;
5597 r->check_utf8 = r->float_utf8;
5598 r->check_offset_min = r->float_min_offset;
5599 r->check_offset_max = r->float_max_offset;
5601 /* XXXX Currently intuiting is not compatible with ANCH_GPOS.
5602 This should be changed ASAP! */
5603 if ((r->check_substr || r->check_utf8) && !(r->extflags & RXf_ANCH_GPOS)) {
5604 r->extflags |= RXf_USE_INTUIT;
5605 if (SvTAIL(r->check_substr ? r->check_substr : r->check_utf8))
5606 r->extflags |= RXf_INTUIT_TAIL;
5608 /* XXX Unneeded? dmq (shouldn't as this is handled elsewhere)
5609 if ( (STRLEN)minlen < longest_float_length )
5610 minlen= longest_float_length;
5611 if ( (STRLEN)minlen < longest_fixed_length )
5612 minlen= longest_fixed_length;
5616 /* Several toplevels. Best we can is to set minlen. */
5618 struct regnode_charclass_class ch_class;
5621 DEBUG_PARSE_r(PerlIO_printf(Perl_debug_log, "\nMulti Top Level\n"));
5623 scan = ri->program + 1;
5624 cl_init(pRExC_state, &ch_class);
5625 data.start_class = &ch_class;
5626 data.last_closep = &last_close;
5629 minlen = study_chunk(pRExC_state, &scan, &minlen, &fake, scan + RExC_size,
5630 &data, -1, NULL, NULL, SCF_DO_STCLASS_AND|SCF_WHILEM_VISITED_POS,0);
5634 r->check_substr = r->check_utf8 = r->anchored_substr = r->anchored_utf8
5635 = r->float_substr = r->float_utf8 = NULL;
5637 if (!(data.start_class->flags & ANYOF_EOS)
5638 && !cl_is_anything(data.start_class))
5640 const U32 n = add_data(pRExC_state, 1, "f");
5641 data.start_class->flags |= ANYOF_IS_SYNTHETIC;
5643 Newx(RExC_rxi->data->data[n], 1,
5644 struct regnode_charclass_class);
5645 StructCopy(data.start_class,
5646 (struct regnode_charclass_class*)RExC_rxi->data->data[n],
5647 struct regnode_charclass_class);
5648 ri->regstclass = (regnode*)RExC_rxi->data->data[n];
5649 r->intflags &= ~PREGf_SKIP; /* Used in find_byclass(). */
5650 DEBUG_COMPILE_r({ SV* sv = sv_newmortal();
5651 regprop(r, sv, (regnode*)data.start_class);
5652 PerlIO_printf(Perl_debug_log,
5653 "synthetic stclass \"%s\".\n",
5654 SvPVX_const(sv));});
5658 /* Guard against an embedded (?=) or (?<=) with a longer minlen than
5659 the "real" pattern. */
5661 PerlIO_printf(Perl_debug_log,"minlen: %"IVdf" r->minlen:%"IVdf"\n",
5662 (IV)minlen, (IV)r->minlen);
5664 r->minlenret = minlen;
5665 if (r->minlen < minlen)
5668 if (RExC_seen & REG_SEEN_GPOS)
5669 r->extflags |= RXf_GPOS_SEEN;
5670 if (RExC_seen & REG_SEEN_LOOKBEHIND)
5671 r->extflags |= RXf_LOOKBEHIND_SEEN;
5672 if (RExC_seen & REG_SEEN_EVAL)
5673 r->extflags |= RXf_EVAL_SEEN;
5674 if (RExC_seen & REG_SEEN_CANY)
5675 r->extflags |= RXf_CANY_SEEN;
5676 if (RExC_seen & REG_SEEN_VERBARG)
5677 r->intflags |= PREGf_VERBARG_SEEN;
5678 if (RExC_seen & REG_SEEN_CUTGROUP)
5679 r->intflags |= PREGf_CUTGROUP_SEEN;
5680 if (RExC_paren_names)
5681 RXp_PAREN_NAMES(r) = MUTABLE_HV(SvREFCNT_inc(RExC_paren_names));
5683 RXp_PAREN_NAMES(r) = NULL;
5685 #ifdef STUPID_PATTERN_CHECKS
5686 if (RX_PRELEN(rx) == 0)
5687 r->extflags |= RXf_NULL;
5688 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5689 /* XXX: this should happen BEFORE we compile */
5690 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5691 else if (RX_PRELEN(rx) == 3 && memEQ("\\s+", RX_PRECOMP(rx), 3))
5692 r->extflags |= RXf_WHITE;
5693 else if (RX_PRELEN(rx) == 1 && RXp_PRECOMP(rx)[0] == '^')
5694 r->extflags |= RXf_START_ONLY;
5696 if (r->extflags & RXf_SPLIT && RX_PRELEN(rx) == 1 && RX_PRECOMP(rx)[0] == ' ')
5697 /* XXX: this should happen BEFORE we compile */
5698 r->extflags |= (RXf_SKIPWHITE|RXf_WHITE);
5700 regnode *first = ri->program + 1;
5703 if (PL_regkind[fop] == NOTHING && OP(NEXTOPER(first)) == END)
5704 r->extflags |= RXf_NULL;
5705 else if (PL_regkind[fop] == BOL && OP(NEXTOPER(first)) == END)
5706 r->extflags |= RXf_START_ONLY;
5707 else if (fop == PLUS && OP(NEXTOPER(first)) == SPACE
5708 && OP(regnext(first)) == END)
5709 r->extflags |= RXf_WHITE;
5713 if (RExC_paren_names) {
5714 ri->name_list_idx = add_data( pRExC_state, 1, "a" );
5715 ri->data->data[ri->name_list_idx] = (void*)SvREFCNT_inc(RExC_paren_name_list);
5718 ri->name_list_idx = 0;
5720 if (RExC_recurse_count) {
5721 for ( ; RExC_recurse_count ; RExC_recurse_count-- ) {
5722 const regnode *scan = RExC_recurse[RExC_recurse_count-1];
5723 ARG2L_SET( scan, RExC_open_parens[ARG(scan)-1] - scan );
5726 Newxz(r->offs, RExC_npar, regexp_paren_pair);
5727 /* assume we don't need to swap parens around before we match */
5730 PerlIO_printf(Perl_debug_log,"Final program:\n");
5733 #ifdef RE_TRACK_PATTERN_OFFSETS
5734 DEBUG_OFFSETS_r(if (ri->u.offsets) {
5735 const U32 len = ri->u.offsets[0];
5737 GET_RE_DEBUG_FLAGS_DECL;
5738 PerlIO_printf(Perl_debug_log, "Offsets: [%"UVuf"]\n\t", (UV)ri->u.offsets[0]);
5739 for (i = 1; i <= len; i++) {
5740 if (ri->u.offsets[i*2-1] || ri->u.offsets[i*2])
5741 PerlIO_printf(Perl_debug_log, "%"UVuf":%"UVuf"[%"UVuf"] ",
5742 (UV)i, (UV)ri->u.offsets[i*2-1], (UV)ri->u.offsets[i*2]);
5744 PerlIO_printf(Perl_debug_log, "\n");
5750 #undef RE_ENGINE_PTR
5754 Perl_reg_named_buff(pTHX_ REGEXP * const rx, SV * const key, SV * const value,
5757 PERL_ARGS_ASSERT_REG_NAMED_BUFF;
5759 PERL_UNUSED_ARG(value);
5761 if (flags & RXapif_FETCH) {
5762 return reg_named_buff_fetch(rx, key, flags);
5763 } else if (flags & (RXapif_STORE | RXapif_DELETE | RXapif_CLEAR)) {
5764 Perl_croak_no_modify(aTHX);
5766 } else if (flags & RXapif_EXISTS) {
5767 return reg_named_buff_exists(rx, key, flags)
5770 } else if (flags & RXapif_REGNAMES) {
5771 return reg_named_buff_all(rx, flags);
5772 } else if (flags & (RXapif_SCALAR | RXapif_REGNAMES_COUNT)) {
5773 return reg_named_buff_scalar(rx, flags);
5775 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff", (int)flags);
5781 Perl_reg_named_buff_iter(pTHX_ REGEXP * const rx, const SV * const lastkey,
5784 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ITER;
5785 PERL_UNUSED_ARG(lastkey);
5787 if (flags & RXapif_FIRSTKEY)
5788 return reg_named_buff_firstkey(rx, flags);
5789 else if (flags & RXapif_NEXTKEY)
5790 return reg_named_buff_nextkey(rx, flags);
5792 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_iter", (int)flags);
5798 Perl_reg_named_buff_fetch(pTHX_ REGEXP * const r, SV * const namesv,
5801 AV *retarray = NULL;
5803 struct regexp *const rx = (struct regexp *)SvANY(r);
5805 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FETCH;
5807 if (flags & RXapif_ALL)
5810 if (rx && RXp_PAREN_NAMES(rx)) {
5811 HE *he_str = hv_fetch_ent( RXp_PAREN_NAMES(rx), namesv, 0, 0 );
5814 SV* sv_dat=HeVAL(he_str);
5815 I32 *nums=(I32*)SvPVX(sv_dat);
5816 for ( i=0; i<SvIVX(sv_dat); i++ ) {
5817 if ((I32)(rx->nparens) >= nums[i]
5818 && rx->offs[nums[i]].start != -1
5819 && rx->offs[nums[i]].end != -1)
5822 CALLREG_NUMBUF_FETCH(r,nums[i],ret);
5827 ret = newSVsv(&PL_sv_undef);
5830 av_push(retarray, ret);
5833 return newRV_noinc(MUTABLE_SV(retarray));
5840 Perl_reg_named_buff_exists(pTHX_ REGEXP * const r, SV * const key,
5843 struct regexp *const rx = (struct regexp *)SvANY(r);
5845 PERL_ARGS_ASSERT_REG_NAMED_BUFF_EXISTS;
5847 if (rx && RXp_PAREN_NAMES(rx)) {
5848 if (flags & RXapif_ALL) {
5849 return hv_exists_ent(RXp_PAREN_NAMES(rx), key, 0);
5851 SV *sv = CALLREG_NAMED_BUFF_FETCH(r, key, flags);
5865 Perl_reg_named_buff_firstkey(pTHX_ REGEXP * const r, const U32 flags)
5867 struct regexp *const rx = (struct regexp *)SvANY(r);
5869 PERL_ARGS_ASSERT_REG_NAMED_BUFF_FIRSTKEY;
5871 if ( rx && RXp_PAREN_NAMES(rx) ) {
5872 (void)hv_iterinit(RXp_PAREN_NAMES(rx));
5874 return CALLREG_NAMED_BUFF_NEXTKEY(r, NULL, flags & ~RXapif_FIRSTKEY);
5881 Perl_reg_named_buff_nextkey(pTHX_ REGEXP * const r, const U32 flags)
5883 struct regexp *const rx = (struct regexp *)SvANY(r);
5884 GET_RE_DEBUG_FLAGS_DECL;
5886 PERL_ARGS_ASSERT_REG_NAMED_BUFF_NEXTKEY;
5888 if (rx && RXp_PAREN_NAMES(rx)) {
5889 HV *hv = RXp_PAREN_NAMES(rx);
5891 while ( (temphe = hv_iternext_flags(hv,0)) ) {
5894 SV* sv_dat = HeVAL(temphe);
5895 I32 *nums = (I32*)SvPVX(sv_dat);
5896 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5897 if ((I32)(rx->lastparen) >= nums[i] &&
5898 rx->offs[nums[i]].start != -1 &&
5899 rx->offs[nums[i]].end != -1)
5905 if (parno || flags & RXapif_ALL) {
5906 return newSVhek(HeKEY_hek(temphe));
5914 Perl_reg_named_buff_scalar(pTHX_ REGEXP * const r, const U32 flags)
5919 struct regexp *const rx = (struct regexp *)SvANY(r);
5921 PERL_ARGS_ASSERT_REG_NAMED_BUFF_SCALAR;
5923 if (rx && RXp_PAREN_NAMES(rx)) {
5924 if (flags & (RXapif_ALL | RXapif_REGNAMES_COUNT)) {
5925 return newSViv(HvTOTALKEYS(RXp_PAREN_NAMES(rx)));
5926 } else if (flags & RXapif_ONE) {
5927 ret = CALLREG_NAMED_BUFF_ALL(r, (flags | RXapif_REGNAMES));
5928 av = MUTABLE_AV(SvRV(ret));
5929 length = av_len(av);
5931 return newSViv(length + 1);
5933 Perl_croak(aTHX_ "panic: Unknown flags %d in named_buff_scalar", (int)flags);
5937 return &PL_sv_undef;
5941 Perl_reg_named_buff_all(pTHX_ REGEXP * const r, const U32 flags)
5943 struct regexp *const rx = (struct regexp *)SvANY(r);
5946 PERL_ARGS_ASSERT_REG_NAMED_BUFF_ALL;
5948 if (rx && RXp_PAREN_NAMES(rx)) {
5949 HV *hv= RXp_PAREN_NAMES(rx);
5951 (void)hv_iterinit(hv);
5952 while ( (temphe = hv_iternext_flags(hv,0)) ) {
5955 SV* sv_dat = HeVAL(temphe);
5956 I32 *nums = (I32*)SvPVX(sv_dat);
5957 for ( i = 0; i < SvIVX(sv_dat); i++ ) {
5958 if ((I32)(rx->lastparen) >= nums[i] &&
5959 rx->offs[nums[i]].start != -1 &&
5960 rx->offs[nums[i]].end != -1)
5966 if (parno || flags & RXapif_ALL) {
5967 av_push(av, newSVhek(HeKEY_hek(temphe)));
5972 return newRV_noinc(MUTABLE_SV(av));
5976 Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren,
5979 struct regexp *const rx = (struct regexp *)SvANY(r);
5984 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_FETCH;
5987 sv_setsv(sv,&PL_sv_undef);
5991 if (paren == RX_BUFF_IDX_PREMATCH && rx->offs[0].start != -1) {
5993 i = rx->offs[0].start;
5997 if (paren == RX_BUFF_IDX_POSTMATCH && rx->offs[0].end != -1) {
5999 s = rx->subbeg + rx->offs[0].end;
6000 i = rx->sublen - rx->offs[0].end;
6003 if ( 0 <= paren && paren <= (I32)rx->nparens &&
6004 (s1 = rx->offs[paren].start) != -1 &&
6005 (t1 = rx->offs[paren].end) != -1)
6009 s = rx->subbeg + s1;
6011 sv_setsv(sv,&PL_sv_undef);
6014 assert(rx->sublen >= (s - rx->subbeg) + i );
6016 const int oldtainted = PL_tainted;
6018 sv_setpvn(sv, s, i);
6019 PL_tainted = oldtainted;
6020 if ( (rx->extflags & RXf_CANY_SEEN)
6021 ? (RXp_MATCH_UTF8(rx)
6022 && (!i || is_utf8_string((U8*)s, i)))
6023 : (RXp_MATCH_UTF8(rx)) )
6030 if (RXp_MATCH_TAINTED(rx)) {
6031 if (SvTYPE(sv) >= SVt_PVMG) {
6032 MAGIC* const mg = SvMAGIC(sv);
6035 SvMAGIC_set(sv, mg->mg_moremagic);
6037 if ((mgt = SvMAGIC(sv))) {
6038 mg->mg_moremagic = mgt;
6039 SvMAGIC_set(sv, mg);
6049 sv_setsv(sv,&PL_sv_undef);
6055 Perl_reg_numbered_buff_store(pTHX_ REGEXP * const rx, const I32 paren,
6056 SV const * const value)
6058 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_STORE;
6060 PERL_UNUSED_ARG(rx);
6061 PERL_UNUSED_ARG(paren);
6062 PERL_UNUSED_ARG(value);
6065 Perl_croak_no_modify(aTHX);
6069 Perl_reg_numbered_buff_length(pTHX_ REGEXP * const r, const SV * const sv,
6072 struct regexp *const rx = (struct regexp *)SvANY(r);
6076 PERL_ARGS_ASSERT_REG_NUMBERED_BUFF_LENGTH;
6078 /* Some of this code was originally in C<Perl_magic_len> in F<mg.c> */
6080 /* $` / ${^PREMATCH} */
6081 case RX_BUFF_IDX_PREMATCH:
6082 if (rx->offs[0].start != -1) {
6083 i = rx->offs[0].start;
6091 /* $' / ${^POSTMATCH} */
6092 case RX_BUFF_IDX_POSTMATCH:
6093 if (rx->offs[0].end != -1) {
6094 i = rx->sublen - rx->offs[0].end;
6096 s1 = rx->offs[0].end;
6102 /* $& / ${^MATCH}, $1, $2, ... */
6104 if (paren <= (I32)rx->nparens &&
6105 (s1 = rx->offs[paren].start) != -1 &&
6106 (t1 = rx->offs[paren].end) != -1)
6111 if (ckWARN(WARN_UNINITIALIZED))
6112 report_uninit((const SV *)sv);
6117 if (i > 0 && RXp_MATCH_UTF8(rx)) {
6118 const char * const s = rx->subbeg + s1;
6123 if (is_utf8_string_loclen((U8*)s, i, &ep, &el))
6130 Perl_reg_qr_package(pTHX_ REGEXP * const rx)
6132 PERL_ARGS_ASSERT_REG_QR_PACKAGE;
6133 PERL_UNUSED_ARG(rx);
6137 return newSVpvs("Regexp");
6140 /* Scans the name of a named buffer from the pattern.
6141 * If flags is REG_RSN_RETURN_NULL returns null.
6142 * If flags is REG_RSN_RETURN_NAME returns an SV* containing the name
6143 * If flags is REG_RSN_RETURN_DATA returns the data SV* corresponding
6144 * to the parsed name as looked up in the RExC_paren_names hash.
6145 * If there is an error throws a vFAIL().. type exception.
6148 #define REG_RSN_RETURN_NULL 0
6149 #define REG_RSN_RETURN_NAME 1
6150 #define REG_RSN_RETURN_DATA 2
6153 S_reg_scan_name(pTHX_ RExC_state_t *pRExC_state, U32 flags)
6155 char *name_start = RExC_parse;
6157 PERL_ARGS_ASSERT_REG_SCAN_NAME;
6159 if (isIDFIRST_lazy_if(RExC_parse, UTF)) {
6160 /* skip IDFIRST by using do...while */
6163 RExC_parse += UTF8SKIP(RExC_parse);
6164 } while (isALNUM_utf8((U8*)RExC_parse));
6168 } while (isALNUM(*RExC_parse));
6173 = newSVpvn_flags(name_start, (int)(RExC_parse - name_start),
6174 SVs_TEMP | (UTF ? SVf_UTF8 : 0));
6175 if ( flags == REG_RSN_RETURN_NAME)
6177 else if (flags==REG_RSN_RETURN_DATA) {
6180 if ( ! sv_name ) /* should not happen*/
6181 Perl_croak(aTHX_ "panic: no svname in reg_scan_name");
6182 if (RExC_paren_names)
6183 he_str = hv_fetch_ent( RExC_paren_names, sv_name, 0, 0 );
6185 sv_dat = HeVAL(he_str);
6187 vFAIL("Reference to nonexistent named group");
6191 Perl_croak(aTHX_ "panic: bad flag %lx in reg_scan_name",
6192 (unsigned long) flags);
6199 #define DEBUG_PARSE_MSG(funcname) DEBUG_PARSE_r({ \
6200 int rem=(int)(RExC_end - RExC_parse); \
6209 if (RExC_lastparse!=RExC_parse) \
6210 PerlIO_printf(Perl_debug_log," >%.*s%-*s", \
6213 iscut ? "..." : "<" \
6216 PerlIO_printf(Perl_debug_log,"%16s",""); \
6219 num = RExC_size + 1; \
6221 num=REG_NODE_NUM(RExC_emit); \
6222 if (RExC_lastnum!=num) \
6223 PerlIO_printf(Perl_debug_log,"|%4d",num); \
6225 PerlIO_printf(Perl_debug_log,"|%4s",""); \
6226 PerlIO_printf(Perl_debug_log,"|%*s%-4s", \
6227 (int)((depth*2)), "", \
6231 RExC_lastparse=RExC_parse; \
6236 #define DEBUG_PARSE(funcname) DEBUG_PARSE_r({ \
6237 DEBUG_PARSE_MSG((funcname)); \
6238 PerlIO_printf(Perl_debug_log,"%4s","\n"); \
6240 #define DEBUG_PARSE_FMT(funcname,fmt,args) DEBUG_PARSE_r({ \
6241 DEBUG_PARSE_MSG((funcname)); \
6242 PerlIO_printf(Perl_debug_log,fmt "\n",args); \
6245 /* This section of code defines the inversion list object and its methods. The
6246 * interfaces are highly subject to change, so as much as possible is static to
6247 * this file. An inversion list is here implemented as a malloc'd C UV array
6248 * with some added info that is placed as UVs at the beginning in a header
6249 * portion. An inversion list for Unicode is an array of code points, sorted
6250 * by ordinal number. The zeroth element is the first code point in the list.
6251 * The 1th element is the first element beyond that not in the list. In other
6252 * words, the first range is
6253 * invlist[0]..(invlist[1]-1)
6254 * The other ranges follow. Thus every element whose index is divisible by two
6255 * marks the beginning of a range that is in the list, and every element not
6256 * divisible by two marks the beginning of a range not in the list. A single
6257 * element inversion list that contains the single code point N generally
6258 * consists of two elements
6261 * (The exception is when N is the highest representable value on the
6262 * machine, in which case the list containing just it would be a single
6263 * element, itself. By extension, if the last range in the list extends to
6264 * infinity, then the first element of that range will be in the inversion list
6265 * at a position that is divisible by two, and is the final element in the
6267 * Taking the complement (inverting) an inversion list is quite simple, if the
6268 * first element is 0, remove it; otherwise add a 0 element at the beginning.
6269 * This implementation reserves an element at the beginning of each inversion list
6270 * to contain 0 when the list contains 0, and contains 1 otherwise. The actual
6271 * beginning of the list is either that element if 0, or the next one if 1.
6273 * More about inversion lists can be found in "Unicode Demystified"
6274 * Chapter 13 by Richard Gillam, published by Addison-Wesley.
6275 * More will be coming when functionality is added later.
6277 * The inversion list data structure is currently implemented as an SV pointing
6278 * to an array of UVs that the SV thinks are bytes. This allows us to have an
6279 * array of UV whose memory management is automatically handled by the existing
6280 * facilities for SV's.
6282 * Some of the methods should always be private to the implementation, and some
6283 * should eventually be made public */
6285 #define INVLIST_LEN_OFFSET 0 /* Number of elements in the inversion list */
6286 #define INVLIST_ITER_OFFSET 1 /* Current iteration position */
6288 /* This is a combination of a version and data structure type, so that one
6289 * being passed in can be validated to be an inversion list of the correct
6290 * vintage. When the structure of the header is changed, a new random number
6291 * in the range 2**31-1 should be generated and the new() method changed to
6292 * insert that at this location. Then, if an auxiliary program doesn't change
6293 * correspondingly, it will be discovered immediately */
6294 #define INVLIST_VERSION_ID_OFFSET 2
6295 #define INVLIST_VERSION_ID 1064334010
6297 /* For safety, when adding new elements, remember to #undef them at the end of
6298 * the inversion list code section */
6300 #define INVLIST_ZERO_OFFSET 3 /* 0 or 1; must be last element in header */
6301 /* The UV at position ZERO contains either 0 or 1. If 0, the inversion list
6302 * contains the code point U+00000, and begins here. If 1, the inversion list
6303 * doesn't contain U+0000, and it begins at the next UV in the array.
6304 * Inverting an inversion list consists of adding or removing the 0 at the
6305 * beginning of it. By reserving a space for that 0, inversion can be made
6308 #define HEADER_LENGTH (INVLIST_ZERO_OFFSET + 1)
6310 /* Internally things are UVs */
6311 #define TO_INTERNAL_SIZE(x) ((x + HEADER_LENGTH) * sizeof(UV))
6312 #define FROM_INTERNAL_SIZE(x) ((x / sizeof(UV)) - HEADER_LENGTH)
6314 #define INVLIST_INITIAL_LEN 10
6316 PERL_STATIC_INLINE UV*
6317 S__invlist_array_init(pTHX_ SV* const invlist, const bool will_have_0)
6319 /* Returns a pointer to the first element in the inversion list's array.
6320 * This is called upon initialization of an inversion list. Where the
6321 * array begins depends on whether the list has the code point U+0000
6322 * in it or not. The other parameter tells it whether the code that
6323 * follows this call is about to put a 0 in the inversion list or not.
6324 * The first element is either the element with 0, if 0, or the next one,
6327 UV* zero = get_invlist_zero_addr(invlist);
6329 PERL_ARGS_ASSERT__INVLIST_ARRAY_INIT;
6332 assert(! *get_invlist_len_addr(invlist));
6334 /* 1^1 = 0; 1^0 = 1 */
6335 *zero = 1 ^ will_have_0;
6336 return zero + *zero;
6339 PERL_STATIC_INLINE UV*
6340 S_invlist_array(pTHX_ SV* const invlist)
6342 /* Returns the pointer to the inversion list's array. Every time the
6343 * length changes, this needs to be called in case malloc or realloc moved
6346 PERL_ARGS_ASSERT_INVLIST_ARRAY;
6348 /* Must not be empty. If these fail, you probably didn't check for <len>
6349 * being non-zero before trying to get the array */
6350 assert(*get_invlist_len_addr(invlist));
6351 assert(*get_invlist_zero_addr(invlist) == 0
6352 || *get_invlist_zero_addr(invlist) == 1);
6354 /* The array begins either at the element reserved for zero if the
6355 * list contains 0 (that element will be set to 0), or otherwise the next
6356 * element (in which case the reserved element will be set to 1). */
6357 return (UV *) (get_invlist_zero_addr(invlist)
6358 + *get_invlist_zero_addr(invlist));
6361 PERL_STATIC_INLINE UV*
6362 S_get_invlist_len_addr(pTHX_ SV* invlist)
6364 /* Return the address of the UV that contains the current number
6365 * of used elements in the inversion list */
6367 PERL_ARGS_ASSERT_GET_INVLIST_LEN_ADDR;
6369 return (UV *) (SvPVX(invlist) + (INVLIST_LEN_OFFSET * sizeof (UV)));
6372 PERL_STATIC_INLINE UV
6373 S_invlist_len(pTHX_ SV* const invlist)
6375 /* Returns the current number of elements stored in the inversion list's
6378 PERL_ARGS_ASSERT_INVLIST_LEN;
6380 return *get_invlist_len_addr(invlist);
6383 PERL_STATIC_INLINE void
6384 S_invlist_set_len(pTHX_ SV* const invlist, const UV len)
6386 /* Sets the current number of elements stored in the inversion list */
6388 PERL_ARGS_ASSERT_INVLIST_SET_LEN;
6390 *get_invlist_len_addr(invlist) = len;
6392 assert(len <= SvLEN(invlist));
6394 SvCUR_set(invlist, TO_INTERNAL_SIZE(len));
6395 /* If the list contains U+0000, that element is part of the header,
6396 * and should not be counted as part of the array. It will contain
6397 * 0 in that case, and 1 otherwise. So we could flop 0=>1, 1=>0 and
6399 * SvCUR_set(invlist,
6400 * TO_INTERNAL_SIZE(len
6401 * - (*get_invlist_zero_addr(inv_list) ^ 1)));
6402 * But, this is only valid if len is not 0. The consequences of not doing
6403 * this is that the memory allocation code may think that 1 more UV is
6404 * being used than actually is, and so might do an unnecessary grow. That
6405 * seems worth not bothering to make this the precise amount.
6407 * Note that when inverting, SvCUR shouldn't change */
6410 PERL_STATIC_INLINE UV
6411 S_invlist_max(pTHX_ SV* const invlist)
6413 /* Returns the maximum number of elements storable in the inversion list's
6414 * array, without having to realloc() */
6416 PERL_ARGS_ASSERT_INVLIST_MAX;
6418 return FROM_INTERNAL_SIZE(SvLEN(invlist));
6421 PERL_STATIC_INLINE UV*
6422 S_get_invlist_zero_addr(pTHX_ SV* invlist)
6424 /* Return the address of the UV that is reserved to hold 0 if the inversion
6425 * list contains 0. This has to be the last element of the heading, as the
6426 * list proper starts with either it if 0, or the next element if not.
6427 * (But we force it to contain either 0 or 1) */
6429 PERL_ARGS_ASSERT_GET_INVLIST_ZERO_ADDR;
6431 return (UV *) (SvPVX(invlist) + (INVLIST_ZERO_OFFSET * sizeof (UV)));
6434 #ifndef PERL_IN_XSUB_RE
6436 Perl__new_invlist(pTHX_ IV initial_size)
6439 /* Return a pointer to a newly constructed inversion list, with enough
6440 * space to store 'initial_size' elements. If that number is negative, a
6441 * system default is used instead */
6445 if (initial_size < 0) {
6446 initial_size = INVLIST_INITIAL_LEN;
6449 /* Allocate the initial space */
6450 new_list = newSV(TO_INTERNAL_SIZE(initial_size));
6451 invlist_set_len(new_list, 0);
6453 /* Force iterinit() to be used to get iteration to work */
6454 *get_invlist_iter_addr(new_list) = UV_MAX;
6456 /* This should force a segfault if a method doesn't initialize this
6458 *get_invlist_zero_addr(new_list) = UV_MAX;
6460 *get_invlist_version_id_addr(new_list) = INVLIST_VERSION_ID;
6461 #if HEADER_LENGTH != 4
6462 # 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
6470 S__new_invlist_C_array(pTHX_ UV* list)
6472 /* Return a pointer to a newly constructed inversion list, initialized to
6473 * point to <list>, which has to be in the exact correct inversion list
6474 * form, including internal fields. Thus this is a dangerous routine that
6475 * should not be used in the wrong hands */
6477 SV* invlist = newSV_type(SVt_PV);
6479 PERL_ARGS_ASSERT__NEW_INVLIST_C_ARRAY;
6481 SvPV_set(invlist, (char *) list);
6482 SvLEN_set(invlist, 0); /* Means we own the contents, and the system
6483 shouldn't touch it */
6484 SvCUR_set(invlist, TO_INTERNAL_SIZE(invlist_len(invlist)));
6486 if (*get_invlist_version_id_addr(invlist) != INVLIST_VERSION_ID) {
6487 Perl_croak(aTHX_ "panic: Incorrect version for previously generated inversion list");
6494 S_invlist_extend(pTHX_ SV* const invlist, const UV new_max)
6496 /* Grow the maximum size of an inversion list */
6498 PERL_ARGS_ASSERT_INVLIST_EXTEND;
6500 SvGROW((SV *)invlist, TO_INTERNAL_SIZE(new_max));
6503 PERL_STATIC_INLINE void
6504 S_invlist_trim(pTHX_ SV* const invlist)
6506 PERL_ARGS_ASSERT_INVLIST_TRIM;
6508 /* Change the length of the inversion list to how many entries it currently
6511 SvPV_shrink_to_cur((SV *) invlist);
6514 /* An element is in an inversion list iff its index is even numbered: 0, 2, 4,
6516 #define ELEMENT_RANGE_MATCHES_INVLIST(i) (! ((i) & 1))
6517 #define PREV_RANGE_MATCHES_INVLIST(i) (! ELEMENT_RANGE_MATCHES_INVLIST(i))
6519 #define _invlist_union_complement_2nd(a, b, output) _invlist_union_maybe_complement_2nd(a, b, TRUE, output)
6521 #ifndef PERL_IN_XSUB_RE
6523 Perl__append_range_to_invlist(pTHX_ SV* const invlist, const UV start, const UV end)
6525 /* Subject to change or removal. Append the range from 'start' to 'end' at
6526 * the end of the inversion list. The range must be above any existing
6530 UV max = invlist_max(invlist);
6531 UV len = invlist_len(invlist);
6533 PERL_ARGS_ASSERT__APPEND_RANGE_TO_INVLIST;
6535 if (len == 0) { /* Empty lists must be initialized */
6536 array = _invlist_array_init(invlist, start == 0);
6539 /* Here, the existing list is non-empty. The current max entry in the
6540 * list is generally the first value not in the set, except when the
6541 * set extends to the end of permissible values, in which case it is
6542 * the first entry in that final set, and so this call is an attempt to
6543 * append out-of-order */
6545 UV final_element = len - 1;
6546 array = invlist_array(invlist);
6547 if (array[final_element] > start
6548 || ELEMENT_RANGE_MATCHES_INVLIST(final_element))
6550 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",
6551 array[final_element], start,
6552 ELEMENT_RANGE_MATCHES_INVLIST(final_element) ? 't' : 'f');
6555 /* Here, it is a legal append. If the new range begins with the first
6556 * value not in the set, it is extending the set, so the new first
6557 * value not in the set is one greater than the newly extended range.
6559 if (array[final_element] == start) {
6560 if (end != UV_MAX) {
6561 array[final_element] = end + 1;
6564 /* But if the end is the maximum representable on the machine,
6565 * just let the range that this would extend to have no end */
6566 invlist_set_len(invlist, len - 1);
6572 /* Here the new range doesn't extend any existing set. Add it */
6574 len += 2; /* Includes an element each for the start and end of range */
6576 /* If overflows the existing space, extend, which may cause the array to be
6579 invlist_extend(invlist, len);
6580 invlist_set_len(invlist, len); /* Have to set len here to avoid assert
6581 failure in invlist_array() */
6582 array = invlist_array(invlist);
6585 invlist_set_len(invlist, len);
6588 /* The next item on the list starts the range, the one after that is
6589 * one past the new range. */
6590 array[len - 2] = start;
6591 if (end != UV_MAX) {
6592 array[len - 1] = end + 1;
6595 /* But if the end is the maximum representable on the machine, just let
6596 * the range have no end */
6597 invlist_set_len(invlist, len - 1);
6602 S_invlist_search(pTHX_ SV* const invlist, const UV cp)
6604 /* Searches the inversion list for the entry that contains the input code
6605 * point <cp>. If <cp> is not in the list, -1 is returned. Otherwise, the
6606 * return value is the index into the list's array of the range that
6610 IV high = invlist_len(invlist);
6611 const UV * const array = invlist_array(invlist);
6613 PERL_ARGS_ASSERT_INVLIST_SEARCH;
6615 /* If list is empty or the code point is before the first element, return
6617 if (high == 0 || cp < array[0]) {
6621 /* Binary search. What we are looking for is <i> such that
6622 * array[i] <= cp < array[i+1]
6623 * The loop below converges on the i+1. */
6624 while (low < high) {
6625 IV mid = (low + high) / 2;
6626 if (array[mid] <= cp) {
6629 /* We could do this extra test to exit the loop early.
6630 if (cp < array[low]) {
6635 else { /* cp < array[mid] */
6644 Perl__invlist_populate_swatch(pTHX_ SV* const invlist, const UV start, const UV end, U8* swatch)
6646 /* populates a swatch of a swash the same way swatch_get() does in utf8.c,
6647 * but is used when the swash has an inversion list. This makes this much
6648 * faster, as it uses a binary search instead of a linear one. This is
6649 * intimately tied to that function, and perhaps should be in utf8.c,
6650 * except it is intimately tied to inversion lists as well. It assumes
6651 * that <swatch> is all 0's on input */
6654 const IV len = invlist_len(invlist);
6658 PERL_ARGS_ASSERT__INVLIST_POPULATE_SWATCH;
6660 if (len == 0) { /* Empty inversion list */
6664 array = invlist_array(invlist);
6666 /* Find which element it is */
6667 i = invlist_search(invlist, start);
6669 /* We populate from <start> to <end> */
6670 while (current < end) {
6673 /* The inversion list gives the results for every possible code point
6674 * after the first one in the list. Only those ranges whose index is
6675 * even are ones that the inversion list matches. For the odd ones,
6676 * and if the initial code point is not in the list, we have to skip
6677 * forward to the next element */
6678 if (i == -1 || ! ELEMENT_RANGE_MATCHES_INVLIST(i)) {
6680 if (i >= len) { /* Finished if beyond the end of the array */
6684 if (current >= end) { /* Finished if beyond the end of what we
6689 assert(current >= start);
6691 /* The current range ends one below the next one, except don't go past
6694 upper = (i < len && array[i] < end) ? array[i] : end;
6696 /* Here we are in a range that matches. Populate a bit in the 3-bit U8
6697 * for each code point in it */
6698 for (; current < upper; current++) {
6699 const STRLEN offset = (STRLEN)(current - start);
6700 swatch[offset >> 3] |= 1 << (offset & 7);
6703 /* Quit if at the end of the list */
6706 /* But first, have to deal with the highest possible code point on
6707 * the platform. The previous code assumes that <end> is one
6708 * beyond where we want to populate, but that is impossible at the
6709 * platform's infinity, so have to handle it specially */
6710 if (UNLIKELY(end == UV_MAX && ELEMENT_RANGE_MATCHES_INVLIST(len-1)))
6712 const STRLEN offset = (STRLEN)(end - start);
6713 swatch[offset >> 3] |= 1 << (offset & 7);
6718 /* Advance to the next range, which will be for code points not in the
6728 Perl__invlist_union_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** output)
6730 /* Take the union of two inversion lists and point <output> to it. *output
6731 * should be defined upon input, and if it points to one of the two lists,
6732 * the reference count to that list will be decremented. The first list,
6733 * <a>, may be NULL, in which case a copy of the second list is returned.
6734 * If <complement_b> is TRUE, the union is taken of the complement
6735 * (inversion) of <b> instead of b itself.
6737 * The basis for this comes from "Unicode Demystified" Chapter 13 by
6738 * Richard Gillam, published by Addison-Wesley, and explained at some
6739 * length there. The preface says to incorporate its examples into your
6740 * code at your own risk.
6742 * The algorithm is like a merge sort.
6744 * XXX A potential performance improvement is to keep track as we go along
6745 * if only one of the inputs contributes to the result, meaning the other
6746 * is a subset of that one. In that case, we can skip the final copy and
6747 * return the larger of the input lists, but then outside code might need
6748 * to keep track of whether to free the input list or not */
6750 UV* array_a; /* a's array */
6752 UV len_a; /* length of a's array */
6755 SV* u; /* the resulting union */
6759 UV i_a = 0; /* current index into a's array */
6763 /* running count, as explained in the algorithm source book; items are
6764 * stopped accumulating and are output when the count changes to/from 0.
6765 * The count is incremented when we start a range that's in the set, and
6766 * decremented when we start a range that's not in the set. So its range
6767 * is 0 to 2. Only when the count is zero is something not in the set.
6771 PERL_ARGS_ASSERT__INVLIST_UNION_MAYBE_COMPLEMENT_2ND;
6774 /* If either one is empty, the union is the other one */
6775 if (a == NULL || ((len_a = invlist_len(a)) == 0)) {
6782 *output = invlist_clone(b);
6784 _invlist_invert(*output);
6786 } /* else *output already = b; */
6789 else if ((len_b = invlist_len(b)) == 0) {
6794 /* The complement of an empty list is a list that has everything in it,
6795 * so the union with <a> includes everything too */
6800 *output = _new_invlist(1);
6801 _append_range_to_invlist(*output, 0, UV_MAX);
6803 else if (*output != a) {
6804 *output = invlist_clone(a);
6806 /* else *output already = a; */
6810 /* Here both lists exist and are non-empty */
6811 array_a = invlist_array(a);
6812 array_b = invlist_array(b);
6814 /* If are to take the union of 'a' with the complement of b, set it
6815 * up so are looking at b's complement. */
6818 /* To complement, we invert: if the first element is 0, remove it. To
6819 * do this, we just pretend the array starts one later, and clear the
6820 * flag as we don't have to do anything else later */
6821 if (array_b[0] == 0) {
6824 complement_b = FALSE;
6828 /* But if the first element is not zero, we unshift a 0 before the
6829 * array. The data structure reserves a space for that 0 (which
6830 * should be a '1' right now), so physical shifting is unneeded,
6831 * but temporarily change that element to 0. Before exiting the
6832 * routine, we must restore the element to '1' */
6839 /* Size the union for the worst case: that the sets are completely
6841 u = _new_invlist(len_a + len_b);
6843 /* Will contain U+0000 if either component does */
6844 array_u = _invlist_array_init(u, (len_a > 0 && array_a[0] == 0)
6845 || (len_b > 0 && array_b[0] == 0));
6847 /* Go through each list item by item, stopping when exhausted one of
6849 while (i_a < len_a && i_b < len_b) {
6850 UV cp; /* The element to potentially add to the union's array */
6851 bool cp_in_set; /* is it in the the input list's set or not */
6853 /* We need to take one or the other of the two inputs for the union.
6854 * Since we are merging two sorted lists, we take the smaller of the
6855 * next items. In case of a tie, we take the one that is in its set
6856 * first. If we took one not in the set first, it would decrement the
6857 * count, possibly to 0 which would cause it to be output as ending the
6858 * range, and the next time through we would take the same number, and
6859 * output it again as beginning the next range. By doing it the
6860 * opposite way, there is no possibility that the count will be
6861 * momentarily decremented to 0, and thus the two adjoining ranges will
6862 * be seamlessly merged. (In a tie and both are in the set or both not
6863 * in the set, it doesn't matter which we take first.) */
6864 if (array_a[i_a] < array_b[i_b]
6865 || (array_a[i_a] == array_b[i_b]
6866 && ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
6868 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
6872 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
6876 /* Here, have chosen which of the two inputs to look at. Only output
6877 * if the running count changes to/from 0, which marks the
6878 * beginning/end of a range in that's in the set */
6881 array_u[i_u++] = cp;
6888 array_u[i_u++] = cp;
6893 /* Here, we are finished going through at least one of the lists, which
6894 * means there is something remaining in at most one. We check if the list
6895 * that hasn't been exhausted is positioned such that we are in the middle
6896 * of a range in its set or not. (i_a and i_b point to the element beyond
6897 * the one we care about.) If in the set, we decrement 'count'; if 0, there
6898 * is potentially more to output.
6899 * There are four cases:
6900 * 1) Both weren't in their sets, count is 0, and remains 0. What's left
6901 * in the union is entirely from the non-exhausted set.
6902 * 2) Both were in their sets, count is 2. Nothing further should
6903 * be output, as everything that remains will be in the exhausted
6904 * list's set, hence in the union; decrementing to 1 but not 0 insures
6906 * 3) the exhausted was in its set, non-exhausted isn't, count is 1.
6907 * Nothing further should be output because the union includes
6908 * everything from the exhausted set. Not decrementing ensures that.
6909 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1;
6910 * decrementing to 0 insures that we look at the remainder of the
6911 * non-exhausted set */
6912 if ((i_a != len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
6913 || (i_b != len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
6918 /* The final length is what we've output so far, plus what else is about to
6919 * be output. (If 'count' is non-zero, then the input list we exhausted
6920 * has everything remaining up to the machine's limit in its set, and hence
6921 * in the union, so there will be no further output. */
6924 /* At most one of the subexpressions will be non-zero */
6925 len_u += (len_a - i_a) + (len_b - i_b);
6928 /* Set result to final length, which can change the pointer to array_u, so
6930 if (len_u != invlist_len(u)) {
6931 invlist_set_len(u, len_u);
6933 array_u = invlist_array(u);
6936 /* When 'count' is 0, the list that was exhausted (if one was shorter than
6937 * the other) ended with everything above it not in its set. That means
6938 * that the remaining part of the union is precisely the same as the
6939 * non-exhausted list, so can just copy it unchanged. (If both list were
6940 * exhausted at the same time, then the operations below will be both 0.)
6943 IV copy_count; /* At most one will have a non-zero copy count */
6944 if ((copy_count = len_a - i_a) > 0) {
6945 Copy(array_a + i_a, array_u + i_u, copy_count, UV);
6947 else if ((copy_count = len_b - i_b) > 0) {
6948 Copy(array_b + i_b, array_u + i_u, copy_count, UV);
6952 /* We may be removing a reference to one of the inputs */
6953 if (a == *output || b == *output) {
6954 SvREFCNT_dec(*output);
6957 /* If we've changed b, restore it */
6967 Perl__invlist_intersection_maybe_complement_2nd(pTHX_ SV* const a, SV* const b, bool complement_b, SV** i)
6969 /* Take the intersection of two inversion lists and point <i> to it. *i
6970 * should be defined upon input, and if it points to one of the two lists,
6971 * the reference count to that list will be decremented.
6972 * If <complement_b> is TRUE, the result will be the intersection of <a>
6973 * and the complement (or inversion) of <b> instead of <b> directly.
6975 * The basis for this comes from "Unicode Demystified" Chapter 13 by
6976 * Richard Gillam, published by Addison-Wesley, and explained at some
6977 * length there. The preface says to incorporate its examples into your
6978 * code at your own risk. In fact, it had bugs
6980 * The algorithm is like a merge sort, and is essentially the same as the
6984 UV* array_a; /* a's array */
6986 UV len_a; /* length of a's array */
6989 SV* r; /* the resulting intersection */
6993 UV i_a = 0; /* current index into a's array */
6997 /* running count, as explained in the algorithm source book; items are
6998 * stopped accumulating and are output when the count changes to/from 2.
6999 * The count is incremented when we start a range that's in the set, and
7000 * decremented when we start a range that's not in the set. So its range
7001 * is 0 to 2. Only when the count is 2 is something in the intersection.
7005 PERL_ARGS_ASSERT__INVLIST_INTERSECTION_MAYBE_COMPLEMENT_2ND;
7008 /* Special case if either one is empty */
7009 len_a = invlist_len(a);
7010 if ((len_a == 0) || ((len_b = invlist_len(b)) == 0)) {
7012 if (len_a != 0 && complement_b) {
7014 /* Here, 'a' is not empty, therefore from the above 'if', 'b' must
7015 * be empty. Here, also we are using 'b's complement, which hence
7016 * must be every possible code point. Thus the intersection is
7019 *i = invlist_clone(a);
7025 /* else *i is already 'a' */
7029 /* Here, 'a' or 'b' is empty and not using the complement of 'b'. The
7030 * intersection must be empty */
7037 *i = _new_invlist(0);
7041 /* Here both lists exist and are non-empty */
7042 array_a = invlist_array(a);
7043 array_b = invlist_array(b);
7045 /* If are to take the intersection of 'a' with the complement of b, set it
7046 * up so are looking at b's complement. */
7049 /* To complement, we invert: if the first element is 0, remove it. To
7050 * do this, we just pretend the array starts one later, and clear the
7051 * flag as we don't have to do anything else later */
7052 if (array_b[0] == 0) {
7055 complement_b = FALSE;
7059 /* But if the first element is not zero, we unshift a 0 before the
7060 * array. The data structure reserves a space for that 0 (which
7061 * should be a '1' right now), so physical shifting is unneeded,
7062 * but temporarily change that element to 0. Before exiting the
7063 * routine, we must restore the element to '1' */
7070 /* Size the intersection for the worst case: that the intersection ends up
7071 * fragmenting everything to be completely disjoint */
7072 r= _new_invlist(len_a + len_b);
7074 /* Will contain U+0000 iff both components do */
7075 array_r = _invlist_array_init(r, len_a > 0 && array_a[0] == 0
7076 && len_b > 0 && array_b[0] == 0);
7078 /* Go through each list item by item, stopping when exhausted one of
7080 while (i_a < len_a && i_b < len_b) {
7081 UV cp; /* The element to potentially add to the intersection's
7083 bool cp_in_set; /* Is it in the input list's set or not */
7085 /* We need to take one or the other of the two inputs for the
7086 * intersection. Since we are merging two sorted lists, we take the
7087 * smaller of the next items. In case of a tie, we take the one that
7088 * is not in its set first (a difference from the union algorithm). If
7089 * we took one in the set first, it would increment the count, possibly
7090 * to 2 which would cause it to be output as starting a range in the
7091 * intersection, and the next time through we would take that same
7092 * number, and output it again as ending the set. By doing it the
7093 * opposite of this, there is no possibility that the count will be
7094 * momentarily incremented to 2. (In a tie and both are in the set or
7095 * both not in the set, it doesn't matter which we take first.) */
7096 if (array_a[i_a] < array_b[i_b]
7097 || (array_a[i_a] == array_b[i_b]
7098 && ! ELEMENT_RANGE_MATCHES_INVLIST(i_a)))
7100 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_a);
7104 cp_in_set = ELEMENT_RANGE_MATCHES_INVLIST(i_b);
7108 /* Here, have chosen which of the two inputs to look at. Only output
7109 * if the running count changes to/from 2, which marks the
7110 * beginning/end of a range that's in the intersection */
7114 array_r[i_r++] = cp;
7119 array_r[i_r++] = cp;
7125 /* Here, we are finished going through at least one of the lists, which
7126 * means there is something remaining in at most one. We check if the list
7127 * that has been exhausted is positioned such that we are in the middle
7128 * of a range in its set or not. (i_a and i_b point to elements 1 beyond
7129 * the ones we care about.) There are four cases:
7130 * 1) Both weren't in their sets, count is 0, and remains 0. There's
7131 * nothing left in the intersection.
7132 * 2) Both were in their sets, count is 2 and perhaps is incremented to
7133 * above 2. What should be output is exactly that which is in the
7134 * non-exhausted set, as everything it has is also in the intersection
7135 * set, and everything it doesn't have can't be in the intersection
7136 * 3) The exhausted was in its set, non-exhausted isn't, count is 1, and
7137 * gets incremented to 2. Like the previous case, the intersection is
7138 * everything that remains in the non-exhausted set.
7139 * 4) the exhausted wasn't in its set, non-exhausted is, count is 1, and
7140 * remains 1. And the intersection has nothing more. */
7141 if ((i_a == len_a && PREV_RANGE_MATCHES_INVLIST(i_a))
7142 || (i_b == len_b && PREV_RANGE_MATCHES_INVLIST(i_b)))
7147 /* The final length is what we've output so far plus what else is in the
7148 * intersection. At most one of the subexpressions below will be non-zero */
7151 len_r += (len_a - i_a) + (len_b - i_b);
7154 /* Set result to final length, which can change the pointer to array_r, so
7156 if (len_r != invlist_len(r)) {
7157 invlist_set_len(r, len_r);
7159 array_r = invlist_array(r);
7162 /* Finish outputting any remaining */
7163 if (count >= 2) { /* At most one will have a non-zero copy count */
7165 if ((copy_count = len_a - i_a) > 0) {
7166 Copy(array_a + i_a, array_r + i_r, copy_count, UV);
7168 else if ((copy_count = len_b - i_b) > 0) {
7169 Copy(array_b + i_b, array_r + i_r, copy_count, UV);
7173 /* We may be removing a reference to one of the inputs */
7174 if (a == *i || b == *i) {
7178 /* If we've changed b, restore it */
7190 S_add_range_to_invlist(pTHX_ SV* invlist, const UV start, const UV end)
7192 /* Add the range from 'start' to 'end' inclusive to the inversion list's
7193 * set. A pointer to the inversion list is returned. This may actually be
7194 * a new list, in which case the passed in one has been destroyed. The
7195 * passed in inversion list can be NULL, in which case a new one is created
7196 * with just the one range in it */
7201 if (invlist == NULL) {
7202 invlist = _new_invlist(2);
7206 len = invlist_len(invlist);
7209 /* If comes after the final entry, can just append it to the end */
7211 || start >= invlist_array(invlist)
7212 [invlist_len(invlist) - 1])
7214 _append_range_to_invlist(invlist, start, end);
7218 /* Here, can't just append things, create and return a new inversion list
7219 * which is the union of this range and the existing inversion list */
7220 range_invlist = _new_invlist(2);
7221 _append_range_to_invlist(range_invlist, start, end);
7223 _invlist_union(invlist, range_invlist, &invlist);
7225 /* The temporary can be freed */
7226 SvREFCNT_dec(range_invlist);
7231 PERL_STATIC_INLINE SV*
7232 S_add_cp_to_invlist(pTHX_ SV* invlist, const UV cp) {
7233 return add_range_to_invlist(invlist, cp, cp);
7236 #ifndef PERL_IN_XSUB_RE
7238 Perl__invlist_invert(pTHX_ SV* const invlist)
7240 /* Complement the input inversion list. This adds a 0 if the list didn't
7241 * have a zero; removes it otherwise. As described above, the data
7242 * structure is set up so that this is very efficient */
7244 UV* len_pos = get_invlist_len_addr(invlist);
7246 PERL_ARGS_ASSERT__INVLIST_INVERT;
7248 /* The inverse of matching nothing is matching everything */
7249 if (*len_pos == 0) {
7250 _append_range_to_invlist(invlist, 0, UV_MAX);
7254 /* The exclusive or complents 0 to 1; and 1 to 0. If the result is 1, the
7255 * zero element was a 0, so it is being removed, so the length decrements
7256 * by 1; and vice-versa. SvCUR is unaffected */
7257 if (*get_invlist_zero_addr(invlist) ^= 1) {
7266 Perl__invlist_invert_prop(pTHX_ SV* const invlist)
7268 /* Complement the input inversion list (which must be a Unicode property,
7269 * all of which don't match above the Unicode maximum code point.) And
7270 * Perl has chosen to not have the inversion match above that either. This
7271 * adds a 0x110000 if the list didn't end with it, and removes it if it did
7277 PERL_ARGS_ASSERT__INVLIST_INVERT_PROP;
7279 _invlist_invert(invlist);
7281 len = invlist_len(invlist);
7283 if (len != 0) { /* If empty do nothing */
7284 array = invlist_array(invlist);
7285 if (array[len - 1] != PERL_UNICODE_MAX + 1) {
7286 /* Add 0x110000. First, grow if necessary */
7288 if (invlist_max(invlist) < len) {
7289 invlist_extend(invlist, len);
7290 array = invlist_array(invlist);
7292 invlist_set_len(invlist, len);
7293 array[len - 1] = PERL_UNICODE_MAX + 1;
7295 else { /* Remove the 0x110000 */
7296 invlist_set_len(invlist, len - 1);
7304 PERL_STATIC_INLINE SV*
7305 S_invlist_clone(pTHX_ SV* const invlist)
7308 /* Return a new inversion list that is a copy of the input one, which is
7311 /* Need to allocate extra space to accommodate Perl's addition of a
7312 * trailing NUL to SvPV's, since it thinks they are always strings */
7313 SV* new_invlist = _new_invlist(invlist_len(invlist) + 1);
7314 STRLEN length = SvCUR(invlist);
7316 PERL_ARGS_ASSERT_INVLIST_CLONE;
7318 SvCUR_set(new_invlist, length); /* This isn't done automatically */
7319 Copy(SvPVX(invlist), SvPVX(new_invlist), length, char);
7324 PERL_STATIC_INLINE UV*
7325 S_get_invlist_iter_addr(pTHX_ SV* invlist)
7327 /* Return the address of the UV that contains the current iteration
7330 PERL_ARGS_ASSERT_GET_INVLIST_ITER_ADDR;
7332 return (UV *) (SvPVX(invlist) + (INVLIST_ITER_OFFSET * sizeof (UV)));
7335 PERL_STATIC_INLINE UV*
7336 S_get_invlist_version_id_addr(pTHX_ SV* invlist)
7338 /* Return the address of the UV that contains the version id. */
7340 PERL_ARGS_ASSERT_GET_INVLIST_VERSION_ID_ADDR;
7342 return (UV *) (SvPVX(invlist) + (INVLIST_VERSION_ID_OFFSET * sizeof (UV)));
7345 PERL_STATIC_INLINE void
7346 S_invlist_iterinit(pTHX_ SV* invlist) /* Initialize iterator for invlist */
7348 PERL_ARGS_ASSERT_INVLIST_ITERINIT;
7350 *get_invlist_iter_addr(invlist) = 0;
7354 S_invlist_iternext(pTHX_ SV* invlist, UV* start, UV* end)
7356 /* An C<invlist_iterinit> call on <invlist> must be used to set this up.
7357 * This call sets in <*start> and <*end>, the next range in <invlist>.
7358 * Returns <TRUE> if successful and the next call will return the next
7359 * range; <FALSE> if was already at the end of the list. If the latter,
7360 * <*start> and <*end> are unchanged, and the next call to this function
7361 * will start over at the beginning of the list */
7363 UV* pos = get_invlist_iter_addr(invlist);
7364 UV len = invlist_len(invlist);
7367 PERL_ARGS_ASSERT_INVLIST_ITERNEXT;
7370 *pos = UV_MAX; /* Force iternit() to be required next time */
7374 array = invlist_array(invlist);
7376 *start = array[(*pos)++];
7382 *end = array[(*pos)++] - 1;
7388 #ifndef PERL_IN_XSUB_RE
7390 Perl__invlist_contents(pTHX_ SV* const invlist)
7392 /* Get the contents of an inversion list into a string SV so that they can
7393 * be printed out. It uses the format traditionally done for debug tracing
7397 SV* output = newSVpvs("\n");
7399 PERL_ARGS_ASSERT__INVLIST_CONTENTS;
7401 invlist_iterinit(invlist);
7402 while (invlist_iternext(invlist, &start, &end)) {
7403 if (end == UV_MAX) {
7404 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\tINFINITY\n", start);
7406 else if (end != start) {
7407 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\t%04"UVXf"\n",
7411 Perl_sv_catpvf(aTHX_ output, "%04"UVXf"\n", start);
7421 S_invlist_dump(pTHX_ SV* const invlist, const char * const header)
7423 /* Dumps out the ranges in an inversion list. The string 'header'
7424 * if present is output on a line before the first range */
7428 if (header && strlen(header)) {
7429 PerlIO_printf(Perl_debug_log, "%s\n", header);
7431 invlist_iterinit(invlist);
7432 while (invlist_iternext(invlist, &start, &end)) {
7433 if (end == UV_MAX) {
7434 PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. INFINITY\n", start);
7437 PerlIO_printf(Perl_debug_log, "0x%04"UVXf" .. 0x%04"UVXf"\n", start, end);
7443 #undef HEADER_LENGTH
7444 #undef INVLIST_INITIAL_LENGTH
7445 #undef TO_INTERNAL_SIZE
7446 #undef FROM_INTERNAL_SIZE
7447 #undef INVLIST_LEN_OFFSET
7448 #undef INVLIST_ZERO_OFFSET
7449 #undef INVLIST_ITER_OFFSET
7450 #undef INVLIST_VERSION_ID
7452 /* End of inversion list object */
7455 - reg - regular expression, i.e. main body or parenthesized thing
7457 * Caller must absorb opening parenthesis.
7459 * Combining parenthesis handling with the base level of regular expression
7460 * is a trifle forced, but the need to tie the tails of the branches to what
7461 * follows makes it hard to avoid.
7463 #define REGTAIL(x,y,z) regtail((x),(y),(z),depth+1)
7465 #define REGTAIL_STUDY(x,y,z) regtail_study((x),(y),(z),depth+1)
7467 #define REGTAIL_STUDY(x,y,z) regtail((x),(y),(z),depth+1)
7471 S_reg(pTHX_ RExC_state_t *pRExC_state, I32 paren, I32 *flagp,U32 depth)
7472 /* paren: Parenthesized? 0=top, 1=(, inside: changed to letter. */
7475 register regnode *ret; /* Will be the head of the group. */
7476 register regnode *br;
7477 register regnode *lastbr;
7478 register regnode *ender = NULL;
7479 register I32 parno = 0;
7481 U32 oregflags = RExC_flags;
7482 bool have_branch = 0;
7484 I32 freeze_paren = 0;
7485 I32 after_freeze = 0;
7487 /* for (?g), (?gc), and (?o) warnings; warning
7488 about (?c) will warn about (?g) -- japhy */
7490 #define WASTED_O 0x01
7491 #define WASTED_G 0x02
7492 #define WASTED_C 0x04
7493 #define WASTED_GC (0x02|0x04)
7494 I32 wastedflags = 0x00;
7496 char * parse_start = RExC_parse; /* MJD */
7497 char * const oregcomp_parse = RExC_parse;
7499 GET_RE_DEBUG_FLAGS_DECL;
7501 PERL_ARGS_ASSERT_REG;
7502 DEBUG_PARSE("reg ");
7504 *flagp = 0; /* Tentatively. */
7507 /* Make an OPEN node, if parenthesized. */
7509 if ( *RExC_parse == '*') { /* (*VERB:ARG) */
7510 char *start_verb = RExC_parse;
7511 STRLEN verb_len = 0;
7512 char *start_arg = NULL;
7513 unsigned char op = 0;
7515 int internal_argval = 0; /* internal_argval is only useful if !argok */
7516 while ( *RExC_parse && *RExC_parse != ')' ) {
7517 if ( *RExC_parse == ':' ) {
7518 start_arg = RExC_parse + 1;
7524 verb_len = RExC_parse - start_verb;
7527 while ( *RExC_parse && *RExC_parse != ')' )
7529 if ( *RExC_parse != ')' )
7530 vFAIL("Unterminated verb pattern argument");
7531 if ( RExC_parse == start_arg )
7534 if ( *RExC_parse != ')' )
7535 vFAIL("Unterminated verb pattern");
7538 switch ( *start_verb ) {
7539 case 'A': /* (*ACCEPT) */
7540 if ( memEQs(start_verb,verb_len,"ACCEPT") ) {
7542 internal_argval = RExC_nestroot;
7545 case 'C': /* (*COMMIT) */
7546 if ( memEQs(start_verb,verb_len,"COMMIT") )
7549 case 'F': /* (*FAIL) */
7550 if ( verb_len==1 || memEQs(start_verb,verb_len,"FAIL") ) {
7555 case ':': /* (*:NAME) */
7556 case 'M': /* (*MARK:NAME) */
7557 if ( verb_len==0 || memEQs(start_verb,verb_len,"MARK") ) {
7562 case 'P': /* (*PRUNE) */
7563 if ( memEQs(start_verb,verb_len,"PRUNE") )
7566 case 'S': /* (*SKIP) */
7567 if ( memEQs(start_verb,verb_len,"SKIP") )
7570 case 'T': /* (*THEN) */
7571 /* [19:06] <TimToady> :: is then */
7572 if ( memEQs(start_verb,verb_len,"THEN") ) {
7574 RExC_seen |= REG_SEEN_CUTGROUP;
7580 vFAIL3("Unknown verb pattern '%.*s'",
7581 verb_len, start_verb);
7584 if ( start_arg && internal_argval ) {
7585 vFAIL3("Verb pattern '%.*s' may not have an argument",
7586 verb_len, start_verb);
7587 } else if ( argok < 0 && !start_arg ) {
7588 vFAIL3("Verb pattern '%.*s' has a mandatory argument",
7589 verb_len, start_verb);
7591 ret = reganode(pRExC_state, op, internal_argval);
7592 if ( ! internal_argval && ! SIZE_ONLY ) {
7594 SV *sv = newSVpvn( start_arg, RExC_parse - start_arg);
7595 ARG(ret) = add_data( pRExC_state, 1, "S" );
7596 RExC_rxi->data->data[ARG(ret)]=(void*)sv;
7603 if (!internal_argval)
7604 RExC_seen |= REG_SEEN_VERBARG;
7605 } else if ( start_arg ) {
7606 vFAIL3("Verb pattern '%.*s' may not have an argument",
7607 verb_len, start_verb);
7609 ret = reg_node(pRExC_state, op);
7611 nextchar(pRExC_state);
7614 if (*RExC_parse == '?') { /* (?...) */
7615 bool is_logical = 0;
7616 const char * const seqstart = RExC_parse;
7617 bool has_use_defaults = FALSE;
7620 paren = *RExC_parse++;
7621 ret = NULL; /* For look-ahead/behind. */
7624 case 'P': /* (?P...) variants for those used to PCRE/Python */
7625 paren = *RExC_parse++;
7626 if ( paren == '<') /* (?P<...>) named capture */
7628 else if (paren == '>') { /* (?P>name) named recursion */
7629 goto named_recursion;
7631 else if (paren == '=') { /* (?P=...) named backref */
7632 /* this pretty much dupes the code for \k<NAME> in regatom(), if
7633 you change this make sure you change that */
7634 char* name_start = RExC_parse;
7636 SV *sv_dat = reg_scan_name(pRExC_state,
7637 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7638 if (RExC_parse == name_start || *RExC_parse != ')')
7639 vFAIL2("Sequence %.3s... not terminated",parse_start);
7642 num = add_data( pRExC_state, 1, "S" );
7643 RExC_rxi->data->data[num]=(void*)sv_dat;
7644 SvREFCNT_inc_simple_void(sv_dat);
7647 ret = reganode(pRExC_state,
7650 : (MORE_ASCII_RESTRICTED)
7652 : (AT_LEAST_UNI_SEMANTICS)
7660 Set_Node_Offset(ret, parse_start+1);
7661 Set_Node_Cur_Length(ret); /* MJD */
7663 nextchar(pRExC_state);
7667 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7669 case '<': /* (?<...) */
7670 if (*RExC_parse == '!')
7672 else if (*RExC_parse != '=')
7678 case '\'': /* (?'...') */
7679 name_start= RExC_parse;
7680 svname = reg_scan_name(pRExC_state,
7681 SIZE_ONLY ? /* reverse test from the others */
7682 REG_RSN_RETURN_NAME :
7683 REG_RSN_RETURN_NULL);
7684 if (RExC_parse == name_start) {
7686 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7689 if (*RExC_parse != paren)
7690 vFAIL2("Sequence (?%c... not terminated",
7691 paren=='>' ? '<' : paren);
7695 if (!svname) /* shouldn't happen */
7697 "panic: reg_scan_name returned NULL");
7698 if (!RExC_paren_names) {
7699 RExC_paren_names= newHV();
7700 sv_2mortal(MUTABLE_SV(RExC_paren_names));
7702 RExC_paren_name_list= newAV();
7703 sv_2mortal(MUTABLE_SV(RExC_paren_name_list));
7706 he_str = hv_fetch_ent( RExC_paren_names, svname, 1, 0 );
7708 sv_dat = HeVAL(he_str);
7710 /* croak baby croak */
7712 "panic: paren_name hash element allocation failed");
7713 } else if ( SvPOK(sv_dat) ) {
7714 /* (?|...) can mean we have dupes so scan to check
7715 its already been stored. Maybe a flag indicating
7716 we are inside such a construct would be useful,
7717 but the arrays are likely to be quite small, so
7718 for now we punt -- dmq */
7719 IV count = SvIV(sv_dat);
7720 I32 *pv = (I32*)SvPVX(sv_dat);
7722 for ( i = 0 ; i < count ; i++ ) {
7723 if ( pv[i] == RExC_npar ) {
7729 pv = (I32*)SvGROW(sv_dat, SvCUR(sv_dat) + sizeof(I32)+1);
7730 SvCUR_set(sv_dat, SvCUR(sv_dat) + sizeof(I32));
7731 pv[count] = RExC_npar;
7732 SvIV_set(sv_dat, SvIVX(sv_dat) + 1);
7735 (void)SvUPGRADE(sv_dat,SVt_PVNV);
7736 sv_setpvn(sv_dat, (char *)&(RExC_npar), sizeof(I32));
7738 SvIV_set(sv_dat, 1);
7741 /* Yes this does cause a memory leak in debugging Perls */
7742 if (!av_store(RExC_paren_name_list, RExC_npar, SvREFCNT_inc(svname)))
7743 SvREFCNT_dec(svname);
7746 /*sv_dump(sv_dat);*/
7748 nextchar(pRExC_state);
7750 goto capturing_parens;
7752 RExC_seen |= REG_SEEN_LOOKBEHIND;
7753 RExC_in_lookbehind++;
7755 case '=': /* (?=...) */
7756 RExC_seen_zerolen++;
7758 case '!': /* (?!...) */
7759 RExC_seen_zerolen++;
7760 if (*RExC_parse == ')') {
7761 ret=reg_node(pRExC_state, OPFAIL);
7762 nextchar(pRExC_state);
7766 case '|': /* (?|...) */
7767 /* branch reset, behave like a (?:...) except that
7768 buffers in alternations share the same numbers */
7770 after_freeze = freeze_paren = RExC_npar;
7772 case ':': /* (?:...) */
7773 case '>': /* (?>...) */
7775 case '$': /* (?$...) */
7776 case '@': /* (?@...) */
7777 vFAIL2("Sequence (?%c...) not implemented", (int)paren);
7779 case '#': /* (?#...) */
7780 while (*RExC_parse && *RExC_parse != ')')
7782 if (*RExC_parse != ')')
7783 FAIL("Sequence (?#... not terminated");
7784 nextchar(pRExC_state);
7787 case '0' : /* (?0) */
7788 case 'R' : /* (?R) */
7789 if (*RExC_parse != ')')
7790 FAIL("Sequence (?R) not terminated");
7791 ret = reg_node(pRExC_state, GOSTART);
7792 *flagp |= POSTPONED;
7793 nextchar(pRExC_state);
7796 { /* named and numeric backreferences */
7798 case '&': /* (?&NAME) */
7799 parse_start = RExC_parse - 1;
7802 SV *sv_dat = reg_scan_name(pRExC_state,
7803 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7804 num = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
7806 goto gen_recurse_regop;
7809 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7811 vFAIL("Illegal pattern");
7813 goto parse_recursion;
7815 case '-': /* (?-1) */
7816 if (!(RExC_parse[0] >= '1' && RExC_parse[0] <= '9')) {
7817 RExC_parse--; /* rewind to let it be handled later */
7821 case '1': case '2': case '3': case '4': /* (?1) */
7822 case '5': case '6': case '7': case '8': case '9':
7825 num = atoi(RExC_parse);
7826 parse_start = RExC_parse - 1; /* MJD */
7827 if (*RExC_parse == '-')
7829 while (isDIGIT(*RExC_parse))
7831 if (*RExC_parse!=')')
7832 vFAIL("Expecting close bracket");
7835 if ( paren == '-' ) {
7837 Diagram of capture buffer numbering.
7838 Top line is the normal capture buffer numbers
7839 Bottom line is the negative indexing as from
7843 /(a(x)y)(a(b(c(?-2)d)e)f)(g(h))/
7847 num = RExC_npar + num;
7850 vFAIL("Reference to nonexistent group");
7852 } else if ( paren == '+' ) {
7853 num = RExC_npar + num - 1;
7856 ret = reganode(pRExC_state, GOSUB, num);
7858 if (num > (I32)RExC_rx->nparens) {
7860 vFAIL("Reference to nonexistent group");
7862 ARG2L_SET( ret, RExC_recurse_count++);
7864 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
7865 "Recurse #%"UVuf" to %"IVdf"\n", (UV)ARG(ret), (IV)ARG2L(ret)));
7869 RExC_seen |= REG_SEEN_RECURSE;
7870 Set_Node_Length(ret, 1 + regarglen[OP(ret)]); /* MJD */
7871 Set_Node_Offset(ret, parse_start); /* MJD */
7873 *flagp |= POSTPONED;
7874 nextchar(pRExC_state);
7876 } /* named and numeric backreferences */
7879 case '?': /* (??...) */
7881 if (*RExC_parse != '{') {
7883 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
7886 *flagp |= POSTPONED;
7887 paren = *RExC_parse++;
7889 case '{': /* (?{...}) */
7894 char *s = RExC_parse;
7896 RExC_seen_zerolen++;
7897 RExC_seen |= REG_SEEN_EVAL;
7898 while (count && (c = *RExC_parse)) {
7909 if (*RExC_parse != ')') {
7911 vFAIL("Sequence (?{...}) not terminated or not {}-balanced");
7915 OP_4tree *sop, *rop;
7916 SV * const sv = newSVpvn(s, RExC_parse - 1 - s);
7919 Perl_save_re_context(aTHX);
7920 rop = Perl_sv_compile_2op_is_broken(aTHX_ sv, &sop, "re", &pad);
7921 sop->op_private |= OPpREFCOUNTED;
7922 /* re_dup will OpREFCNT_inc */
7923 OpREFCNT_set(sop, 1);
7926 n = add_data(pRExC_state, 3, "nop");
7927 RExC_rxi->data->data[n] = (void*)rop;
7928 RExC_rxi->data->data[n+1] = (void*)sop;
7929 RExC_rxi->data->data[n+2] = (void*)pad;
7932 else { /* First pass */
7933 if (PL_reginterp_cnt < ++RExC_seen_evals
7935 /* No compiled RE interpolated, has runtime
7936 components ===> unsafe. */
7937 FAIL("Eval-group not allowed at runtime, use re 'eval'");
7938 if (PL_tainting && PL_tainted)
7939 FAIL("Eval-group in insecure regular expression");
7940 #if PERL_VERSION > 8
7941 if (IN_PERL_COMPILETIME)
7946 nextchar(pRExC_state);
7948 ret = reg_node(pRExC_state, LOGICAL);
7951 REGTAIL(pRExC_state, ret, reganode(pRExC_state, EVAL, n));
7952 /* deal with the length of this later - MJD */
7955 ret = reganode(pRExC_state, EVAL, n);
7956 Set_Node_Length(ret, RExC_parse - parse_start + 1);
7957 Set_Node_Offset(ret, parse_start);
7960 case '(': /* (?(?{...})...) and (?(?=...)...) */
7963 if (RExC_parse[0] == '?') { /* (?(?...)) */
7964 if (RExC_parse[1] == '=' || RExC_parse[1] == '!'
7965 || RExC_parse[1] == '<'
7966 || RExC_parse[1] == '{') { /* Lookahead or eval. */
7969 ret = reg_node(pRExC_state, LOGICAL);
7972 REGTAIL(pRExC_state, ret, reg(pRExC_state, 1, &flag,depth+1));
7976 else if ( RExC_parse[0] == '<' /* (?(<NAME>)...) */
7977 || RExC_parse[0] == '\'' ) /* (?('NAME')...) */
7979 char ch = RExC_parse[0] == '<' ? '>' : '\'';
7980 char *name_start= RExC_parse++;
7982 SV *sv_dat=reg_scan_name(pRExC_state,
7983 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
7984 if (RExC_parse == name_start || *RExC_parse != ch)
7985 vFAIL2("Sequence (?(%c... not terminated",
7986 (ch == '>' ? '<' : ch));
7989 num = add_data( pRExC_state, 1, "S" );
7990 RExC_rxi->data->data[num]=(void*)sv_dat;
7991 SvREFCNT_inc_simple_void(sv_dat);
7993 ret = reganode(pRExC_state,NGROUPP,num);
7994 goto insert_if_check_paren;
7996 else if (RExC_parse[0] == 'D' &&
7997 RExC_parse[1] == 'E' &&
7998 RExC_parse[2] == 'F' &&
7999 RExC_parse[3] == 'I' &&
8000 RExC_parse[4] == 'N' &&
8001 RExC_parse[5] == 'E')
8003 ret = reganode(pRExC_state,DEFINEP,0);
8006 goto insert_if_check_paren;
8008 else if (RExC_parse[0] == 'R') {
8011 if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8012 parno = atoi(RExC_parse++);
8013 while (isDIGIT(*RExC_parse))
8015 } else if (RExC_parse[0] == '&') {
8018 sv_dat = reg_scan_name(pRExC_state,
8019 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
8020 parno = sv_dat ? *((I32 *)SvPVX(sv_dat)) : 0;
8022 ret = reganode(pRExC_state,INSUBP,parno);
8023 goto insert_if_check_paren;
8025 else if (RExC_parse[0] >= '1' && RExC_parse[0] <= '9' ) {
8028 parno = atoi(RExC_parse++);
8030 while (isDIGIT(*RExC_parse))
8032 ret = reganode(pRExC_state, GROUPP, parno);
8034 insert_if_check_paren:
8035 if ((c = *nextchar(pRExC_state)) != ')')
8036 vFAIL("Switch condition not recognized");
8038 REGTAIL(pRExC_state, ret, reganode(pRExC_state, IFTHEN, 0));
8039 br = regbranch(pRExC_state, &flags, 1,depth+1);
8041 br = reganode(pRExC_state, LONGJMP, 0);
8043 REGTAIL(pRExC_state, br, reganode(pRExC_state, LONGJMP, 0));
8044 c = *nextchar(pRExC_state);
8049 vFAIL("(?(DEFINE)....) does not allow branches");
8050 lastbr = reganode(pRExC_state, IFTHEN, 0); /* Fake one for optimizer. */
8051 regbranch(pRExC_state, &flags, 1,depth+1);
8052 REGTAIL(pRExC_state, ret, lastbr);
8055 c = *nextchar(pRExC_state);
8060 vFAIL("Switch (?(condition)... contains too many branches");
8061 ender = reg_node(pRExC_state, TAIL);
8062 REGTAIL(pRExC_state, br, ender);
8064 REGTAIL(pRExC_state, lastbr, ender);
8065 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender);
8068 REGTAIL(pRExC_state, ret, ender);
8069 RExC_size++; /* XXX WHY do we need this?!!
8070 For large programs it seems to be required
8071 but I can't figure out why. -- dmq*/
8075 vFAIL2("Unknown switch condition (?(%.2s", RExC_parse);
8079 RExC_parse--; /* for vFAIL to print correctly */
8080 vFAIL("Sequence (? incomplete");
8082 case DEFAULT_PAT_MOD: /* Use default flags with the exceptions
8084 has_use_defaults = TRUE;
8085 STD_PMMOD_FLAGS_CLEAR(&RExC_flags);
8086 set_regex_charset(&RExC_flags, (RExC_utf8 || RExC_uni_semantics)
8087 ? REGEX_UNICODE_CHARSET
8088 : REGEX_DEPENDS_CHARSET);
8092 parse_flags: /* (?i) */
8094 U32 posflags = 0, negflags = 0;
8095 U32 *flagsp = &posflags;
8096 char has_charset_modifier = '\0';
8097 regex_charset cs = get_regex_charset(RExC_flags);
8098 if (cs == REGEX_DEPENDS_CHARSET
8099 && (RExC_utf8 || RExC_uni_semantics))
8101 cs = REGEX_UNICODE_CHARSET;
8104 while (*RExC_parse) {
8105 /* && strchr("iogcmsx", *RExC_parse) */
8106 /* (?g), (?gc) and (?o) are useless here
8107 and must be globally applied -- japhy */
8108 switch (*RExC_parse) {
8109 CASE_STD_PMMOD_FLAGS_PARSE_SET(flagsp);
8110 case LOCALE_PAT_MOD:
8111 if (has_charset_modifier) {
8112 goto excess_modifier;
8114 else if (flagsp == &negflags) {
8117 cs = REGEX_LOCALE_CHARSET;
8118 has_charset_modifier = LOCALE_PAT_MOD;
8119 RExC_contains_locale = 1;
8121 case UNICODE_PAT_MOD:
8122 if (has_charset_modifier) {
8123 goto excess_modifier;
8125 else if (flagsp == &negflags) {
8128 cs = REGEX_UNICODE_CHARSET;
8129 has_charset_modifier = UNICODE_PAT_MOD;
8131 case ASCII_RESTRICT_PAT_MOD:
8132 if (flagsp == &negflags) {
8135 if (has_charset_modifier) {
8136 if (cs != REGEX_ASCII_RESTRICTED_CHARSET) {
8137 goto excess_modifier;
8139 /* Doubled modifier implies more restricted */
8140 cs = REGEX_ASCII_MORE_RESTRICTED_CHARSET;
8143 cs = REGEX_ASCII_RESTRICTED_CHARSET;
8145 has_charset_modifier = ASCII_RESTRICT_PAT_MOD;
8147 case DEPENDS_PAT_MOD:
8148 if (has_use_defaults) {
8149 goto fail_modifiers;
8151 else if (flagsp == &negflags) {
8154 else if (has_charset_modifier) {
8155 goto excess_modifier;
8158 /* The dual charset means unicode semantics if the
8159 * pattern (or target, not known until runtime) are
8160 * utf8, or something in the pattern indicates unicode
8162 cs = (RExC_utf8 || RExC_uni_semantics)
8163 ? REGEX_UNICODE_CHARSET
8164 : REGEX_DEPENDS_CHARSET;
8165 has_charset_modifier = DEPENDS_PAT_MOD;
8169 if (has_charset_modifier == ASCII_RESTRICT_PAT_MOD) {
8170 vFAIL2("Regexp modifier \"%c\" may appear a maximum of twice", ASCII_RESTRICT_PAT_MOD);
8172 else if (has_charset_modifier == *(RExC_parse - 1)) {
8173 vFAIL2("Regexp modifier \"%c\" may not appear twice", *(RExC_parse - 1));
8176 vFAIL3("Regexp modifiers \"%c\" and \"%c\" are mutually exclusive", has_charset_modifier, *(RExC_parse - 1));
8181 vFAIL2("Regexp modifier \"%c\" may not appear after the \"-\"", *(RExC_parse - 1));
8183 case ONCE_PAT_MOD: /* 'o' */
8184 case GLOBAL_PAT_MOD: /* 'g' */
8185 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8186 const I32 wflagbit = *RExC_parse == 'o' ? WASTED_O : WASTED_G;
8187 if (! (wastedflags & wflagbit) ) {
8188 wastedflags |= wflagbit;
8191 "Useless (%s%c) - %suse /%c modifier",
8192 flagsp == &negflags ? "?-" : "?",
8194 flagsp == &negflags ? "don't " : "",
8201 case CONTINUE_PAT_MOD: /* 'c' */
8202 if (SIZE_ONLY && ckWARN(WARN_REGEXP)) {
8203 if (! (wastedflags & WASTED_C) ) {
8204 wastedflags |= WASTED_GC;
8207 "Useless (%sc) - %suse /gc modifier",
8208 flagsp == &negflags ? "?-" : "?",
8209 flagsp == &negflags ? "don't " : ""
8214 case KEEPCOPY_PAT_MOD: /* 'p' */
8215 if (flagsp == &negflags) {
8217 ckWARNreg(RExC_parse + 1,"Useless use of (?-p)");
8219 *flagsp |= RXf_PMf_KEEPCOPY;
8223 /* A flag is a default iff it is following a minus, so
8224 * if there is a minus, it means will be trying to
8225 * re-specify a default which is an error */
8226 if (has_use_defaults || flagsp == &negflags) {
8229 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8233 wastedflags = 0; /* reset so (?g-c) warns twice */
8239 RExC_flags |= posflags;
8240 RExC_flags &= ~negflags;
8241 set_regex_charset(&RExC_flags, cs);
8243 oregflags |= posflags;
8244 oregflags &= ~negflags;
8245 set_regex_charset(&oregflags, cs);
8247 nextchar(pRExC_state);
8258 vFAIL3("Sequence (%.*s...) not recognized", RExC_parse-seqstart, seqstart);
8263 }} /* one for the default block, one for the switch */
8270 ret = reganode(pRExC_state, OPEN, parno);
8273 RExC_nestroot = parno;
8274 if (RExC_seen & REG_SEEN_RECURSE
8275 && !RExC_open_parens[parno-1])
8277 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8278 "Setting open paren #%"IVdf" to %d\n",
8279 (IV)parno, REG_NODE_NUM(ret)));
8280 RExC_open_parens[parno-1]= ret;
8283 Set_Node_Length(ret, 1); /* MJD */
8284 Set_Node_Offset(ret, RExC_parse); /* MJD */
8292 /* Pick up the branches, linking them together. */
8293 parse_start = RExC_parse; /* MJD */
8294 br = regbranch(pRExC_state, &flags, 1,depth+1);
8296 /* branch_len = (paren != 0); */
8300 if (*RExC_parse == '|') {
8301 if (!SIZE_ONLY && RExC_extralen) {
8302 reginsert(pRExC_state, BRANCHJ, br, depth+1);
8305 reginsert(pRExC_state, BRANCH, br, depth+1);
8306 Set_Node_Length(br, paren != 0);
8307 Set_Node_Offset_To_R(br-RExC_emit_start, parse_start-RExC_start);
8311 RExC_extralen += 1; /* For BRANCHJ-BRANCH. */
8313 else if (paren == ':') {
8314 *flagp |= flags&SIMPLE;
8316 if (is_open) { /* Starts with OPEN. */
8317 REGTAIL(pRExC_state, ret, br); /* OPEN -> first. */
8319 else if (paren != '?') /* Not Conditional */
8321 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8323 while (*RExC_parse == '|') {
8324 if (!SIZE_ONLY && RExC_extralen) {
8325 ender = reganode(pRExC_state, LONGJMP,0);
8326 REGTAIL(pRExC_state, NEXTOPER(NEXTOPER(lastbr)), ender); /* Append to the previous. */
8329 RExC_extralen += 2; /* Account for LONGJMP. */
8330 nextchar(pRExC_state);
8332 if (RExC_npar > after_freeze)
8333 after_freeze = RExC_npar;
8334 RExC_npar = freeze_paren;
8336 br = regbranch(pRExC_state, &flags, 0, depth+1);
8340 REGTAIL(pRExC_state, lastbr, br); /* BRANCH -> BRANCH. */
8342 *flagp |= flags & (SPSTART | HASWIDTH | POSTPONED);
8345 if (have_branch || paren != ':') {
8346 /* Make a closing node, and hook it on the end. */
8349 ender = reg_node(pRExC_state, TAIL);
8352 ender = reganode(pRExC_state, CLOSE, parno);
8353 if (!SIZE_ONLY && RExC_seen & REG_SEEN_RECURSE) {
8354 DEBUG_OPTIMISE_MORE_r(PerlIO_printf(Perl_debug_log,
8355 "Setting close paren #%"IVdf" to %d\n",
8356 (IV)parno, REG_NODE_NUM(ender)));
8357 RExC_close_parens[parno-1]= ender;
8358 if (RExC_nestroot == parno)
8361 Set_Node_Offset(ender,RExC_parse+1); /* MJD */
8362 Set_Node_Length(ender,1); /* MJD */
8368 *flagp &= ~HASWIDTH;
8371 ender = reg_node(pRExC_state, SUCCEED);
8374 ender = reg_node(pRExC_state, END);
8376 assert(!RExC_opend); /* there can only be one! */
8381 REGTAIL(pRExC_state, lastbr, ender);
8383 if (have_branch && !SIZE_ONLY) {
8385 RExC_seen |= REG_TOP_LEVEL_BRANCHES;
8387 /* Hook the tails of the branches to the closing node. */
8388 for (br = ret; br; br = regnext(br)) {
8389 const U8 op = PL_regkind[OP(br)];
8391 REGTAIL_STUDY(pRExC_state, NEXTOPER(br), ender);
8393 else if (op == BRANCHJ) {
8394 REGTAIL_STUDY(pRExC_state, NEXTOPER(NEXTOPER(br)), ender);
8402 static const char parens[] = "=!<,>";
8404 if (paren && (p = strchr(parens, paren))) {
8405 U8 node = ((p - parens) % 2) ? UNLESSM : IFMATCH;
8406 int flag = (p - parens) > 1;
8409 node = SUSPEND, flag = 0;
8410 reginsert(pRExC_state, node,ret, depth+1);
8411 Set_Node_Cur_Length(ret);
8412 Set_Node_Offset(ret, parse_start + 1);
8414 REGTAIL_STUDY(pRExC_state, ret, reg_node(pRExC_state, TAIL));
8418 /* Check for proper termination. */
8420 RExC_flags = oregflags;
8421 if (RExC_parse >= RExC_end || *nextchar(pRExC_state) != ')') {
8422 RExC_parse = oregcomp_parse;
8423 vFAIL("Unmatched (");
8426 else if (!paren && RExC_parse < RExC_end) {
8427 if (*RExC_parse == ')') {
8429 vFAIL("Unmatched )");
8432 FAIL("Junk on end of regexp"); /* "Can't happen". */
8436 if (RExC_in_lookbehind) {
8437 RExC_in_lookbehind--;
8439 if (after_freeze > RExC_npar)
8440 RExC_npar = after_freeze;
8445 - regbranch - one alternative of an | operator
8447 * Implements the concatenation operator.
8450 S_regbranch(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, I32 first, U32 depth)
8453 register regnode *ret;
8454 register regnode *chain = NULL;
8455 register regnode *latest;
8456 I32 flags = 0, c = 0;
8457 GET_RE_DEBUG_FLAGS_DECL;
8459 PERL_ARGS_ASSERT_REGBRANCH;
8461 DEBUG_PARSE("brnc");
8466 if (!SIZE_ONLY && RExC_extralen)
8467 ret = reganode(pRExC_state, BRANCHJ,0);
8469 ret = reg_node(pRExC_state, BRANCH);
8470 Set_Node_Length(ret, 1);
8474 if (!first && SIZE_ONLY)
8475 RExC_extralen += 1; /* BRANCHJ */
8477 *flagp = WORST; /* Tentatively. */
8480 nextchar(pRExC_state);
8481 while (RExC_parse < RExC_end && *RExC_parse != '|' && *RExC_parse != ')') {
8483 latest = regpiece(pRExC_state, &flags,depth+1);
8484 if (latest == NULL) {
8485 if (flags & TRYAGAIN)
8489 else if (ret == NULL)
8491 *flagp |= flags&(HASWIDTH|POSTPONED);
8492 if (chain == NULL) /* First piece. */
8493 *flagp |= flags&SPSTART;
8496 REGTAIL(pRExC_state, chain, latest);
8501 if (chain == NULL) { /* Loop ran zero times. */
8502 chain = reg_node(pRExC_state, NOTHING);
8507 *flagp |= flags&SIMPLE;
8514 - regpiece - something followed by possible [*+?]
8516 * Note that the branching code sequences used for ? and the general cases
8517 * of * and + are somewhat optimized: they use the same NOTHING node as
8518 * both the endmarker for their branch list and the body of the last branch.
8519 * It might seem that this node could be dispensed with entirely, but the
8520 * endmarker role is not redundant.
8523 S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8526 register regnode *ret;
8528 register char *next;
8530 const char * const origparse = RExC_parse;
8532 I32 max = REG_INFTY;
8533 #ifdef RE_TRACK_PATTERN_OFFSETS
8536 const char *maxpos = NULL;
8537 GET_RE_DEBUG_FLAGS_DECL;
8539 PERL_ARGS_ASSERT_REGPIECE;
8541 DEBUG_PARSE("piec");
8543 ret = regatom(pRExC_state, &flags,depth+1);
8545 if (flags & TRYAGAIN)
8552 if (op == '{' && regcurly(RExC_parse)) {
8554 #ifdef RE_TRACK_PATTERN_OFFSETS
8555 parse_start = RExC_parse; /* MJD */
8557 next = RExC_parse + 1;
8558 while (isDIGIT(*next) || *next == ',') {
8567 if (*next == '}') { /* got one */
8571 min = atoi(RExC_parse);
8575 maxpos = RExC_parse;
8577 if (!max && *maxpos != '0')
8578 max = REG_INFTY; /* meaning "infinity" */
8579 else if (max >= REG_INFTY)
8580 vFAIL2("Quantifier in {,} bigger than %d", REG_INFTY - 1);
8582 nextchar(pRExC_state);
8585 if ((flags&SIMPLE)) {
8586 RExC_naughty += 2 + RExC_naughty / 2;
8587 reginsert(pRExC_state, CURLY, ret, depth+1);
8588 Set_Node_Offset(ret, parse_start+1); /* MJD */
8589 Set_Node_Cur_Length(ret);
8592 regnode * const w = reg_node(pRExC_state, WHILEM);
8595 REGTAIL(pRExC_state, ret, w);
8596 if (!SIZE_ONLY && RExC_extralen) {
8597 reginsert(pRExC_state, LONGJMP,ret, depth+1);
8598 reginsert(pRExC_state, NOTHING,ret, depth+1);
8599 NEXT_OFF(ret) = 3; /* Go over LONGJMP. */
8601 reginsert(pRExC_state, CURLYX,ret, depth+1);
8603 Set_Node_Offset(ret, parse_start+1);
8604 Set_Node_Length(ret,
8605 op == '{' ? (RExC_parse - parse_start) : 1);
8607 if (!SIZE_ONLY && RExC_extralen)
8608 NEXT_OFF(ret) = 3; /* Go over NOTHING to LONGJMP. */
8609 REGTAIL(pRExC_state, ret, reg_node(pRExC_state, NOTHING));
8611 RExC_whilem_seen++, RExC_extralen += 3;
8612 RExC_naughty += 4 + RExC_naughty; /* compound interest */
8621 vFAIL("Can't do {n,m} with n > m");
8623 ARG1_SET(ret, (U16)min);
8624 ARG2_SET(ret, (U16)max);
8636 #if 0 /* Now runtime fix should be reliable. */
8638 /* if this is reinstated, don't forget to put this back into perldiag:
8640 =item Regexp *+ operand could be empty at {#} in regex m/%s/
8642 (F) The part of the regexp subject to either the * or + quantifier
8643 could match an empty string. The {#} shows in the regular
8644 expression about where the problem was discovered.
8648 if (!(flags&HASWIDTH) && op != '?')
8649 vFAIL("Regexp *+ operand could be empty");
8652 #ifdef RE_TRACK_PATTERN_OFFSETS
8653 parse_start = RExC_parse;
8655 nextchar(pRExC_state);
8657 *flagp = (op != '+') ? (WORST|SPSTART|HASWIDTH) : (WORST|HASWIDTH);
8659 if (op == '*' && (flags&SIMPLE)) {
8660 reginsert(pRExC_state, STAR, ret, depth+1);
8664 else if (op == '*') {
8668 else if (op == '+' && (flags&SIMPLE)) {
8669 reginsert(pRExC_state, PLUS, ret, depth+1);
8673 else if (op == '+') {
8677 else if (op == '?') {
8682 if (!SIZE_ONLY && !(flags&(HASWIDTH|POSTPONED)) && max > REG_INFTY/3) {
8683 ckWARN3reg(RExC_parse,
8684 "%.*s matches null string many times",
8685 (int)(RExC_parse >= origparse ? RExC_parse - origparse : 0),
8689 if (RExC_parse < RExC_end && *RExC_parse == '?') {
8690 nextchar(pRExC_state);
8691 reginsert(pRExC_state, MINMOD, ret, depth+1);
8692 REGTAIL(pRExC_state, ret, ret + NODE_STEP_REGNODE);
8694 #ifndef REG_ALLOW_MINMOD_SUSPEND
8697 if (RExC_parse < RExC_end && *RExC_parse == '+') {
8699 nextchar(pRExC_state);
8700 ender = reg_node(pRExC_state, SUCCEED);
8701 REGTAIL(pRExC_state, ret, ender);
8702 reginsert(pRExC_state, SUSPEND, ret, depth+1);
8704 ender = reg_node(pRExC_state, TAIL);
8705 REGTAIL(pRExC_state, ret, ender);
8709 if (RExC_parse < RExC_end && ISMULT2(RExC_parse)) {
8711 vFAIL("Nested quantifiers");
8718 /* reg_namedseq(pRExC_state,UVp, UV depth)
8720 This is expected to be called by a parser routine that has
8721 recognized '\N' and needs to handle the rest. RExC_parse is
8722 expected to point at the first char following the N at the time
8725 The \N may be inside (indicated by valuep not being NULL) or outside a
8728 \N may begin either a named sequence, or if outside a character class, mean
8729 to match a non-newline. For non single-quoted regexes, the tokenizer has
8730 attempted to decide which, and in the case of a named sequence converted it
8731 into one of the forms: \N{} (if the sequence is null), or \N{U+c1.c2...},
8732 where c1... are the characters in the sequence. For single-quoted regexes,
8733 the tokenizer passes the \N sequence through unchanged; this code will not
8734 attempt to determine this nor expand those. The net effect is that if the
8735 beginning of the passed-in pattern isn't '{U+' or there is no '}', it
8736 signals that this \N occurrence means to match a non-newline.
8738 Only the \N{U+...} form should occur in a character class, for the same
8739 reason that '.' inside a character class means to just match a period: it
8740 just doesn't make sense.
8742 If valuep is non-null then it is assumed that we are parsing inside
8743 of a charclass definition and the first codepoint in the resolved
8744 string is returned via *valuep and the routine will return NULL.
8745 In this mode if a multichar string is returned from the charnames
8746 handler, a warning will be issued, and only the first char in the
8747 sequence will be examined. If the string returned is zero length
8748 then the value of *valuep is undefined and NON-NULL will
8749 be returned to indicate failure. (This will NOT be a valid pointer
8752 If valuep is null then it is assumed that we are parsing normal text and a
8753 new EXACT node is inserted into the program containing the resolved string,
8754 and a pointer to the new node is returned. But if the string is zero length
8755 a NOTHING node is emitted instead.
8757 On success RExC_parse is set to the char following the endbrace.
8758 Parsing failures will generate a fatal error via vFAIL(...)
8761 S_reg_namedseq(pTHX_ RExC_state_t *pRExC_state, UV *valuep, I32 *flagp, U32 depth)
8763 char * endbrace; /* '}' following the name */
8764 regnode *ret = NULL;
8767 GET_RE_DEBUG_FLAGS_DECL;
8769 PERL_ARGS_ASSERT_REG_NAMEDSEQ;
8773 /* The [^\n] meaning of \N ignores spaces and comments under the /x
8774 * modifier. The other meaning does not */
8775 p = (RExC_flags & RXf_PMf_EXTENDED)
8776 ? regwhite( pRExC_state, RExC_parse )
8779 /* Disambiguate between \N meaning a named character versus \N meaning
8780 * [^\n]. The former is assumed when it can't be the latter. */
8781 if (*p != '{' || regcurly(p)) {
8784 /* no bare \N in a charclass */
8785 vFAIL("\\N in a character class must be a named character: \\N{...}");
8787 nextchar(pRExC_state);
8788 ret = reg_node(pRExC_state, REG_ANY);
8789 *flagp |= HASWIDTH|SIMPLE;
8792 Set_Node_Length(ret, 1); /* MJD */
8796 /* Here, we have decided it should be a named sequence */
8798 /* The test above made sure that the next real character is a '{', but
8799 * under the /x modifier, it could be separated by space (or a comment and
8800 * \n) and this is not allowed (for consistency with \x{...} and the
8801 * tokenizer handling of \N{NAME}). */
8802 if (*RExC_parse != '{') {
8803 vFAIL("Missing braces on \\N{}");
8806 RExC_parse++; /* Skip past the '{' */
8808 if (! (endbrace = strchr(RExC_parse, '}')) /* no trailing brace */
8809 || ! (endbrace == RExC_parse /* nothing between the {} */
8810 || (endbrace - RExC_parse >= 2 /* U+ (bad hex is checked below */
8811 && strnEQ(RExC_parse, "U+", 2)))) /* for a better error msg) */
8813 if (endbrace) RExC_parse = endbrace; /* position msg's '<--HERE' */
8814 vFAIL("\\N{NAME} must be resolved by the lexer");
8817 if (endbrace == RExC_parse) { /* empty: \N{} */
8819 RExC_parse = endbrace + 1;
8820 return reg_node(pRExC_state,NOTHING);
8824 ckWARNreg(RExC_parse,
8825 "Ignoring zero length \\N{} in character class"
8827 RExC_parse = endbrace + 1;
8830 return (regnode *) &RExC_parse; /* Invalid regnode pointer */
8833 REQUIRE_UTF8; /* named sequences imply Unicode semantics */
8834 RExC_parse += 2; /* Skip past the 'U+' */
8836 if (valuep) { /* In a bracketed char class */
8837 /* We only pay attention to the first char of
8838 multichar strings being returned. I kinda wonder
8839 if this makes sense as it does change the behaviour
8840 from earlier versions, OTOH that behaviour was broken
8841 as well. XXX Solution is to recharacterize as
8842 [rest-of-class]|multi1|multi2... */
8844 STRLEN length_of_hex;
8845 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
8846 | PERL_SCAN_DISALLOW_PREFIX
8847 | (SIZE_ONLY ? PERL_SCAN_SILENT_ILLDIGIT : 0);
8849 char * endchar = RExC_parse + strcspn(RExC_parse, ".}");
8850 if (endchar < endbrace) {
8851 ckWARNreg(endchar, "Using just the first character returned by \\N{} in character class");
8854 length_of_hex = (STRLEN)(endchar - RExC_parse);
8855 *valuep = grok_hex(RExC_parse, &length_of_hex, &flags, NULL);
8857 /* The tokenizer should have guaranteed validity, but it's possible to
8858 * bypass it by using single quoting, so check */
8859 if (length_of_hex == 0
8860 || length_of_hex != (STRLEN)(endchar - RExC_parse) )
8862 RExC_parse += length_of_hex; /* Includes all the valid */
8863 RExC_parse += (RExC_orig_utf8) /* point to after 1st invalid */
8864 ? UTF8SKIP(RExC_parse)
8866 /* Guard against malformed utf8 */
8867 if (RExC_parse >= endchar) RExC_parse = endchar;
8868 vFAIL("Invalid hexadecimal number in \\N{U+...}");
8871 RExC_parse = endbrace + 1;
8872 if (endchar == endbrace) return NULL;
8874 ret = (regnode *) &RExC_parse; /* Invalid regnode pointer */
8876 else { /* Not a char class */
8878 /* What is done here is to convert this to a sub-pattern of the form
8879 * (?:\x{char1}\x{char2}...)
8880 * and then call reg recursively. That way, it retains its atomicness,
8881 * while not having to worry about special handling that some code
8882 * points may have. toke.c has converted the original Unicode values
8883 * to native, so that we can just pass on the hex values unchanged. We
8884 * do have to set a flag to keep recoding from happening in the
8887 SV * substitute_parse = newSVpvn_flags("?:", 2, SVf_UTF8|SVs_TEMP);
8889 char *endchar; /* Points to '.' or '}' ending cur char in the input
8891 char *orig_end = RExC_end;
8893 while (RExC_parse < endbrace) {
8895 /* Code points are separated by dots. If none, there is only one
8896 * code point, and is terminated by the brace */
8897 endchar = RExC_parse + strcspn(RExC_parse, ".}");
8899 /* Convert to notation the rest of the code understands */
8900 sv_catpv(substitute_parse, "\\x{");
8901 sv_catpvn(substitute_parse, RExC_parse, endchar - RExC_parse);
8902 sv_catpv(substitute_parse, "}");
8904 /* Point to the beginning of the next character in the sequence. */
8905 RExC_parse = endchar + 1;
8907 sv_catpv(substitute_parse, ")");
8909 RExC_parse = SvPV(substitute_parse, len);
8911 /* Don't allow empty number */
8913 vFAIL("Invalid hexadecimal number in \\N{U+...}");
8915 RExC_end = RExC_parse + len;
8917 /* The values are Unicode, and therefore not subject to recoding */
8918 RExC_override_recoding = 1;
8920 ret = reg(pRExC_state, 1, flagp, depth+1);
8922 RExC_parse = endbrace;
8923 RExC_end = orig_end;
8924 RExC_override_recoding = 0;
8926 nextchar(pRExC_state);
8936 * It returns the code point in utf8 for the value in *encp.
8937 * value: a code value in the source encoding
8938 * encp: a pointer to an Encode object
8940 * If the result from Encode is not a single character,
8941 * it returns U+FFFD (Replacement character) and sets *encp to NULL.
8944 S_reg_recode(pTHX_ const char value, SV **encp)
8947 SV * const sv = newSVpvn_flags(&value, numlen, SVs_TEMP);
8948 const char * const s = *encp ? sv_recode_to_utf8(sv, *encp) : SvPVX(sv);
8949 const STRLEN newlen = SvCUR(sv);
8950 UV uv = UNICODE_REPLACEMENT;
8952 PERL_ARGS_ASSERT_REG_RECODE;
8956 ? utf8n_to_uvchr((U8*)s, newlen, &numlen, UTF8_ALLOW_DEFAULT)
8959 if (!newlen || numlen != newlen) {
8960 uv = UNICODE_REPLACEMENT;
8968 - regatom - the lowest level
8970 Try to identify anything special at the start of the pattern. If there
8971 is, then handle it as required. This may involve generating a single regop,
8972 such as for an assertion; or it may involve recursing, such as to
8973 handle a () structure.
8975 If the string doesn't start with something special then we gobble up
8976 as much literal text as we can.
8978 Once we have been able to handle whatever type of thing started the
8979 sequence, we return.
8981 Note: we have to be careful with escapes, as they can be both literal
8982 and special, and in the case of \10 and friends can either, depending
8983 on context. Specifically there are two separate switches for handling
8984 escape sequences, with the one for handling literal escapes requiring
8985 a dummy entry for all of the special escapes that are actually handled
8990 S_regatom(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth)
8993 register regnode *ret = NULL;
8995 char *parse_start = RExC_parse;
8997 GET_RE_DEBUG_FLAGS_DECL;
8998 DEBUG_PARSE("atom");
8999 *flagp = WORST; /* Tentatively. */
9001 PERL_ARGS_ASSERT_REGATOM;
9004 switch ((U8)*RExC_parse) {
9006 RExC_seen_zerolen++;
9007 nextchar(pRExC_state);
9008 if (RExC_flags & RXf_PMf_MULTILINE)
9009 ret = reg_node(pRExC_state, MBOL);
9010 else if (RExC_flags & RXf_PMf_SINGLELINE)
9011 ret = reg_node(pRExC_state, SBOL);
9013 ret = reg_node(pRExC_state, BOL);
9014 Set_Node_Length(ret, 1); /* MJD */
9017 nextchar(pRExC_state);
9019 RExC_seen_zerolen++;
9020 if (RExC_flags & RXf_PMf_MULTILINE)
9021 ret = reg_node(pRExC_state, MEOL);
9022 else if (RExC_flags & RXf_PMf_SINGLELINE)
9023 ret = reg_node(pRExC_state, SEOL);
9025 ret = reg_node(pRExC_state, EOL);
9026 Set_Node_Length(ret, 1); /* MJD */
9029 nextchar(pRExC_state);
9030 if (RExC_flags & RXf_PMf_SINGLELINE)
9031 ret = reg_node(pRExC_state, SANY);
9033 ret = reg_node(pRExC_state, REG_ANY);
9034 *flagp |= HASWIDTH|SIMPLE;
9036 Set_Node_Length(ret, 1); /* MJD */
9040 char * const oregcomp_parse = ++RExC_parse;
9041 ret = regclass(pRExC_state,depth+1);
9042 if (*RExC_parse != ']') {
9043 RExC_parse = oregcomp_parse;
9044 vFAIL("Unmatched [");
9046 nextchar(pRExC_state);
9047 *flagp |= HASWIDTH|SIMPLE;
9048 Set_Node_Length(ret, RExC_parse - oregcomp_parse + 1); /* MJD */
9052 nextchar(pRExC_state);
9053 ret = reg(pRExC_state, 1, &flags,depth+1);
9055 if (flags & TRYAGAIN) {
9056 if (RExC_parse == RExC_end) {
9057 /* Make parent create an empty node if needed. */
9065 *flagp |= flags&(HASWIDTH|SPSTART|SIMPLE|POSTPONED);
9069 if (flags & TRYAGAIN) {
9073 vFAIL("Internal urp");
9074 /* Supposed to be caught earlier. */
9077 if (!regcurly(RExC_parse)) {
9086 vFAIL("Quantifier follows nothing");
9091 This switch handles escape sequences that resolve to some kind
9092 of special regop and not to literal text. Escape sequnces that
9093 resolve to literal text are handled below in the switch marked
9096 Every entry in this switch *must* have a corresponding entry
9097 in the literal escape switch. However, the opposite is not
9098 required, as the default for this switch is to jump to the
9099 literal text handling code.
9101 switch ((U8)*++RExC_parse) {
9102 /* Special Escapes */
9104 RExC_seen_zerolen++;
9105 ret = reg_node(pRExC_state, SBOL);
9107 goto finish_meta_pat;
9109 ret = reg_node(pRExC_state, GPOS);
9110 RExC_seen |= REG_SEEN_GPOS;
9112 goto finish_meta_pat;
9114 RExC_seen_zerolen++;
9115 ret = reg_node(pRExC_state, KEEPS);
9117 /* XXX:dmq : disabling in-place substitution seems to
9118 * be necessary here to avoid cases of memory corruption, as
9119 * with: C<$_="x" x 80; s/x\K/y/> -- rgs
9121 RExC_seen |= REG_SEEN_LOOKBEHIND;
9122 goto finish_meta_pat;
9124 ret = reg_node(pRExC_state, SEOL);
9126 RExC_seen_zerolen++; /* Do not optimize RE away */
9127 goto finish_meta_pat;
9129 ret = reg_node(pRExC_state, EOS);
9131 RExC_seen_zerolen++; /* Do not optimize RE away */
9132 goto finish_meta_pat;
9134 ret = reg_node(pRExC_state, CANY);
9135 RExC_seen |= REG_SEEN_CANY;
9136 *flagp |= HASWIDTH|SIMPLE;
9137 goto finish_meta_pat;
9139 ret = reg_node(pRExC_state, CLUMP);
9141 goto finish_meta_pat;
9143 switch (get_regex_charset(RExC_flags)) {
9144 case REGEX_LOCALE_CHARSET:
9147 case REGEX_UNICODE_CHARSET:
9150 case REGEX_ASCII_RESTRICTED_CHARSET:
9151 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9154 case REGEX_DEPENDS_CHARSET:
9160 ret = reg_node(pRExC_state, op);
9161 *flagp |= HASWIDTH|SIMPLE;
9162 goto finish_meta_pat;
9164 switch (get_regex_charset(RExC_flags)) {
9165 case REGEX_LOCALE_CHARSET:
9168 case REGEX_UNICODE_CHARSET:
9171 case REGEX_ASCII_RESTRICTED_CHARSET:
9172 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9175 case REGEX_DEPENDS_CHARSET:
9181 ret = reg_node(pRExC_state, op);
9182 *flagp |= HASWIDTH|SIMPLE;
9183 goto finish_meta_pat;
9185 RExC_seen_zerolen++;
9186 RExC_seen |= REG_SEEN_LOOKBEHIND;
9187 switch (get_regex_charset(RExC_flags)) {
9188 case REGEX_LOCALE_CHARSET:
9191 case REGEX_UNICODE_CHARSET:
9194 case REGEX_ASCII_RESTRICTED_CHARSET:
9195 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9198 case REGEX_DEPENDS_CHARSET:
9204 ret = reg_node(pRExC_state, op);
9205 FLAGS(ret) = get_regex_charset(RExC_flags);
9207 if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9208 ckWARNregdep(RExC_parse, "\"\\b{\" is deprecated; use \"\\b\\{\" instead");
9210 goto finish_meta_pat;
9212 RExC_seen_zerolen++;
9213 RExC_seen |= REG_SEEN_LOOKBEHIND;
9214 switch (get_regex_charset(RExC_flags)) {
9215 case REGEX_LOCALE_CHARSET:
9218 case REGEX_UNICODE_CHARSET:
9221 case REGEX_ASCII_RESTRICTED_CHARSET:
9222 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9225 case REGEX_DEPENDS_CHARSET:
9231 ret = reg_node(pRExC_state, op);
9232 FLAGS(ret) = get_regex_charset(RExC_flags);
9234 if (! SIZE_ONLY && (U8) *(RExC_parse + 1) == '{') {
9235 ckWARNregdep(RExC_parse, "\"\\B{\" is deprecated; use \"\\B\\{\" instead");
9237 goto finish_meta_pat;
9239 switch (get_regex_charset(RExC_flags)) {
9240 case REGEX_LOCALE_CHARSET:
9243 case REGEX_UNICODE_CHARSET:
9246 case REGEX_ASCII_RESTRICTED_CHARSET:
9247 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9250 case REGEX_DEPENDS_CHARSET:
9256 ret = reg_node(pRExC_state, op);
9257 *flagp |= HASWIDTH|SIMPLE;
9258 goto finish_meta_pat;
9260 switch (get_regex_charset(RExC_flags)) {
9261 case REGEX_LOCALE_CHARSET:
9264 case REGEX_UNICODE_CHARSET:
9267 case REGEX_ASCII_RESTRICTED_CHARSET:
9268 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9271 case REGEX_DEPENDS_CHARSET:
9277 ret = reg_node(pRExC_state, op);
9278 *flagp |= HASWIDTH|SIMPLE;
9279 goto finish_meta_pat;
9281 switch (get_regex_charset(RExC_flags)) {
9282 case REGEX_LOCALE_CHARSET:
9285 case REGEX_ASCII_RESTRICTED_CHARSET:
9286 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9289 case REGEX_DEPENDS_CHARSET: /* No difference between these */
9290 case REGEX_UNICODE_CHARSET:
9296 ret = reg_node(pRExC_state, op);
9297 *flagp |= HASWIDTH|SIMPLE;
9298 goto finish_meta_pat;
9300 switch (get_regex_charset(RExC_flags)) {
9301 case REGEX_LOCALE_CHARSET:
9304 case REGEX_ASCII_RESTRICTED_CHARSET:
9305 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
9308 case REGEX_DEPENDS_CHARSET: /* No difference between these */
9309 case REGEX_UNICODE_CHARSET:
9315 ret = reg_node(pRExC_state, op);
9316 *flagp |= HASWIDTH|SIMPLE;
9317 goto finish_meta_pat;
9319 ret = reg_node(pRExC_state, LNBREAK);
9320 *flagp |= HASWIDTH|SIMPLE;
9321 goto finish_meta_pat;
9323 ret = reg_node(pRExC_state, HORIZWS);
9324 *flagp |= HASWIDTH|SIMPLE;
9325 goto finish_meta_pat;
9327 ret = reg_node(pRExC_state, NHORIZWS);
9328 *flagp |= HASWIDTH|SIMPLE;
9329 goto finish_meta_pat;
9331 ret = reg_node(pRExC_state, VERTWS);
9332 *flagp |= HASWIDTH|SIMPLE;
9333 goto finish_meta_pat;
9335 ret = reg_node(pRExC_state, NVERTWS);
9336 *flagp |= HASWIDTH|SIMPLE;
9338 nextchar(pRExC_state);
9339 Set_Node_Length(ret, 2); /* MJD */
9344 char* const oldregxend = RExC_end;
9346 char* parse_start = RExC_parse - 2;
9349 if (RExC_parse[1] == '{') {
9350 /* a lovely hack--pretend we saw [\pX] instead */
9351 RExC_end = strchr(RExC_parse, '}');
9353 const U8 c = (U8)*RExC_parse;
9355 RExC_end = oldregxend;
9356 vFAIL2("Missing right brace on \\%c{}", c);
9361 RExC_end = RExC_parse + 2;
9362 if (RExC_end > oldregxend)
9363 RExC_end = oldregxend;
9367 ret = regclass(pRExC_state,depth+1);
9369 RExC_end = oldregxend;
9372 Set_Node_Offset(ret, parse_start + 2);
9373 Set_Node_Cur_Length(ret);
9374 nextchar(pRExC_state);
9375 *flagp |= HASWIDTH|SIMPLE;
9379 /* Handle \N and \N{NAME} here and not below because it can be
9380 multicharacter. join_exact() will join them up later on.
9381 Also this makes sure that things like /\N{BLAH}+/ and
9382 \N{BLAH} being multi char Just Happen. dmq*/
9384 ret= reg_namedseq(pRExC_state, NULL, flagp, depth);
9386 case 'k': /* Handle \k<NAME> and \k'NAME' */
9389 char ch= RExC_parse[1];
9390 if (ch != '<' && ch != '\'' && ch != '{') {
9392 vFAIL2("Sequence %.2s... not terminated",parse_start);
9394 /* this pretty much dupes the code for (?P=...) in reg(), if
9395 you change this make sure you change that */
9396 char* name_start = (RExC_parse += 2);
9398 SV *sv_dat = reg_scan_name(pRExC_state,
9399 SIZE_ONLY ? REG_RSN_RETURN_NULL : REG_RSN_RETURN_DATA);
9400 ch= (ch == '<') ? '>' : (ch == '{') ? '}' : '\'';
9401 if (RExC_parse == name_start || *RExC_parse != ch)
9402 vFAIL2("Sequence %.3s... not terminated",parse_start);
9405 num = add_data( pRExC_state, 1, "S" );
9406 RExC_rxi->data->data[num]=(void*)sv_dat;
9407 SvREFCNT_inc_simple_void(sv_dat);
9411 ret = reganode(pRExC_state,
9414 : (MORE_ASCII_RESTRICTED)
9416 : (AT_LEAST_UNI_SEMANTICS)
9424 /* override incorrect value set in reganode MJD */
9425 Set_Node_Offset(ret, parse_start+1);
9426 Set_Node_Cur_Length(ret); /* MJD */
9427 nextchar(pRExC_state);
9433 case '1': case '2': case '3': case '4':
9434 case '5': case '6': case '7': case '8': case '9':
9437 bool isg = *RExC_parse == 'g';
9442 if (*RExC_parse == '{') {
9446 if (*RExC_parse == '-') {
9450 if (hasbrace && !isDIGIT(*RExC_parse)) {
9451 if (isrel) RExC_parse--;
9453 goto parse_named_seq;
9455 num = atoi(RExC_parse);
9456 if (isg && num == 0)
9457 vFAIL("Reference to invalid group 0");
9459 num = RExC_npar - num;
9461 vFAIL("Reference to nonexistent or unclosed group");
9463 if (!isg && num > 9 && num >= RExC_npar)
9466 char * const parse_start = RExC_parse - 1; /* MJD */
9467 while (isDIGIT(*RExC_parse))
9469 if (parse_start == RExC_parse - 1)
9470 vFAIL("Unterminated \\g... pattern");
9472 if (*RExC_parse != '}')
9473 vFAIL("Unterminated \\g{...} pattern");
9477 if (num > (I32)RExC_rx->nparens)
9478 vFAIL("Reference to nonexistent group");
9481 ret = reganode(pRExC_state,
9484 : (MORE_ASCII_RESTRICTED)
9486 : (AT_LEAST_UNI_SEMANTICS)
9494 /* override incorrect value set in reganode MJD */
9495 Set_Node_Offset(ret, parse_start+1);
9496 Set_Node_Cur_Length(ret); /* MJD */
9498 nextchar(pRExC_state);
9503 if (RExC_parse >= RExC_end)
9504 FAIL("Trailing \\");
9507 /* Do not generate "unrecognized" warnings here, we fall
9508 back into the quick-grab loop below */
9515 if (RExC_flags & RXf_PMf_EXTENDED) {
9516 if ( reg_skipcomment( pRExC_state ) )
9523 parse_start = RExC_parse - 1;
9528 register STRLEN len;
9533 U8 tmpbuf[UTF8_MAXBYTES_CASE+1], *foldbuf;
9536 /* Is this a LATIN LOWER CASE SHARP S in an EXACTFU node? If so,
9537 * it is folded to 'ss' even if not utf8 */
9538 bool is_exactfu_sharp_s;
9541 node_type = ((! FOLD) ? EXACT
9544 : (MORE_ASCII_RESTRICTED)
9546 : (AT_LEAST_UNI_SEMANTICS)
9549 ret = reg_node(pRExC_state, node_type);
9552 /* XXX The node can hold up to 255 bytes, yet this only goes to
9553 * 127. I (khw) do not know why. Keeping it somewhat less than
9554 * 255 allows us to not have to worry about overflow due to
9555 * converting to utf8 and fold expansion, but that value is
9556 * 255-UTF8_MAXBYTES_CASE. join_exact() may join adjacent nodes
9557 * split up by this limit into a single one using the real max of
9558 * 255. Even at 127, this breaks under rare circumstances. If
9559 * folding, we do not want to split a node at a character that is a
9560 * non-final in a multi-char fold, as an input string could just
9561 * happen to want to match across the node boundary. The join
9562 * would solve that problem if the join actually happens. But a
9563 * series of more than two nodes in a row each of 127 would cause
9564 * the first join to succeed to get to 254, but then there wouldn't
9565 * be room for the next one, which could at be one of those split
9566 * multi-char folds. I don't know of any fool-proof solution. One
9567 * could back off to end with only a code point that isn't such a
9568 * non-final, but it is possible for there not to be any in the
9570 for (len = 0, p = RExC_parse - 1;
9571 len < 127 && p < RExC_end;
9574 char * const oldp = p;
9576 if (RExC_flags & RXf_PMf_EXTENDED)
9577 p = regwhite( pRExC_state, p );
9588 /* Literal Escapes Switch
9590 This switch is meant to handle escape sequences that
9591 resolve to a literal character.
9593 Every escape sequence that represents something
9594 else, like an assertion or a char class, is handled
9595 in the switch marked 'Special Escapes' above in this
9596 routine, but also has an entry here as anything that
9597 isn't explicitly mentioned here will be treated as
9598 an unescaped equivalent literal.
9602 /* These are all the special escapes. */
9603 case 'A': /* Start assertion */
9604 case 'b': case 'B': /* Word-boundary assertion*/
9605 case 'C': /* Single char !DANGEROUS! */
9606 case 'd': case 'D': /* digit class */
9607 case 'g': case 'G': /* generic-backref, pos assertion */
9608 case 'h': case 'H': /* HORIZWS */
9609 case 'k': case 'K': /* named backref, keep marker */
9610 case 'N': /* named char sequence */
9611 case 'p': case 'P': /* Unicode property */
9612 case 'R': /* LNBREAK */
9613 case 's': case 'S': /* space class */
9614 case 'v': case 'V': /* VERTWS */
9615 case 'w': case 'W': /* word class */
9616 case 'X': /* eXtended Unicode "combining character sequence" */
9617 case 'z': case 'Z': /* End of line/string assertion */
9621 /* Anything after here is an escape that resolves to a
9622 literal. (Except digits, which may or may not)
9641 ender = ASCII_TO_NATIVE('\033');
9645 ender = ASCII_TO_NATIVE('\007');
9650 STRLEN brace_len = len;
9652 const char* error_msg;
9654 bool valid = grok_bslash_o(p,
9661 RExC_parse = p; /* going to die anyway; point
9662 to exact spot of failure */
9669 if (PL_encoding && ender < 0x100) {
9670 goto recode_encoding;
9679 char* const e = strchr(p, '}');
9683 vFAIL("Missing right brace on \\x{}");
9686 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
9687 | PERL_SCAN_DISALLOW_PREFIX;
9688 STRLEN numlen = e - p - 1;
9689 ender = grok_hex(p + 1, &numlen, &flags, NULL);
9696 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
9698 ender = grok_hex(p, &numlen, &flags, NULL);
9701 if (PL_encoding && ender < 0x100)
9702 goto recode_encoding;
9706 ender = grok_bslash_c(*p++, UTF, SIZE_ONLY);
9708 case '0': case '1': case '2': case '3':case '4':
9709 case '5': case '6': case '7': case '8':case '9':
9711 (isDIGIT(p[1]) && atoi(p) >= RExC_npar))
9713 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
9715 ender = grok_oct(p, &numlen, &flags, NULL);
9725 if (PL_encoding && ender < 0x100)
9726 goto recode_encoding;
9729 if (! RExC_override_recoding) {
9730 SV* enc = PL_encoding;
9731 ender = reg_recode((const char)(U8)ender, &enc);
9732 if (!enc && SIZE_ONLY)
9733 ckWARNreg(p, "Invalid escape in the specified encoding");
9739 FAIL("Trailing \\");
9742 if (!SIZE_ONLY&& isALPHA(*p)) {
9743 /* Include any { following the alpha to emphasize
9744 * that it could be part of an escape at some point
9746 int len = (*(p + 1) == '{') ? 2 : 1;
9747 ckWARN3reg(p + len, "Unrecognized escape \\%.*s passed through", len, p);
9749 goto normal_default;
9754 if (UTF8_IS_START(*p) && UTF) {
9756 ender = utf8n_to_uvchr((U8*)p, RExC_end - p,
9757 &numlen, UTF8_ALLOW_DEFAULT);
9763 } /* End of switch on the literal */
9765 is_exactfu_sharp_s = (node_type == EXACTFU
9766 && ender == LATIN_SMALL_LETTER_SHARP_S);
9767 if ( RExC_flags & RXf_PMf_EXTENDED)
9768 p = regwhite( pRExC_state, p );
9769 if ((UTF && FOLD) || is_exactfu_sharp_s) {
9770 /* Prime the casefolded buffer. Locale rules, which apply
9771 * only to code points < 256, aren't known until execution,
9772 * so for them, just output the original character using
9773 * utf8. If we start to fold non-UTF patterns, be sure to
9774 * update join_exact() */
9775 if (LOC && ender < 256) {
9776 if (UNI_IS_INVARIANT(ender)) {
9777 *tmpbuf = (U8) ender;
9780 *tmpbuf = UTF8_TWO_BYTE_HI(ender);
9781 *(tmpbuf + 1) = UTF8_TWO_BYTE_LO(ender);
9785 else if (isASCII(ender)) { /* Note: Here can't also be LOC
9787 ender = toLOWER(ender);
9788 *tmpbuf = (U8) ender;
9791 else if (! MORE_ASCII_RESTRICTED && ! LOC) {
9793 /* Locale and /aa require more selectivity about the
9794 * fold, so are handled below. Otherwise, here, just
9796 ender = toFOLD_uni(ender, tmpbuf, &foldlen);
9799 /* Under locale rules or /aa we are not to mix,
9800 * respectively, ords < 256 or ASCII with non-. So
9801 * reject folds that mix them, using only the
9802 * non-folded code point. So do the fold to a
9803 * temporary, and inspect each character in it. */
9804 U8 trialbuf[UTF8_MAXBYTES_CASE+1];
9806 UV tmpender = toFOLD_uni(ender, trialbuf, &foldlen);
9807 U8* e = s + foldlen;
9808 bool fold_ok = TRUE;
9812 || (LOC && (UTF8_IS_INVARIANT(*s)
9813 || UTF8_IS_DOWNGRADEABLE_START(*s))))
9821 Copy(trialbuf, tmpbuf, foldlen, U8);
9825 uvuni_to_utf8(tmpbuf, ender);
9826 foldlen = UNISKIP(ender);
9830 if (p < RExC_end && ISMULT2(p)) { /* Back off on ?+*. */
9833 else if (UTF || is_exactfu_sharp_s) {
9835 /* Emit all the Unicode characters. */
9837 for (foldbuf = tmpbuf;
9839 foldlen -= numlen) {
9841 /* tmpbuf has been constructed by us, so we
9842 * know it is valid utf8 */
9843 ender = valid_utf8_to_uvchr(foldbuf, &numlen);
9845 const STRLEN unilen = reguni(pRExC_state, ender, s);
9848 /* In EBCDIC the numlen
9849 * and unilen can differ. */
9851 if (numlen >= foldlen)
9855 break; /* "Can't happen." */
9859 const STRLEN unilen = reguni(pRExC_state, ender, s);
9868 REGC((char)ender, s++);
9872 if (UTF || is_exactfu_sharp_s) {
9874 /* Emit all the Unicode characters. */
9876 for (foldbuf = tmpbuf;
9878 foldlen -= numlen) {
9879 ender = valid_utf8_to_uvchr(foldbuf, &numlen);
9881 const STRLEN unilen = reguni(pRExC_state, ender, s);
9884 /* In EBCDIC the numlen
9885 * and unilen can differ. */
9887 if (numlen >= foldlen)
9895 const STRLEN unilen = reguni(pRExC_state, ender, s);
9904 REGC((char)ender, s++);
9907 loopdone: /* Jumped to when encounters something that shouldn't be in
9910 Set_Node_Cur_Length(ret); /* MJD */
9911 nextchar(pRExC_state);
9913 /* len is STRLEN which is unsigned, need to copy to signed */
9916 vFAIL("Internal disaster");
9920 if (len == 1 && UNI_IS_INVARIANT(ender))
9924 RExC_size += STR_SZ(len);
9927 RExC_emit += STR_SZ(len);
9935 /* Jumped to when an unrecognized character set is encountered */
9937 Perl_croak(aTHX_ "panic: Unknown regex character set encoding: %u", get_regex_charset(RExC_flags));
9942 S_regwhite( RExC_state_t *pRExC_state, char *p )
9944 const char *e = RExC_end;
9946 PERL_ARGS_ASSERT_REGWHITE;
9951 else if (*p == '#') {
9960 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
9968 /* Parse POSIX character classes: [[:foo:]], [[=foo=]], [[.foo.]].
9969 Character classes ([:foo:]) can also be negated ([:^foo:]).
9970 Returns a named class id (ANYOF_XXX) if successful, -1 otherwise.
9971 Equivalence classes ([=foo=]) and composites ([.foo.]) are parsed,
9972 but trigger failures because they are currently unimplemented. */
9974 #define POSIXCC_DONE(c) ((c) == ':')
9975 #define POSIXCC_NOTYET(c) ((c) == '=' || (c) == '.')
9976 #define POSIXCC(c) (POSIXCC_DONE(c) || POSIXCC_NOTYET(c))
9979 S_regpposixcc(pTHX_ RExC_state_t *pRExC_state, I32 value)
9982 I32 namedclass = OOB_NAMEDCLASS;
9984 PERL_ARGS_ASSERT_REGPPOSIXCC;
9986 if (value == '[' && RExC_parse + 1 < RExC_end &&
9987 /* I smell either [: or [= or [. -- POSIX has been here, right? */
9988 POSIXCC(UCHARAT(RExC_parse))) {
9989 const char c = UCHARAT(RExC_parse);
9990 char* const s = RExC_parse++;
9992 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != c)
9994 if (RExC_parse == RExC_end)
9995 /* Grandfather lone [:, [=, [. */
9998 const char* const t = RExC_parse++; /* skip over the c */
10001 if (UCHARAT(RExC_parse) == ']') {
10002 const char *posixcc = s + 1;
10003 RExC_parse++; /* skip over the ending ] */
10006 const I32 complement = *posixcc == '^' ? *posixcc++ : 0;
10007 const I32 skip = t - posixcc;
10009 /* Initially switch on the length of the name. */
10012 if (memEQ(posixcc, "word", 4)) /* this is not POSIX, this is the Perl \w */
10013 namedclass = complement ? ANYOF_NALNUM : ANYOF_ALNUM;
10016 /* Names all of length 5. */
10017 /* alnum alpha ascii blank cntrl digit graph lower
10018 print punct space upper */
10019 /* Offset 4 gives the best switch position. */
10020 switch (posixcc[4]) {
10022 if (memEQ(posixcc, "alph", 4)) /* alpha */
10023 namedclass = complement ? ANYOF_NALPHA : ANYOF_ALPHA;
10026 if (memEQ(posixcc, "spac", 4)) /* space */
10027 namedclass = complement ? ANYOF_NPSXSPC : ANYOF_PSXSPC;
10030 if (memEQ(posixcc, "grap", 4)) /* graph */
10031 namedclass = complement ? ANYOF_NGRAPH : ANYOF_GRAPH;
10034 if (memEQ(posixcc, "asci", 4)) /* ascii */
10035 namedclass = complement ? ANYOF_NASCII : ANYOF_ASCII;
10038 if (memEQ(posixcc, "blan", 4)) /* blank */
10039 namedclass = complement ? ANYOF_NBLANK : ANYOF_BLANK;
10042 if (memEQ(posixcc, "cntr", 4)) /* cntrl */
10043 namedclass = complement ? ANYOF_NCNTRL : ANYOF_CNTRL;
10046 if (memEQ(posixcc, "alnu", 4)) /* alnum */
10047 namedclass = complement ? ANYOF_NALNUMC : ANYOF_ALNUMC;
10050 if (memEQ(posixcc, "lowe", 4)) /* lower */
10051 namedclass = complement ? ANYOF_NLOWER : ANYOF_LOWER;
10052 else if (memEQ(posixcc, "uppe", 4)) /* upper */
10053 namedclass = complement ? ANYOF_NUPPER : ANYOF_UPPER;
10056 if (memEQ(posixcc, "digi", 4)) /* digit */
10057 namedclass = complement ? ANYOF_NDIGIT : ANYOF_DIGIT;
10058 else if (memEQ(posixcc, "prin", 4)) /* print */
10059 namedclass = complement ? ANYOF_NPRINT : ANYOF_PRINT;
10060 else if (memEQ(posixcc, "punc", 4)) /* punct */
10061 namedclass = complement ? ANYOF_NPUNCT : ANYOF_PUNCT;
10066 if (memEQ(posixcc, "xdigit", 6))
10067 namedclass = complement ? ANYOF_NXDIGIT : ANYOF_XDIGIT;
10071 if (namedclass == OOB_NAMEDCLASS)
10072 Simple_vFAIL3("POSIX class [:%.*s:] unknown",
10074 assert (posixcc[skip] == ':');
10075 assert (posixcc[skip+1] == ']');
10076 } else if (!SIZE_ONLY) {
10077 /* [[=foo=]] and [[.foo.]] are still future. */
10079 /* adjust RExC_parse so the warning shows after
10080 the class closes */
10081 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse) != ']')
10083 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10086 /* Maternal grandfather:
10087 * "[:" ending in ":" but not in ":]" */
10097 S_checkposixcc(pTHX_ RExC_state_t *pRExC_state)
10101 PERL_ARGS_ASSERT_CHECKPOSIXCC;
10103 if (POSIXCC(UCHARAT(RExC_parse))) {
10104 const char *s = RExC_parse;
10105 const char c = *s++;
10107 while (isALNUM(*s))
10109 if (*s && c == *s && s[1] == ']') {
10111 "POSIX syntax [%c %c] belongs inside character classes",
10114 /* [[=foo=]] and [[.foo.]] are still future. */
10115 if (POSIXCC_NOTYET(c)) {
10116 /* adjust RExC_parse so the error shows after
10117 the class closes */
10118 while (UCHARAT(RExC_parse) && UCHARAT(RExC_parse++) != ']')
10120 Simple_vFAIL3("POSIX syntax [%c %c] is reserved for future extensions", c, c);
10126 /* Generate the code to add a full posix character <class> to the bracketed
10127 * character class given by <node>. (<node> is needed only under locale rules)
10128 * destlist is the inversion list for non-locale rules that this class is
10130 * sourcelist is the ASCII-range inversion list to add under /a rules
10131 * Xsourcelist is the full Unicode range list to use otherwise. */
10132 #define DO_POSIX(node, class, destlist, sourcelist, Xsourcelist) \
10134 SV* scratch_list = NULL; \
10136 /* Set this class in the node for runtime matching */ \
10137 ANYOF_CLASS_SET(node, class); \
10139 /* For above Latin1 code points, we use the full Unicode range */ \
10140 _invlist_intersection(PL_AboveLatin1, \
10143 /* And set the output to it, adding instead if there already is an \
10144 * output. Checking if <destlist> is NULL first saves an extra \
10145 * clone. Its reference count will be decremented at the next \
10146 * union, etc, or if this is the only instance, at the end of the \
10148 if (! destlist) { \
10149 destlist = scratch_list; \
10152 _invlist_union(destlist, scratch_list, &destlist); \
10153 SvREFCNT_dec(scratch_list); \
10157 /* For non-locale, just add it to any existing list */ \
10158 _invlist_union(destlist, \
10159 (AT_LEAST_ASCII_RESTRICTED) \
10165 /* Like DO_POSIX, but matches the complement of <sourcelist> and <Xsourcelist>.
10167 #define DO_N_POSIX(node, class, destlist, sourcelist, Xsourcelist) \
10169 SV* scratch_list = NULL; \
10170 ANYOF_CLASS_SET(node, class); \
10171 _invlist_subtract(PL_AboveLatin1, Xsourcelist, &scratch_list); \
10172 if (! destlist) { \
10173 destlist = scratch_list; \
10176 _invlist_union(destlist, scratch_list, &destlist); \
10177 SvREFCNT_dec(scratch_list); \
10181 _invlist_union_complement_2nd(destlist, \
10182 (AT_LEAST_ASCII_RESTRICTED) \
10186 /* Under /d, everything in the upper half of the Latin1 range \
10187 * matches this complement */ \
10188 if (DEPENDS_SEMANTICS) { \
10189 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL; \
10193 /* Generate the code to add a posix character <class> to the bracketed
10194 * character class given by <node>. (<node> is needed only under locale rules)
10195 * destlist is the inversion list for non-locale rules that this class is
10197 * sourcelist is the ASCII-range inversion list to add under /a rules
10198 * l1_sourcelist is the Latin1 range list to use otherwise.
10199 * Xpropertyname is the name to add to <run_time_list> of the property to
10200 * specify the code points above Latin1 that will have to be
10201 * determined at run-time
10202 * run_time_list is a SV* that contains text names of properties that are to
10203 * be computed at run time. This concatenates <Xpropertyname>
10204 * to it, apppropriately
10205 * This is essentially DO_POSIX, but we know only the Latin1 values at compile
10207 #define DO_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist, \
10208 l1_sourcelist, Xpropertyname, run_time_list) \
10209 /* If not /a matching, there are going to be code points we will have \
10210 * to defer to runtime to look-up */ \
10211 if (! AT_LEAST_ASCII_RESTRICTED) { \
10212 Perl_sv_catpvf(aTHX_ run_time_list, "+utf8::%s\n", Xpropertyname); \
10215 ANYOF_CLASS_SET(node, class); \
10218 _invlist_union(destlist, \
10219 (AT_LEAST_ASCII_RESTRICTED) \
10225 /* Like DO_POSIX_LATIN1_ONLY_KNOWN, but for the complement. A combination of
10226 * this and DO_N_POSIX */
10227 #define DO_N_POSIX_LATIN1_ONLY_KNOWN(node, class, destlist, sourcelist, \
10228 l1_sourcelist, Xpropertyname, run_time_list) \
10229 if (AT_LEAST_ASCII_RESTRICTED) { \
10230 _invlist_union_complement_2nd(destlist, sourcelist, &destlist); \
10233 Perl_sv_catpvf(aTHX_ run_time_list, "!utf8::%s\n", Xpropertyname); \
10235 ANYOF_CLASS_SET(node, namedclass); \
10238 SV* scratch_list = NULL; \
10239 _invlist_subtract(PL_Latin1, l1_sourcelist, &scratch_list); \
10240 if (! destlist) { \
10241 destlist = scratch_list; \
10244 _invlist_union(destlist, scratch_list, &destlist); \
10245 SvREFCNT_dec(scratch_list); \
10247 if (DEPENDS_SEMANTICS) { \
10248 ANYOF_FLAGS(node) |= ANYOF_NON_UTF8_LATIN1_ALL; \
10254 S_set_regclass_bit_fold(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10257 /* Handle the setting of folds in the bitmap for non-locale ANYOF nodes.
10258 * Locale folding is done at run-time, so this function should not be
10259 * called for nodes that are for locales.
10261 * This function sets the bit corresponding to the fold of the input
10262 * 'value', if not already set. The fold of 'f' is 'F', and the fold of
10265 * It also knows about the characters that are in the bitmap that have
10266 * folds that are matchable only outside it, and sets the appropriate lists
10269 * It returns the number of bits that actually changed from 0 to 1 */
10274 PERL_ARGS_ASSERT_SET_REGCLASS_BIT_FOLD;
10276 fold = (AT_LEAST_UNI_SEMANTICS) ? PL_fold_latin1[value]
10279 /* It assumes the bit for 'value' has already been set */
10280 if (fold != value && ! ANYOF_BITMAP_TEST(node, fold)) {
10281 ANYOF_BITMAP_SET(node, fold);
10284 if (_HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value) && (! isASCII(value) || ! MORE_ASCII_RESTRICTED)) {
10285 /* Certain Latin1 characters have matches outside the bitmap. To get
10286 * here, 'value' is one of those characters. None of these matches is
10287 * valid for ASCII characters under /aa, which have been excluded by
10288 * the 'if' above. The matches fall into three categories:
10289 * 1) They are singly folded-to or -from an above 255 character, as
10290 * LATIN SMALL LETTER Y WITH DIAERESIS and LATIN CAPITAL LETTER Y
10292 * 2) They are part of a multi-char fold with another character in the
10293 * bitmap, only LATIN SMALL LETTER SHARP S => "ss" fits that bill;
10294 * 3) They are part of a multi-char fold with a character not in the
10295 * bitmap, such as various ligatures.
10296 * We aren't dealing fully with multi-char folds, except we do deal
10297 * with the pattern containing a character that has a multi-char fold
10298 * (not so much the inverse).
10299 * For types 1) and 3), the matches only happen when the target string
10300 * is utf8; that's not true for 2), and we set a flag for it.
10302 * The code below adds to the passed in inversion list the single fold
10303 * closures for 'value'. The values are hard-coded here so that an
10304 * innocent-looking character class, like /[ks]/i won't have to go out
10305 * to disk to find the possible matches. XXX It would be better to
10306 * generate these via regen, in case a new version of the Unicode
10307 * standard adds new mappings, though that is not really likely. */
10312 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212A);
10316 /* LATIN SMALL LETTER LONG S */
10317 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x017F);
10320 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10321 GREEK_SMALL_LETTER_MU);
10322 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10323 GREEK_CAPITAL_LETTER_MU);
10325 case LATIN_CAPITAL_LETTER_A_WITH_RING_ABOVE:
10326 case LATIN_SMALL_LETTER_A_WITH_RING_ABOVE:
10327 /* ANGSTROM SIGN */
10328 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, 0x212B);
10329 if (DEPENDS_SEMANTICS) { /* See DEPENDS comment below */
10330 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10331 PL_fold_latin1[value]);
10334 case LATIN_SMALL_LETTER_Y_WITH_DIAERESIS:
10335 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10336 LATIN_CAPITAL_LETTER_Y_WITH_DIAERESIS);
10338 case LATIN_SMALL_LETTER_SHARP_S:
10339 *invlist_ptr = add_cp_to_invlist(*invlist_ptr,
10340 LATIN_CAPITAL_LETTER_SHARP_S);
10342 /* Under /a, /d, and /u, this can match the two chars "ss" */
10343 if (! MORE_ASCII_RESTRICTED) {
10344 add_alternate(alternate_ptr, (U8 *) "ss", 2);
10346 /* And under /u or /a, it can match even if the target is
10348 if (AT_LEAST_UNI_SEMANTICS) {
10349 ANYOF_FLAGS(node) |= ANYOF_NONBITMAP_NON_UTF8;
10353 case 'F': case 'f':
10354 case 'I': case 'i':
10355 case 'L': case 'l':
10356 case 'T': case 't':
10357 case 'A': case 'a':
10358 case 'H': case 'h':
10359 case 'J': case 'j':
10360 case 'N': case 'n':
10361 case 'W': case 'w':
10362 case 'Y': case 'y':
10363 /* These all are targets of multi-character folds from code
10364 * points that require UTF8 to express, so they can't match
10365 * unless the target string is in UTF-8, so no action here is
10366 * necessary, as regexec.c properly handles the general case
10367 * for UTF-8 matching */
10370 /* Use deprecated warning to increase the chances of this
10372 ckWARN2regdep(RExC_parse, "Perl folding rules are not up-to-date for 0x%x; please use the perlbug utility to report;", value);
10376 else if (DEPENDS_SEMANTICS
10377 && ! isASCII(value)
10378 && PL_fold_latin1[value] != value)
10380 /* Under DEPENDS rules, non-ASCII Latin1 characters match their
10381 * folds only when the target string is in UTF-8. We add the fold
10382 * here to the list of things to match outside the bitmap, which
10383 * won't be looked at unless it is UTF8 (or else if something else
10384 * says to look even if not utf8, but those things better not happen
10385 * under DEPENDS semantics. */
10386 *invlist_ptr = add_cp_to_invlist(*invlist_ptr, PL_fold_latin1[value]);
10393 PERL_STATIC_INLINE U8
10394 S_set_regclass_bit(pTHX_ RExC_state_t *pRExC_state, regnode* node, const U8 value, SV** invlist_ptr, AV** alternate_ptr)
10396 /* This inline function sets a bit in the bitmap if not already set, and if
10397 * appropriate, its fold, returning the number of bits that actually
10398 * changed from 0 to 1 */
10402 PERL_ARGS_ASSERT_SET_REGCLASS_BIT;
10404 if (ANYOF_BITMAP_TEST(node, value)) { /* Already set */
10408 ANYOF_BITMAP_SET(node, value);
10411 if (FOLD && ! LOC) { /* Locale folds aren't known until runtime */
10412 stored += set_regclass_bit_fold(pRExC_state, node, value, invlist_ptr, alternate_ptr);
10419 S_add_alternate(pTHX_ AV** alternate_ptr, U8* string, STRLEN len)
10421 /* Adds input 'string' with length 'len' to the ANYOF node's unicode
10422 * alternate list, pointed to by 'alternate_ptr'. This is an array of
10423 * the multi-character folds of characters in the node */
10426 PERL_ARGS_ASSERT_ADD_ALTERNATE;
10428 if (! *alternate_ptr) {
10429 *alternate_ptr = newAV();
10431 sv = newSVpvn_utf8((char*)string, len, TRUE);
10432 av_push(*alternate_ptr, sv);
10437 parse a class specification and produce either an ANYOF node that
10438 matches the pattern or perhaps will be optimized into an EXACTish node
10439 instead. The node contains a bit map for the first 256 characters, with the
10440 corresponding bit set if that character is in the list. For characters
10441 above 255, a range list is used */
10444 S_regclass(pTHX_ RExC_state_t *pRExC_state, U32 depth)
10447 register UV nextvalue;
10448 register IV prevvalue = OOB_UNICODE;
10449 register IV range = 0;
10450 UV value = 0; /* XXX:dmq: needs to be referenceable (unfortunately) */
10451 register regnode *ret;
10454 char *rangebegin = NULL;
10455 bool need_class = 0;
10456 bool allow_full_fold = TRUE; /* Assume wants multi-char folding */
10458 STRLEN initial_listsv_len = 0; /* Kind of a kludge to see if it is more
10459 than just initialized. */
10460 SV* properties = NULL; /* Code points that match \p{} \P{} */
10461 UV element_count = 0; /* Number of distinct elements in the class.
10462 Optimizations may be possible if this is tiny */
10465 /* Unicode properties are stored in a swash; this holds the current one
10466 * being parsed. If this swash is the only above-latin1 component of the
10467 * character class, an optimization is to pass it directly on to the
10468 * execution engine. Otherwise, it is set to NULL to indicate that there
10469 * are other things in the class that have to be dealt with at execution
10471 SV* swash = NULL; /* Code points that match \p{} \P{} */
10473 /* Set if a component of this character class is user-defined; just passed
10474 * on to the engine */
10475 UV has_user_defined_property = 0;
10477 /* code points this node matches that can't be stored in the bitmap */
10478 SV* nonbitmap = NULL;
10480 /* The items that are to match that aren't stored in the bitmap, but are a
10481 * result of things that are stored there. This is the fold closure of
10482 * such a character, either because it has DEPENDS semantics and shouldn't
10483 * be matched unless the target string is utf8, or is a code point that is
10484 * too large for the bit map, as for example, the fold of the MICRO SIGN is
10485 * above 255. This all is solely for performance reasons. By having this
10486 * code know the outside-the-bitmap folds that the bitmapped characters are
10487 * involved with, we don't have to go out to disk to find the list of
10488 * matches, unless the character class includes code points that aren't
10489 * storable in the bit map. That means that a character class with an 's'
10490 * in it, for example, doesn't need to go out to disk to find everything
10491 * that matches. A 2nd list is used so that the 'nonbitmap' list is kept
10492 * empty unless there is something whose fold we don't know about, and will
10493 * have to go out to the disk to find. */
10494 SV* l1_fold_invlist = NULL;
10496 /* List of multi-character folds that are matched by this node */
10497 AV* unicode_alternate = NULL;
10499 UV literal_endpoint = 0;
10501 UV stored = 0; /* how many chars stored in the bitmap */
10503 regnode * const orig_emit = RExC_emit; /* Save the original RExC_emit in
10504 case we need to change the emitted regop to an EXACT. */
10505 const char * orig_parse = RExC_parse;
10506 GET_RE_DEBUG_FLAGS_DECL;
10508 PERL_ARGS_ASSERT_REGCLASS;
10510 PERL_UNUSED_ARG(depth);
10513 DEBUG_PARSE("clas");
10515 /* Assume we are going to generate an ANYOF node. */
10516 ret = reganode(pRExC_state, ANYOF, 0);
10520 ANYOF_FLAGS(ret) = 0;
10523 if (UCHARAT(RExC_parse) == '^') { /* Complement of range. */
10527 ANYOF_FLAGS(ret) |= ANYOF_INVERT;
10529 /* We have decided to not allow multi-char folds in inverted character
10530 * classes, due to the confusion that can happen, especially with
10531 * classes that are designed for a non-Unicode world: You have the
10532 * peculiar case that:
10533 "s s" =~ /^[^\xDF]+$/i => Y
10534 "ss" =~ /^[^\xDF]+$/i => N
10536 * See [perl #89750] */
10537 allow_full_fold = FALSE;
10541 RExC_size += ANYOF_SKIP;
10542 listsv = &PL_sv_undef; /* For code scanners: listsv always non-NULL. */
10545 RExC_emit += ANYOF_SKIP;
10547 ANYOF_FLAGS(ret) |= ANYOF_LOCALE;
10549 ANYOF_BITMAP_ZERO(ret);
10550 listsv = newSVpvs("# comment\n");
10551 initial_listsv_len = SvCUR(listsv);
10554 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10556 if (!SIZE_ONLY && POSIXCC(nextvalue))
10557 checkposixcc(pRExC_state);
10559 /* allow 1st char to be ] (allowing it to be - is dealt with later) */
10560 if (UCHARAT(RExC_parse) == ']')
10561 goto charclassloop;
10564 while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
10568 namedclass = OOB_NAMEDCLASS; /* initialize as illegal */
10571 rangebegin = RExC_parse;
10575 value = utf8n_to_uvchr((U8*)RExC_parse,
10576 RExC_end - RExC_parse,
10577 &numlen, UTF8_ALLOW_DEFAULT);
10578 RExC_parse += numlen;
10581 value = UCHARAT(RExC_parse++);
10583 nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
10584 if (value == '[' && POSIXCC(nextvalue))
10585 namedclass = regpposixcc(pRExC_state, value);
10586 else if (value == '\\') {
10588 value = utf8n_to_uvchr((U8*)RExC_parse,
10589 RExC_end - RExC_parse,
10590 &numlen, UTF8_ALLOW_DEFAULT);
10591 RExC_parse += numlen;
10594 value = UCHARAT(RExC_parse++);
10595 /* Some compilers cannot handle switching on 64-bit integer
10596 * values, therefore value cannot be an UV. Yes, this will
10597 * be a problem later if we want switch on Unicode.
10598 * A similar issue a little bit later when switching on
10599 * namedclass. --jhi */
10600 switch ((I32)value) {
10601 case 'w': namedclass = ANYOF_ALNUM; break;
10602 case 'W': namedclass = ANYOF_NALNUM; break;
10603 case 's': namedclass = ANYOF_SPACE; break;
10604 case 'S': namedclass = ANYOF_NSPACE; break;
10605 case 'd': namedclass = ANYOF_DIGIT; break;
10606 case 'D': namedclass = ANYOF_NDIGIT; break;
10607 case 'v': namedclass = ANYOF_VERTWS; break;
10608 case 'V': namedclass = ANYOF_NVERTWS; break;
10609 case 'h': namedclass = ANYOF_HORIZWS; break;
10610 case 'H': namedclass = ANYOF_NHORIZWS; break;
10611 case 'N': /* Handle \N{NAME} in class */
10613 /* We only pay attention to the first char of
10614 multichar strings being returned. I kinda wonder
10615 if this makes sense as it does change the behaviour
10616 from earlier versions, OTOH that behaviour was broken
10618 UV v; /* value is register so we cant & it /grrr */
10619 if (reg_namedseq(pRExC_state, &v, NULL, depth)) {
10629 if (RExC_parse >= RExC_end)
10630 vFAIL2("Empty \\%c{}", (U8)value);
10631 if (*RExC_parse == '{') {
10632 const U8 c = (U8)value;
10633 e = strchr(RExC_parse++, '}');
10635 vFAIL2("Missing right brace on \\%c{}", c);
10636 while (isSPACE(UCHARAT(RExC_parse)))
10638 if (e == RExC_parse)
10639 vFAIL2("Empty \\%c{}", c);
10640 n = e - RExC_parse;
10641 while (isSPACE(UCHARAT(RExC_parse + n - 1)))
10652 if (UCHARAT(RExC_parse) == '^') {
10655 value = value == 'p' ? 'P' : 'p'; /* toggle */
10656 while (isSPACE(UCHARAT(RExC_parse))) {
10661 /* Try to get the definition of the property into
10662 * <invlist>. If /i is in effect, the effective property
10663 * will have its name be <__NAME_i>. The design is
10664 * discussed in commit
10665 * 2f833f5208e26b208886e51e09e2c072b5eabb46 */
10666 Newx(name, n + sizeof("_i__\n"), char);
10668 sprintf(name, "%s%.*s%s\n",
10669 (FOLD) ? "__" : "",
10675 /* Look up the property name, and get its swash and
10676 * inversion list, if the property is found */
10678 SvREFCNT_dec(swash);
10680 swash = _core_swash_init("utf8", name, &PL_sv_undef,
10683 TRUE, /* this routine will handle
10684 undefined properties */
10685 NULL, FALSE /* No inversion list */
10689 || ! SvTYPE(SvRV(swash)) == SVt_PVHV
10691 hv_fetchs(MUTABLE_HV(SvRV(swash)),
10693 || ! (invlist = *invlistsvp))
10696 SvREFCNT_dec(swash);
10700 /* Here didn't find it. It could be a user-defined
10701 * property that will be available at run-time. Add it
10702 * to the list to look up then */
10703 Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%s\n",
10704 (value == 'p' ? '+' : '!'),
10706 has_user_defined_property = 1;
10708 /* We don't know yet, so have to assume that the
10709 * property could match something in the Latin1 range,
10710 * hence something that isn't utf8 */
10711 ANYOF_FLAGS(ret) |= ANYOF_NONBITMAP_NON_UTF8;
10715 /* Here, did get the swash and its inversion list. If
10716 * the swash is from a user-defined property, then this
10717 * whole character class should be regarded as such */
10718 SV** user_defined_svp =
10719 hv_fetchs(MUTABLE_HV(SvRV(swash)),
10720 "USER_DEFINED", FALSE);
10721 if (user_defined_svp) {
10722 has_user_defined_property
10723 |= SvUV(*user_defined_svp);
10726 /* Invert if asking for the complement */
10727 if (value == 'P') {
10728 _invlist_union_complement_2nd(properties, invlist, &properties);
10730 /* The swash can't be used as-is, because we've
10731 * inverted things; delay removing it to here after
10732 * have copied its invlist above */
10733 SvREFCNT_dec(swash);
10737 _invlist_union(properties, invlist, &properties);
10742 RExC_parse = e + 1;
10743 namedclass = ANYOF_MAX; /* no official name, but it's named */
10745 /* \p means they want Unicode semantics */
10746 RExC_uni_semantics = 1;
10749 case 'n': value = '\n'; break;
10750 case 'r': value = '\r'; break;
10751 case 't': value = '\t'; break;
10752 case 'f': value = '\f'; break;
10753 case 'b': value = '\b'; break;
10754 case 'e': value = ASCII_TO_NATIVE('\033');break;
10755 case 'a': value = ASCII_TO_NATIVE('\007');break;
10757 RExC_parse--; /* function expects to be pointed at the 'o' */
10759 const char* error_msg;
10760 bool valid = grok_bslash_o(RExC_parse,
10765 RExC_parse += numlen;
10770 if (PL_encoding && value < 0x100) {
10771 goto recode_encoding;
10775 if (*RExC_parse == '{') {
10776 I32 flags = PERL_SCAN_ALLOW_UNDERSCORES
10777 | PERL_SCAN_DISALLOW_PREFIX;
10778 char * const e = strchr(RExC_parse++, '}');
10780 vFAIL("Missing right brace on \\x{}");
10782 numlen = e - RExC_parse;
10783 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10784 RExC_parse = e + 1;
10787 I32 flags = PERL_SCAN_DISALLOW_PREFIX;
10789 value = grok_hex(RExC_parse, &numlen, &flags, NULL);
10790 RExC_parse += numlen;
10792 if (PL_encoding && value < 0x100)
10793 goto recode_encoding;
10796 value = grok_bslash_c(*RExC_parse++, UTF, SIZE_ONLY);
10798 case '0': case '1': case '2': case '3': case '4':
10799 case '5': case '6': case '7':
10801 /* Take 1-3 octal digits */
10802 I32 flags = PERL_SCAN_SILENT_ILLDIGIT;
10804 value = grok_oct(--RExC_parse, &numlen, &flags, NULL);
10805 RExC_parse += numlen;
10806 if (PL_encoding && value < 0x100)
10807 goto recode_encoding;
10811 if (! RExC_override_recoding) {
10812 SV* enc = PL_encoding;
10813 value = reg_recode((const char)(U8)value, &enc);
10814 if (!enc && SIZE_ONLY)
10815 ckWARNreg(RExC_parse,
10816 "Invalid escape in the specified encoding");
10820 /* Allow \_ to not give an error */
10821 if (!SIZE_ONLY && isALNUM(value) && value != '_') {
10822 ckWARN2reg(RExC_parse,
10823 "Unrecognized escape \\%c in character class passed through",
10828 } /* end of \blah */
10831 literal_endpoint++;
10834 if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */
10836 /* What matches in a locale is not known until runtime, so need to
10837 * (one time per class) allocate extra space to pass to regexec.
10838 * The space will contain a bit for each named class that is to be
10839 * matched against. This isn't needed for \p{} and pseudo-classes,
10840 * as they are not affected by locale, and hence are dealt with
10842 if (LOC && namedclass < ANYOF_MAX && ! need_class) {
10845 RExC_size += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10848 RExC_emit += ANYOF_CLASS_SKIP - ANYOF_SKIP;
10849 ANYOF_CLASS_ZERO(ret);
10851 ANYOF_FLAGS(ret) |= ANYOF_CLASS;
10854 /* a bad range like a-\d, a-[:digit:]. The '-' is taken as a
10855 * literal, as is the character that began the false range, i.e.
10856 * the 'a' in the examples */
10860 RExC_parse >= rangebegin ?
10861 RExC_parse - rangebegin : 0;
10862 ckWARN4reg(RExC_parse,
10863 "False [] range \"%*.*s\"",
10867 set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
10868 if (prevvalue < 256) {
10870 set_regclass_bit(pRExC_state, ret, (U8) prevvalue, &l1_fold_invlist, &unicode_alternate);
10873 nonbitmap = add_cp_to_invlist(nonbitmap, prevvalue);
10877 range = 0; /* this was not a true range */
10882 /* Possible truncation here but in some 64-bit environments
10883 * the compiler gets heartburn about switch on 64-bit values.
10884 * A similar issue a little earlier when switching on value.
10886 switch ((I32)namedclass) {
10888 case ANYOF_ALNUMC: /* C's alnum, in contrast to \w */
10889 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10890 PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10892 case ANYOF_NALNUMC:
10893 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10894 PL_PosixAlnum, PL_L1PosixAlnum, "XPosixAlnum", listsv);
10897 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10898 PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10901 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10902 PL_PosixAlpha, PL_L1PosixAlpha, "XPosixAlpha", listsv);
10906 ANYOF_CLASS_SET(ret, namedclass);
10909 _invlist_union(properties, PL_ASCII, &properties);
10914 ANYOF_CLASS_SET(ret, namedclass);
10917 _invlist_union_complement_2nd(properties,
10918 PL_ASCII, &properties);
10919 if (DEPENDS_SEMANTICS) {
10920 ANYOF_FLAGS(ret) |= ANYOF_NON_UTF8_LATIN1_ALL;
10925 DO_POSIX(ret, namedclass, properties,
10926 PL_PosixBlank, PL_XPosixBlank);
10929 DO_N_POSIX(ret, namedclass, properties,
10930 PL_PosixBlank, PL_XPosixBlank);
10933 DO_POSIX(ret, namedclass, properties,
10934 PL_PosixCntrl, PL_XPosixCntrl);
10937 DO_N_POSIX(ret, namedclass, properties,
10938 PL_PosixCntrl, PL_XPosixCntrl);
10941 /* Ignore the compiler warning for this macro, planned to
10942 * be eliminated later */
10943 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10944 PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10947 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10948 PL_PosixDigit, PL_PosixDigit, "XPosixDigit", listsv);
10951 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10952 PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10955 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10956 PL_PosixGraph, PL_L1PosixGraph, "XPosixGraph", listsv);
10958 case ANYOF_HORIZWS:
10959 /* For these, we use the nonbitmap, as /d doesn't make a
10960 * difference in what these match. There would be problems
10961 * if these characters had folds other than themselves, as
10962 * nonbitmap is subject to folding. It turns out that \h
10963 * is just a synonym for XPosixBlank */
10964 _invlist_union(nonbitmap, PL_XPosixBlank, &nonbitmap);
10966 case ANYOF_NHORIZWS:
10967 _invlist_union_complement_2nd(nonbitmap,
10968 PL_XPosixBlank, &nonbitmap);
10972 { /* These require special handling, as they differ under
10973 folding, matching Cased there (which in the ASCII range
10974 is the same as Alpha */
10980 if (FOLD && ! LOC) {
10981 ascii_source = PL_PosixAlpha;
10982 l1_source = PL_L1Cased;
10986 ascii_source = PL_PosixLower;
10987 l1_source = PL_L1PosixLower;
10988 Xname = "XPosixLower";
10990 if (namedclass == ANYOF_LOWER) {
10991 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
10992 ascii_source, l1_source, Xname, listsv);
10995 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
10996 properties, ascii_source, l1_source, Xname, listsv);
11001 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11002 PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11005 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11006 PL_PosixPrint, PL_L1PosixPrint, "XPosixPrint", listsv);
11009 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11010 PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11013 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11014 PL_PosixPunct, PL_L1PosixPunct, "XPosixPunct", listsv);
11017 DO_POSIX(ret, namedclass, properties,
11018 PL_PosixSpace, PL_XPosixSpace);
11020 case ANYOF_NPSXSPC:
11021 DO_N_POSIX(ret, namedclass, properties,
11022 PL_PosixSpace, PL_XPosixSpace);
11025 DO_POSIX(ret, namedclass, properties,
11026 PL_PerlSpace, PL_XPerlSpace);
11029 DO_N_POSIX(ret, namedclass, properties,
11030 PL_PerlSpace, PL_XPerlSpace);
11032 case ANYOF_UPPER: /* Same as LOWER, above */
11039 if (FOLD && ! LOC) {
11040 ascii_source = PL_PosixAlpha;
11041 l1_source = PL_L1Cased;
11045 ascii_source = PL_PosixUpper;
11046 l1_source = PL_L1PosixUpper;
11047 Xname = "XPosixUpper";
11049 if (namedclass == ANYOF_UPPER) {
11050 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11051 ascii_source, l1_source, Xname, listsv);
11054 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass,
11055 properties, ascii_source, l1_source, Xname, listsv);
11059 case ANYOF_ALNUM: /* Really is 'Word' */
11060 DO_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11061 PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11064 DO_N_POSIX_LATIN1_ONLY_KNOWN(ret, namedclass, properties,
11065 PL_PosixWord, PL_L1PosixWord, "XPosixWord", listsv);
11068 /* For these, we use the nonbitmap, as /d doesn't make a
11069 * difference in what these match. There would be problems
11070 * if these characters had folds other than themselves, as
11071 * nonbitmap is subject to folding */
11072 _invlist_union(nonbitmap, PL_VertSpace, &nonbitmap);
11074 case ANYOF_NVERTWS:
11075 _invlist_union_complement_2nd(nonbitmap,
11076 PL_VertSpace, &nonbitmap);
11079 DO_POSIX(ret, namedclass, properties,
11080 PL_PosixXDigit, PL_XPosixXDigit);
11082 case ANYOF_NXDIGIT:
11083 DO_N_POSIX(ret, namedclass, properties,
11084 PL_PosixXDigit, PL_XPosixXDigit);
11087 /* this is to handle \p and \P */
11090 vFAIL("Invalid [::] class");
11096 } /* end of namedclass \blah */
11099 if (prevvalue > (IV)value) /* b-a */ {
11100 const int w = RExC_parse - rangebegin;
11101 Simple_vFAIL4("Invalid [] range \"%*.*s\"", w, w, rangebegin);
11102 range = 0; /* not a valid range */
11106 prevvalue = value; /* save the beginning of the range */
11107 if (RExC_parse+1 < RExC_end
11108 && *RExC_parse == '-'
11109 && RExC_parse[1] != ']')
11113 /* a bad range like \w-, [:word:]- ? */
11114 if (namedclass > OOB_NAMEDCLASS) {
11115 if (ckWARN(WARN_REGEXP)) {
11117 RExC_parse >= rangebegin ?
11118 RExC_parse - rangebegin : 0;
11120 "False [] range \"%*.*s\"",
11125 set_regclass_bit(pRExC_state, ret, '-', &l1_fold_invlist, &unicode_alternate);
11127 range = 1; /* yeah, it's a range! */
11128 continue; /* but do it the next time */
11132 /* non-Latin1 code point implies unicode semantics. Must be set in
11133 * pass1 so is there for the whole of pass 2 */
11135 RExC_uni_semantics = 1;
11138 /* now is the next time */
11140 if (prevvalue < 256) {
11141 const IV ceilvalue = value < 256 ? value : 255;
11144 /* In EBCDIC [\x89-\x91] should include
11145 * the \x8e but [i-j] should not. */
11146 if (literal_endpoint == 2 &&
11147 ((isLOWER(prevvalue) && isLOWER(ceilvalue)) ||
11148 (isUPPER(prevvalue) && isUPPER(ceilvalue))))
11150 if (isLOWER(prevvalue)) {
11151 for (i = prevvalue; i <= ceilvalue; i++)
11152 if (isLOWER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11154 set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11157 for (i = prevvalue; i <= ceilvalue; i++)
11158 if (isUPPER(i) && !ANYOF_BITMAP_TEST(ret,i)) {
11160 set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11166 for (i = prevvalue; i <= ceilvalue; i++) {
11167 stored += set_regclass_bit(pRExC_state, ret, (U8) i, &l1_fold_invlist, &unicode_alternate);
11171 const UV prevnatvalue = NATIVE_TO_UNI(prevvalue);
11172 const UV natvalue = NATIVE_TO_UNI(value);
11173 nonbitmap = add_range_to_invlist(nonbitmap, prevnatvalue, natvalue);
11176 literal_endpoint = 0;
11180 range = 0; /* this range (if it was one) is done now */
11187 /****** !SIZE_ONLY AFTER HERE *********/
11189 /* If folding and there are code points above 255, we calculate all
11190 * characters that could fold to or from the ones already on the list */
11191 if (FOLD && nonbitmap) {
11192 UV start, end; /* End points of code point ranges */
11194 SV* fold_intersection = NULL;
11196 /* This is a list of all the characters that participate in folds
11197 * (except marks, etc in multi-char folds */
11198 if (! PL_utf8_foldable) {
11199 SV* swash = swash_init("utf8", "Cased", &PL_sv_undef, 1, 0);
11200 PL_utf8_foldable = _swash_to_invlist(swash);
11201 SvREFCNT_dec(swash);
11204 /* This is a hash that for a particular fold gives all characters
11205 * that are involved in it */
11206 if (! PL_utf8_foldclosures) {
11208 /* If we were unable to find any folds, then we likely won't be
11209 * able to find the closures. So just create an empty list.
11210 * Folding will effectively be restricted to the non-Unicode rules
11211 * hard-coded into Perl. (This case happens legitimately during
11212 * compilation of Perl itself before the Unicode tables are
11214 if (invlist_len(PL_utf8_foldable) == 0) {
11215 PL_utf8_foldclosures = newHV();
11217 /* If the folds haven't been read in, call a fold function
11219 if (! PL_utf8_tofold) {
11220 U8 dummy[UTF8_MAXBYTES+1];
11223 /* This particular string is above \xff in both UTF-8 and
11225 to_utf8_fold((U8*) "\xC8\x80", dummy, &dummy_len);
11226 assert(PL_utf8_tofold); /* Verify that worked */
11228 PL_utf8_foldclosures = _swash_inversion_hash(PL_utf8_tofold);
11232 /* Only the characters in this class that participate in folds need be
11233 * checked. Get the intersection of this class and all the possible
11234 * characters that are foldable. This can quickly narrow down a large
11236 _invlist_intersection(PL_utf8_foldable, nonbitmap, &fold_intersection);
11238 /* Now look at the foldable characters in this class individually */
11239 invlist_iterinit(fold_intersection);
11240 while (invlist_iternext(fold_intersection, &start, &end)) {
11243 /* Look at every character in the range */
11244 for (j = start; j <= end; j++) {
11247 U8 foldbuf[UTF8_MAXBYTES_CASE+1];
11250 _to_uni_fold_flags(j, foldbuf, &foldlen, allow_full_fold);
11252 if (foldlen > (STRLEN)UNISKIP(f)) {
11254 /* Any multicharacter foldings (disallowed in lookbehind
11255 * patterns) require the following transform: [ABCDEF] ->
11256 * (?:[ABCabcDEFd]|pq|rst) where E folds into "pq" and F
11257 * folds into "rst", all other characters fold to single
11258 * characters. We save away these multicharacter foldings,
11259 * to be later saved as part of the additional "s" data. */
11260 if (! RExC_in_lookbehind) {
11262 U8* e = foldbuf + foldlen;
11264 /* If any of the folded characters of this are in the
11265 * Latin1 range, tell the regex engine that this can
11266 * match a non-utf8 target string. The only multi-byte
11267 * fold whose source is in the Latin1 range (U+00DF)
11268 * applies only when the target string is utf8, or
11269 * under unicode rules */
11270 if (j > 255 || AT_LEAST_UNI_SEMANTICS) {
11273 /* Can't mix ascii with non- under /aa */
11274 if (MORE_ASCII_RESTRICTED
11275 && (isASCII(*loc) != isASCII(j)))
11277 goto end_multi_fold;
11279 if (UTF8_IS_INVARIANT(*loc)
11280 || UTF8_IS_DOWNGRADEABLE_START(*loc))
11282 /* Can't mix above and below 256 under LOC
11285 goto end_multi_fold;
11288 |= ANYOF_NONBITMAP_NON_UTF8;
11291 loc += UTF8SKIP(loc);
11295 add_alternate(&unicode_alternate, foldbuf, foldlen);
11299 /* This is special-cased, as it is the only letter which
11300 * has both a multi-fold and single-fold in Latin1. All
11301 * the other chars that have single and multi-folds are
11302 * always in utf8, and the utf8 folding algorithm catches
11304 if (! LOC && j == LATIN_CAPITAL_LETTER_SHARP_S) {
11305 stored += set_regclass_bit(pRExC_state,
11307 LATIN_SMALL_LETTER_SHARP_S,
11308 &l1_fold_invlist, &unicode_alternate);
11312 /* Single character fold. Add everything in its fold
11313 * closure to the list that this node should match */
11316 /* The fold closures data structure is a hash with the keys
11317 * being every character that is folded to, like 'k', and
11318 * the values each an array of everything that folds to its
11319 * key. e.g. [ 'k', 'K', KELVIN_SIGN ] */
11320 if ((listp = hv_fetch(PL_utf8_foldclosures,
11321 (char *) foldbuf, foldlen, FALSE)))
11323 AV* list = (AV*) *listp;
11325 for (k = 0; k <= av_len(list); k++) {
11326 SV** c_p = av_fetch(list, k, FALSE);
11329 Perl_croak(aTHX_ "panic: invalid PL_utf8_foldclosures structure");
11333 /* /aa doesn't allow folds between ASCII and non-;
11334 * /l doesn't allow them between above and below
11336 if ((MORE_ASCII_RESTRICTED
11337 && (isASCII(c) != isASCII(j)))
11338 || (LOC && ((c < 256) != (j < 256))))
11343 if (c < 256 && AT_LEAST_UNI_SEMANTICS) {
11344 stored += set_regclass_bit(pRExC_state,
11347 &l1_fold_invlist, &unicode_alternate);
11349 /* It may be that the code point is already in
11350 * this range or already in the bitmap, in
11351 * which case we need do nothing */
11352 else if ((c < start || c > end)
11354 || ! ANYOF_BITMAP_TEST(ret, c)))
11356 nonbitmap = add_cp_to_invlist(nonbitmap, c);
11363 SvREFCNT_dec(fold_intersection);
11366 /* Combine the two lists into one. */
11367 if (l1_fold_invlist) {
11369 _invlist_union(nonbitmap, l1_fold_invlist, &nonbitmap);
11370 SvREFCNT_dec(l1_fold_invlist);
11373 nonbitmap = l1_fold_invlist;
11377 /* And combine the result (if any) with any inversion list from properties.
11378 * The lists are kept separate up to now because we don't want to fold the
11382 _invlist_union(nonbitmap, properties, &nonbitmap);
11383 SvREFCNT_dec(properties);
11386 nonbitmap = properties;
11390 /* Here, <nonbitmap> contains all the code points we can determine at
11391 * compile time that we haven't put into the bitmap. Go through it, and
11392 * for things that belong in the bitmap, put them there, and delete from
11396 /* Above-ASCII code points in /d have to stay in <nonbitmap>, as they
11397 * possibly only should match when the target string is UTF-8 */
11398 UV max_cp_to_set = (DEPENDS_SEMANTICS) ? 127 : 255;
11400 /* This gets set if we actually need to modify things */
11401 bool change_invlist = FALSE;
11405 /* Start looking through <nonbitmap> */
11406 invlist_iterinit(nonbitmap);
11407 while (invlist_iternext(nonbitmap, &start, &end)) {
11411 /* Quit if are above what we should change */
11412 if (start > max_cp_to_set) {
11416 change_invlist = TRUE;
11418 /* Set all the bits in the range, up to the max that we are doing */
11419 high = (end < max_cp_to_set) ? end : max_cp_to_set;
11420 for (i = start; i <= (int) high; i++) {
11421 if (! ANYOF_BITMAP_TEST(ret, i)) {
11422 ANYOF_BITMAP_SET(ret, i);
11430 /* Done with loop; remove any code points that are in the bitmap from
11432 if (change_invlist) {
11433 _invlist_subtract(nonbitmap,
11434 (DEPENDS_SEMANTICS)
11440 /* If have completely emptied it, remove it completely */
11441 if (invlist_len(nonbitmap) == 0) {
11442 SvREFCNT_dec(nonbitmap);
11447 /* Here, we have calculated what code points should be in the character
11448 * class. <nonbitmap> does not overlap the bitmap except possibly in the
11449 * case of DEPENDS rules.
11451 * Now we can see about various optimizations. Fold calculation (which we
11452 * did above) needs to take place before inversion. Otherwise /[^k]/i
11453 * would invert to include K, which under /i would match k, which it
11456 /* Optimize inverted simple patterns (e.g. [^a-z]). Note that we haven't
11457 * set the FOLD flag yet, so this does optimize those. It doesn't
11458 * optimize locale. Doing so perhaps could be done as long as there is
11459 * nothing like \w in it; some thought also would have to be given to the
11460 * interaction with above 0x100 chars */
11461 if ((ANYOF_FLAGS(ret) & ANYOF_INVERT)
11463 && ! unicode_alternate
11464 /* In case of /d, there are some things that should match only when in
11465 * not in the bitmap, i.e., they require UTF8 to match. These are
11466 * listed in nonbitmap, but if ANYOF_NONBITMAP_NON_UTF8 is set in this
11467 * case, they don't require UTF8, so can invert here */
11469 || ! DEPENDS_SEMANTICS
11470 || (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11471 && SvCUR(listsv) == initial_listsv_len)
11475 for (i = 0; i < 256; ++i) {
11476 if (ANYOF_BITMAP_TEST(ret, i)) {
11477 ANYOF_BITMAP_CLEAR(ret, i);
11480 ANYOF_BITMAP_SET(ret, i);
11485 /* The inversion means that everything above 255 is matched */
11486 ANYOF_FLAGS(ret) |= ANYOF_UNICODE_ALL;
11489 /* Here, also has things outside the bitmap that may overlap with
11490 * the bitmap. We have to sync them up, so that they get inverted
11491 * in both places. Earlier, we removed all overlaps except in the
11492 * case of /d rules, so no syncing is needed except for this case
11494 SV *remove_list = NULL;
11496 if (DEPENDS_SEMANTICS) {
11499 /* Set the bits that correspond to the ones that aren't in the
11500 * bitmap. Otherwise, when we invert, we'll miss these.
11501 * Earlier, we removed from the nonbitmap all code points
11502 * < 128, so there is no extra work here */
11503 invlist_iterinit(nonbitmap);
11504 while (invlist_iternext(nonbitmap, &start, &end)) {
11505 if (start > 255) { /* The bit map goes to 255 */
11511 for (i = start; i <= (int) end; ++i) {
11512 ANYOF_BITMAP_SET(ret, i);
11519 /* Now invert both the bitmap and the nonbitmap. Anything in the
11520 * bitmap has to also be removed from the non-bitmap, but again,
11521 * there should not be overlap unless is /d rules. */
11522 _invlist_invert(nonbitmap);
11524 /* Any swash can't be used as-is, because we've inverted things */
11526 SvREFCNT_dec(swash);
11530 for (i = 0; i < 256; ++i) {
11531 if (ANYOF_BITMAP_TEST(ret, i)) {
11532 ANYOF_BITMAP_CLEAR(ret, i);
11533 if (DEPENDS_SEMANTICS) {
11534 if (! remove_list) {
11535 remove_list = _new_invlist(2);
11537 remove_list = add_cp_to_invlist(remove_list, i);
11541 ANYOF_BITMAP_SET(ret, i);
11547 /* And do the removal */
11548 if (DEPENDS_SEMANTICS) {
11550 _invlist_subtract(nonbitmap, remove_list, &nonbitmap);
11551 SvREFCNT_dec(remove_list);
11555 /* There is no overlap for non-/d, so just delete anything
11557 _invlist_intersection(nonbitmap, PL_AboveLatin1, &nonbitmap);
11561 stored = 256 - stored;
11563 /* Clear the invert flag since have just done it here */
11564 ANYOF_FLAGS(ret) &= ~ANYOF_INVERT;
11567 /* Folding in the bitmap is taken care of above, but not for locale (for
11568 * which we have to wait to see what folding is in effect at runtime), and
11569 * for some things not in the bitmap (only the upper latin folds in this
11570 * case, as all other single-char folding has been set above). Set
11571 * run-time fold flag for these */
11573 || (DEPENDS_SEMANTICS
11575 && ! (ANYOF_FLAGS(ret) & ANYOF_NONBITMAP_NON_UTF8))
11576 || unicode_alternate))
11578 ANYOF_FLAGS(ret) |= ANYOF_LOC_NONBITMAP_FOLD;
11581 /* A single character class can be "optimized" into an EXACTish node.
11582 * Note that since we don't currently count how many characters there are
11583 * outside the bitmap, we are XXX missing optimization possibilities for
11584 * them. This optimization can't happen unless this is a truly single
11585 * character class, which means that it can't be an inversion into a
11586 * many-character class, and there must be no possibility of there being
11587 * things outside the bitmap. 'stored' (only) for locales doesn't include
11588 * \w, etc, so have to make a special test that they aren't present
11590 * Similarly A 2-character class of the very special form like [bB] can be
11591 * optimized into an EXACTFish node, but only for non-locales, and for
11592 * characters which only have the two folds; so things like 'fF' and 'Ii'
11593 * wouldn't work because they are part of the fold of 'LATIN SMALL LIGATURE
11596 && ! unicode_alternate
11597 && SvCUR(listsv) == initial_listsv_len
11598 && ! (ANYOF_FLAGS(ret) & (ANYOF_INVERT|ANYOF_UNICODE_ALL))
11599 && (((stored == 1 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11600 || (! ANYOF_CLASS_TEST_ANY_SET(ret)))))
11601 || (stored == 2 && ((! (ANYOF_FLAGS(ret) & ANYOF_LOCALE))
11602 && (! _HAS_NONLATIN1_FOLD_CLOSURE_ONLY_FOR_USE_BY_REGCOMP_DOT_C_AND_REGEXEC_DOT_C(value))
11603 /* If the latest code point has a fold whose
11604 * bit is set, it must be the only other one */
11605 && ((prevvalue = PL_fold_latin1[value]) != (IV)value)
11606 && ANYOF_BITMAP_TEST(ret, prevvalue)))))
11608 /* Note that the information needed to decide to do this optimization
11609 * is not currently available until the 2nd pass, and that the actually
11610 * used EXACTish node takes less space than the calculated ANYOF node,
11611 * and hence the amount of space calculated in the first pass is larger
11612 * than actually used, so this optimization doesn't gain us any space.
11613 * But an EXACT node is faster than an ANYOF node, and can be combined
11614 * with any adjacent EXACT nodes later by the optimizer for further
11615 * gains. The speed of executing an EXACTF is similar to an ANYOF
11616 * node, so the optimization advantage comes from the ability to join
11617 * it to adjacent EXACT nodes */
11619 const char * cur_parse= RExC_parse;
11621 RExC_emit = (regnode *)orig_emit;
11622 RExC_parse = (char *)orig_parse;
11626 /* A locale node with one point can be folded; all the other cases
11627 * with folding will have two points, since we calculate them above
11629 if (ANYOF_FLAGS(ret) & ANYOF_LOC_NONBITMAP_FOLD) {
11636 else { /* else 2 chars in the bit map: the folds of each other */
11638 /* Use the folded value, which for the cases where we get here,
11639 * is just the lower case of the current one (which may resolve to
11640 * itself, or to the other one */
11641 value = toLOWER_LATIN1(value);
11643 /* To join adjacent nodes, they must be the exact EXACTish type.
11644 * Try to use the most likely type, by using EXACTFA if possible,
11645 * then EXACTFU if the regex calls for it, or is required because
11646 * the character is non-ASCII. (If <value> is ASCII, its fold is
11647 * also ASCII for the cases where we get here.) */
11648 if (MORE_ASCII_RESTRICTED && isASCII(value)) {
11651 else if (AT_LEAST_UNI_SEMANTICS || !isASCII(value)) {
11654 else { /* Otherwise, more likely to be EXACTF type */
11659 ret = reg_node(pRExC_state, op);
11660 RExC_parse = (char *)cur_parse;
11661 if (UTF && ! NATIVE_IS_INVARIANT(value)) {
11662 *STRING(ret)= UTF8_EIGHT_BIT_HI((U8) value);
11663 *(STRING(ret) + 1)= UTF8_EIGHT_BIT_LO((U8) value);
11665 RExC_emit += STR_SZ(2);
11668 *STRING(ret)= (char)value;
11670 RExC_emit += STR_SZ(1);
11672 SvREFCNT_dec(listsv);
11676 /* If there is a swash and more than one element, we can't use the swash in
11677 * the optimization below. */
11678 if (swash && element_count > 1) {
11679 SvREFCNT_dec(swash);
11683 && SvCUR(listsv) == initial_listsv_len
11684 && ! unicode_alternate)
11686 ARG_SET(ret, ANYOF_NONBITMAP_EMPTY);
11687 SvREFCNT_dec(listsv);
11688 SvREFCNT_dec(unicode_alternate);
11691 /* av[0] stores the character class description in its textual form:
11692 * used later (regexec.c:Perl_regclass_swash()) to initialize the
11693 * appropriate swash, and is also useful for dumping the regnode.
11694 * av[1] if NULL, is a placeholder to later contain the swash computed
11695 * from av[0]. But if no further computation need be done, the
11696 * swash is stored there now.
11697 * av[2] stores the multicharacter foldings, used later in
11698 * regexec.c:S_reginclass().
11699 * av[3] stores the nonbitmap inversion list for use in addition or
11700 * instead of av[0]; not used if av[1] isn't NULL
11701 * av[4] is set if any component of the class is from a user-defined
11702 * property; not used if av[1] isn't NULL */
11703 AV * const av = newAV();
11706 av_store(av, 0, (SvCUR(listsv) == initial_listsv_len)
11710 av_store(av, 1, swash);
11711 SvREFCNT_dec(nonbitmap);
11714 av_store(av, 1, NULL);
11716 av_store(av, 3, nonbitmap);
11717 av_store(av, 4, newSVuv(has_user_defined_property));
11721 /* Store any computed multi-char folds only if we are allowing
11723 if (allow_full_fold) {
11724 av_store(av, 2, MUTABLE_SV(unicode_alternate));
11725 if (unicode_alternate) { /* This node is variable length */
11730 av_store(av, 2, NULL);
11732 rv = newRV_noinc(MUTABLE_SV(av));
11733 n = add_data(pRExC_state, 1, "s");
11734 RExC_rxi->data->data[n] = (void*)rv;
11741 /* reg_skipcomment()
11743 Absorbs an /x style # comments from the input stream.
11744 Returns true if there is more text remaining in the stream.
11745 Will set the REG_SEEN_RUN_ON_COMMENT flag if the comment
11746 terminates the pattern without including a newline.
11748 Note its the callers responsibility to ensure that we are
11749 actually in /x mode
11754 S_reg_skipcomment(pTHX_ RExC_state_t *pRExC_state)
11758 PERL_ARGS_ASSERT_REG_SKIPCOMMENT;
11760 while (RExC_parse < RExC_end)
11761 if (*RExC_parse++ == '\n') {
11766 /* we ran off the end of the pattern without ending
11767 the comment, so we have to add an \n when wrapping */
11768 RExC_seen |= REG_SEEN_RUN_ON_COMMENT;
11776 Advances the parse position, and optionally absorbs
11777 "whitespace" from the inputstream.
11779 Without /x "whitespace" means (?#...) style comments only,
11780 with /x this means (?#...) and # comments and whitespace proper.
11782 Returns the RExC_parse point from BEFORE the scan occurs.
11784 This is the /x friendly way of saying RExC_parse++.
11788 S_nextchar(pTHX_ RExC_state_t *pRExC_state)
11790 char* const retval = RExC_parse++;
11792 PERL_ARGS_ASSERT_NEXTCHAR;
11795 if (RExC_end - RExC_parse >= 3
11796 && *RExC_parse == '('
11797 && RExC_parse[1] == '?'
11798 && RExC_parse[2] == '#')
11800 while (*RExC_parse != ')') {
11801 if (RExC_parse == RExC_end)
11802 FAIL("Sequence (?#... not terminated");
11808 if (RExC_flags & RXf_PMf_EXTENDED) {
11809 if (isSPACE(*RExC_parse)) {
11813 else if (*RExC_parse == '#') {
11814 if ( reg_skipcomment( pRExC_state ) )
11823 - reg_node - emit a node
11825 STATIC regnode * /* Location. */
11826 S_reg_node(pTHX_ RExC_state_t *pRExC_state, U8 op)
11829 register regnode *ptr;
11830 regnode * const ret = RExC_emit;
11831 GET_RE_DEBUG_FLAGS_DECL;
11833 PERL_ARGS_ASSERT_REG_NODE;
11836 SIZE_ALIGN(RExC_size);
11840 if (RExC_emit >= RExC_emit_bound)
11841 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11842 op, RExC_emit, RExC_emit_bound);
11844 NODE_ALIGN_FILL(ret);
11846 FILL_ADVANCE_NODE(ptr, op);
11847 REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (ptr) - 1);
11848 #ifdef RE_TRACK_PATTERN_OFFSETS
11849 if (RExC_offsets) { /* MJD */
11850 MJD_OFFSET_DEBUG(("%s:%d: (op %s) %s %"UVuf" (len %"UVuf") (max %"UVuf").\n",
11851 "reg_node", __LINE__,
11853 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0]
11854 ? "Overwriting end of array!\n" : "OK",
11855 (UV)(RExC_emit - RExC_emit_start),
11856 (UV)(RExC_parse - RExC_start),
11857 (UV)RExC_offsets[0]));
11858 Set_Node_Offset(RExC_emit, RExC_parse + (op == END));
11866 - reganode - emit a node with an argument
11868 STATIC regnode * /* Location. */
11869 S_reganode(pTHX_ RExC_state_t *pRExC_state, U8 op, U32 arg)
11872 register regnode *ptr;
11873 regnode * const ret = RExC_emit;
11874 GET_RE_DEBUG_FLAGS_DECL;
11876 PERL_ARGS_ASSERT_REGANODE;
11879 SIZE_ALIGN(RExC_size);
11884 assert(2==regarglen[op]+1);
11886 Anything larger than this has to allocate the extra amount.
11887 If we changed this to be:
11889 RExC_size += (1 + regarglen[op]);
11891 then it wouldn't matter. Its not clear what side effect
11892 might come from that so its not done so far.
11897 if (RExC_emit >= RExC_emit_bound)
11898 Perl_croak(aTHX_ "panic: reg_node overrun trying to emit %d, %p>=%p",
11899 op, RExC_emit, RExC_emit_bound);
11901 NODE_ALIGN_FILL(ret);
11903 FILL_ADVANCE_NODE_ARG(ptr, op, arg);
11904 REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (ptr) - 2);
11905 #ifdef RE_TRACK_PATTERN_OFFSETS
11906 if (RExC_offsets) { /* MJD */
11907 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
11911 (UV)(RExC_emit - RExC_emit_start) > RExC_offsets[0] ?
11912 "Overwriting end of array!\n" : "OK",
11913 (UV)(RExC_emit - RExC_emit_start),
11914 (UV)(RExC_parse - RExC_start),
11915 (UV)RExC_offsets[0]));
11916 Set_Cur_Node_Offset;
11924 - reguni - emit (if appropriate) a Unicode character
11927 S_reguni(pTHX_ const RExC_state_t *pRExC_state, UV uv, char* s)
11931 PERL_ARGS_ASSERT_REGUNI;
11933 return SIZE_ONLY ? UNISKIP(uv) : (uvchr_to_utf8((U8*)s, uv) - (U8*)s);
11937 - reginsert - insert an operator in front of already-emitted operand
11939 * Means relocating the operand.
11942 S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth)
11945 register regnode *src;
11946 register regnode *dst;
11947 register regnode *place;
11948 const int offset = regarglen[(U8)op];
11949 const int size = NODE_STEP_REGNODE + offset;
11950 GET_RE_DEBUG_FLAGS_DECL;
11952 PERL_ARGS_ASSERT_REGINSERT;
11953 PERL_UNUSED_ARG(depth);
11954 /* (PL_regkind[(U8)op] == CURLY ? EXTRA_STEP_2ARGS : 0); */
11955 DEBUG_PARSE_FMT("inst"," - %s",PL_reg_name[op]);
11964 if (RExC_open_parens) {
11966 /*DEBUG_PARSE_FMT("inst"," - %"IVdf, (IV)RExC_npar);*/
11967 for ( paren=0 ; paren < RExC_npar ; paren++ ) {
11968 if ( RExC_open_parens[paren] >= opnd ) {
11969 /*DEBUG_PARSE_FMT("open"," - %d",size);*/
11970 RExC_open_parens[paren] += size;
11972 /*DEBUG_PARSE_FMT("open"," - %s","ok");*/
11974 if ( RExC_close_parens[paren] >= opnd ) {
11975 /*DEBUG_PARSE_FMT("close"," - %d",size);*/
11976 RExC_close_parens[paren] += size;
11978 /*DEBUG_PARSE_FMT("close"," - %s","ok");*/
11983 while (src > opnd) {
11984 StructCopy(--src, --dst, regnode);
11985 #ifdef RE_TRACK_PATTERN_OFFSETS
11986 if (RExC_offsets) { /* MJD 20010112 */
11987 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s copy %"UVuf" -> %"UVuf" (max %"UVuf").\n",
11991 (UV)(dst - RExC_emit_start) > RExC_offsets[0]
11992 ? "Overwriting end of array!\n" : "OK",
11993 (UV)(src - RExC_emit_start),
11994 (UV)(dst - RExC_emit_start),
11995 (UV)RExC_offsets[0]));
11996 Set_Node_Offset_To_R(dst-RExC_emit_start, Node_Offset(src));
11997 Set_Node_Length_To_R(dst-RExC_emit_start, Node_Length(src));
12003 place = opnd; /* Op node, where operand used to be. */
12004 #ifdef RE_TRACK_PATTERN_OFFSETS
12005 if (RExC_offsets) { /* MJD */
12006 MJD_OFFSET_DEBUG(("%s(%d): (op %s) %s %"UVuf" <- %"UVuf" (max %"UVuf").\n",
12010 (UV)(place - RExC_emit_start) > RExC_offsets[0]
12011 ? "Overwriting end of array!\n" : "OK",
12012 (UV)(place - RExC_emit_start),
12013 (UV)(RExC_parse - RExC_start),
12014 (UV)RExC_offsets[0]));
12015 Set_Node_Offset(place, RExC_parse);
12016 Set_Node_Length(place, 1);
12019 src = NEXTOPER(place);
12020 FILL_ADVANCE_NODE(place, op);
12021 REH_CALL_REGCOMP_HOOK(pRExC_state->rx, (place) - 1);
12022 Zero(src, offset, regnode);
12026 - regtail - set the next-pointer at the end of a node chain of p to val.
12027 - SEE ALSO: regtail_study
12029 /* TODO: All three parms should be const */
12031 S_regtail(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12034 register regnode *scan;
12035 GET_RE_DEBUG_FLAGS_DECL;
12037 PERL_ARGS_ASSERT_REGTAIL;
12039 PERL_UNUSED_ARG(depth);
12045 /* Find last node. */
12048 regnode * const temp = regnext(scan);
12050 SV * const mysv=sv_newmortal();
12051 DEBUG_PARSE_MSG((scan==p ? "tail" : ""));
12052 regprop(RExC_rx, mysv, scan);
12053 PerlIO_printf(Perl_debug_log, "~ %s (%d) %s %s\n",
12054 SvPV_nolen_const(mysv), REG_NODE_NUM(scan),
12055 (temp == NULL ? "->" : ""),
12056 (temp == NULL ? PL_reg_name[OP(val)] : "")
12064 if (reg_off_by_arg[OP(scan)]) {
12065 ARG_SET(scan, val - scan);
12068 NEXT_OFF(scan) = val - scan;
12074 - regtail_study - set the next-pointer at the end of a node chain of p to val.
12075 - Look for optimizable sequences at the same time.
12076 - currently only looks for EXACT chains.
12078 This is experimental code. The idea is to use this routine to perform
12079 in place optimizations on branches and groups as they are constructed,
12080 with the long term intention of removing optimization from study_chunk so
12081 that it is purely analytical.
12083 Currently only used when in DEBUG mode. The macro REGTAIL_STUDY() is used
12084 to control which is which.
12087 /* TODO: All four parms should be const */
12090 S_regtail_study(pTHX_ RExC_state_t *pRExC_state, regnode *p, const regnode *val,U32 depth)
12093 register regnode *scan;
12095 #ifdef EXPERIMENTAL_INPLACESCAN
12098 GET_RE_DEBUG_FLAGS_DECL;
12100 PERL_ARGS_ASSERT_REGTAIL_STUDY;
12106 /* Find last node. */
12110 regnode * const temp = regnext(scan);
12111 #ifdef EXPERIMENTAL_INPLACESCAN
12112 if (PL_regkind[OP(scan)] == EXACT) {
12113 bool has_exactf_sharp_s; /* Unexamined in this routine */
12114 if (join_exact(pRExC_state,scan,&min, &has_exactf_sharp_s, 1,val,depth+1))
12119 switch (OP(scan)) {
12125 case EXACTFU_TRICKYFOLD:
12127 if( exact == PSEUDO )
12129 else if ( exact != OP(scan) )
12138 SV * const mysv=sv_newmortal();
12139 DEBUG_PARSE_MSG((scan==p ? "tsdy" : ""));
12140 regprop(RExC_rx, mysv, scan);
12141 PerlIO_printf(Perl_debug_log, "~ %s (%d) -> %s\n",
12142 SvPV_nolen_const(mysv),
12143 REG_NODE_NUM(scan),
12144 PL_reg_name[exact]);
12151 SV * const mysv_val=sv_newmortal();
12152 DEBUG_PARSE_MSG("");
12153 regprop(RExC_rx, mysv_val, val);
12154 PerlIO_printf(Perl_debug_log, "~ attach to %s (%"IVdf") offset to %"IVdf"\n",
12155 SvPV_nolen_const(mysv_val),
12156 (IV)REG_NODE_NUM(val),
12160 if (reg_off_by_arg[OP(scan)]) {
12161 ARG_SET(scan, val - scan);
12164 NEXT_OFF(scan) = val - scan;
12172 - regdump - dump a regexp onto Perl_debug_log in vaguely comprehensible form
12176 S_regdump_extflags(pTHX_ const char *lead, const U32 flags)
12182 for (bit=0; bit<32; bit++) {
12183 if (flags & (1<<bit)) {
12184 if ((1<<bit) & RXf_PMf_CHARSET) { /* Output separately, below */
12187 if (!set++ && lead)
12188 PerlIO_printf(Perl_debug_log, "%s",lead);
12189 PerlIO_printf(Perl_debug_log, "%s ",PL_reg_extflags_name[bit]);
12192 if ((cs = get_regex_charset(flags)) != REGEX_DEPENDS_CHARSET) {
12193 if (!set++ && lead) {
12194 PerlIO_printf(Perl_debug_log, "%s",lead);
12197 case REGEX_UNICODE_CHARSET:
12198 PerlIO_printf(Perl_debug_log, "UNICODE");
12200 case REGEX_LOCALE_CHARSET:
12201 PerlIO_printf(Perl_debug_log, "LOCALE");
12203 case REGEX_ASCII_RESTRICTED_CHARSET:
12204 PerlIO_printf(Perl_debug_log, "ASCII-RESTRICTED");
12206 case REGEX_ASCII_MORE_RESTRICTED_CHARSET:
12207 PerlIO_printf(Perl_debug_log, "ASCII-MORE_RESTRICTED");
12210 PerlIO_printf(Perl_debug_log, "UNKNOWN CHARACTER SET");
12216 PerlIO_printf(Perl_debug_log, "\n");
12218 PerlIO_printf(Perl_debug_log, "%s[none-set]\n",lead);
12224 Perl_regdump(pTHX_ const regexp *r)
12228 SV * const sv = sv_newmortal();
12229 SV *dsv= sv_newmortal();
12230 RXi_GET_DECL(r,ri);
12231 GET_RE_DEBUG_FLAGS_DECL;
12233 PERL_ARGS_ASSERT_REGDUMP;
12235 (void)dumpuntil(r, ri->program, ri->program + 1, NULL, NULL, sv, 0, 0);
12237 /* Header fields of interest. */
12238 if (r->anchored_substr) {
12239 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->anchored_substr),
12240 RE_SV_DUMPLEN(r->anchored_substr), 30);
12241 PerlIO_printf(Perl_debug_log,
12242 "anchored %s%s at %"IVdf" ",
12243 s, RE_SV_TAIL(r->anchored_substr),
12244 (IV)r->anchored_offset);
12245 } else if (r->anchored_utf8) {
12246 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->anchored_utf8),
12247 RE_SV_DUMPLEN(r->anchored_utf8), 30);
12248 PerlIO_printf(Perl_debug_log,
12249 "anchored utf8 %s%s at %"IVdf" ",
12250 s, RE_SV_TAIL(r->anchored_utf8),
12251 (IV)r->anchored_offset);
12253 if (r->float_substr) {
12254 RE_PV_QUOTED_DECL(s, 0, dsv, SvPVX_const(r->float_substr),
12255 RE_SV_DUMPLEN(r->float_substr), 30);
12256 PerlIO_printf(Perl_debug_log,
12257 "floating %s%s at %"IVdf"..%"UVuf" ",
12258 s, RE_SV_TAIL(r->float_substr),
12259 (IV)r->float_min_offset, (UV)r->float_max_offset);
12260 } else if (r->float_utf8) {
12261 RE_PV_QUOTED_DECL(s, 1, dsv, SvPVX_const(r->float_utf8),
12262 RE_SV_DUMPLEN(r->float_utf8), 30);
12263 PerlIO_printf(Perl_debug_log,
12264 "floating utf8 %s%s at %"IVdf"..%"UVuf" ",
12265 s, RE_SV_TAIL(r->float_utf8),
12266 (IV)r->float_min_offset, (UV)r->float_max_offset);
12268 if (r->check_substr || r->check_utf8)
12269 PerlIO_printf(Perl_debug_log,
12271 (r->check_substr == r->float_substr
12272 && r->check_utf8 == r->float_utf8
12273 ? "(checking floating" : "(checking anchored"));
12274 if (r->extflags & RXf_NOSCAN)
12275 PerlIO_printf(Perl_debug_log, " noscan");
12276 if (r->extflags & RXf_CHECK_ALL)
12277 PerlIO_printf(Perl_debug_log, " isall");
12278 if (r->check_substr || r->check_utf8)
12279 PerlIO_printf(Perl_debug_log, ") ");
12281 if (ri->regstclass) {
12282 regprop(r, sv, ri->regstclass);
12283 PerlIO_printf(Perl_debug_log, "stclass %s ", SvPVX_const(sv));
12285 if (r->extflags & RXf_ANCH) {
12286 PerlIO_printf(Perl_debug_log, "anchored");
12287 if (r->extflags & RXf_ANCH_BOL)
12288 PerlIO_printf(Perl_debug_log, "(BOL)");
12289 if (r->extflags & RXf_ANCH_MBOL)
12290 PerlIO_printf(Perl_debug_log, "(MBOL)");
12291 if (r->extflags & RXf_ANCH_SBOL)
12292 PerlIO_printf(Perl_debug_log, "(SBOL)");
12293 if (r->extflags & RXf_ANCH_GPOS)
12294 PerlIO_printf(Perl_debug_log, "(GPOS)");
12295 PerlIO_putc(Perl_debug_log, ' ');
12297 if (r->extflags & RXf_GPOS_SEEN)
12298 PerlIO_printf(Perl_debug_log, "GPOS:%"UVuf" ", (UV)r->gofs);
12299 if (r->intflags & PREGf_SKIP)
12300 PerlIO_printf(Perl_debug_log, "plus ");
12301 if (r->intflags & PREGf_IMPLICIT)
12302 PerlIO_printf(Perl_debug_log, "implicit ");
12303 PerlIO_printf(Perl_debug_log, "minlen %"IVdf" ", (IV)r->minlen);
12304 if (r->extflags & RXf_EVAL_SEEN)
12305 PerlIO_printf(Perl_debug_log, "with eval ");
12306 PerlIO_printf(Perl_debug_log, "\n");
12307 DEBUG_FLAGS_r(regdump_extflags("r->extflags: ",r->extflags));
12309 PERL_ARGS_ASSERT_REGDUMP;
12310 PERL_UNUSED_CONTEXT;
12311 PERL_UNUSED_ARG(r);
12312 #endif /* DEBUGGING */
12316 - regprop - printable representation of opcode
12318 #define EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags) \
12321 Perl_sv_catpvf(aTHX_ sv,"%s][%s",PL_colors[1],PL_colors[0]); \
12322 if (flags & ANYOF_INVERT) \
12323 /*make sure the invert info is in each */ \
12324 sv_catpvs(sv, "^"); \
12330 Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o)
12335 RXi_GET_DECL(prog,progi);
12336 GET_RE_DEBUG_FLAGS_DECL;
12338 PERL_ARGS_ASSERT_REGPROP;
12342 if (OP(o) > REGNODE_MAX) /* regnode.type is unsigned */
12343 /* It would be nice to FAIL() here, but this may be called from
12344 regexec.c, and it would be hard to supply pRExC_state. */
12345 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(o), (int)REGNODE_MAX);
12346 sv_catpv(sv, PL_reg_name[OP(o)]); /* Take off const! */
12348 k = PL_regkind[OP(o)];
12351 sv_catpvs(sv, " ");
12352 /* Using is_utf8_string() (via PERL_PV_UNI_DETECT)
12353 * is a crude hack but it may be the best for now since
12354 * we have no flag "this EXACTish node was UTF-8"
12356 pv_pretty(sv, STRING(o), STR_LEN(o), 60, PL_colors[0], PL_colors[1],
12357 PERL_PV_ESCAPE_UNI_DETECT |
12358 PERL_PV_ESCAPE_NONASCII |
12359 PERL_PV_PRETTY_ELLIPSES |
12360 PERL_PV_PRETTY_LTGT |
12361 PERL_PV_PRETTY_NOCLEAR
12363 } else if (k == TRIE) {
12364 /* print the details of the trie in dumpuntil instead, as
12365 * progi->data isn't available here */
12366 const char op = OP(o);
12367 const U32 n = ARG(o);
12368 const reg_ac_data * const ac = IS_TRIE_AC(op) ?
12369 (reg_ac_data *)progi->data->data[n] :
12371 const reg_trie_data * const trie
12372 = (reg_trie_data*)progi->data->data[!IS_TRIE_AC(op) ? n : ac->trie];
12374 Perl_sv_catpvf(aTHX_ sv, "-%s",PL_reg_name[o->flags]);
12375 DEBUG_TRIE_COMPILE_r(
12376 Perl_sv_catpvf(aTHX_ sv,
12377 "<S:%"UVuf"/%"IVdf" W:%"UVuf" L:%"UVuf"/%"UVuf" C:%"UVuf"/%"UVuf">",
12378 (UV)trie->startstate,
12379 (IV)trie->statecount-1, /* -1 because of the unused 0 element */
12380 (UV)trie->wordcount,
12383 (UV)TRIE_CHARCOUNT(trie),
12384 (UV)trie->uniquecharcount
12387 if ( IS_ANYOF_TRIE(op) || trie->bitmap ) {
12389 int rangestart = -1;
12390 U8* bitmap = IS_ANYOF_TRIE(op) ? (U8*)ANYOF_BITMAP(o) : (U8*)TRIE_BITMAP(trie);
12391 sv_catpvs(sv, "[");
12392 for (i = 0; i <= 256; i++) {
12393 if (i < 256 && BITMAP_TEST(bitmap,i)) {
12394 if (rangestart == -1)
12396 } else if (rangestart != -1) {
12397 if (i <= rangestart + 3)
12398 for (; rangestart < i; rangestart++)
12399 put_byte(sv, rangestart);
12401 put_byte(sv, rangestart);
12402 sv_catpvs(sv, "-");
12403 put_byte(sv, i - 1);
12408 sv_catpvs(sv, "]");
12411 } else if (k == CURLY) {
12412 if (OP(o) == CURLYM || OP(o) == CURLYN || OP(o) == CURLYX)
12413 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* Parenth number */
12414 Perl_sv_catpvf(aTHX_ sv, " {%d,%d}", ARG1(o), ARG2(o));
12416 else if (k == WHILEM && o->flags) /* Ordinal/of */
12417 Perl_sv_catpvf(aTHX_ sv, "[%d/%d]", o->flags & 0xf, o->flags>>4);
12418 else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) {
12419 Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */
12420 if ( RXp_PAREN_NAMES(prog) ) {
12421 if ( k != REF || (OP(o) < NREF)) {
12422 AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]);
12423 SV **name= av_fetch(list, ARG(o), 0 );
12425 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12428 AV *list= MUTABLE_AV(progi->data->data[ progi->name_list_idx ]);
12429 SV *sv_dat= MUTABLE_SV(progi->data->data[ ARG( o ) ]);
12430 I32 *nums=(I32*)SvPVX(sv_dat);
12431 SV **name= av_fetch(list, nums[0], 0 );
12434 for ( n=0; n<SvIVX(sv_dat); n++ ) {
12435 Perl_sv_catpvf(aTHX_ sv, "%s%"IVdf,
12436 (n ? "," : ""), (IV)nums[n]);
12438 Perl_sv_catpvf(aTHX_ sv, " '%"SVf"'", SVfARG(*name));
12442 } else if (k == GOSUB)
12443 Perl_sv_catpvf(aTHX_ sv, "%d[%+d]", (int)ARG(o),(int)ARG2L(o)); /* Paren and offset */
12444 else if (k == VERB) {
12446 Perl_sv_catpvf(aTHX_ sv, ":%"SVf,
12447 SVfARG((MUTABLE_SV(progi->data->data[ ARG( o ) ]))));
12448 } else if (k == LOGICAL)
12449 Perl_sv_catpvf(aTHX_ sv, "[%d]", o->flags); /* 2: embedded, otherwise 1 */
12450 else if (k == ANYOF) {
12451 int i, rangestart = -1;
12452 const U8 flags = ANYOF_FLAGS(o);
12455 /* Should be synchronized with * ANYOF_ #xdefines in regcomp.h */
12456 static const char * const anyofs[] = {
12489 if (flags & ANYOF_LOCALE)
12490 sv_catpvs(sv, "{loc}");
12491 if (flags & ANYOF_LOC_NONBITMAP_FOLD)
12492 sv_catpvs(sv, "{i}");
12493 Perl_sv_catpvf(aTHX_ sv, "[%s", PL_colors[0]);
12494 if (flags & ANYOF_INVERT)
12495 sv_catpvs(sv, "^");
12497 /* output what the standard cp 0-255 bitmap matches */
12498 for (i = 0; i <= 256; i++) {
12499 if (i < 256 && ANYOF_BITMAP_TEST(o,i)) {
12500 if (rangestart == -1)
12502 } else if (rangestart != -1) {
12503 if (i <= rangestart + 3)
12504 for (; rangestart < i; rangestart++)
12505 put_byte(sv, rangestart);
12507 put_byte(sv, rangestart);
12508 sv_catpvs(sv, "-");
12509 put_byte(sv, i - 1);
12516 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12517 /* output any special charclass tests (used entirely under use locale) */
12518 if (ANYOF_CLASS_TEST_ANY_SET(o))
12519 for (i = 0; i < (int)(sizeof(anyofs)/sizeof(char*)); i++)
12520 if (ANYOF_CLASS_TEST(o,i)) {
12521 sv_catpv(sv, anyofs[i]);
12525 EMIT_ANYOF_TEST_SEPARATOR(do_sep,sv,flags);
12527 if (flags & ANYOF_NON_UTF8_LATIN1_ALL) {
12528 sv_catpvs(sv, "{non-utf8-latin1-all}");
12531 /* output information about the unicode matching */
12532 if (flags & ANYOF_UNICODE_ALL)
12533 sv_catpvs(sv, "{unicode_all}");
12534 else if (ANYOF_NONBITMAP(o))
12535 sv_catpvs(sv, "{unicode}");
12536 if (flags & ANYOF_NONBITMAP_NON_UTF8)
12537 sv_catpvs(sv, "{outside bitmap}");
12539 if (ANYOF_NONBITMAP(o)) {
12540 SV *lv; /* Set if there is something outside the bit map */
12541 SV * const sw = regclass_swash(prog, o, FALSE, &lv, 0);
12542 bool byte_output = FALSE; /* If something in the bitmap has been
12545 if (lv && lv != &PL_sv_undef) {
12547 U8 s[UTF8_MAXBYTES_CASE+1];
12549 for (i = 0; i <= 256; i++) { /* Look at chars in bitmap */
12550 uvchr_to_utf8(s, i);
12553 && ! ANYOF_BITMAP_TEST(o, i) /* Don't duplicate
12557 && swash_fetch(sw, s, TRUE))
12559 if (rangestart == -1)
12561 } else if (rangestart != -1) {
12562 byte_output = TRUE;
12563 if (i <= rangestart + 3)
12564 for (; rangestart < i; rangestart++) {
12565 put_byte(sv, rangestart);
12568 put_byte(sv, rangestart);
12569 sv_catpvs(sv, "-");
12578 char *s = savesvpv(lv);
12579 char * const origs = s;
12581 while (*s && *s != '\n')
12585 const char * const t = ++s;
12588 sv_catpvs(sv, " ");
12594 /* Truncate very long output */
12595 if (s - origs > 256) {
12596 Perl_sv_catpvf(aTHX_ sv,
12598 (int) (s - origs - 1),
12604 else if (*s == '\t') {
12623 Perl_sv_catpvf(aTHX_ sv, "%s]", PL_colors[1]);
12625 else if (k == BRANCHJ && (OP(o) == UNLESSM || OP(o) == IFMATCH))
12626 Perl_sv_catpvf(aTHX_ sv, "[%d]", -(o->flags));
12628 PERL_UNUSED_CONTEXT;
12629 PERL_UNUSED_ARG(sv);
12630 PERL_UNUSED_ARG(o);
12631 PERL_UNUSED_ARG(prog);
12632 #endif /* DEBUGGING */
12636 Perl_re_intuit_string(pTHX_ REGEXP * const r)
12637 { /* Assume that RE_INTUIT is set */
12639 struct regexp *const prog = (struct regexp *)SvANY(r);
12640 GET_RE_DEBUG_FLAGS_DECL;
12642 PERL_ARGS_ASSERT_RE_INTUIT_STRING;
12643 PERL_UNUSED_CONTEXT;
12647 const char * const s = SvPV_nolen_const(prog->check_substr
12648 ? prog->check_substr : prog->check_utf8);
12650 if (!PL_colorset) reginitcolors();
12651 PerlIO_printf(Perl_debug_log,
12652 "%sUsing REx %ssubstr:%s \"%s%.60s%s%s\"\n",
12654 prog->check_substr ? "" : "utf8 ",
12655 PL_colors[5],PL_colors[0],
12658 (strlen(s) > 60 ? "..." : ""));
12661 return prog->check_substr ? prog->check_substr : prog->check_utf8;
12667 handles refcounting and freeing the perl core regexp structure. When
12668 it is necessary to actually free the structure the first thing it
12669 does is call the 'free' method of the regexp_engine associated to
12670 the regexp, allowing the handling of the void *pprivate; member
12671 first. (This routine is not overridable by extensions, which is why
12672 the extensions free is called first.)
12674 See regdupe and regdupe_internal if you change anything here.
12676 #ifndef PERL_IN_XSUB_RE
12678 Perl_pregfree(pTHX_ REGEXP *r)
12684 Perl_pregfree2(pTHX_ REGEXP *rx)
12687 struct regexp *const r = (struct regexp *)SvANY(rx);
12688 GET_RE_DEBUG_FLAGS_DECL;
12690 PERL_ARGS_ASSERT_PREGFREE2;
12692 if (r->mother_re) {
12693 ReREFCNT_dec(r->mother_re);
12695 CALLREGFREE_PVT(rx); /* free the private data */
12696 SvREFCNT_dec(RXp_PAREN_NAMES(r));
12699 SvREFCNT_dec(r->anchored_substr);
12700 SvREFCNT_dec(r->anchored_utf8);
12701 SvREFCNT_dec(r->float_substr);
12702 SvREFCNT_dec(r->float_utf8);
12703 Safefree(r->substrs);
12705 RX_MATCH_COPY_FREE(rx);
12706 #ifdef PERL_OLD_COPY_ON_WRITE
12707 SvREFCNT_dec(r->saved_copy);
12714 This is a hacky workaround to the structural issue of match results
12715 being stored in the regexp structure which is in turn stored in
12716 PL_curpm/PL_reg_curpm. The problem is that due to qr// the pattern
12717 could be PL_curpm in multiple contexts, and could require multiple
12718 result sets being associated with the pattern simultaneously, such
12719 as when doing a recursive match with (??{$qr})
12721 The solution is to make a lightweight copy of the regexp structure
12722 when a qr// is returned from the code executed by (??{$qr}) this
12723 lightweight copy doesn't actually own any of its data except for
12724 the starp/end and the actual regexp structure itself.
12730 Perl_reg_temp_copy (pTHX_ REGEXP *ret_x, REGEXP *rx)
12732 struct regexp *ret;
12733 struct regexp *const r = (struct regexp *)SvANY(rx);
12734 register const I32 npar = r->nparens+1;
12736 PERL_ARGS_ASSERT_REG_TEMP_COPY;
12739 ret_x = (REGEXP*) newSV_type(SVt_REGEXP);
12740 ret = (struct regexp *)SvANY(ret_x);
12742 (void)ReREFCNT_inc(rx);
12743 /* We can take advantage of the existing "copied buffer" mechanism in SVs
12744 by pointing directly at the buffer, but flagging that the allocated
12745 space in the copy is zero. As we've just done a struct copy, it's now
12746 a case of zero-ing that, rather than copying the current length. */
12747 SvPV_set(ret_x, RX_WRAPPED(rx));
12748 SvFLAGS(ret_x) |= SvFLAGS(rx) & (SVf_POK|SVp_POK|SVf_UTF8);
12749 memcpy(&(ret->xpv_cur), &(r->xpv_cur),
12750 sizeof(regexp) - STRUCT_OFFSET(regexp, xpv_cur));
12751 SvLEN_set(ret_x, 0);
12752 SvSTASH_set(ret_x, NULL);
12753 SvMAGIC_set(ret_x, NULL);
12754 Newx(ret->offs, npar, regexp_paren_pair);
12755 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12757 Newx(ret->substrs, 1, struct reg_substr_data);
12758 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12760 SvREFCNT_inc_void(ret->anchored_substr);
12761 SvREFCNT_inc_void(ret->anchored_utf8);
12762 SvREFCNT_inc_void(ret->float_substr);
12763 SvREFCNT_inc_void(ret->float_utf8);
12765 /* check_substr and check_utf8, if non-NULL, point to either their
12766 anchored or float namesakes, and don't hold a second reference. */
12768 RX_MATCH_COPIED_off(ret_x);
12769 #ifdef PERL_OLD_COPY_ON_WRITE
12770 ret->saved_copy = NULL;
12772 ret->mother_re = rx;
12778 /* regfree_internal()
12780 Free the private data in a regexp. This is overloadable by
12781 extensions. Perl takes care of the regexp structure in pregfree(),
12782 this covers the *pprivate pointer which technically perl doesn't
12783 know about, however of course we have to handle the
12784 regexp_internal structure when no extension is in use.
12786 Note this is called before freeing anything in the regexp
12791 Perl_regfree_internal(pTHX_ REGEXP * const rx)
12794 struct regexp *const r = (struct regexp *)SvANY(rx);
12795 RXi_GET_DECL(r,ri);
12796 GET_RE_DEBUG_FLAGS_DECL;
12798 PERL_ARGS_ASSERT_REGFREE_INTERNAL;
12804 SV *dsv= sv_newmortal();
12805 RE_PV_QUOTED_DECL(s, RX_UTF8(rx),
12806 dsv, RX_PRECOMP(rx), RX_PRELEN(rx), 60);
12807 PerlIO_printf(Perl_debug_log,"%sFreeing REx:%s %s\n",
12808 PL_colors[4],PL_colors[5],s);
12811 #ifdef RE_TRACK_PATTERN_OFFSETS
12813 Safefree(ri->u.offsets); /* 20010421 MJD */
12816 int n = ri->data->count;
12817 PAD* new_comppad = NULL;
12822 /* If you add a ->what type here, update the comment in regcomp.h */
12823 switch (ri->data->what[n]) {
12828 SvREFCNT_dec(MUTABLE_SV(ri->data->data[n]));
12831 Safefree(ri->data->data[n]);
12834 new_comppad = MUTABLE_AV(ri->data->data[n]);
12837 if (new_comppad == NULL)
12838 Perl_croak(aTHX_ "panic: pregfree comppad");
12839 PAD_SAVE_LOCAL(old_comppad,
12840 /* Watch out for global destruction's random ordering. */
12841 (SvTYPE(new_comppad) == SVt_PVAV) ? new_comppad : NULL
12844 refcnt = OpREFCNT_dec((OP_4tree*)ri->data->data[n]);
12847 op_free((OP_4tree*)ri->data->data[n]);
12849 PAD_RESTORE_LOCAL(old_comppad);
12850 SvREFCNT_dec(MUTABLE_SV(new_comppad));
12851 new_comppad = NULL;
12856 { /* Aho Corasick add-on structure for a trie node.
12857 Used in stclass optimization only */
12859 reg_ac_data *aho=(reg_ac_data*)ri->data->data[n];
12861 refcount = --aho->refcount;
12864 PerlMemShared_free(aho->states);
12865 PerlMemShared_free(aho->fail);
12866 /* do this last!!!! */
12867 PerlMemShared_free(ri->data->data[n]);
12868 PerlMemShared_free(ri->regstclass);
12874 /* trie structure. */
12876 reg_trie_data *trie=(reg_trie_data*)ri->data->data[n];
12878 refcount = --trie->refcount;
12881 PerlMemShared_free(trie->charmap);
12882 PerlMemShared_free(trie->states);
12883 PerlMemShared_free(trie->trans);
12885 PerlMemShared_free(trie->bitmap);
12887 PerlMemShared_free(trie->jump);
12888 PerlMemShared_free(trie->wordinfo);
12889 /* do this last!!!! */
12890 PerlMemShared_free(ri->data->data[n]);
12895 Perl_croak(aTHX_ "panic: regfree data code '%c'", ri->data->what[n]);
12898 Safefree(ri->data->what);
12899 Safefree(ri->data);
12905 #define av_dup_inc(s,t) MUTABLE_AV(sv_dup_inc((const SV *)s,t))
12906 #define hv_dup_inc(s,t) MUTABLE_HV(sv_dup_inc((const SV *)s,t))
12907 #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL)
12910 re_dup - duplicate a regexp.
12912 This routine is expected to clone a given regexp structure. It is only
12913 compiled under USE_ITHREADS.
12915 After all of the core data stored in struct regexp is duplicated
12916 the regexp_engine.dupe method is used to copy any private data
12917 stored in the *pprivate pointer. This allows extensions to handle
12918 any duplication it needs to do.
12920 See pregfree() and regfree_internal() if you change anything here.
12922 #if defined(USE_ITHREADS)
12923 #ifndef PERL_IN_XSUB_RE
12925 Perl_re_dup_guts(pTHX_ const REGEXP *sstr, REGEXP *dstr, CLONE_PARAMS *param)
12929 const struct regexp *r = (const struct regexp *)SvANY(sstr);
12930 struct regexp *ret = (struct regexp *)SvANY(dstr);
12932 PERL_ARGS_ASSERT_RE_DUP_GUTS;
12934 npar = r->nparens+1;
12935 Newx(ret->offs, npar, regexp_paren_pair);
12936 Copy(r->offs, ret->offs, npar, regexp_paren_pair);
12938 /* no need to copy these */
12939 Newx(ret->swap, npar, regexp_paren_pair);
12942 if (ret->substrs) {
12943 /* Do it this way to avoid reading from *r after the StructCopy().
12944 That way, if any of the sv_dup_inc()s dislodge *r from the L1
12945 cache, it doesn't matter. */
12946 const bool anchored = r->check_substr
12947 ? r->check_substr == r->anchored_substr
12948 : r->check_utf8 == r->anchored_utf8;
12949 Newx(ret->substrs, 1, struct reg_substr_data);
12950 StructCopy(r->substrs, ret->substrs, struct reg_substr_data);
12952 ret->anchored_substr = sv_dup_inc(ret->anchored_substr, param);
12953 ret->anchored_utf8 = sv_dup_inc(ret->anchored_utf8, param);
12954 ret->float_substr = sv_dup_inc(ret->float_substr, param);
12955 ret->float_utf8 = sv_dup_inc(ret->float_utf8, param);
12957 /* check_substr and check_utf8, if non-NULL, point to either their
12958 anchored or float namesakes, and don't hold a second reference. */
12960 if (ret->check_substr) {
12962 assert(r->check_utf8 == r->anchored_utf8);
12963 ret->check_substr = ret->anchored_substr;
12964 ret->check_utf8 = ret->anchored_utf8;
12966 assert(r->check_substr == r->float_substr);
12967 assert(r->check_utf8 == r->float_utf8);
12968 ret->check_substr = ret->float_substr;
12969 ret->check_utf8 = ret->float_utf8;
12971 } else if (ret->check_utf8) {
12973 ret->check_utf8 = ret->anchored_utf8;
12975 ret->check_utf8 = ret->float_utf8;
12980 RXp_PAREN_NAMES(ret) = hv_dup_inc(RXp_PAREN_NAMES(ret), param);
12983 RXi_SET(ret,CALLREGDUPE_PVT(dstr,param));
12985 if (RX_MATCH_COPIED(dstr))
12986 ret->subbeg = SAVEPVN(ret->subbeg, ret->sublen);
12988 ret->subbeg = NULL;
12989 #ifdef PERL_OLD_COPY_ON_WRITE
12990 ret->saved_copy = NULL;
12993 if (ret->mother_re) {
12994 if (SvPVX_const(dstr) == SvPVX_const(ret->mother_re)) {
12995 /* Our storage points directly to our mother regexp, but that's
12996 1: a buffer in a different thread
12997 2: something we no longer hold a reference on
12998 so we need to copy it locally. */
12999 /* Note we need to use SvCUR(), rather than
13000 SvLEN(), on our mother_re, because it, in
13001 turn, may well be pointing to its own mother_re. */
13002 SvPV_set(dstr, SAVEPVN(SvPVX_const(ret->mother_re),
13003 SvCUR(ret->mother_re)+1));
13004 SvLEN_set(dstr, SvCUR(ret->mother_re)+1);
13006 ret->mother_re = NULL;
13010 #endif /* PERL_IN_XSUB_RE */
13015 This is the internal complement to regdupe() which is used to copy
13016 the structure pointed to by the *pprivate pointer in the regexp.
13017 This is the core version of the extension overridable cloning hook.
13018 The regexp structure being duplicated will be copied by perl prior
13019 to this and will be provided as the regexp *r argument, however
13020 with the /old/ structures pprivate pointer value. Thus this routine
13021 may override any copying normally done by perl.
13023 It returns a pointer to the new regexp_internal structure.
13027 Perl_regdupe_internal(pTHX_ REGEXP * const rx, CLONE_PARAMS *param)
13030 struct regexp *const r = (struct regexp *)SvANY(rx);
13031 regexp_internal *reti;
13033 RXi_GET_DECL(r,ri);
13035 PERL_ARGS_ASSERT_REGDUPE_INTERNAL;
13039 Newxc(reti, sizeof(regexp_internal) + len*sizeof(regnode), char, regexp_internal);
13040 Copy(ri->program, reti->program, len+1, regnode);
13043 reti->regstclass = NULL;
13046 struct reg_data *d;
13047 const int count = ri->data->count;
13050 Newxc(d, sizeof(struct reg_data) + count*sizeof(void *),
13051 char, struct reg_data);
13052 Newx(d->what, count, U8);
13055 for (i = 0; i < count; i++) {
13056 d->what[i] = ri->data->what[i];
13057 switch (d->what[i]) {
13058 /* legal options are one of: sSfpontTua
13059 see also regcomp.h and pregfree() */
13060 case 'a': /* actually an AV, but the dup function is identical. */
13063 case 'p': /* actually an AV, but the dup function is identical. */
13064 case 'u': /* actually an HV, but the dup function is identical. */
13065 d->data[i] = sv_dup_inc((const SV *)ri->data->data[i], param);
13068 /* This is cheating. */
13069 Newx(d->data[i], 1, struct regnode_charclass_class);
13070 StructCopy(ri->data->data[i], d->data[i],
13071 struct regnode_charclass_class);
13072 reti->regstclass = (regnode*)d->data[i];
13075 /* Compiled op trees are readonly and in shared memory,
13076 and can thus be shared without duplication. */
13078 d->data[i] = (void*)OpREFCNT_inc((OP*)ri->data->data[i]);
13082 /* Trie stclasses are readonly and can thus be shared
13083 * without duplication. We free the stclass in pregfree
13084 * when the corresponding reg_ac_data struct is freed.
13086 reti->regstclass= ri->regstclass;
13090 ((reg_trie_data*)ri->data->data[i])->refcount++;
13094 d->data[i] = ri->data->data[i];
13097 Perl_croak(aTHX_ "panic: re_dup unknown data code '%c'", ri->data->what[i]);
13106 reti->name_list_idx = ri->name_list_idx;
13108 #ifdef RE_TRACK_PATTERN_OFFSETS
13109 if (ri->u.offsets) {
13110 Newx(reti->u.offsets, 2*len+1, U32);
13111 Copy(ri->u.offsets, reti->u.offsets, 2*len+1, U32);
13114 SetProgLen(reti,len);
13117 return (void*)reti;
13120 #endif /* USE_ITHREADS */
13122 #ifndef PERL_IN_XSUB_RE
13125 - regnext - dig the "next" pointer out of a node
13128 Perl_regnext(pTHX_ register regnode *p)
13131 register I32 offset;
13136 if (OP(p) > REGNODE_MAX) { /* regnode.type is unsigned */
13137 Perl_croak(aTHX_ "Corrupted regexp opcode %d > %d", (int)OP(p), (int)REGNODE_MAX);
13140 offset = (reg_off_by_arg[OP(p)] ? ARG(p) : NEXT_OFF(p));
13149 S_re_croak2(pTHX_ const char* pat1,const char* pat2,...)
13152 STRLEN l1 = strlen(pat1);
13153 STRLEN l2 = strlen(pat2);
13156 const char *message;
13158 PERL_ARGS_ASSERT_RE_CROAK2;
13164 Copy(pat1, buf, l1 , char);
13165 Copy(pat2, buf + l1, l2 , char);
13166 buf[l1 + l2] = '\n';
13167 buf[l1 + l2 + 1] = '\0';
13169 /* ANSI variant takes additional second argument */
13170 va_start(args, pat2);
13174 msv = vmess(buf, &args);
13176 message = SvPV_const(msv,l1);
13179 Copy(message, buf, l1 , char);
13180 buf[l1-1] = '\0'; /* Overwrite \n */
13181 Perl_croak(aTHX_ "%s", buf);
13184 /* XXX Here's a total kludge. But we need to re-enter for swash routines. */
13186 #ifndef PERL_IN_XSUB_RE
13188 Perl_save_re_context(pTHX)
13192 struct re_save_state *state;
13194 SAVEVPTR(PL_curcop);
13195 SSGROW(SAVESTACK_ALLOC_FOR_RE_SAVE_STATE + 1);
13197 state = (struct re_save_state *)(PL_savestack + PL_savestack_ix);
13198 PL_savestack_ix += SAVESTACK_ALLOC_FOR_RE_SAVE_STATE;
13199 SSPUSHUV(SAVEt_RE_STATE);
13201 Copy(&PL_reg_state, state, 1, struct re_save_state);
13203 PL_reg_start_tmp = 0;
13204 PL_reg_start_tmpl = 0;
13205 PL_reg_oldsaved = NULL;
13206 PL_reg_oldsavedlen = 0;
13207 PL_reg_maxiter = 0;
13208 PL_reg_leftiter = 0;
13209 PL_reg_poscache = NULL;
13210 PL_reg_poscache_size = 0;
13211 #ifdef PERL_OLD_COPY_ON_WRITE
13215 /* Save $1..$n (#18107: UTF-8 s/(\w+)/uc($1)/e); AMS 20021106. */
13217 const REGEXP * const rx = PM_GETRE(PL_curpm);
13220 for (i = 1; i <= RX_NPARENS(rx); i++) {
13221 char digits[TYPE_CHARS(long)];
13222 const STRLEN len = my_snprintf(digits, sizeof(digits), "%lu", (long)i);
13223 GV *const *const gvp
13224 = (GV**)hv_fetch(PL_defstash, digits, len, 0);
13227 GV * const gv = *gvp;
13228 if (SvTYPE(gv) == SVt_PVGV && GvSV(gv))
13238 clear_re(pTHX_ void *r)
13241 ReREFCNT_dec((REGEXP *)r);
13247 S_put_byte(pTHX_ SV *sv, int c)
13249 PERL_ARGS_ASSERT_PUT_BYTE;
13251 /* Our definition of isPRINT() ignores locales, so only bytes that are
13252 not part of UTF-8 are considered printable. I assume that the same
13253 holds for UTF-EBCDIC.
13254 Also, code point 255 is not printable in either (it's E0 in EBCDIC,
13255 which Wikipedia says:
13257 EO, or Eight Ones, is an 8-bit EBCDIC character code represented as all
13258 ones (binary 1111 1111, hexadecimal FF). It is similar, but not
13259 identical, to the ASCII delete (DEL) or rubout control character.
13260 ) So the old condition can be simplified to !isPRINT(c) */
13263 Perl_sv_catpvf(aTHX_ sv, "\\x%02x", c);
13266 Perl_sv_catpvf(aTHX_ sv, "\\x{%x}", c);
13270 const char string = c;
13271 if (c == '-' || c == ']' || c == '\\' || c == '^')
13272 sv_catpvs(sv, "\\");
13273 sv_catpvn(sv, &string, 1);
13278 #define CLEAR_OPTSTART \
13279 if (optstart) STMT_START { \
13280 DEBUG_OPTIMISE_r(PerlIO_printf(Perl_debug_log, " (%"IVdf" nodes)\n", (IV)(node - optstart))); \
13284 #define DUMPUNTIL(b,e) CLEAR_OPTSTART; node=dumpuntil(r,start,(b),(e),last,sv,indent+1,depth+1);
13286 STATIC const regnode *
13287 S_dumpuntil(pTHX_ const regexp *r, const regnode *start, const regnode *node,
13288 const regnode *last, const regnode *plast,
13289 SV* sv, I32 indent, U32 depth)
13292 register U8 op = PSEUDO; /* Arbitrary non-END op. */
13293 register const regnode *next;
13294 const regnode *optstart= NULL;
13296 RXi_GET_DECL(r,ri);
13297 GET_RE_DEBUG_FLAGS_DECL;
13299 PERL_ARGS_ASSERT_DUMPUNTIL;
13301 #ifdef DEBUG_DUMPUNTIL
13302 PerlIO_printf(Perl_debug_log, "--- %d : %d - %d - %d\n",indent,node-start,
13303 last ? last-start : 0,plast ? plast-start : 0);
13306 if (plast && plast < last)
13309 while (PL_regkind[op] != END && (!last || node < last)) {
13310 /* While that wasn't END last time... */
13313 if (op == CLOSE || op == WHILEM)
13315 next = regnext((regnode *)node);
13318 if (OP(node) == OPTIMIZED) {
13319 if (!optstart && RE_DEBUG_FLAG(RE_DEBUG_COMPILE_OPTIMISE))
13326 regprop(r, sv, node);
13327 PerlIO_printf(Perl_debug_log, "%4"IVdf":%*s%s", (IV)(node - start),
13328 (int)(2*indent + 1), "", SvPVX_const(sv));
13330 if (OP(node) != OPTIMIZED) {
13331 if (next == NULL) /* Next ptr. */
13332 PerlIO_printf(Perl_debug_log, " (0)");
13333 else if (PL_regkind[(U8)op] == BRANCH && PL_regkind[OP(next)] != BRANCH )
13334 PerlIO_printf(Perl_debug_log, " (FAIL)");
13336 PerlIO_printf(Perl_debug_log, " (%"IVdf")", (IV)(next - start));
13337 (void)PerlIO_putc(Perl_debug_log, '\n');
13341 if (PL_regkind[(U8)op] == BRANCHJ) {
13344 register const regnode *nnode = (OP(next) == LONGJMP
13345 ? regnext((regnode *)next)
13347 if (last && nnode > last)
13349 DUMPUNTIL(NEXTOPER(NEXTOPER(node)), nnode);
13352 else if (PL_regkind[(U8)op] == BRANCH) {
13354 DUMPUNTIL(NEXTOPER(node), next);
13356 else if ( PL_regkind[(U8)op] == TRIE ) {
13357 const regnode *this_trie = node;
13358 const char op = OP(node);
13359 const U32 n = ARG(node);
13360 const reg_ac_data * const ac = op>=AHOCORASICK ?
13361 (reg_ac_data *)ri->data->data[n] :
13363 const reg_trie_data * const trie =
13364 (reg_trie_data*)ri->data->data[op<AHOCORASICK ? n : ac->trie];
13366 AV *const trie_words = MUTABLE_AV(ri->data->data[n + TRIE_WORDS_OFFSET]);
13368 const regnode *nextbranch= NULL;
13371 for (word_idx= 0; word_idx < (I32)trie->wordcount; word_idx++) {
13372 SV ** const elem_ptr = av_fetch(trie_words,word_idx,0);
13374 PerlIO_printf(Perl_debug_log, "%*s%s ",
13375 (int)(2*(indent+3)), "",
13376 elem_ptr ? pv_pretty(sv, SvPV_nolen_const(*elem_ptr), SvCUR(*elem_ptr), 60,
13377 PL_colors[0], PL_colors[1],
13378 (SvUTF8(*elem_ptr) ? PERL_PV_ESCAPE_UNI : 0) |
13379 PERL_PV_PRETTY_ELLIPSES |
13380 PERL_PV_PRETTY_LTGT
13385 U16 dist= trie->jump[word_idx+1];
13386 PerlIO_printf(Perl_debug_log, "(%"UVuf")\n",
13387 (UV)((dist ? this_trie + dist : next) - start));
13390 nextbranch= this_trie + trie->jump[0];
13391 DUMPUNTIL(this_trie + dist, nextbranch);
13393 if (nextbranch && PL_regkind[OP(nextbranch)]==BRANCH)
13394 nextbranch= regnext((regnode *)nextbranch);
13396 PerlIO_printf(Perl_debug_log, "\n");
13399 if (last && next > last)
13404 else if ( op == CURLY ) { /* "next" might be very big: optimizer */
13405 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS,
13406 NEXTOPER(node) + EXTRA_STEP_2ARGS + 1);
13408 else if (PL_regkind[(U8)op] == CURLY && op != CURLYX) {
13410 DUMPUNTIL(NEXTOPER(node) + EXTRA_STEP_2ARGS, next);
13412 else if ( op == PLUS || op == STAR) {
13413 DUMPUNTIL(NEXTOPER(node), NEXTOPER(node) + 1);
13415 else if (PL_regkind[(U8)op] == ANYOF) {
13416 /* arglen 1 + class block */
13417 node += 1 + ((ANYOF_FLAGS(node) & ANYOF_CLASS)
13418 ? ANYOF_CLASS_SKIP : ANYOF_SKIP);
13419 node = NEXTOPER(node);
13421 else if (PL_regkind[(U8)op] == EXACT) {
13422 /* Literal string, where present. */
13423 node += NODE_SZ_STR(node) - 1;
13424 node = NEXTOPER(node);
13427 node = NEXTOPER(node);
13428 node += regarglen[(U8)op];
13430 if (op == CURLYX || op == OPEN)
13434 #ifdef DEBUG_DUMPUNTIL
13435 PerlIO_printf(Perl_debug_log, "--- %d\n", (int)indent);
13440 #endif /* DEBUGGING */
13444 * c-indentation-style: bsd
13445 * c-basic-offset: 4
13446 * indent-tabs-mode: t
13449 * ex: set ts=8 sts=4 sw=4 noet: